From d4c209fb9543019461bcf612da67708aeabcdce2 Mon Sep 17 00:00:00 2001 From: Joe Crayne Date: Sat, 25 Jan 2020 01:02:33 -0500 Subject: Ported dhtd to reworked QueryResponse design. --- dht/src/Data/Tox/Onion.hs | 147 +++++++++++++++++++++++----------------------- 1 file changed, 75 insertions(+), 72 deletions(-) (limited to 'dht/src/Data/Tox/Onion.hs') diff --git a/dht/src/Data/Tox/Onion.hs b/dht/src/Data/Tox/Onion.hs index faff3cdf..1cf89bae 100644 --- a/dht/src/Data/Tox/Onion.hs +++ b/dht/src/Data/Tox/Onion.hs @@ -66,8 +66,6 @@ import Util (sameAddress) import Text.XXD import qualified Data.ByteArray as BA -type HandleLo a = Arrival String SockAddr ByteString -> IO a - type UDPTransport = Transport String SockAddr ByteString @@ -186,10 +184,10 @@ onion bs saddr getf = do (f,(asymm,ret3)) <- runGet ((,) <$> getf <*> getOnionRe oaddr <- onionToOwner asymm ret3 saddr return (f asymm, oaddr) -parseOnionAddr :: (SockAddr -> Nonce8 -> IO (Maybe (OnionDestination r))) +parseOnionAddr :: (SockAddr -> Nonce8 -> STM (Maybe (OnionDestination r))) -> (ByteString, SockAddr) - -> IO (Either (OnionMessage Encrypted,OnionDestination r) - (ByteString,SockAddr)) + -> STM (Either (OnionMessage Encrypted,OnionDestination r) + (ByteString,SockAddr)) parseOnionAddr lookupSender (msg,saddr) | Just (typ,bs) <- B.uncons msg , let right = Right (msg,saddr) @@ -271,24 +269,25 @@ forwardOnions crypto baddr udp sendTCP = udp { awaitMessage = forwardAwait crypt forwardAwait :: TransportCrypto -> UDPTransport - -> (Int -> OnionMessage Encrypted -> IO ()) {- ^ TCP relay send -} -> HandleLo a -> STM (IO a) -forwardAwait crypto udp sendTCP kont = do - fix $ \another0 -> do - let another = join $ atomically another0 - awaitMessage udp $ \case - m@(Arrival saddr bs) -> case B.head bs of - 0x80 -> forward kont bs $ handleOnionRequest (Proxy :: Proxy N0) crypto (Addressed saddr) udp another - 0x81 -> forward kont bs $ handleOnionRequest (Proxy :: Proxy N1) crypto (Addressed saddr) udp another - 0x82 -> forward kont bs $ handleOnionRequest (Proxy :: Proxy N2) crypto (Addressed saddr) udp another - 0x8c -> forward kont bs $ handleOnionResponse (Proxy :: Proxy N3) crypto saddr udp sendTCP another - 0x8d -> forward kont bs $ handleOnionResponse (Proxy :: Proxy N2) crypto saddr udp sendTCP another - 0x8e -> forward kont bs $ handleOnionResponse (Proxy :: Proxy N1) crypto saddr udp sendTCP another - _ -> kont m - m -> kont m - -forward :: (Serialize b, Show b) => - HandleLo a -> ByteString -> (b -> IO a) -> IO a -forward kont bs f = either (kont . ParseError) f $ decode $ B.tail bs + -> (Int -> OnionMessage Encrypted -> IO ()) {- ^ TCP relay send -} -> STM (Arrival String SockAddr ByteString,IO()) +forwardAwait crypto udp sendTCP = do + (m,io) <- awaitMessage udp + let pass = return (m, io) + case m of + Arrival saddr bs -> + let forward :: Serialize b => (b -> STM (Arrival String SockAddr ByteString, IO ())) + -> STM (Arrival String SockAddr ByteString, IO ()) + forward f = either (\e -> return (ParseError e,io)) (fmap (second (io >>)) . f) $ decode $ B.tail bs + in case B.head bs of + 0x80 -> forward $ handleOnionRequest (Proxy :: Proxy N0) crypto (Addressed saddr) udp + 0x81 -> forward $ handleOnionRequest (Proxy :: Proxy N1) crypto (Addressed saddr) udp + 0x82 -> forward $ handleOnionRequest (Proxy :: Proxy N2) crypto (Addressed saddr) udp + 0x8c -> forward $ handleOnionResponse (Proxy :: Proxy N3) crypto saddr udp sendTCP + 0x8d -> forward $ handleOnionResponse (Proxy :: Proxy N2) crypto saddr udp sendTCP + 0x8e -> forward $ handleOnionResponse (Proxy :: Proxy N1) crypto saddr udp sendTCP + _ -> pass + _ -> pass + class SumToThree a b @@ -586,28 +585,29 @@ handleOnionRequest :: forall a proxy n. , Sized (ReturnPath n) , Typeable n , Typeable (ThreeMinus (S n)) - ) => proxy n -> TransportCrypto -> (forall x. x -> Addressed x) -> UDPTransport -> IO a -> OnionRequest n -> IO a -handleOnionRequest proxy crypto saddr udp kont (OnionRequest nonce msg rpath) = do + ) => proxy n -> TransportCrypto + -> (forall x. x -> Addressed x) + -> UDPTransport + -> OnionRequest n + -> STM (Arrival String SockAddr ByteString, IO ()) +handleOnionRequest proxy crypto saddr udp (OnionRequest nonce msg rpath) = do let n = peanoVal rpath - dput XOnion $ "handleOnionRequest " ++ show n - (sym, snonce) <- atomically ( (,) <$> transportSymmetric crypto - <*> transportNewNonce crypto ) + io1 = dput XOnion $ "handleOnionRequest " ++ show n + (sym, snonce) <- ( (,) <$> transportSymmetric crypto + <*> transportNewNonce crypto ) peeled <- peelOnion crypto nonce msg let showDestination = case saddr () of Addressed a _ -> either show show $ either4or6 a TCPIndex i _ -> "TCP" ++ show [i] - case peeled of - Left e -> do + fmap (second (io1 >>)) $ case peeled of + Left e -> return $ (ParseError e,) $ do dput XOnion $ unwords [ "peelOnion:", show n, showDestination, e] - kont - Right (Addressed dst msg') -> do + Right (Addressed dst msg') -> return $ (Discarded,) $ do dput XOnion $ unwords [ "peelOnion:", show n, showDestination, "-->", either show show (either4or6 dst), "SUCCESS"] sendMessage udp dst (runPut $ putRequest $ OnionRequest nonce msg' $ wrapSymmetric sym snonce saddr rpath) - kont - Right (TCPIndex {}) -> do + Right (TCPIndex {}) -> return $ (,) (ParseError "handleOnionRequest: Onion forward to TCP client?") $ do dput XUnexpected "handleOnionRequest: Onion forward to TCP client?" - kont wrapSymmetric :: Serialize (ReturnPath n) => SymmetricKey -> Nonce24 -> (forall x. x -> Addressed x) -> ReturnPath n -> ReturnPath (S n) @@ -622,7 +622,7 @@ peelOnion :: ( Typeable n, Typeable t, Serialize (Addressed (Forwarding n t))) => TransportCrypto -> Nonce24 -> Forwarding (S n) t - -> IO (Either String (Addressed (Forwarding n t))) + -> STM (Either String (Addressed (Forwarding n t))) peelOnion crypto nonce (Forwarding k fwd) = do fmap runIdentity . uncomposed <$> decryptMessage crypto (dhtKey crypto) nonce (Right $ Asymm k nonce fwd) @@ -632,25 +632,22 @@ handleOnionResponse :: (KnownPeanoNat n, Sized (ReturnPath n), Serialize (Return -> SockAddr -> UDPTransport -> (Int -> OnionMessage Encrypted -> IO ()) -- ^ TCP-relay onion send. - -> IO a -> OnionResponse (S n) - -> IO a -handleOnionResponse proxy crypto saddr udp sendTCP kont (OnionResponse path msg) = do - sym <- atomically $ transportSymmetric crypto + -> STM (Arrival String SockAddr ByteString, IO ()) +handleOnionResponse proxy crypto saddr udp sendTCP (OnionResponse path msg) = do + sym <- transportSymmetric crypto case peelSymmetric sym path of - Left e -> do + Left e -> return $ (ParseError e,) $ do -- todo report encryption error let n = peanoVal path dput XMisc $ unwords [ "peelSymmetric:", show n, either show show (either4or6 saddr), e] - kont - Right (Addressed dst path') -> do + Right (Addressed dst path') -> return $ (Discarded,) $ do sendMessage udp dst (runPut $ putResponse $ OnionResponse path' msg) - kont Right (TCPIndex dst path') -> do case peanoVal path' of - 0 -> sendTCP dst msg - n -> dput XUnexpected $ "handleOnionResponse: TCP-bound OnionResponse" ++ show n ++ " not supported." - kont + 0 -> return (Discarded, sendTCP dst msg) + n -> let e = "handleOnionResponse: TCP-bound OnionResponse" ++ show n ++ " not supported." + in return (ParseError e, dput XUnexpected e) data AnnounceRequest = AnnounceRequest @@ -787,7 +784,7 @@ instance Serialize OnionData where put (OnionDHTPublicKey dpk) = put (0x9c :: Word8) >> put dpk put (OnionFriendRequest fr) = put (0x20 :: Word8) >> put fr -selectKey :: TransportCrypto -> OnionMessage f -> OnionDestination r -> IO (SecretKey, PublicKey) +selectKey :: Monad m => TransportCrypto -> OnionMessage f -> OnionDestination r -> m (SecretKey, PublicKey) selectKey crypto _ rpath@(OnionDestination (AnnouncingAlias skey pkey) _ _) = return (skey, pkey) selectKey crypto msg rpath = return $ aliasKey crypto rpath @@ -808,32 +805,36 @@ encrypt crypto msg rpath = do m <- sequenceMessage $ transcode encipher msg return (m, rpath) -decrypt :: TransportCrypto -> OnionMessage Encrypted -> OnionDestination r -> IO (Either String (OnionMessage Identity, OnionDestination r)) +decrypt :: TransportCrypto + -> OnionMessage Encrypted + -> OnionDestination r + -> STM (Either String (OnionMessage Identity, OnionDestination r)) decrypt crypto msg addr = do (skey,pkey) <- selectKey crypto msg addr let decipher1 :: Serialize a => TransportCrypto -> SecretKey -> Nonce24 -> Either (PublicKey,Encrypted a) (Asymm (Encrypted a)) - -> (IO ∘ Either String ∘ Identity) a + -> (STM ∘ Either String ∘ Identity) a decipher1 crypto k n arg = Composed $ do let (sender,e) = either id (senderKey &&& asymmData) arg - secret <- lookupSharedSecret crypto k sender n + secret <- lookupSharedSecretSTM crypto k sender n return $ Composed $ do plain <- ToxCrypto.decrypt secret e Identity <$> decodePlain plain decipher :: Serialize a => Nonce24 -> Either (Encrypted a) (Asymm (Encrypted a)) - -> (IO ∘ Either String ∘ Identity) a + -> (STM ∘ Either String ∘ Identity) a decipher = (\n -> decipher1 crypto skey n . left (senderkey addr)) foo <- sequenceMessage $ transcode decipher msg let result = do msg <- sequenceMessage foo Right (msg, addr) - case msg of - OnionToRouteResponse {} -> case result of - Left e -> dput XMan $ "Error decrypting data-to-route response: " ++ e - Right m -> dput XMan $ "Decrypted data-to-route response: " ++ show (fst m) - _ -> return () + -- -- TODO runio + -- case msg of + -- OnionToRouteResponse {} -> case result of + -- Left e -> dput XMan $ "Error decrypting data-to-route response: " ++ e + -- Right m -> dput XMan $ "Decrypted data-to-route response: " ++ show (fst m) + -- _ -> return () return result senderkey :: OnionDestination r -> t -> (PublicKey, t) @@ -857,11 +858,11 @@ decryptMessage :: (Typeable x, Serialize x) => -> Nonce24 -> Either (PublicKey, Encrypted x) (Asymm (Encrypted x)) - -> IO ((Either String ∘ Identity) x) + -> STM ((Either String ∘ Identity) x) decryptMessage crypto (sk,pk) n arg = do let (sender,e) = either id (senderKey &&& asymmData) arg plain = Composed . fmap Identity . (>>= decodePlainVerbose) - secret <- lookupSharedSecret crypto sk sender n + secret <- lookupSharedSecretSTM crypto sk sender n return $ plain $ ToxCrypto.decrypt secret e sequenceMessage :: Applicative m => OnionMessage (m ∘ f) -> m (OnionMessage f) @@ -1002,9 +1003,9 @@ selectAlias crypto pkey = do parseDataToRoute :: TransportCrypto -> (OnionMessage Encrypted,OnionDestination r) - -> IO (Either ((PublicKey,OnionData),AnnouncedRendezvous) (OnionMessage Encrypted, OnionDestination r)) + -> STM (Either ((PublicKey,OnionData),AnnouncedRendezvous) (OnionMessage Encrypted, OnionDestination r)) parseDataToRoute crypto (OnionToRouteResponse dta, od) = do - ks <- atomically $ userKeys crypto + ks <- userKeys crypto omsg0 <- decryptMessage crypto (rendezvousSecret crypto,rendezvousPublic crypto) (asymmNonce dta) @@ -1035,17 +1036,19 @@ parseDataToRoute crypto (OnionToRouteResponse dta, od) = do (dataFromKey dtr) $ Rendezvous (rendezvousPublic crypto) $ onionNodeInfo od ) r = either (const $ Right (OnionToRouteResponse dta,od)) Left e - -- parseDataToRoute OnionToRouteResponse decipherAndAuth: auth fail - case e of - Left _ -> dput XMisc $ "Failed keys: " ++ show (map (key2id . snd) ks) - Right _ -> return () - dput XMisc $ unlines - [ "parseDataToRoute " ++ either id (const "Right") e - , " crypto inner.me = " ++ either id (\(pk,_,_) -> show $ key2id pk) eInner - , " inner.them = " ++ either id (show . key2id . dataFromKey) eOuter - , " outer.me = " ++ show (key2id $ rendezvousPublic crypto) - , " outer.them = " ++ show (key2id $ senderKey dta) - ] + io :: IO () + io = do + case e of + Left _ -> dput XMisc $ "Failed keys: " ++ show (map (key2id . snd) ks) + Right _ -> return () + dput XMisc $ unlines + [ "parseDataToRoute " ++ either id (const "Right") e + , " crypto inner.me = " ++ either id (\(pk,_,_) -> show $ key2id pk) eInner + , " inner.them = " ++ either id (show . key2id . dataFromKey) eOuter + , " outer.me = " ++ show (key2id $ rendezvousPublic crypto) + , " outer.them = " ++ show (key2id $ senderKey dta) + ] + -- TODO: run io return r parseDataToRoute _ msg = return $ Right msg -- cgit v1.2.3