{-# 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 , forwardOnions , OnionDestination(..) , OnionMessage(..) , DataToRoute(..) , AnnounceResponse(..) , AnnounceRequest(..) , Forwarding(..) , ReturnPath(..) , OnionRequest(..) , OnionResponse(..) , Addressed(..) , UDPTransport , KeyRecord(..) , encrypt , decrypt , peelSymmetric ) 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,asymNodeInfo) import Debug.Trace import Control.Arrow 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) data OnionDestination = OnionToOwner NodeInfo (ReturnPath N3) -- ^ Somebody else's path to us. | OnionDestination NodeInfo -- ^ Our own onion-path. deriving Show onionKey :: OnionDestination -> Maybe PublicKey onionKey (OnionToOwner ni _) = Just $ id2key (nodeId ni) onionKey _ = Nothing 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 0x84 -> getOnionReply typ 0x86 -> getOnionReply typ t -> fail $ "Unknown onion payload: " ++ show 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 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) onion bs saddr getf = do (f,(assym,ret3)) <- runGet ((,) <$> getf <*> getOnionRequest) bs oaddr <- onionToOwner assym ret3 saddr return (f assym, oaddr) parseOnionAddr :: (ByteString, SockAddr) -> Either (OnionMessage Encrypted,OnionDestination) (ByteString,SockAddr) parseOnionAddr (msg,saddr) | Just (typ,bs) <- B.uncons msg , let right = Right (msg,saddr) query = either (const right) Left response = either (const right) (Left . \msg -> ( msg , replyAlias saddr msg )) = case typ of 0x83 -> query $ onion bs saddr (pure OnionAnnounce) -- Announce Request 0x85 -> query $ onion bs saddr (OnionToRoute <$> getPublicKey) -- Onion Data Request 0x84 -> response $ runGet (getOnionReply 0x84) bs -- Announce Response 0x86 -> response $ runGet (getOnionReply 0x86) bs -- Onion Data Response _ -> right getOnionReply :: Word8 -> Get (OnionMessage Encrypted) getOnionReply 0x84 = OnionAnnounceResponse <$> get <*> get <*> get getOnionReply 0x86 = OnionToRouteResponse <$> getOnionAssym replyAlias :: SockAddr -> OnionMessage Encrypted -> OnionDestination replyAlias saddr (OnionAnnounceResponse _ _ _) = OnionDestination $ either (error "replyAlias: bad protocol") id $ nodeInfo zeroID saddr -- TODO OnionAnnounceResponse has no sender key replyAlias saddr (OnionToRouteResponse asym) = OnionDestination $ asymNodeInfo saddr asym 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 :: (OnionMessage Encrypted,OnionDestination) -> (ByteString, SockAddr) encodeOnionAddr (msg,OnionToOwner ni p) = ( runPut $ putResponse (OnionResponse p msg) , nodeAddr ni ) encodeOnionAddr (msg,OnionDestination a) = ( runPut (putOnionMsg msg), nodeAddr a) -- TODO: Construct (OnionRequest N0)? 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) ) => Serialize (OnionRequest n) where get = do -- TODO share code with 'getOnionRequest' n24 <- 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) = put n >> 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 >>= 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) ) => 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), "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 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)) => OnionRequest n -> Put putRequest req = do putWord8 $ 0x80 + fromIntegral (peanoVal req) 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 instance S.Serialize AnnounceResponse where get = AnnounceResponse <$> S.get <*> S.get put (AnnounceResponse st ns) = S.put st >> 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 = OnionDHTPublicKey DHTPublicKey -- 0x9c instance Sized OnionData where size = VarSize $ \(OnionDHTPublicKey dhtpk) -> case size of ConstSize n -> n -- Override because OnionData probably -- should be treated as variable sized. VarSize f -> f dhtpk encrypt :: TransportCrypto -> OnionMessage Identity -> OnionDestination -> (OnionMessage Encrypted, OnionDestination) encrypt crypto msg rpath = ( transcode ( (. (runIdentity . either id assymData)) . encryptMessage skey okey) msg , rpath) where skey = transportSecret crypto -- The OnionToMe case shouldn't happen, but we'll use our own public -- key in this situation. okey = fromMaybe (transportPublic crypto) $ onionKey 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 -> Either String (OnionMessage Identity, OnionDestination) decrypt crypto msg addr = (, addr) <$> (sequenceMessage $ transcode (decryptMessage crypto) msg) decryptMessage :: Serialize x => TransportCrypto -> Nonce24 -> Either (Encrypted x) (Assym (Encrypted x)) -> (Either String ∘ Identity) x decryptMessage crypto n (Right assymE) = plain $ ToxCrypto.decrypt secret e where secret = computeSharedSecret (transportSecret crypto) (senderKey assymE) n e = assymData assymE plain = Composed . fmap Identity . (>>= decodePlain) decryptMessage crypto n (Left e) = _todo -- OnionAnnounceResponse has no sender key 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 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