path: root/dht/src/Data/Tox/Onion.hs

{-# 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,nullAddress4)
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
#if MIN_VERSION_iproute(1,7,8)
                      , toSockAddr
#endif
                      )
#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)
import Text.XXD
import qualified Data.ByteArray as BA

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.
        } -- ^ incoming queries and outgoing responses
    | OnionDestination
        { onionAliasSelector' :: AliasSelector
        , onionNodeInfo       :: NodeInfo
        , onionRouteSpec      :: Maybe r    -- ^ Our own onion-path.
        } -- ^ outgoing queries and incoming responses
    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

-- | /r/ parameter for 'OnionDestination'
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
                      , Typeable (ThreeMinus (S 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 :: ( Typeable n, Typeable t, 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 -> 1 + case size of
            ConstSize n -> n -- Override because OnionData probably
                             -- should be treated as variable sized.
            VarSize f   -> f dhtpk
        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
    let result = do
            msg <- sequenceMessage foo
            Right (msg, addr)
    case msg of
        OnionToRouteResponse {} -> case result of
            Left e  -> dput XMan $ "Error decrypting data-to-route response: " ++ e
            Right m -> dput XMan $ "Decrypted data-to-route response: " ++ show (fst m)
        _ -> return ()
    return result

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

decodePlainVerbose :: (Typeable a, Serialize a) => Plain Serialize a -> Either String a
decodePlainVerbose p =
    left (\e -> unlines (unwords [e , show $ typeRep p] : xxd2 0 (BA.convert p :: ByteString)))
        $ decodePlain p

decryptMessage :: (Typeable x, 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 . (>>= decodePlainVerbose)
    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

dummySecret :: SecretKey
dummySecret = fromJust $ decodeSecret "AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA"

dummyNodeId :: NodeId
dummyNodeId = read "AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA"

dummyNode :: NodeInfo
dummyNode = k where Right k = nodeInfo dummyNodeId nullAddress4

dummyRoute :: OnionRoute
dummyRoute = OnionRoute dummySecret dummySecret dummySecret
                        dummyNode dummyNode dummyNode
                        Nothing

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
                }
            }


-- | Lookup the secret key for the given toxid public key.  If it is not found,
-- then the SearchingAlias symbol will be used to indicate that a new temporary
-- key pair should be generated or that all known keys should be tried until one
-- succeeds to decrypt the message.
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 []     e f = return $ Left $ "parseDataToRoute: " ++ e
      anyRight (x:xs) e f = f x >>= either (\e2 -> anyRight xs e2 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 "no user key" $ \(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 )