{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveDataTypeable #-} {-# 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 Data.Tox.Onion where import Network.Address (fromSockAddr,toSockAddr,setPort,either4or6,sockAddrPort,localhost4,localhost6) 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 Network.Tox.TCP.NodeId (fromUDPNode) 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.Data 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 import Data.Word64Map (fitsInInt) import Data.Bits (shiftR,shiftL) import qualified Rank2 import Util (sameAddress) type HandleLo a = Arrival String SockAddr ByteString -> 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) -- XXX: Why is Nonce8 transmitted in the clear? | OnionToRoute PublicKey (Asymm (Encrypted DataToRoute)) -- destination key, aliased Asymm | OnionToRouteResponse (Asymm (Encrypted DataToRoute)) deriving instance ( Eq (f (AnnounceRequest, Nonce8)) , Eq (f AnnounceResponse) , Eq (f DataToRoute) ) => Eq (OnionMessage f) deriving instance ( Ord (f (AnnounceRequest, Nonce8)) , Ord (f AnnounceResponse) , Ord (f DataToRoute) ) => Ord (OnionMessage f) deriving instance ( Show (f (AnnounceRequest, Nonce8)) , Show (f AnnounceResponse) , Show (f DataToRoute) ) => Show (OnionMessage f) instance Data (OnionMessage Encrypted) where gfoldl f z txt = z (either error id . S.decode) `f` S.encode txt toConstr _ = error "OnionMessage.toConstr" gunfold _ _ = error "OnionMessage.gunfold" #if MIN_VERSION_base(4,2,0) dataTypeOf _ = mkNoRepType "Network.Tox.Onion.Transport.OnionMessage" #else dataTypeOf _ = mkNorepType "Network.Tox.Onion.Transport.OnionMessage" #endif instance Rank2.Functor OnionMessage where f <$> m = mapPayload (Proxy :: Proxy Serialize) f m instance Payload Serialize OnionMessage where mapPayload _ f (OnionAnnounce a) = OnionAnnounce (fmap f a) mapPayload _ f (OnionAnnounceResponse n8 n24 a) = OnionAnnounceResponse n8 n24 (f a) mapPayload _ f (OnionToRoute k a) = OnionToRoute k a mapPayload _ f (OnionToRouteResponse a) = OnionToRouteResponse a 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 nodeInfo 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 substituteLoopback :: SockAddr -- ^ UDP bind address -> SockAddr -- ^ Logical destination address. -> SockAddr -- ^ Destination address unless localhost, then bind address. substituteLoopback (SockAddrInet 0 _ ) saddr = saddr substituteLoopback (SockAddrInet6 _ _ (0,0,0,0) _) saddr = saddr substituteLoopback baddr saddr = case either4or6 saddr of Left s -> if sameAddress s localhost4 then baddr else saddr Right s -> if sameAddress s localhost6 then baddr else saddr handleLoopback :: SockAddr -> UDPTransport -> UDPTransport handleLoopback baddr udp = udp { sendMessage = \a x -> sendMessage udp (substituteLoopback baddr a) x } forwardOnions :: TransportCrypto -> SockAddr -- UDP bind address -> UDPTransport -> (Int -> OnionMessage Encrypted -> IO ()) {- ^ TCP relay send -} -> UDPTransport forwardOnions crypto baddr udp sendTCP = udp { awaitMessage = forwardAwait crypto (handleLoopback baddr udp) sendTCP } 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 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 (Eq,Ord) {- instance (Typeable n, Sized (ReturnPath n), Serialize (ReturnPath n) , Serialize (Forwarding (ThreeMinus n) (OnionMessage Encrypted)) ) => Data (OnionRequest n) where gfoldl f z txt = z (either error id . S.decode) `f` S.encode txt toConstr _ = error "OnionRequest.toConstr" gunfold _ _ = error "OnionRequest.gunfold" #if MIN_VERSION_base(4,2,0) dataTypeOf _ = mkNoRepType "Network.Tox.Onion.Transport.OnionRequest" #else dataTypeOf _ = mkNorepType "Network.Tox.Onion.Transport.OnionRequest" #endif -} instance (Typeable n, Serialize (ReturnPath n)) => Data (OnionResponse n) where gfoldl f z txt = z (either error id . S.decode) `f` S.encode txt toConstr _ = error "OnionResponse.toConstr" gunfold _ _ = error "OnionResponse.gunfold" #if MIN_VERSION_base(4,2,0) dataTypeOf _ = mkNoRepType "Network.Tox.Onion.Transport.OnionResponse" #else dataTypeOf _ = mkNorepType "Network.Tox.Onion.Transport.OnionResponse" #endif deriving instance ( Show (Forwarding (ThreeMinus n) (OnionMessage Encrypted)) , KnownNat (PeanoNat n) ) => Show (OnionRequest n) instance Sized (OnionRequest N0) where -- N1 and N2 are the same, N3 does not encode the nonce. size = contramap onionNonce size <> contramap onionForward size <> contramap pathFromOwner size 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 (Eq,Ord) 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 instance (Sized (ReturnPath n)) => Sized (OnionResponse (S n)) where size = contramap pathToOwner size <> contramap msgToOwner size data Addressed a = Addressed { sockAddr :: SockAddr, unaddressed :: a } | TCPIndex { tcpIndex :: Int, unaddressed :: a } deriving (Eq,Ord,Show) instance (Typeable a, Serialize a) => Data (Addressed a) where gfoldl f z a = z (either error id . S.decode) `f` S.encode a toConstr _ = error "Addressed.toConstr" gunfold _ _ = error "Addressed.gunfold" #if MIN_VERSION_base(4,2,0) dataTypeOf _ = mkNoRepType "Network.Tox.Onion.Transport.Addressed" #else dataTypeOf _ = mkNorepType "Network.Tox.Onion.Transport.Addressed" #endif 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 addrToIndex :: SockAddr -> Int addrToIndex (SockAddrInet6 _ _ (lo, hi, _, _) _) = if fitsInInt (Proxy :: Proxy Word64) then fromIntegral lo + (fromIntegral hi `shiftL` 32) else fromIntegral lo addrToIndex _ = 0 indexToAddr :: Int -> SockAddr indexToAddr x = SockAddrInet6 0 0 (fromIntegral x, fromIntegral (x `shiftR` 32),0,0) 0 -- Note, toxcore would check an address family byte here to detect a TCP-bound -- packet, but we instead use the IPv6 id and rely on the port number being -- zero. Since it will be symmetrically encrypted for our eyes only, it's not -- important to conform on this point. instance Serialize a => Serialize (Addressed a) where get = do saddr <- getForwardAddr a <- get case sockAddrPort saddr of Just 0 -> return $ TCPIndex (addrToIndex saddr) a _ -> return $ Addressed saddr a put (Addressed addr x) = putForwardAddr addr >> put x put (TCPIndex idx x) = putForwardAddr (indexToAddr idx) >> put x data N0 data S n type N1 = S N0 type N2 = S N1 type N3 = S N2 deriving instance Data N0 deriving instance Data n => Data (S n) 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) deriving instance Eq (ReturnPath n) deriving instance Ord (ReturnPath 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 deriving instance Eq msg => Eq (Forwarding n msg) deriving instance Ord msg => Ord (Forwarding 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 {- rewrap :: (ThreeMinus n ~ S (ThreeMinus (S n)), Serialize (ReturnPath n), Serialize (Forwarding (ThreeMinus (S n)) (OnionMessage Encrypted))) => TransportCrypto -> (forall x. x -> Addressed x) -> OnionRequest n -> IO (Either String (OnionRequest (S n), SockAddr)) rewrap crypto saddr (OnionRequest nonce msg rpath) = do (sym, snonce) <- atomically ( (,) <$> transportSymmetric crypto <*> transportNewNonce crypto ) peeled <- peelOnion crypto nonce msg return $ peeled >>= \case Addressed dst msg' -> Right (OnionRequest nonce msg' $ wrapSymmetric sym snonce saddr rpath, dst) _ -> Left "Onion forward to TCP client?" -} handleOnionRequest :: forall a proxy n. ( LessThanThree n , KnownPeanoNat n , Sized (ReturnPath n) , Typeable 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 let n = peanoVal rpath dput XOnion $ "handleOnionRequest " ++ show n (sym, snonce) <- atomically ( (,) <$> 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 dput XOnion $ unwords [ "peelOnion:", show n, showDestination, e] kont Right (Addressed dst msg') -> 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 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) wrapSymmetric sym n saddr rpath = ReturnPath n $ encryptSymmetric sym n (encodePlain $ 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), Typeable n) => proxy (S n) -> TransportCrypto -> 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 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 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 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 . map fromUDPNode <$> 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 } deriving Show 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 , routeRelayPort :: Maybe PortNumber } deriving Show 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 wrapOnionPure :: Serialize (Forwarding n msg) => SecretKey -> ToxCrypto.State -> SockAddr -> Forwarding n msg -> Forwarding (S n) msg wrapOnionPure skey st saddr fwd = Forwarding (toPublic skey) (ToxCrypto.encrypt st plain) where plain = encodePlain $ 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 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 )