Moved OnionTransport to its hierarchical location.

1 files changed, 569 insertions, 0 deletions

diff --git a/src/Network/Tox/Onion/Transport.hs b/src/Network/Tox/Onion/Transport.hs
new file mode 100644
index 00000000..f10dcb43
--- /dev/null
+++ b/src/Network/Tox/Onion/Transport.hs
@@ -0,0 +1,569 @@
+{-# 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 TypeFamilyDependencies     #-}
+{-# LANGUAGE TypeOperators              #-}
+{-# LANGUAGE UndecidableInstances       #-}
+module Network.Tox.Onion.Transport
+    ( parseOnionAddr
+    , encodeOnionAddr
+    , forwardOnions
+    , OnionToOwner(..)
+    , 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.Address
+import qualified Crypto.Tox as ToxCrypto
+import Network.Tox.DHT.Transport (NodeInfo(..),NodeId(..),SendNodes,nodeInfo,DHTPublicKey)
+
+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 (f DataToRoute)) -- destination key, aliased Assym
+    | OnionToRouteResponse (Assym (f DataToRoute))
+
+deriving instance ( Show (f (AnnounceRequest, Nonce8))
+                  , Show (f AnnounceResponse)
+                  , Show (f DataToRoute)
+                  ) => Show (OnionMessage f)
+
+data OnionToOwner = OnionToOwner NodeInfo (ReturnPath N3)
+                  | OnionToMe SockAddr -- SockAddr is immediate peer in route
+    deriving Show
+
+onionKey :: OnionToOwner -> 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 OnionToOwner
+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, OnionToOwner)
+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,OnionToOwner) (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 . (, OnionToMe saddr))
+    = 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
+
+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,OnionToOwner) -> (ByteString, SockAddr)
+encodeOnionAddr (msg,OnionToOwner ni p) = ( runPut $ putResponse (OnionResponse p msg)
+                                          , nodeAddr ni )
+encodeOnionAddr (msg,OnionToMe a) = ( runPut (putOnionMsg msg), a)
+
+forwardOnions :: TransportCrypto -> UDPTransport -> UDPTransport -- HandleHi a -> IO a -> HandleLo a
+forwardOnions crypto udp = udp { awaitMessage = forwardAwait crypto udp }
+
+-- forMe :: HandleHi
+-- forThem :: handleLo
+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 = r | r -> 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 -> OnionToOwner -> (OnionMessage Encrypted, OnionToOwner)
+encrypt crypto msg rpath = ( transcode (encryptMessage crypto okey) msg
+                           , rpath)
+    where
+        -- 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 =>
+                  TransportCrypto -> PublicKey -> Nonce24 -> Either (Identity a) (Assym (Identity a)) -> Encrypted a
+encryptMessage crypto destKey n (Right a) = ToxCrypto.encrypt secret plain
+ where
+    secret = computeSharedSecret (transportSecret crypto) destKey n
+    plain  = encodePlain $ runIdentity $ assymData a
+encryptMessage crypto destKey n (Left x) = ToxCrypto.encrypt secret plain
+ where
+    secret = computeSharedSecret (transportSecret crypto) destKey n
+    plain  = encodePlain $ runIdentity $ x
+
+decrypt :: TransportCrypto -> OnionMessage Encrypted -> OnionToOwner -> Either String (OnionMessage Identity, OnionToOwner)
+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 (OnionToRoute pub a)     = fmap (OnionToRoute pub)   $ sequenceA $ fmap uncomposed a
+sequenceMessage (OnionToRouteResponse a) = fmap OnionToRouteResponse $ sequenceA $ fmap uncomposed a
+sequenceMessage (OnionAnnounceResponse n8 n24 dta) = OnionAnnounceResponse n8 n24 <$> uncomposed dta
+
+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 (OnionToRoute pub a)     = OnionToRoute pub     $ a { assymData = f (assymNonce a) (Right a) }
+transcode f (OnionToRouteResponse a) = OnionToRouteResponse $ a { assymData = f (assymNonce a) (Right a) }
+transcode f (OnionAnnounceResponse n8 n24 dta) = OnionAnnounceResponse n8 n24 $ f n24 $ Left dta
+