{-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE PartialTypeSignatures #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} module Network.Tox.Onion.Transport ( parseOnionAddr , encodeOnionAddr , parseDataToRoute , encodeDataToRoute , forwardOnions , OnionDestination(..) , OnionMessage(..) , Rendezvous(..) , DataToRoute(..) , AnnounceResponse(..) , AnnounceRequest(..) , Forwarding(..) , ReturnPath(..) , OnionRequest(..) , OnionResponse(..) , Addressed(..) , UDPTransport , KeyRecord(..) , encrypt , decrypt , peelSymmetric , OnionRoute(..) , N3 , onionKey , onionNodeInfo ) where import Network.Address (fromSockAddr,toSockAddr,setPort,either4or6,sockAddrPort) import Network.QueryResponse import Crypto.Tox hiding (encrypt,decrypt) import Network.Tox.NodeId import qualified Crypto.Tox as ToxCrypto import Network.Tox.DHT.Transport (NodeInfo(..),NodeId(..),SendNodes(..),nodeInfo,DHTPublicKey,FriendRequest,asymNodeInfo) import Debug.Trace import Control.Arrow import Control.Applicative import Control.Concurrent.STM import Control.Monad import qualified Data.ByteString as B ;import Data.ByteString (ByteString) import Data.Coerce import Data.Function import Data.Functor.Contravariant import Data.Functor.Identity import Data.IP import Data.Maybe import Data.Monoid import Data.Serialize as S import Data.Type.Equality import Data.Typeable import Data.Word import GHC.Generics () import GHC.TypeLits import Network.Socket import System.IO type HandleLo a = Maybe (Either String (ByteString, SockAddr)) -> IO a type UDPTransport = Transport String SockAddr ByteString getOnionAssym :: Get (Assym (Encrypted DataToRoute)) getOnionAssym = getAliasedAssym putOnionAssym :: Serialize a => Word8 -> Put -> Assym a -> Put putOnionAssym typ p a = put typ >> p >> putAliasedAssym a data OnionMessage (f :: * -> *) = OnionAnnounce (Assym (f (AnnounceRequest,Nonce8))) | OnionAnnounceResponse Nonce8 Nonce24 (f AnnounceResponse) | OnionToRoute PublicKey (Assym (Encrypted DataToRoute)) -- destination key, aliased Assym | OnionToRouteResponse (Assym (Encrypted DataToRoute)) deriving instance ( Show (f (AnnounceRequest, Nonce8)) , Show (f AnnounceResponse) , Show (f DataToRoute) ) => Show (OnionMessage f) msgNonce :: OnionMessage f -> Nonce24 msgNonce (OnionAnnounce a) = assymNonce a msgNonce (OnionAnnounceResponse _ n24 _) = n24 msgNonce (OnionToRoute _ a) = assymNonce a msgNonce (OnionToRouteResponse a) = assymNonce a data OnionDestination r = OnionToOwner NodeInfo (ReturnPath N3) -- ^ Somebody else's path to us. | OnionDestination NodeInfo (Maybe r) -- ^ Our own onion-path. deriving Show onionNodeInfo :: OnionDestination r -> NodeInfo onionNodeInfo (OnionToOwner ni _) = ni onionNodeInfo (OnionDestination ni _) = ni onionKey :: OnionDestination r -> Maybe PublicKey onionKey od = Just $ id2key . nodeId $ onionNodeInfo od instance Sized (OnionMessage Encrypted) where size = VarSize $ \case OnionAnnounce a -> case size of ConstSize n -> n + 1 VarSize f -> f a + 1 OnionAnnounceResponse n8 n24 x -> case size of ConstSize n -> n + 33 VarSize f -> f x + 33 OnionToRoute pubkey a -> case size of ConstSize n -> n + 33 VarSize f -> f a + 33 OnionToRouteResponse a -> case size of ConstSize n -> n + 1 VarSize f -> f a + 1 instance Serialize (OnionMessage Encrypted) where get = do typ <- get case typ :: Word8 of 0x83 -> OnionAnnounce <$> getAliasedAssym 0x85 -> OnionToRoute <$> getPublicKey <*> getAliasedAssym t -> fail ("Unknown onion payload: " ++ show t) `fromMaybe` getOnionReply t put (OnionAnnounce a) = putWord8 0x83 >> putAliasedAssym a put (OnionToRoute k a) = putWord8 0x85 >> putPublicKey k >> putAliasedAssym a put (OnionAnnounceResponse n8 n24 x) = putWord8 0x84 >> put n8 >> put n24 >> put x put (OnionToRouteResponse a) = putWord8 0x86 >> putAliasedAssym a onionToOwner :: Assym a -> ReturnPath N3 -> SockAddr -> Either String (OnionDestination r) onionToOwner assym ret3 saddr = do ni <- nodeInfo (key2id $ senderKey assym) saddr return $ OnionToOwner ni ret3 -- data CookieAddress = WithoutCookie NodeInfo | CookieAddress Cookie SockAddr onion :: Sized msg => ByteString -> SockAddr -> Get (Assym (Encrypted msg) -> t) -> Either String (t, OnionDestination r) onion bs saddr getf = do (f,(assym,ret3)) <- runGet ((,) <$> getf <*> getOnionRequest) bs oaddr <- onionToOwner assym ret3 saddr return (f assym, oaddr) parseOnionAddr :: (SockAddr -> Nonce8 -> IO (Maybe (NodeInfo,r))) -> (ByteString, SockAddr) -> IO (Either (OnionMessage Encrypted,OnionDestination r) (ByteString,SockAddr)) parseOnionAddr lookupSender (msg,saddr) | Just (typ,bs) <- B.uncons msg , let right = Right (msg,saddr) query = return . either (const right) Left = case typ of 0x83 -> query $ onion bs saddr (pure OnionAnnounce) -- Announce Request 0x85 -> query $ onion bs saddr (OnionToRoute <$> getPublicKey) -- Onion Data Request _ -> case flip runGet bs <$> getOnionReply typ of Just (Right msg@(OnionAnnounceResponse n8 _ _)) -> do maddr <- lookupSender saddr n8 maybe (return right) -- Response unsolicited or too late. (return . Left . \(ni,r) -> (msg,OnionDestination ni (Just r))) maddr Just (Right msg@(OnionToRouteResponse asym)) -> do let ni = asymNodeInfo saddr asym return $ Left (msg, OnionDestination ni Nothing) _ -> return right getOnionReply :: Word8 -> Maybe (Get (OnionMessage Encrypted)) getOnionReply 0x84 = Just $ OnionAnnounceResponse <$> get <*> get <*> get getOnionReply 0x86 = Just $ OnionToRouteResponse <$> getOnionAssym getOnionReply _ = Nothing putOnionMsg :: OnionMessage Encrypted -> Put putOnionMsg (OnionAnnounce a) = putOnionAssym 0x83 (return ()) a putOnionMsg (OnionToRoute pubkey a) = putOnionAssym 0x85 (putPublicKey pubkey) a putOnionMsg (OnionAnnounceResponse n8 n24 x) = put (0x84 :: Word8) >> put n8 >> put n24 >> put x putOnionMsg (OnionToRouteResponse a) = putOnionAssym 0x86 (return ()) a encodeOnionAddr :: (NodeInfo -> r -> IO (Maybe OnionRoute)) -> (OnionMessage Encrypted,OnionDestination r) -> IO (Maybe (ByteString, SockAddr)) encodeOnionAddr _ (msg,OnionToOwner ni p) = return $ Just ( runPut $ putResponse (OnionResponse p msg) , nodeAddr ni ) encodeOnionAddr _ (msg,OnionDestination _ Nothing ) = do hPutStrLn stderr $ "ONION encode missing routeid" return Nothing encodeOnionAddr getRoute (msg,OnionDestination ni (Just rid)) = do let go route = do return ( runPut $ putRequest $ wrapForRoute msg ni route , nodeAddr $ routeNodeA route) mapM' f x = do hPutStrLn stderr $ "ONION encode sending to " ++ show ni hPutStrLn stderr $ "ONION encode getRoute -> " ++ show (mapM (\y -> map ($ y) [routeNodeA,routeNodeB,routeNodeC]) x) mapM f x getRoute ni rid >>= mapM' go forwardOnions :: TransportCrypto -> UDPTransport -> UDPTransport forwardOnions crypto udp = udp { awaitMessage = forwardAwait crypto udp } forwardAwait :: TransportCrypto -> UDPTransport -> HandleLo a -> IO a forwardAwait crypto udp kont = do fix $ \another -> do awaitMessage udp $ \case m@(Just (Right (bs,saddr))) -> case B.head bs of 0x80 -> forward kont bs $ handleOnionRequest (Proxy :: Proxy N0) crypto saddr udp another 0x81 -> forward kont bs $ handleOnionRequest (Proxy :: Proxy N1) crypto saddr udp another 0x82 -> forward kont bs $ handleOnionRequest (Proxy :: Proxy N2) crypto saddr udp another 0x8c -> forward kont bs $ handleOnionResponse (Proxy :: Proxy N3) crypto saddr udp another 0x8d -> forward kont bs $ handleOnionResponse (Proxy :: Proxy N2) crypto saddr udp another 0x8e -> forward kont bs $ handleOnionResponse (Proxy :: Proxy N1) crypto saddr udp another _ -> kont m m -> kont m forward :: forall c b b1. (Serialize b, Show b) => (Maybe (Either String b1) -> c) -> ByteString -> (b -> c) -> c forward kont bs f = either (kont . Just . Left) f $ decode $ B.tail bs class SumToThree a b instance SumToThree N0 N3 instance SumToThree (S a) b => SumToThree a (S b) class ( Serialize (ReturnPath n) , Serialize (ReturnPath (S n)) , Serialize (Forwarding (ThreeMinus (S n)) (OnionMessage Encrypted)) , ThreeMinus n ~ S (ThreeMinus (S n)) ) => LessThanThree n instance LessThanThree N0 instance LessThanThree N1 instance LessThanThree N2 type family ThreeMinus n where ThreeMinus N3 = N0 ThreeMinus N2 = N1 ThreeMinus N1 = N2 ThreeMinus N0 = N3 -- n = 0, 1, 2 data OnionRequest n = OnionRequest { onionNonce :: Nonce24 , onionForward :: Forwarding (ThreeMinus n) (OnionMessage Encrypted) , pathFromOwner :: ReturnPath n } deriving instance ( Show (Forwarding (ThreeMinus n) (OnionMessage Encrypted)) , KnownNat (PeanoNat n) ) => Show (OnionRequest n) instance ( Serialize (Forwarding (ThreeMinus n) (OnionMessage Encrypted)) , Sized (ReturnPath n) , Serialize (ReturnPath n) , Typeable n ) => Serialize (OnionRequest n) where get = do -- TODO share code with 'getOnionRequest' n24 <- case eqT :: Maybe (n :~: N3) of Just Refl -> return $ Nonce24 zeros24 Nothing -> get cnt <- remaining let fwdsize = case size :: Size (ReturnPath n) of ConstSize n -> cnt - n fwd <- isolate fwdsize get rpath <- get return $ OnionRequest n24 fwd rpath put (OnionRequest n f p) = maybe (put n) (\Refl -> return ()) (eqT :: Maybe (n :~: N3)) >> put f >> put p -- getRequest :: _ -- getRequest = OnionRequest <$> get <*> get <*> get -- n = 1, 2, 3 -- Attributed (Encrypted ( data OnionResponse n = OnionResponse { pathToOwner :: ReturnPath n , msgToOwner :: OnionMessage Encrypted } deriving instance KnownNat (PeanoNat n) => Show (OnionResponse n) instance ( Serialize (ReturnPath n) ) => Serialize (OnionResponse n) where get = OnionResponse <$> get <*> (get >>= fromMaybe (fail "illegal onion forwarding") . getOnionReply) put (OnionResponse p m) = put p >> putOnionMsg m data Addressed a = Addressed { sockAddr :: SockAddr, unaddressed :: a } deriving (Eq,Show) instance Sized a => Sized (Addressed a) where size = case size :: Size a of ConstSize n -> ConstSize $ 1{-family-} + 16{-ip-} + 2{-port-} + n VarSize f -> VarSize $ \x -> 1{-family-} + 16{-ip-} + 2{-port-} + f (unaddressed x) getForwardAddr :: S.Get SockAddr getForwardAddr = do addrfam <- S.get :: S.Get Word8 ip <- getIP addrfam case ip of IPv4 _ -> S.skip 12 -- compliant peers would zero-fill this. IPv6 _ -> return () port <- S.get :: S.Get PortNumber return $ setPort port $ toSockAddr ip putForwardAddr :: SockAddr -> S.Put putForwardAddr saddr = fromMaybe (return $ error "unsupported SockAddr family") $ do port <- sockAddrPort saddr ip <- fromSockAddr $ either id id $ either4or6 saddr return $ do case ip of IPv4 ip4 -> S.put (0x02 :: Word8) >> S.put ip4 >> S.putByteString (B.replicate 12 0) IPv6 ip6 -> S.put (0x0a :: Word8) >> S.put ip6 S.put port instance Serialize a => Serialize (Addressed a) where get = Addressed <$> getForwardAddr <*> get put (Addressed addr x) = putForwardAddr addr >> put x data N0 data S n type N1 = S N0 type N2 = S N1 type N3 = S N2 class KnownPeanoNat n where peanoVal :: p n -> Int instance KnownPeanoNat N0 where peanoVal _ = 0 instance KnownPeanoNat n => KnownPeanoNat (S n) where peanoVal _ = 1 + peanoVal (Proxy :: Proxy n) type family PeanoNat p where PeanoNat N0 = 0 PeanoNat (S n) = 1 + PeanoNat n data ReturnPath n where NoReturnPath :: ReturnPath N0 ReturnPath :: Nonce24 -> Encrypted (Addressed (ReturnPath n)) -> ReturnPath (S n) -- Size: 59 = 1(family) + 16(ip) + 2(port) +16(mac) + 24(nonce) instance Sized (ReturnPath N0) where size = ConstSize 0 instance Sized (ReturnPath n) => Sized (ReturnPath (S n)) where size = ConstSize 59 <> contramap (\x -> let _ = x :: ReturnPath (S n) in error "non-constant ReturnPath size") (size :: Size (ReturnPath n)) {- instance KnownNat (PeanoNat n) => Sized (ReturnPath n) where size = ConstSize $ 59 * fromIntegral (natVal (Proxy :: Proxy (PeanoNat n))) -} instance Serialize (ReturnPath N0) where get = pure NoReturnPath put NoReturnPath = pure () instance Serialize (ReturnPath N1) where get = ReturnPath <$> get <*> get put (ReturnPath n24 p) = put n24 >> put p instance (Sized (ReturnPath n), Serialize (ReturnPath n)) => Serialize (ReturnPath (S (S n))) where get = ReturnPath <$> get <*> get put (ReturnPath n24 p) = put n24 >> put p {- -- This doesn't work because it tried to infer it for (0 - 1) instance (Serialize (Encrypted (Addressed (ReturnPath (n - 1))))) => Serialize (ReturnPath n) where get = ReturnPath <$> get <*> get put (ReturnPath n24 p) = put n24 >> put p -} instance KnownNat (PeanoNat n) => Show (ReturnPath n) where show rpath = "ReturnPath" ++ show (natVal (Proxy :: Proxy (PeanoNat n))) -- instance KnownNat n => Serialize (ReturnPath n) where -- -- Size: 59 = 1(family) + 16(ip) + 2(port) +16(mac) + 24(nonce) -- get = ReturnPath <$> getBytes ( 59 * (fromIntegral $ natVal $ Proxy @n) ) -- put (ReturnPath bs) = putByteString bs data Forwarding n msg where NotForwarded :: msg -> Forwarding N0 msg Forwarding :: PublicKey -> Encrypted (Addressed (Forwarding n msg)) -> Forwarding (S n) msg instance Show msg => Show (Forwarding N0 msg) where show (NotForwarded x) = "NotForwarded "++show x instance ( KnownNat (PeanoNat (S n)) , Show (Encrypted (Addressed (Forwarding n msg))) ) => Show (Forwarding (S n) msg) where show (Forwarding k a) = unwords [ "Forwarding" , "("++show (natVal (Proxy :: Proxy (PeanoNat (S n))))++")" , show (key2id k) , show a ] instance Sized msg => Sized (Forwarding N0 msg) where size = case size :: Size msg of ConstSize n -> ConstSize n VarSize f -> VarSize $ \(NotForwarded x) -> f x instance Sized (Forwarding n msg) => Sized (Forwarding (S n) msg) where size = ConstSize 32 <> contramap (\(Forwarding _ e) -> e) (size :: Size (Encrypted (Addressed (Forwarding n msg)))) instance Serialize msg => Serialize (Forwarding N0 msg) where get = NotForwarded <$> get put (NotForwarded msg) = put msg instance (Serialize (Encrypted (Addressed (Forwarding n msg)))) => Serialize (Forwarding (S n) msg) where get = Forwarding <$> getPublicKey <*> get put (Forwarding k x) = putPublicKey k >> put x handleOnionRequest :: forall a proxy n. ( LessThanThree n , KnownPeanoNat n , Sized (ReturnPath n) , Typeable n ) => proxy n -> TransportCrypto -> SockAddr -> UDPTransport -> IO a -> OnionRequest n -> IO a handleOnionRequest proxy crypto saddr udp kont (OnionRequest nonce msg rpath) = do let n = peanoVal rpath hPutStrLn stderr $ "handleOnionRequest " ++ show n (sym, snonce) <- atomically ( (,) <$> transportSymmetric crypto <*> transportNewNonce crypto ) case peelOnion crypto nonce msg of Left e -> do -- todo report encryption error hPutStrLn stderr $ unwords [ "peelOnion:", show n, either show show (either4or6 saddr), e] kont Right (Addressed dst msg') -> do hPutStrLn stderr $ unwords [ "peelOnion:", show n, either show show (either4or6 saddr), "-->", either show show (either4or6 dst), "SUCCESS"] sendMessage udp dst (runPut $ putRequest $ OnionRequest nonce msg' $ wrapSymmetric sym snonce saddr rpath) kont wrapSymmetric :: Serialize (ReturnPath n) => SymmetricKey -> Nonce24 -> SockAddr -> ReturnPath n -> ReturnPath (S n) wrapSymmetric sym n saddr rpath = ReturnPath n $ encryptSymmetric sym n (encodePlain $ Addressed saddr rpath) peelSymmetric :: Serialize (Addressed (ReturnPath n)) => SymmetricKey -> ReturnPath (S n) -> Either String (Addressed (ReturnPath n)) peelSymmetric sym (ReturnPath nonce e) = decryptSymmetric sym nonce e >>= decodePlain peelOnion :: Serialize (Addressed (Forwarding n t)) => TransportCrypto -> Nonce24 -> Forwarding (S n) t -> Either String (Addressed (Forwarding n t)) peelOnion crypto nonce (Forwarding k fwd) = fmap runIdentity $ uncomposed $ decryptMessage (dhtKey crypto) nonce (Right $ Assym k nonce fwd) handleOnionResponse :: (KnownPeanoNat n, Sized (ReturnPath n), Serialize (ReturnPath n)) => proxy (S n) -> TransportCrypto -> SockAddr -> UDPTransport -> IO a -> OnionResponse (S n) -> IO a handleOnionResponse proxy crypto saddr udp kont (OnionResponse path msg) = do sym <- atomically $ transportSymmetric crypto case peelSymmetric sym path of Left e -> do -- todo report encryption error let n = peanoVal path hPutStrLn stderr $ unwords [ "peelSymmetric:", show n, either show show (either4or6 saddr), e] kont Right (Addressed dst path') -> do sendMessage udp dst (runPut $ putResponse $ OnionResponse path' msg) kont data AnnounceRequest = AnnounceRequest { announcePingId :: Nonce32 -- Ping ID , announceSeeking :: NodeId -- Public key we are searching for , announceKey :: NodeId -- Public key that we want those sending back data packets to use } deriving Show instance Sized AnnounceRequest where size = ConstSize (32*3) instance S.Serialize AnnounceRequest where get = AnnounceRequest <$> S.get <*> S.get <*> S.get put (AnnounceRequest p s k) = S.put (p,s,k) getOnionRequest :: Sized msg => Get (Assym (Encrypted msg), ReturnPath N3) getOnionRequest = do -- Assumes return path is constant size so that we can isolate -- the variable-sized prefix. cnt <- remaining a <- isolate (case size :: Size (ReturnPath N3) of ConstSize n -> cnt - n) getAliasedAssym path <- get return (a,path) putRequest :: ( KnownPeanoNat n , Serialize (OnionRequest n) , Typeable n ) => OnionRequest n -> Put putRequest req = do let tag = 0x80 + fromIntegral (peanoVal req) when (tag <= 0x82) (putWord8 tag) put req putResponse :: (KnownPeanoNat n, Serialize (OnionResponse n)) => OnionResponse n -> Put putResponse resp = do let tag = 0x8f - fromIntegral (peanoVal resp) -- OnionResponse N0 is an alias for the OnionMessage Encrypted type which includes a tag -- in it's Serialize instance. when (tag /= 0x8f) (putWord8 tag) put resp data KeyRecord = NotStored Nonce32 | SendBackKey PublicKey | Acknowledged Nonce32 deriving Show instance Sized KeyRecord where size = ConstSize 33 instance S.Serialize KeyRecord where get = do is_stored <- S.get :: S.Get Word8 case is_stored of 1 -> SendBackKey <$> getPublicKey 2 -> Acknowledged <$> S.get _ -> NotStored <$> S.get put (NotStored n32) = S.put (0 :: Word8) >> S.put n32 put (SendBackKey key) = S.put (1 :: Word8) >> putPublicKey key put (Acknowledged n32) = S.put (2 :: Word8) >> S.put n32 data AnnounceResponse = AnnounceResponse { is_stored :: KeyRecord , announceNodes :: SendNodes } deriving Show instance Sized AnnounceResponse where size = contramap is_stored size <> contramap announceNodes size getNodeList :: S.Get [NodeInfo] getNodeList = do n <- S.get (:) n <$> (getNodeList <|> pure []) instance S.Serialize AnnounceResponse where get = AnnounceResponse <$> S.get <*> (SendNodes <$> getNodeList) put (AnnounceResponse st (SendNodes ns)) = S.put st >> mapM_ S.put ns data DataToRoute = DataToRoute { dataFromKey :: PublicKey -- Real public key of sender , dataToRoute :: Encrypted OnionData -- (Word8,ByteString) -- DHTPK 0x9c } instance Sized DataToRoute where size = ConstSize 32 <> contramap dataToRoute size instance Serialize DataToRoute where get = DataToRoute <$> getPublicKey <*> get put (DataToRoute k dta) = putPublicKey k >> put dta data OnionData = -- | type 0x9c -- -- We send this packet every 30 seconds if there is more than one peer (in -- the 8) that says they our friend is announced on them. This packet can -- also be sent through the DHT module as a DHT request packet (see DHT) if -- we know the DHT public key of the friend and are looking for them in the -- DHT but have not connected to them yet. 30 second is a reasonable -- timeout to not flood the network with too many packets while making sure -- the other will eventually receive the packet. Since packets are sent -- through every peer that knows the friend, resending it right away -- without waiting has a high likelihood of failure as the chances of -- packet loss happening to all (up to to 8) packets sent is low. -- -- If a friend is online and connected to us, the onion will stop all of -- its actions for that friend. If the peer goes offline it will restart -- searching for the friend as if toxcore was just started. OnionDHTPublicKey DHTPublicKey | -- | type 0x20 -- -- OnionFriendRequest FriendRequest -- 0x20 instance Sized OnionData where size = VarSize $ \case OnionDHTPublicKey dhtpk -> case size of ConstSize n -> n -- Override because OnionData probably -- should be treated as variable sized. VarSize f -> f dhtpk -- FIXME: inconsitantly, we have to add in the tag byte for this case. OnionFriendRequest req -> 1 + case size of ConstSize n -> n VarSize f -> f req selectKey :: TransportCrypto -> OnionMessage Identity -> OnionDestination r -> IO (SecretKey, PublicKey) selectKey crypto (OnionAnnounce a@Assym { assymData = Identity (AnnounceRequest _ pkey akey, _) }) rpath | (akey /= zeroID) = atomically $ do ks <- filter (\(sk,pk) -> pk == id2key pkey) <$> readTVar (userKeys crypto) maybe (return $ aliasKey crypto rpath) return (listToMaybe ks) selectKey crypto msg rpath = return $ aliasKey crypto rpath encrypt :: TransportCrypto -> OnionMessage Identity -> OnionDestination r -> IO (OnionMessage Encrypted, OnionDestination r) encrypt crypto msg rpath = do (skey,pkey) <- selectKey crypto msg rpath let skey = fst $ aliasKey crypto rpath -- The OnionToMe case shouldn't happen, but we'll use our own public -- key in this situation. okey = fromMaybe (transportPublic crypto) $ onionKey rpath return ( transcode ( (. (runIdentity . either id assymData)) . encryptMessage skey okey) msg , rpath) encryptMessage :: Serialize a => SecretKey -> PublicKey -> Nonce24 -> a -> Encrypted a encryptMessage skey destKey n a = ToxCrypto.encrypt secret plain where secret = computeSharedSecret skey destKey n plain = encodePlain a decrypt :: TransportCrypto -> OnionMessage Encrypted -> OnionDestination r -> IO (Either String (OnionMessage Identity, OnionDestination r)) decrypt crypto msg addr = return $ do msg <- sequenceMessage $ transcode (\n -> decryptMessage (aliasKey crypto addr) n . left (senderkey addr)) msg Right (msg, addr) senderkey :: OnionDestination r -> t -> (Maybe PublicKey, t) senderkey addr e = (onionKey addr, e) aliasKey :: TransportCrypto -> OnionDestination r -> (SecretKey,PublicKey) aliasKey crypto (OnionToOwner {}) = (transportSecret &&& transportPublic) crypto aliasKey crypto (OnionDestination {}) = (onionAliasSecret &&& onionAliasPublic) crypto dhtKey :: TransportCrypto -> (SecretKey,PublicKey) dhtKey crypto = (transportSecret &&& transportPublic) crypto decryptMessage :: Serialize x => (SecretKey,PublicKey) -> Nonce24 -> Either (Maybe PublicKey, Encrypted x) (Assym (Encrypted x)) -> (Either String ∘ Identity) x decryptMessage crypto n arg | Just secret <- msecret = plain $ ToxCrypto.decrypt secret e | otherwise = Composed $ Left "decryptMessage: Unknown sender" where msecret = do sender <- mkey Just $ computeSharedSecret (fst crypto) sender n (mkey,e) = either id (Just . senderKey &&& assymData) arg plain = Composed . fmap Identity . (>>= decodePlain) sequenceMessage :: Applicative m => OnionMessage (m ∘ f) -> m (OnionMessage f) sequenceMessage (OnionAnnounce a) = fmap OnionAnnounce $ sequenceA $ fmap uncomposed a sequenceMessage (OnionAnnounceResponse n8 n24 dta) = OnionAnnounceResponse n8 n24 <$> uncomposed dta sequenceMessage (OnionToRoute pub a) = pure $ OnionToRoute pub a sequenceMessage (OnionToRouteResponse a) = pure $ OnionToRouteResponse a -- sequenceMessage (OnionToRouteResponse a) = fmap OnionToRouteResponse $ sequenceA $ fmap uncomposed a transcode :: forall f g. (forall a. Serialize a => Nonce24 -> Either (f a) (Assym (f a)) -> g a) -> OnionMessage f -> OnionMessage g transcode f (OnionAnnounce a) = OnionAnnounce $ a { assymData = f (assymNonce a) (Right a) } transcode f (OnionAnnounceResponse n8 n24 dta) = OnionAnnounceResponse n8 n24 $ f n24 $ Left dta transcode f (OnionToRoute pub a) = OnionToRoute pub a transcode f (OnionToRouteResponse a) = OnionToRouteResponse a -- transcode f (OnionToRouteResponse a) = OnionToRouteResponse $ a { assymData = f (assymNonce a) (Right a) } data OnionRoute = OnionRoute { routeAliasA :: SecretKey , routeAliasB :: SecretKey , routeAliasC :: SecretKey , routeNodeA :: NodeInfo , routeNodeB :: NodeInfo , routeNodeC :: NodeInfo } wrapForRoute :: OnionMessage Encrypted -> NodeInfo -> OnionRoute -> OnionRequest N0 wrapForRoute msg ni r = -- We needn't use the same nonce value here, but I think it is safe to do so. let nonce = msgNonce msg in OnionRequest { onionNonce = nonce , onionForward = wrapOnion (routeAliasA r) nonce (id2key . nodeId $ routeNodeA r) (nodeAddr $ routeNodeB r) $ wrapOnion (routeAliasB r) nonce (id2key . nodeId $ routeNodeB r) (nodeAddr $ routeNodeC r) $ wrapOnion (routeAliasC r) nonce (id2key . nodeId $ routeNodeC r) (nodeAddr ni) $ NotForwarded msg , pathFromOwner = NoReturnPath } wrapOnion :: Serialize (Forwarding n msg) => SecretKey -> Nonce24 -> PublicKey -> SockAddr -> Forwarding n msg -> Forwarding (S n) msg wrapOnion skey nonce destkey saddr fwd = Forwarding (toPublic skey) $ encryptMessage skey destkey nonce (Addressed saddr fwd) -- TODO -- Two types of packets may be sent to Rendezvous via OnionToRoute requests. -- -- (1) DHT public key packet (0x9c) -- -- (2) Friend request data Rendezvous = Rendezvous { rendezvousKey :: PublicKey , rendezvousNode :: NodeInfo } deriving Eq instance Show Rendezvous where show (Rendezvous k ni) = concat [show $ key2id k, ":", show ni] parseDataToRoute :: TransportCrypto -> (OnionMessage Encrypted,OnionDestination r) -> Either (Assym (Encrypted DataToRoute),Rendezvous) (OnionMessage Encrypted, OnionDestination r) parseDataToRoute crypto (OnionToRouteResponse dta, od) = Left ( dta , Rendezvous (onionAliasPublic crypto) $ onionNodeInfo od ) parseDataToRoute _ msg = Right msg encodeDataToRoute :: TransportCrypto -> (Assym (Encrypted DataToRoute),Rendezvous) -> Maybe (OnionMessage Encrypted,OnionDestination r) encodeDataToRoute crypto (dta, Rendezvous pub ni) = Just ( OnionToRoute pub -- Public key of destination node dta , OnionDestination ni Nothing )