{-# LANGUAGE CPP #-} {-# 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 , AliasSelector(..) , OnionDestination(..) , OnionMessage(..) , Rendezvous(..) , DataToRoute(..) , OnionData(..) , AnnouncedRendezvous(..) , AnnounceResponse(..) , AnnounceRequest(..) , Forwarding(..) , ReturnPath(..) , OnionRequest(..) , OnionResponse(..) , Addressed(..) , UDPTransport , KeyRecord(..) , encrypt , decrypt , peelSymmetric , OnionRoute(..) , N3 , onionKey , onionAliasSelector , selectAlias , RouteId(..) , routeId ) 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 Control.Applicative import Control.Arrow import Control.Concurrent.STM import Control.Monad import qualified Data.ByteString as B ;import Data.ByteString (ByteString) import Data.Function import Data.Functor.Contravariant import Data.Functor.Identity #if MIN_VERSION_iproute(1,7,4) import Data.IP hiding (fromSockAddr) #else import Data.IP #endif 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 qualified Text.ParserCombinators.ReadP as RP import Data.Hashable import DPut import DebugTag type HandleLo a = Maybe (Either String (ByteString, SockAddr)) -> IO a type UDPTransport = Transport String SockAddr ByteString getOnionAsymm :: Get (Asymm (Encrypted DataToRoute)) getOnionAsymm = getAliasedAsymm putOnionAsymm :: Serialize a => Word8 -> Put -> Asymm a -> Put putOnionAsymm typ p a = put typ >> p >> putAliasedAsymm a data OnionMessage (f :: * -> *) = OnionAnnounce (Asymm (f (AnnounceRequest,Nonce8))) | OnionAnnounceResponse Nonce8 Nonce24 (f AnnounceResponse) | OnionToRoute PublicKey (Asymm (Encrypted DataToRoute)) -- destination key, aliased Asymm | OnionToRouteResponse (Asymm (Encrypted DataToRoute)) deriving instance ( Show (f (AnnounceRequest, Nonce8)) , Show (f AnnounceResponse) , Show (f DataToRoute) ) => Show (OnionMessage f) msgNonce :: OnionMessage f -> Nonce24 msgNonce (OnionAnnounce a) = asymmNonce a msgNonce (OnionAnnounceResponse _ n24 _) = n24 msgNonce (OnionToRoute _ a) = asymmNonce a msgNonce (OnionToRouteResponse a) = asymmNonce a data AliasSelector = SearchingAlias | AnnouncingAlias SecretKey PublicKey deriving (Eq,Show) data OnionDestination r = OnionToOwner { onionNodeInfo :: NodeInfo , onionReturnPath :: ReturnPath N3 -- ^ Somebody else's path to us. } | OnionDestination { onionAliasSelector' :: AliasSelector , onionNodeInfo :: NodeInfo , onionRouteSpec :: Maybe r -- ^ Our own onion-path. } deriving Show onionAliasSelector :: OnionDestination r -> AliasSelector onionAliasSelector (OnionToOwner {} ) = SearchingAlias onionAliasSelector (OnionDestination{onionAliasSelector' = sel}) = sel onionKey :: OnionDestination r -> PublicKey onionKey od = 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 <$> getAliasedAsymm 0x85 -> OnionToRoute <$> getPublicKey <*> getAliasedAsymm t -> fail ("Unknown onion payload: " ++ show t) `fromMaybe` getOnionReply t put (OnionAnnounce a) = putWord8 0x83 >> putAliasedAsymm a put (OnionToRoute k a) = putWord8 0x85 >> putPublicKey k >> putAliasedAsymm a put (OnionAnnounceResponse n8 n24 x) = putWord8 0x84 >> put n8 >> put n24 >> put x put (OnionToRouteResponse a) = putWord8 0x86 >> putAliasedAsymm a onionToOwner :: Asymm a -> ReturnPath N3 -> SockAddr -> Either String (OnionDestination r) onionToOwner asymm ret3 saddr = do ni <- nodeInfo (key2id $ senderKey asymm) saddr return $ OnionToOwner ni ret3 -- data CookieAddress = WithoutCookie NodeInfo | CookieAddress Cookie SockAddr onion :: Sized msg => ByteString -> SockAddr -> Get (Asymm (Encrypted msg) -> t) -> Either String (t, OnionDestination r) onion bs saddr getf = do (f,(asymm,ret3)) <- runGet ((,) <$> getf <*> getOnionRequest) bs oaddr <- onionToOwner asymm ret3 saddr return (f asymm, oaddr) parseOnionAddr :: (SockAddr -> Nonce8 -> IO (Maybe (OnionDestination 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 . \od -> (msg,od)) maddr Just (Right msg@(OnionToRouteResponse asym)) -> do let ni = asymNodeInfo saddr asym return $ Left (msg, OnionDestination SearchingAlias ni Nothing) _ -> return right getOnionReply :: Word8 -> Maybe (Get (OnionMessage Encrypted)) getOnionReply 0x84 = Just $ OnionAnnounceResponse <$> get <*> get <*> get getOnionReply 0x86 = Just $ OnionToRouteResponse <$> getOnionAsymm getOnionReply _ = Nothing putOnionMsg :: OnionMessage Encrypted -> Put putOnionMsg (OnionAnnounce a) = putOnionAsymm 0x83 (return ()) a putOnionMsg (OnionToRoute pubkey a) = putOnionAsymm 0x85 (putPublicKey pubkey) a putOnionMsg (OnionAnnounceResponse n8 n24 x) = put (0x84 :: Word8) >> put n8 >> put n24 >> put x putOnionMsg (OnionToRouteResponse a) = putOnionAsymm 0x86 (return ()) a newtype RouteId = RouteId Int deriving Show -- We used to derive the RouteId from the Nonce8 associated with the query. -- This is problematic because a nonce generated by toxcore will not validate -- if it is received via a different route than it was issued. This is -- described by the Tox spec: -- -- Toxcore generates `ping_id`s by taking a 32 byte sha hash of the current -- time, some secret bytes generated when the instance is created, the -- current time divided by a 20 second timeout, the public key of the -- requester and the source ip/port that the packet was received from. Since -- the ip/port that the packet was received from is in the `ping_id`, the -- announce packets being sent with a ping id must be sent using the same -- path as the packet that we received the `ping_id` from or announcing will -- fail. -- -- The original idea was: -- -- > routeId :: Nonce8 -> RouteId -- > routeId (Nonce8 w8) = RouteId $ mod (fromIntegral w8) 12 -- -- Instead, we'll just hash the destination node id. routeId :: NodeId -> RouteId routeId nid = RouteId $ mod (hash nid) 12 encodeOnionAddr :: TransportCrypto -> (NodeInfo -> RouteId -> IO (Maybe OnionRoute)) -> (OnionMessage Encrypted,OnionDestination RouteId) -> IO (Maybe (ByteString, SockAddr)) encodeOnionAddr crypto _ (msg,OnionToOwner ni p) = return $ Just ( runPut $ putResponse (OnionResponse p msg) , nodeAddr ni ) encodeOnionAddr crypto getRoute (msg,OnionDestination x ni Nothing) = do encodeOnionAddr crypto getRoute (msg,OnionDestination x ni (Just $ routeId $ nodeId ni) ) -- dput XMisc $ "ONION encode missing routeid" -- return Nothing encodeOnionAddr crypto getRoute (msg,OnionDestination _ ni (Just rid)) = do let go route = do req <- wrapForRoute crypto msg ni route return ( runPut $ putRequest req , nodeAddr $ routeNodeA route) m <- {-# SCC "encodeOnionAddr.getRoute" #-} getRoute ni rid x <- {-# SCC "encodeOnionAddr.wrapForRoute" #-} mapM go m return x 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 dput XOnion $ "handleOnionRequest " ++ show n (sym, snonce) <- atomically ( (,) <$> transportSymmetric crypto <*> transportNewNonce crypto ) peeled <- peelOnion crypto nonce msg case peeled of Left e -> do -- todo report encryption error dput XOnion $ unwords [ "peelOnion:", show n, either show show (either4or6 saddr), e] kont Right (Addressed dst msg') -> do dput XOnion $ 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 -> IO (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) 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 dput XMisc $ 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 (Asymm (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) getAliasedAsymm 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 deriving (Eq,Show) 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 instance Serialize OnionData where get = do tag <- get case tag :: Word8 of 0x9c -> OnionDHTPublicKey <$> get 0x20 -> OnionFriendRequest <$> get _ -> fail $ "Unknown onion data: "++show tag 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 crypto _ rpath@(OnionDestination (AnnouncingAlias skey pkey) _ _) = return (skey, pkey) 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 -- source key let okey = onionKey rpath -- destination key encipher1 :: Serialize a => SecretKey -> PublicKey -> Nonce24 -> a -> (IO ∘ Encrypted) a encipher1 sk pk n a = Composed $ do secret <- lookupSharedSecret crypto sk pk n return $ ToxCrypto.encrypt secret $ encodePlain a encipher :: Serialize a => Nonce24 -> Either (Identity a) (Asymm (Identity a)) -> (IO ∘ Encrypted) a encipher n d = encipher1 skey okey n $ either runIdentity (runIdentity . asymmData) d m <- sequenceMessage $ transcode encipher msg return (m, rpath) decrypt :: TransportCrypto -> OnionMessage Encrypted -> OnionDestination r -> IO (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 decipher1 crypto k n arg = Composed $ do let (sender,e) = either id (senderKey &&& asymmData) arg secret <- lookupSharedSecret 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 decipher = (\n -> decipher1 crypto skey n . left (senderkey addr)) foo <- sequenceMessage $ transcode decipher msg return $ do msg <- sequenceMessage foo Right (msg, addr) senderkey :: OnionDestination r -> t -> (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 => TransportCrypto -> (SecretKey,PublicKey) -> Nonce24 -> Either (PublicKey, Encrypted x) (Asymm (Encrypted x)) -> IO ((Either String ∘ Identity) x) decryptMessage crypto (sk,pk) n arg = do let (sender,e) = either id (senderKey &&& asymmData) arg plain = Composed . fmap Identity . (>>= decodePlain) secret <- lookupSharedSecret crypto sk sender n return $ plain $ ToxCrypto.decrypt secret e 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) (Asymm (f a)) -> g a) -> OnionMessage f -> OnionMessage g transcode f (OnionAnnounce a) = OnionAnnounce $ a { asymmData = f (asymmNonce 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 { asymmData = f (asymmNonce a) (Right a) } data OnionRoute = OnionRoute { routeAliasA :: SecretKey , routeAliasB :: SecretKey , routeAliasC :: SecretKey , routeNodeA :: NodeInfo , routeNodeB :: NodeInfo , routeNodeC :: NodeInfo } wrapForRoute :: TransportCrypto -> OnionMessage Encrypted -> NodeInfo -> OnionRoute -> IO (OnionRequest N0) wrapForRoute crypto msg ni r = do -- We needn't use the same nonce value here, but I think it is safe to do so. let nonce = msgNonce msg fwd <- wrapOnion crypto (routeAliasA r) nonce (id2key . nodeId $ routeNodeA r) (nodeAddr $ routeNodeB r) =<< wrapOnion crypto (routeAliasB r) nonce (id2key . nodeId $ routeNodeB r) (nodeAddr $ routeNodeC r) =<< wrapOnion crypto (routeAliasC r) nonce (id2key . nodeId $ routeNodeC r) (nodeAddr ni) (NotForwarded msg) return OnionRequest { onionNonce = nonce , onionForward = fwd , pathFromOwner = NoReturnPath } wrapOnion :: Serialize (Forwarding n msg) => TransportCrypto -> SecretKey -> Nonce24 -> PublicKey -> SockAddr -> Forwarding n msg -> IO (Forwarding (S n) msg) wrapOnion crypto skey nonce destkey saddr fwd = do let plain = encodePlain $ Addressed saddr fwd secret <- lookupSharedSecret crypto skey destkey nonce return $ Forwarding (toPublic skey) $ ToxCrypto.encrypt secret plain -- 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 showsPrec d (Rendezvous k ni) = showsPrec d (key2id k) . (':' :) . showsPrec d ni instance Read Rendezvous where readsPrec d = RP.readP_to_S $ do rkstr <- RP.munch (/=':') RP.char ':' nistr <- RP.munch (const True) return Rendezvous { rendezvousKey = id2key $ read rkstr , rendezvousNode = read nistr } data AnnouncedRendezvous = AnnouncedRendezvous { remoteUserKey :: PublicKey , rendezvous :: Rendezvous } deriving Eq instance Show AnnouncedRendezvous where showsPrec d (AnnouncedRendezvous remote rendez) = showsPrec d (key2id remote) . (':' :) . showsPrec d rendez instance Read AnnouncedRendezvous where readsPrec d = RP.readP_to_S $ do ukstr <- RP.munch (/=':') RP.char ':' rkstr <- RP.munch (/=':') RP.char ':' nistr <- RP.munch (const True) return AnnouncedRendezvous { remoteUserKey = id2key $ read ukstr , rendezvous = Rendezvous { rendezvousKey = id2key $ read rkstr , rendezvousNode = read nistr } } selectAlias :: TransportCrypto -> NodeId -> STM AliasSelector selectAlias crypto pkey = do ks <- filter (\(sk,pk) -> pk == id2key pkey) <$> userKeys crypto maybe (return SearchingAlias) (return . uncurry AnnouncingAlias) (listToMaybe ks) parseDataToRoute :: TransportCrypto -> (OnionMessage Encrypted,OnionDestination r) -> IO (Either ((PublicKey,OnionData),AnnouncedRendezvous) (OnionMessage Encrypted, OnionDestination r)) parseDataToRoute crypto (OnionToRouteResponse dta, od) = do ks <- atomically $ userKeys crypto omsg0 <- decryptMessage crypto (rendezvousSecret crypto,rendezvousPublic crypto) (asymmNonce dta) (Right dta) -- using Asymm{senderKey} as remote key let eOuter = fmap runIdentity $ uncomposed omsg0 anyRight [] f = return $ Left "parseDataToRoute: no user key" anyRight (x:xs) f = f x >>= either (const $ anyRight xs f) (return . Right) -- TODO: We don't currently have a way to look up which user key we -- announced using along this onion route. Therefore, for now, we will -- try all our user keys to see if any can decrypt the packet. eInner <- case eOuter of Left e -> return $ Left e Right dtr -> anyRight ks $ \(sk,pk) -> do omsg0 <- decryptMessage crypto (sk,pk) (asymmNonce dta) (Left (dataFromKey dtr, dataToRoute dtr)) return $ do omsg <- fmap runIdentity . uncomposed $ omsg0 Right (pk,dtr,omsg) let e = do (pk,dtr,omsg) <- eInner return ( (pk, omsg) , AnnouncedRendezvous (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) ] return r parseDataToRoute _ msg = return $ Right msg encodeDataToRoute :: TransportCrypto -> ((PublicKey,OnionData),AnnouncedRendezvous) -> IO (Maybe (OnionMessage Encrypted,OnionDestination r)) encodeDataToRoute crypto ((me,omsg), AnnouncedRendezvous toxid (Rendezvous pub ni)) = do nonce <- atomically $ transportNewNonce crypto asel <- atomically $ selectAlias crypto (key2id me) let (sk,pk) = case asel of AnnouncingAlias sk pk -> (sk,pk) _ -> (onionAliasSecret crypto, onionAliasPublic crypto) innerSecret <- lookupSharedSecret crypto sk toxid nonce let plain = encodePlain $ DataToRoute { dataFromKey = pk , dataToRoute = ToxCrypto.encrypt innerSecret $ encodePlain omsg } outerSecret <- lookupSharedSecret crypto (onionAliasSecret crypto) pub nonce let dta = ToxCrypto.encrypt outerSecret plain dput XOnion $ unlines [ "encodeDataToRoute me=" ++ show (key2id me) , " dhtpk=" ++ case omsg of OnionDHTPublicKey dmsg -> show (key2id $ dhtpk dmsg) OnionFriendRequest fr -> "friend request" , " ns=" ++ case omsg of OnionDHTPublicKey dmsg -> show (dhtpkNodes dmsg) OnionFriendRequest fr -> "friend request" , " crypto inner.me =" ++ show (key2id pk) , " inner.you=" ++ show (key2id toxid) , " outer.me =" ++ show (key2id $ onionAliasPublic crypto) , " outer.you=" ++ show (key2id pub) , " " ++ show (AnnouncedRendezvous toxid (Rendezvous pub ni)) , " " ++ show dta ] return $ Just ( OnionToRoute toxid -- Public key of destination node Asymm { senderKey = onionAliasPublic crypto , asymmNonce = nonce , asymmData = dta } , OnionDestination SearchingAlias ni Nothing )