diff options
author | Joe Crayne <joe@jerkface.net> | 2020-01-25 01:02:33 -0500 |
---|---|---|
committer | Joe Crayne <joe@jerkface.net> | 2020-01-25 19:18:13 -0500 |
commit | d4c209fb9543019461bcf612da67708aeabcdce2 (patch) | |
tree | c8c0c4b681b114080f39d6b9fc19090a78d60bf6 /dht/src/Data/Tox | |
parent | 9953d0a9ba7e992062ae60ae8e24054b0883b50e (diff) |
Ported dhtd to reworked QueryResponse design.
Diffstat (limited to 'dht/src/Data/Tox')
-rw-r--r-- | dht/src/Data/Tox/Onion.hs | 147 |
1 files changed, 75 insertions, 72 deletions
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) | |||
66 | import Text.XXD | 66 | import Text.XXD |
67 | import qualified Data.ByteArray as BA | 67 | import qualified Data.ByteArray as BA |
68 | 68 | ||
69 | type HandleLo a = Arrival String SockAddr ByteString -> IO a | ||
70 | |||
71 | type UDPTransport = Transport String SockAddr ByteString | 69 | type UDPTransport = Transport String SockAddr ByteString |
72 | 70 | ||
73 | 71 | ||
@@ -186,10 +184,10 @@ onion bs saddr getf = do (f,(asymm,ret3)) <- runGet ((,) <$> getf <*> getOnionRe | |||
186 | oaddr <- onionToOwner asymm ret3 saddr | 184 | oaddr <- onionToOwner asymm ret3 saddr |
187 | return (f asymm, oaddr) | 185 | return (f asymm, oaddr) |
188 | 186 | ||
189 | parseOnionAddr :: (SockAddr -> Nonce8 -> IO (Maybe (OnionDestination r))) | 187 | parseOnionAddr :: (SockAddr -> Nonce8 -> STM (Maybe (OnionDestination r))) |
190 | -> (ByteString, SockAddr) | 188 | -> (ByteString, SockAddr) |
191 | -> IO (Either (OnionMessage Encrypted,OnionDestination r) | 189 | -> STM (Either (OnionMessage Encrypted,OnionDestination r) |
192 | (ByteString,SockAddr)) | 190 | (ByteString,SockAddr)) |
193 | parseOnionAddr lookupSender (msg,saddr) | 191 | parseOnionAddr lookupSender (msg,saddr) |
194 | | Just (typ,bs) <- B.uncons msg | 192 | | Just (typ,bs) <- B.uncons msg |
195 | , let right = Right (msg,saddr) | 193 | , let right = Right (msg,saddr) |
@@ -271,24 +269,25 @@ forwardOnions crypto baddr udp sendTCP = udp { awaitMessage = forwardAwait crypt | |||
271 | 269 | ||
272 | forwardAwait :: TransportCrypto | 270 | forwardAwait :: TransportCrypto |
273 | -> UDPTransport | 271 | -> UDPTransport |
274 | -> (Int -> OnionMessage Encrypted -> IO ()) {- ^ TCP relay send -} -> HandleLo a -> STM (IO a) | 272 | -> (Int -> OnionMessage Encrypted -> IO ()) {- ^ TCP relay send -} -> STM (Arrival String SockAddr ByteString,IO()) |
275 | forwardAwait crypto udp sendTCP kont = do | 273 | forwardAwait crypto udp sendTCP = do |
276 | fix $ \another0 -> do | 274 | (m,io) <- awaitMessage udp |
277 | let another = join $ atomically another0 | 275 | let pass = return (m, io) |
278 | awaitMessage udp $ \case | 276 | case m of |
279 | m@(Arrival saddr bs) -> case B.head bs of | 277 | Arrival saddr bs -> |
280 | 0x80 -> forward kont bs $ handleOnionRequest (Proxy :: Proxy N0) crypto (Addressed saddr) udp another | 278 | let forward :: Serialize b => (b -> STM (Arrival String SockAddr ByteString, IO ())) |
281 | 0x81 -> forward kont bs $ handleOnionRequest (Proxy :: Proxy N1) crypto (Addressed saddr) udp another | 279 | -> STM (Arrival String SockAddr ByteString, IO ()) |
282 | 0x82 -> forward kont bs $ handleOnionRequest (Proxy :: Proxy N2) crypto (Addressed saddr) udp another | 280 | forward f = either (\e -> return (ParseError e,io)) (fmap (second (io >>)) . f) $ decode $ B.tail bs |
283 | 0x8c -> forward kont bs $ handleOnionResponse (Proxy :: Proxy N3) crypto saddr udp sendTCP another | 281 | in case B.head bs of |
284 | 0x8d -> forward kont bs $ handleOnionResponse (Proxy :: Proxy N2) crypto saddr udp sendTCP another | 282 | 0x80 -> forward $ handleOnionRequest (Proxy :: Proxy N0) crypto (Addressed saddr) udp |
285 | 0x8e -> forward kont bs $ handleOnionResponse (Proxy :: Proxy N1) crypto saddr udp sendTCP another | 283 | 0x81 -> forward $ handleOnionRequest (Proxy :: Proxy N1) crypto (Addressed saddr) udp |
286 | _ -> kont m | 284 | 0x82 -> forward $ handleOnionRequest (Proxy :: Proxy N2) crypto (Addressed saddr) udp |
287 | m -> kont m | 285 | 0x8c -> forward $ handleOnionResponse (Proxy :: Proxy N3) crypto saddr udp sendTCP |
288 | 286 | 0x8d -> forward $ handleOnionResponse (Proxy :: Proxy N2) crypto saddr udp sendTCP | |
289 | forward :: (Serialize b, Show b) => | 287 | 0x8e -> forward $ handleOnionResponse (Proxy :: Proxy N1) crypto saddr udp sendTCP |
290 | HandleLo a -> ByteString -> (b -> IO a) -> IO a | 288 | _ -> pass |
291 | forward kont bs f = either (kont . ParseError) f $ decode $ B.tail bs | 289 | _ -> pass |
290 | |||
292 | 291 | ||
293 | class SumToThree a b | 292 | class SumToThree a b |
294 | 293 | ||
@@ -586,28 +585,29 @@ handleOnionRequest :: forall a proxy n. | |||
586 | , Sized (ReturnPath n) | 585 | , Sized (ReturnPath n) |
587 | , Typeable n | 586 | , Typeable n |
588 | , Typeable (ThreeMinus (S n)) | 587 | , Typeable (ThreeMinus (S n)) |
589 | ) => proxy n -> TransportCrypto -> (forall x. x -> Addressed x) -> UDPTransport -> IO a -> OnionRequest n -> IO a | 588 | ) => proxy n -> TransportCrypto |
590 | handleOnionRequest proxy crypto saddr udp kont (OnionRequest nonce msg rpath) = do | 589 | -> (forall x. x -> Addressed x) |
590 | -> UDPTransport | ||
591 | -> OnionRequest n | ||
592 | -> STM (Arrival String SockAddr ByteString, IO ()) | ||
593 | handleOnionRequest proxy crypto saddr udp (OnionRequest nonce msg rpath) = do | ||
591 | let n = peanoVal rpath | 594 | let n = peanoVal rpath |
592 | dput XOnion $ "handleOnionRequest " ++ show n | 595 | io1 = dput XOnion $ "handleOnionRequest " ++ show n |
593 | (sym, snonce) <- atomically ( (,) <$> transportSymmetric crypto | 596 | (sym, snonce) <- ( (,) <$> transportSymmetric crypto |
594 | <*> transportNewNonce crypto ) | 597 | <*> transportNewNonce crypto ) |
595 | peeled <- peelOnion crypto nonce msg | 598 | peeled <- peelOnion crypto nonce msg |
596 | let showDestination = case saddr () of | 599 | let showDestination = case saddr () of |
597 | Addressed a _ -> either show show $ either4or6 a | 600 | Addressed a _ -> either show show $ either4or6 a |
598 | TCPIndex i _ -> "TCP" ++ show [i] | 601 | TCPIndex i _ -> "TCP" ++ show [i] |
599 | 602 | ||
600 | case peeled of | 603 | fmap (second (io1 >>)) $ case peeled of |
601 | Left e -> do | 604 | Left e -> return $ (ParseError e,) $ do |
602 | dput XOnion $ unwords [ "peelOnion:", show n, showDestination, e] | 605 | dput XOnion $ unwords [ "peelOnion:", show n, showDestination, e] |
603 | kont | 606 | Right (Addressed dst msg') -> return $ (Discarded,) $ do |
604 | Right (Addressed dst msg') -> do | ||
605 | dput XOnion $ unwords [ "peelOnion:", show n, showDestination, "-->", either show show (either4or6 dst), "SUCCESS"] | 607 | dput XOnion $ unwords [ "peelOnion:", show n, showDestination, "-->", either show show (either4or6 dst), "SUCCESS"] |
606 | sendMessage udp dst (runPut $ putRequest $ OnionRequest nonce msg' $ wrapSymmetric sym snonce saddr rpath) | 608 | sendMessage udp dst (runPut $ putRequest $ OnionRequest nonce msg' $ wrapSymmetric sym snonce saddr rpath) |
607 | kont | 609 | Right (TCPIndex {}) -> return $ (,) (ParseError "handleOnionRequest: Onion forward to TCP client?") $ do |
608 | Right (TCPIndex {}) -> do | ||
609 | dput XUnexpected "handleOnionRequest: Onion forward to TCP client?" | 610 | dput XUnexpected "handleOnionRequest: Onion forward to TCP client?" |
610 | kont | ||
611 | 611 | ||
612 | wrapSymmetric :: Serialize (ReturnPath n) => | 612 | wrapSymmetric :: Serialize (ReturnPath n) => |
613 | SymmetricKey -> Nonce24 -> (forall x. x -> Addressed x) -> ReturnPath n -> ReturnPath (S n) | 613 | 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))) | |||
622 | => TransportCrypto | 622 | => TransportCrypto |
623 | -> Nonce24 | 623 | -> Nonce24 |
624 | -> Forwarding (S n) t | 624 | -> Forwarding (S n) t |
625 | -> IO (Either String (Addressed (Forwarding n t))) | 625 | -> STM (Either String (Addressed (Forwarding n t))) |
626 | peelOnion crypto nonce (Forwarding k fwd) = do | 626 | peelOnion crypto nonce (Forwarding k fwd) = do |
627 | fmap runIdentity . uncomposed <$> decryptMessage crypto (dhtKey crypto) nonce (Right $ Asymm k nonce fwd) | 627 | fmap runIdentity . uncomposed <$> decryptMessage crypto (dhtKey crypto) nonce (Right $ Asymm k nonce fwd) |
628 | 628 | ||
@@ -632,25 +632,22 @@ handleOnionResponse :: (KnownPeanoNat n, Sized (ReturnPath n), Serialize (Return | |||
632 | -> SockAddr | 632 | -> SockAddr |
633 | -> UDPTransport | 633 | -> UDPTransport |
634 | -> (Int -> OnionMessage Encrypted -> IO ()) -- ^ TCP-relay onion send. | 634 | -> (Int -> OnionMessage Encrypted -> IO ()) -- ^ TCP-relay onion send. |
635 | -> IO a | ||
636 | -> OnionResponse (S n) | 635 | -> OnionResponse (S n) |
637 | -> IO a | 636 | -> STM (Arrival String SockAddr ByteString, IO ()) |
638 | handleOnionResponse proxy crypto saddr udp sendTCP kont (OnionResponse path msg) = do | 637 | handleOnionResponse proxy crypto saddr udp sendTCP (OnionResponse path msg) = do |
639 | sym <- atomically $ transportSymmetric crypto | 638 | sym <- transportSymmetric crypto |
640 | case peelSymmetric sym path of | 639 | case peelSymmetric sym path of |
641 | Left e -> do | 640 | Left e -> return $ (ParseError e,) $ do |
642 | -- todo report encryption error | 641 | -- todo report encryption error |
643 | let n = peanoVal path | 642 | let n = peanoVal path |
644 | dput XMisc $ unwords [ "peelSymmetric:", show n, either show show (either4or6 saddr), e] | 643 | dput XMisc $ unwords [ "peelSymmetric:", show n, either show show (either4or6 saddr), e] |
645 | kont | 644 | Right (Addressed dst path') -> return $ (Discarded,) $ do |
646 | Right (Addressed dst path') -> do | ||
647 | sendMessage udp dst (runPut $ putResponse $ OnionResponse path' msg) | 645 | sendMessage udp dst (runPut $ putResponse $ OnionResponse path' msg) |
648 | kont | ||
649 | Right (TCPIndex dst path') -> do | 646 | Right (TCPIndex dst path') -> do |
650 | case peanoVal path' of | 647 | case peanoVal path' of |
651 | 0 -> sendTCP dst msg | 648 | 0 -> return (Discarded, sendTCP dst msg) |
652 | n -> dput XUnexpected $ "handleOnionResponse: TCP-bound OnionResponse" ++ show n ++ " not supported." | 649 | n -> let e = "handleOnionResponse: TCP-bound OnionResponse" ++ show n ++ " not supported." |
653 | kont | 650 | in return (ParseError e, dput XUnexpected e) |
654 | 651 | ||
655 | 652 | ||
656 | data AnnounceRequest = AnnounceRequest | 653 | data AnnounceRequest = AnnounceRequest |
@@ -787,7 +784,7 @@ instance Serialize OnionData where | |||
787 | put (OnionDHTPublicKey dpk) = put (0x9c :: Word8) >> put dpk | 784 | put (OnionDHTPublicKey dpk) = put (0x9c :: Word8) >> put dpk |
788 | put (OnionFriendRequest fr) = put (0x20 :: Word8) >> put fr | 785 | put (OnionFriendRequest fr) = put (0x20 :: Word8) >> put fr |
789 | 786 | ||
790 | selectKey :: TransportCrypto -> OnionMessage f -> OnionDestination r -> IO (SecretKey, PublicKey) | 787 | selectKey :: Monad m => TransportCrypto -> OnionMessage f -> OnionDestination r -> m (SecretKey, PublicKey) |
791 | selectKey crypto _ rpath@(OnionDestination (AnnouncingAlias skey pkey) _ _) | 788 | selectKey crypto _ rpath@(OnionDestination (AnnouncingAlias skey pkey) _ _) |
792 | = return (skey, pkey) | 789 | = return (skey, pkey) |
793 | selectKey crypto msg rpath = return $ aliasKey crypto rpath | 790 | selectKey crypto msg rpath = return $ aliasKey crypto rpath |
@@ -808,32 +805,36 @@ encrypt crypto msg rpath = do | |||
808 | m <- sequenceMessage $ transcode encipher msg | 805 | m <- sequenceMessage $ transcode encipher msg |
809 | return (m, rpath) | 806 | return (m, rpath) |
810 | 807 | ||
811 | decrypt :: TransportCrypto -> OnionMessage Encrypted -> OnionDestination r -> IO (Either String (OnionMessage Identity, OnionDestination r)) | 808 | decrypt :: TransportCrypto |
809 | -> OnionMessage Encrypted | ||
810 | -> OnionDestination r | ||
811 | -> STM (Either String (OnionMessage Identity, OnionDestination r)) | ||
812 | decrypt crypto msg addr = do | 812 | decrypt crypto msg addr = do |
813 | (skey,pkey) <- selectKey crypto msg addr | 813 | (skey,pkey) <- selectKey crypto msg addr |
814 | let decipher1 :: Serialize a => | 814 | let decipher1 :: Serialize a => |
815 | TransportCrypto -> SecretKey -> Nonce24 | 815 | TransportCrypto -> SecretKey -> Nonce24 |
816 | -> Either (PublicKey,Encrypted a) (Asymm (Encrypted a)) | 816 | -> Either (PublicKey,Encrypted a) (Asymm (Encrypted a)) |
817 | -> (IO ∘ Either String ∘ Identity) a | 817 | -> (STM ∘ Either String ∘ Identity) a |
818 | decipher1 crypto k n arg = Composed $ do | 818 | decipher1 crypto k n arg = Composed $ do |
819 | let (sender,e) = either id (senderKey &&& asymmData) arg | 819 | let (sender,e) = either id (senderKey &&& asymmData) arg |
820 | secret <- lookupSharedSecret crypto k sender n | 820 | secret <- lookupSharedSecretSTM crypto k sender n |
821 | return $ Composed $ do | 821 | return $ Composed $ do |
822 | plain <- ToxCrypto.decrypt secret e | 822 | plain <- ToxCrypto.decrypt secret e |
823 | Identity <$> decodePlain plain | 823 | Identity <$> decodePlain plain |
824 | decipher :: Serialize a | 824 | decipher :: Serialize a |
825 | => Nonce24 -> Either (Encrypted a) (Asymm (Encrypted a)) | 825 | => Nonce24 -> Either (Encrypted a) (Asymm (Encrypted a)) |
826 | -> (IO ∘ Either String ∘ Identity) a | 826 | -> (STM ∘ Either String ∘ Identity) a |
827 | decipher = (\n -> decipher1 crypto skey n . left (senderkey addr)) | 827 | decipher = (\n -> decipher1 crypto skey n . left (senderkey addr)) |
828 | foo <- sequenceMessage $ transcode decipher msg | 828 | foo <- sequenceMessage $ transcode decipher msg |
829 | let result = do | 829 | let result = do |
830 | msg <- sequenceMessage foo | 830 | msg <- sequenceMessage foo |
831 | Right (msg, addr) | 831 | Right (msg, addr) |
832 | case msg of | 832 | -- -- TODO runio |
833 | OnionToRouteResponse {} -> case result of | 833 | -- case msg of |
834 | Left e -> dput XMan $ "Error decrypting data-to-route response: " ++ e | 834 | -- OnionToRouteResponse {} -> case result of |
835 | Right m -> dput XMan $ "Decrypted data-to-route response: " ++ show (fst m) | 835 | -- Left e -> dput XMan $ "Error decrypting data-to-route response: " ++ e |
836 | _ -> return () | 836 | -- Right m -> dput XMan $ "Decrypted data-to-route response: " ++ show (fst m) |
837 | -- _ -> return () | ||
837 | return result | 838 | return result |
838 | 839 | ||
839 | senderkey :: OnionDestination r -> t -> (PublicKey, t) | 840 | senderkey :: OnionDestination r -> t -> (PublicKey, t) |
@@ -857,11 +858,11 @@ decryptMessage :: (Typeable x, Serialize x) => | |||
857 | -> Nonce24 | 858 | -> Nonce24 |
858 | -> Either (PublicKey, Encrypted x) | 859 | -> Either (PublicKey, Encrypted x) |
859 | (Asymm (Encrypted x)) | 860 | (Asymm (Encrypted x)) |
860 | -> IO ((Either String ∘ Identity) x) | 861 | -> STM ((Either String ∘ Identity) x) |
861 | decryptMessage crypto (sk,pk) n arg = do | 862 | decryptMessage crypto (sk,pk) n arg = do |
862 | let (sender,e) = either id (senderKey &&& asymmData) arg | 863 | let (sender,e) = either id (senderKey &&& asymmData) arg |
863 | plain = Composed . fmap Identity . (>>= decodePlainVerbose) | 864 | plain = Composed . fmap Identity . (>>= decodePlainVerbose) |
864 | secret <- lookupSharedSecret crypto sk sender n | 865 | secret <- lookupSharedSecretSTM crypto sk sender n |
865 | return $ plain $ ToxCrypto.decrypt secret e | 866 | return $ plain $ ToxCrypto.decrypt secret e |
866 | 867 | ||
867 | sequenceMessage :: Applicative m => OnionMessage (m ∘ f) -> m (OnionMessage f) | 868 | sequenceMessage :: Applicative m => OnionMessage (m ∘ f) -> m (OnionMessage f) |
@@ -1002,9 +1003,9 @@ selectAlias crypto pkey = do | |||
1002 | parseDataToRoute | 1003 | parseDataToRoute |
1003 | :: TransportCrypto | 1004 | :: TransportCrypto |
1004 | -> (OnionMessage Encrypted,OnionDestination r) | 1005 | -> (OnionMessage Encrypted,OnionDestination r) |
1005 | -> IO (Either ((PublicKey,OnionData),AnnouncedRendezvous) (OnionMessage Encrypted, OnionDestination r)) | 1006 | -> STM (Either ((PublicKey,OnionData),AnnouncedRendezvous) (OnionMessage Encrypted, OnionDestination r)) |
1006 | parseDataToRoute crypto (OnionToRouteResponse dta, od) = do | 1007 | parseDataToRoute crypto (OnionToRouteResponse dta, od) = do |
1007 | ks <- atomically $ userKeys crypto | 1008 | ks <- userKeys crypto |
1008 | 1009 | ||
1009 | omsg0 <- decryptMessage crypto (rendezvousSecret crypto,rendezvousPublic crypto) | 1010 | omsg0 <- decryptMessage crypto (rendezvousSecret crypto,rendezvousPublic crypto) |
1010 | (asymmNonce dta) | 1011 | (asymmNonce dta) |
@@ -1035,17 +1036,19 @@ parseDataToRoute crypto (OnionToRouteResponse dta, od) = do | |||
1035 | (dataFromKey dtr) | 1036 | (dataFromKey dtr) |
1036 | $ Rendezvous (rendezvousPublic crypto) $ onionNodeInfo od ) | 1037 | $ Rendezvous (rendezvousPublic crypto) $ onionNodeInfo od ) |
1037 | r = either (const $ Right (OnionToRouteResponse dta,od)) Left e | 1038 | r = either (const $ Right (OnionToRouteResponse dta,od)) Left e |
1038 | -- parseDataToRoute OnionToRouteResponse decipherAndAuth: auth fail | 1039 | io :: IO () |
1039 | case e of | 1040 | io = do |
1040 | Left _ -> dput XMisc $ "Failed keys: " ++ show (map (key2id . snd) ks) | 1041 | case e of |
1041 | Right _ -> return () | 1042 | Left _ -> dput XMisc $ "Failed keys: " ++ show (map (key2id . snd) ks) |
1042 | dput XMisc $ unlines | 1043 | Right _ -> return () |
1043 | [ "parseDataToRoute " ++ either id (const "Right") e | 1044 | dput XMisc $ unlines |
1044 | , " crypto inner.me = " ++ either id (\(pk,_,_) -> show $ key2id pk) eInner | 1045 | [ "parseDataToRoute " ++ either id (const "Right") e |
1045 | , " inner.them = " ++ either id (show . key2id . dataFromKey) eOuter | 1046 | , " crypto inner.me = " ++ either id (\(pk,_,_) -> show $ key2id pk) eInner |
1046 | , " outer.me = " ++ show (key2id $ rendezvousPublic crypto) | 1047 | , " inner.them = " ++ either id (show . key2id . dataFromKey) eOuter |
1047 | , " outer.them = " ++ show (key2id $ senderKey dta) | 1048 | , " outer.me = " ++ show (key2id $ rendezvousPublic crypto) |
1048 | ] | 1049 | , " outer.them = " ++ show (key2id $ senderKey dta) |
1050 | ] | ||
1051 | -- TODO: run io | ||
1049 | return r | 1052 | return r |
1050 | parseDataToRoute _ msg = return $ Right msg | 1053 | parseDataToRoute _ msg = return $ Right msg |
1051 | 1054 | ||