path: root/src/Network/Tox/Onion/Transport.hs

{-# 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.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 Debug.Trace
import GHC.Generics                 ()
import GHC.TypeLits
import Network.Socket
import System.IO
import qualified Text.ParserCombinators.ReadP as RP
import Data.Hashable

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 :: (NodeInfo -> RouteId -> IO (Maybe OnionRoute))
                   -> (OnionMessage Encrypted,OnionDestination RouteId)
                   -> IO (Maybe (ByteString, SockAddr))
encodeOnionAddr _ (msg,OnionToOwner ni p) =
    return $ Just ( runPut $ putResponse (OnionResponse p msg)
                  , nodeAddr ni )
encodeOnionAddr getRoute (msg,OnionDestination x ni Nothing) = do
    encodeOnionAddr getRoute (msg,OnionDestination x ni (Just $ routeId $ nodeId ni) )
    -- hPutStrLn stderr $ "ONION encode missing routeid"
    -- return Nothing
encodeOnionAddr getRoute (msg,OnionDestination _ ni (Just rid)) = do
    let go route = do
            return ( runPut $ putRequest $ wrapForRoute msg ni route
                   , nodeAddr $ routeNodeA route)
        mapM' f x = do
            let _ = x :: Maybe OnionRoute
            -- hPutStrLn stderr $ "ONION encode sending to  " ++ show ni
            -- hPutStrLn stderr $ "ONION encode getRoute -> " ++ show (fmap (\y -> map ($ y) [routeNodeA,routeNodeB,routeNodeC]) x)
            mapM f x         -- ONION encode getRoute -> Nothing
    getRoute ni rid >>= mapM' go


forwardOnions :: TransportCrypto -> UDPTransport -> UDPTransport
forwardOnions crypto udp = udp { awaitMessage = forwardAwait crypto udp }

forwardAwait :: TransportCrypto -> UDPTransport -> HandleLo a -> IO a
forwardAwait crypto udp kont = do
    fix $ \another -> do
      awaitMessage udp $ \case
        m@(Just (Right (bs,saddr))) -> case B.head bs of
            0x80 -> forward kont bs $ handleOnionRequest (Proxy :: Proxy  N0) crypto saddr udp another
            0x81 -> forward kont bs $ handleOnionRequest (Proxy :: Proxy  N1) crypto saddr udp another
            0x82 -> forward kont bs $ handleOnionRequest (Proxy :: Proxy  N2) crypto saddr udp another
            0x8c -> forward kont bs $ handleOnionResponse (Proxy :: Proxy N3) crypto saddr udp another
            0x8d -> forward kont bs $ handleOnionResponse (Proxy :: Proxy N2) crypto saddr udp another
            0x8e -> forward kont bs $ handleOnionResponse (Proxy :: Proxy N1) crypto saddr udp another
            _    -> kont m
        m -> kont m

forward :: forall c b b1. (Serialize b, Show b) =>
              (Maybe (Either String b1) -> c) -> ByteString -> (b -> c) -> c
forward kont bs f = either (kont . Just . Left) f $ decode $ B.tail bs

class SumToThree a b

instance SumToThree N0 N3
instance SumToThree (S a) b => SumToThree a (S b)

class ( Serialize (ReturnPath n)
      , Serialize (ReturnPath (S n))
      , Serialize (Forwarding (ThreeMinus (S n)) (OnionMessage Encrypted))
      , ThreeMinus n ~ S (ThreeMinus (S n))
      ) => LessThanThree n

instance LessThanThree N0
instance LessThanThree N1
instance LessThanThree N2

type family ThreeMinus n where
    ThreeMinus N3 = N0
    ThreeMinus N2 = N1
    ThreeMinus N1 = N2
    ThreeMinus N0 = N3

-- n = 0, 1, 2
data OnionRequest n = OnionRequest
    { onionNonce    :: Nonce24
    , onionForward  :: Forwarding (ThreeMinus n) (OnionMessage Encrypted)
    , pathFromOwner :: ReturnPath n
    }

deriving instance ( Show (Forwarding (ThreeMinus n) (OnionMessage Encrypted))
                  , KnownNat (PeanoNat n)
                  ) => Show (OnionRequest n)

instance ( Serialize (Forwarding (ThreeMinus n) (OnionMessage Encrypted))
         , Sized (ReturnPath n)
         , Serialize (ReturnPath n)
         , Typeable n
         ) => Serialize (OnionRequest n) where
    get = do
        -- TODO share code with 'getOnionRequest'
        n24 <- case eqT :: Maybe (n :~: N3) of
                Just Refl -> return $ Nonce24 zeros24
                Nothing   -> get
        cnt <- remaining
        let fwdsize = case size :: Size (ReturnPath n) of ConstSize n -> cnt - n
        fwd <- isolate fwdsize get
        rpath <- get
        return $ OnionRequest n24 fwd rpath
    put (OnionRequest n f p) = maybe (put n) (\Refl -> return ()) (eqT :: Maybe (n :~: N3)) >> put f >> put p

-- getRequest :: _
-- getRequest = OnionRequest <$> get <*> get <*> get

-- n = 1, 2, 3
-- Attributed (Encrypted (

data OnionResponse n = OnionResponse
    { pathToOwner :: ReturnPath n
    , msgToOwner  :: OnionMessage Encrypted
    }

deriving instance KnownNat (PeanoNat n) => Show (OnionResponse n)

instance ( Serialize (ReturnPath n) ) => Serialize (OnionResponse n) where
    get = OnionResponse <$> get <*> (get >>= fromMaybe (fail "illegal onion forwarding")
                                             . getOnionReply)
    put (OnionResponse p m) = put p >> putOnionMsg m


data Addressed a = Addressed { sockAddr :: SockAddr, unaddressed :: a }
 deriving (Eq,Show)

instance Sized a => Sized (Addressed a) where
    size = case size :: Size a of
            ConstSize n -> ConstSize     $ 1{-family-} + 16{-ip-} + 2{-port-} + n
            VarSize f   -> VarSize $ \x -> 1{-family-} + 16{-ip-} + 2{-port-} + f (unaddressed x)

getForwardAddr :: S.Get SockAddr
getForwardAddr = do
    addrfam <- S.get :: S.Get Word8
    ip <- getIP addrfam
    case ip of IPv4 _ -> S.skip 12 -- compliant peers would zero-fill this.
               IPv6 _ -> return ()
    port <- S.get :: S.Get PortNumber
    return $ setPort port $ toSockAddr ip


putForwardAddr :: SockAddr -> S.Put
putForwardAddr saddr = fromMaybe (return $ error "unsupported SockAddr family") $ do
    port <- sockAddrPort saddr
    ip <- fromSockAddr $ either id id $ either4or6 saddr
    return $ do
        case ip of
            IPv4 ip4 -> S.put (0x02 :: Word8) >> S.put ip4 >> S.putByteString (B.replicate 12 0)
            IPv6 ip6 -> S.put (0x0a :: Word8) >> S.put ip6
        S.put port

instance Serialize a => Serialize (Addressed a) where
    get = Addressed <$> getForwardAddr <*> get
    put (Addressed addr x) = putForwardAddr addr >> put x

data N0
data S n
type N1 = S N0
type N2 = S N1
type N3 = S N2

class KnownPeanoNat n where
    peanoVal :: p n -> Int

instance KnownPeanoNat N0 where
    peanoVal _ = 0
instance KnownPeanoNat n => KnownPeanoNat (S n) where
    peanoVal _ = 1 + peanoVal (Proxy :: Proxy n)

type family PeanoNat p where
    PeanoNat N0    = 0
    PeanoNat (S n) = 1 + PeanoNat n

data ReturnPath n where
    NoReturnPath :: ReturnPath N0
    ReturnPath :: Nonce24 -> Encrypted (Addressed (ReturnPath n)) -> ReturnPath (S n)

-- Size: 59 = 1(family) + 16(ip) + 2(port) +16(mac) + 24(nonce)
instance Sized (ReturnPath N0) where size = ConstSize 0
instance Sized (ReturnPath n) => Sized (ReturnPath (S n)) where
    size = ConstSize 59 <> contramap (\x -> let _ = x :: ReturnPath (S n)
                                            in error "non-constant ReturnPath size")
                                     (size :: Size (ReturnPath n))

{-
instance KnownNat (PeanoNat n) => Sized (ReturnPath n) where
    size = ConstSize $ 59 * fromIntegral (natVal (Proxy :: Proxy (PeanoNat n)))
-}

instance Serialize (ReturnPath N0) where get              = pure NoReturnPath
                                         put NoReturnPath = pure ()

instance Serialize (ReturnPath N1) where
    get = ReturnPath <$> get <*> get
    put (ReturnPath n24 p) = put n24 >> put p

instance (Sized (ReturnPath n), Serialize (ReturnPath n)) => Serialize (ReturnPath (S (S n))) where
    get = ReturnPath <$> get <*> get
    put (ReturnPath n24 p) = put n24 >> put p


{-
-- This doesn't work because it tried to infer it for (0 - 1)
instance (Serialize (Encrypted (Addressed (ReturnPath (n - 1))))) => Serialize (ReturnPath n) where
    get = ReturnPath <$> get <*> get
    put (ReturnPath n24 p) = put n24 >> put p
-}

instance KnownNat (PeanoNat n) => Show (ReturnPath n) where
    show rpath = "ReturnPath" ++ show (natVal (Proxy :: Proxy (PeanoNat n)))


-- instance KnownNat n => Serialize (ReturnPath n) where
--     -- Size: 59 = 1(family) + 16(ip) + 2(port) +16(mac) + 24(nonce)
--     get = ReturnPath <$> getBytes ( 59 * (fromIntegral $ natVal $ Proxy @n) )
--     put (ReturnPath bs) = putByteString bs


data Forwarding n msg where
    NotForwarded :: msg -> Forwarding N0 msg
    Forwarding :: PublicKey -> Encrypted (Addressed (Forwarding n msg)) -> Forwarding (S n) msg

instance Show msg => Show (Forwarding N0 msg) where
    show (NotForwarded x) = "NotForwarded "++show x

instance ( KnownNat (PeanoNat (S n))
         , Show (Encrypted (Addressed (Forwarding n msg)))
         ) => Show (Forwarding (S n) msg) where
    show (Forwarding k a) = unwords [ "Forwarding"
                                    , "("++show (natVal (Proxy :: Proxy (PeanoNat (S n))))++")"
                                    , show (key2id k)
                                    , show a
                                    ]

instance Sized msg => Sized (Forwarding N0 msg)
   where size = case size :: Size msg of
                 ConstSize n -> ConstSize n
                 VarSize f -> VarSize $ \(NotForwarded x) -> f x

instance Sized (Forwarding n msg) => Sized (Forwarding (S n) msg)
   where size = ConstSize 32
                <> contramap (\(Forwarding _ e) -> e)
                             (size :: Size (Encrypted (Addressed (Forwarding n msg))))

instance Serialize msg => Serialize (Forwarding N0 msg) where
    get = NotForwarded <$> get
    put (NotForwarded msg) = put msg

instance (Serialize (Encrypted (Addressed (Forwarding n msg)))) => Serialize (Forwarding (S n) msg) where
    get = Forwarding <$> getPublicKey <*> get
    put (Forwarding k x) = putPublicKey k >> put x

handleOnionRequest :: forall a proxy n.
                      ( LessThanThree n
                      , KnownPeanoNat n
                      , Sized (ReturnPath n)
                      , Typeable n
                      ) => proxy n -> TransportCrypto -> SockAddr -> UDPTransport -> IO a -> OnionRequest n -> IO a
handleOnionRequest proxy crypto saddr udp kont (OnionRequest nonce msg rpath) = do
    let n = peanoVal rpath
    hPutStrLn stderr $ "handleOnionRequest " ++ show n
    (sym, snonce) <- atomically ( (,) <$> transportSymmetric crypto
                                      <*> transportNewNonce crypto )
    case peelOnion crypto nonce msg of
        Left e -> do
            -- todo report encryption error
            hPutStrLn stderr $ unwords [ "peelOnion:", show n, either show show (either4or6 saddr), e]
            kont
        Right (Addressed dst msg') -> do
            hPutStrLn stderr $ unwords [ "peelOnion:", show n, either show show (either4or6 saddr), "-->", either show show (either4or6 dst), "SUCCESS"]
            sendMessage udp dst (runPut $ putRequest $ OnionRequest nonce msg' $ wrapSymmetric sym snonce saddr rpath)
            kont

wrapSymmetric :: Serialize (ReturnPath n) =>
                 SymmetricKey -> Nonce24 -> SockAddr -> ReturnPath n -> ReturnPath (S n)
wrapSymmetric sym n saddr rpath = ReturnPath n $ encryptSymmetric sym n (encodePlain $ Addressed saddr rpath)

peelSymmetric :: Serialize (Addressed (ReturnPath n))
                 => SymmetricKey -> ReturnPath (S n) -> Either String (Addressed (ReturnPath n))
peelSymmetric sym (ReturnPath nonce e) = decryptSymmetric sym nonce e >>= decodePlain


peelOnion :: Serialize (Addressed (Forwarding n t))
              => TransportCrypto
              -> Nonce24
              -> Forwarding (S n) t
              -> Either String (Addressed (Forwarding n t))
peelOnion crypto nonce (Forwarding k fwd) =
    fmap runIdentity $ uncomposed $ decryptMessage (dhtKey crypto) nonce (Right $ 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
            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 (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
    return ( transcode ( (. (runIdentity . either id asymmData))
                                         . encryptMessage skey okey)
                                       msg
           , rpath)

encryptMessage :: Serialize a =>
                  SecretKey -> PublicKey -> Nonce24 -> a -> Encrypted a
encryptMessage skey destKey n a = ToxCrypto.encrypt secret plain
 where
    secret = computeSharedSecret skey destKey n
    plain  = encodePlain a

decrypt :: TransportCrypto -> OnionMessage Encrypted -> OnionDestination r -> IO (Either String (OnionMessage Identity, OnionDestination r))
decrypt crypto msg addr = do
    (skey,pkey) <- selectKey crypto msg addr
    return $ do
        msg <- sequenceMessage $ transcode (\n -> decryptMessage (skey,pkey) n . left (senderkey addr)) msg
        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 =>
                  (SecretKey,PublicKey)
                  -> Nonce24
                  -> Either (PublicKey, Encrypted x)
                            (Asymm (Encrypted x))
                  -> (Either String ∘ Identity) x
decryptMessage crypto n arg = plain $ ToxCrypto.decrypt secret e
 where
    secret     = computeSharedSecret (fst crypto) sender n
    (sender,e) = either id (senderKey &&& asymmData) arg
    plain      = Composed . fmap Identity . (>>= decodePlain)


sequenceMessage :: Applicative m => OnionMessage (m ∘ f) -> m (OnionMessage f)
sequenceMessage (OnionAnnounce a)        = fmap OnionAnnounce $ sequenceA $ fmap uncomposed a
sequenceMessage (OnionAnnounceResponse n8 n24 dta) = OnionAnnounceResponse n8 n24 <$> uncomposed dta
sequenceMessage (OnionToRoute pub a)     = pure $ OnionToRoute pub a
sequenceMessage (OnionToRouteResponse a) = pure $ OnionToRouteResponse a
-- sequenceMessage (OnionToRouteResponse a) = fmap OnionToRouteResponse $ sequenceA $ fmap uncomposed a

transcode :: forall f g. (forall a. Serialize a => Nonce24 -> Either (f a) (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 :: OnionMessage Encrypted -> NodeInfo -> OnionRoute -> OnionRequest N0
wrapForRoute msg ni r =
    -- We needn't use the same nonce value here, but I think it is safe to do so.
    let nonce = msgNonce msg
    in OnionRequest
    { onionNonce = nonce
    , onionForward = wrapOnion (routeAliasA r)
                               nonce
                               (id2key . nodeId $ routeNodeA r)
                               (nodeAddr $ routeNodeB r)
                   $ wrapOnion (routeAliasB r)
                               nonce
                               (id2key . nodeId $ routeNodeB r)
                               (nodeAddr $ routeNodeC r)
                   $ wrapOnion (routeAliasC r)
                               nonce
                               (id2key . nodeId $ routeNodeC r)
                               (nodeAddr ni)
                   $ NotForwarded msg
    , pathFromOwner = NoReturnPath
    }

wrapOnion :: Serialize (Forwarding n msg) =>
           SecretKey
           -> Nonce24
           -> PublicKey
           -> SockAddr
           -> Forwarding n msg
           -> Forwarding (S n) msg
wrapOnion skey nonce destkey saddr fwd =
    Forwarding (toPublic skey) $ encryptMessage skey destkey nonce (Addressed saddr fwd)


-- TODO
-- Two types of packets may be sent to Rendezvous via OnionToRoute requests.
--
--  (1) DHT public key packet (0x9c)
--
--  (2) Friend request
data Rendezvous = Rendezvous
    { rendezvousKey :: PublicKey
    , rendezvousNode :: NodeInfo
    }
 deriving Eq

instance Show Rendezvous where
    showsPrec d (Rendezvous k ni)
        = showsPrec d (key2id k)
          . (':' :)
          . showsPrec d ni

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)
                                <$> readTVar (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 $ readTVar $ userKeys crypto

  let eOuter = do
        fmap runIdentity
                 $ uncomposed
                 $ decryptMessage (rendezvousSecret crypto,rendezvousPublic crypto)
                                  (asymmNonce dta)
                                  (Right dta) -- using Asymm{senderKey} as remote key

      -- 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.
      eInners = flip map ks $ \(sk,pk) -> do
        dtr <- eOuter
        omsg <- fmap runIdentity
                $ uncomposed
                $ decryptMessage (sk,pk)
                                 (asymmNonce dta)
                                 (Left (dataFromKey dtr, dataToRoute dtr))
        return (pk,dtr,omsg)

      eInner = foldr (<|>) (Left "no user key") eInners

      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
  hPutStrLn stderr $ unlines
        [ "parseDataToRoute " ++ either id (const "Right") e
        , "       crypto inner.me =" ++ either id (\(pk,_,_) -> show $ key2id pk) eInner
        , "              inner.you=" ++ either id (show . key2id . dataFromKey) eOuter
        , "              outer.me =" ++ show (key2id $ rendezvousPublic crypto)
        , "              outer.you=" ++ 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)
    let plain = DataToRoute { dataFromKey = pk
                            , dataToRoute = encryptMessage sk toxid nonce omsg
                            }
    let dta = encryptMessage (onionAliasSecret crypto) pub nonce plain
    hPutStrLn stderr $ 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 )