path: root/Tox.hs

{-# LANGUAGE DeriveDataTypeable         #-}
{-# LANGUAGE DeriveFoldable             #-}
{-# LANGUAGE DeriveFunctor              #-}
{-# LANGUAGE DeriveGeneric              #-}
{-# LANGUAGE DeriveTraversable          #-}
{-# LANGUAGE ExistentialQuantification  #-}
{-# LANGUAGE FlexibleInstances          #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE NamedFieldPuns             #-}
{-# LANGUAGE PatternSynonyms            #-}
{-# LANGUAGE RankNTypes                 #-}
{-# LANGUAGE ScopedTypeVariables        #-}
{-# LANGUAGE TupleSections              #-}
module Tox where

import Debug.Trace
import Control.Exception hiding (Handler)
import Control.Applicative
import Control.Arrow
import Control.Concurrent                     (MVar)
import Control.Concurrent.STM
import Control.Monad
import qualified Crypto.Cipher.ChaChaPoly1305 as Symmetric
import qualified Crypto.Cipher.Salsa          as Salsa
import qualified Crypto.Cipher.XSalsa         as XSalsa
import Crypto.ECC.Class
import qualified Crypto.Error                 as Cryptonite
import Crypto.Error.Types
import qualified Crypto.MAC.Poly1305          as Poly1305
import Crypto.PubKey.Curve25519
import Crypto.PubKey.ECC.Types
import Crypto.Random
import qualified Data.Aeson                   as JSON
         ;import Data.Aeson                   (FromJSON, ToJSON, (.=))
import Data.Bitraversable                     (bisequence)
import Data.Bits
import Data.Bits.ByteString                   ()
import Data.Bool
import qualified Data.ByteArray               as BA
         ;import Data.ByteArray               (ByteArrayAccess, Bytes)
import qualified Data.ByteString              as B
         ;import Data.ByteString              (ByteString)
import qualified Data.ByteString.Base16       as Base16
import qualified Data.ByteString.Char8        as C8
import Data.ByteString.Lazy                   (toStrict)
import Data.Char
import Data.Data
import Data.Hashable
import Data.IP
import Data.Maybe
import qualified Data.MinMaxPSQ               as MinMaxPSQ
         ;import Data.MinMaxPSQ               (MinMaxPSQ')
import Data.Monoid
import Data.Ord
import qualified Data.Serialize               as S
import Data.Time.Clock.POSIX                  (POSIXTime, getPOSIXTime)
import Data.Typeable
import Data.Word
import qualified Data.Wrapper.PSQ             as PSQ
         ;import Data.Wrapper.PSQ             (PSQ)
import qualified Data.Wrapper.PSQInt          as Int
import Foreign.Marshal.Alloc
import Foreign.Ptr
import Foreign.Storable
import GHC.Generics                           (Generic)
import Global6
import Kademlia
import Network.Address                        (Address, WantIP (..), either4or6,
                                               fromSockAddr, ipFamily, setPort,
                                               sockAddrPort, testIdBit,
                                               toSockAddr, un4map)
import Network.BitTorrent.DHT.Search          (Search (..))
import qualified Network.DHT.Routing          as R
import Network.QueryResponse
import Network.Socket
import System.Endian
import System.IO
import qualified Text.ParserCombinators.ReadP as RP
import Text.Printf
import Text.Read
import ToxMessage                   as Tox hiding (Ping,Pong,SendNodes,GetNodes,AnnounceResponse)
         ;import ToxMessage                   (bin2hex, quoted)
import TriadCommittee
import Network.BitTorrent.DHT.Token           as Token
import GHC.TypeLits

{-
newtype NodeId = NodeId ByteString
 deriving (Eq,Ord,ByteArrayAccess, Bits, Hashable)
-}

type NodeId = Tox.PubKey

{-
instance Show NodeId where
    show (NodeId bs) = C8.unpack $ Base16.encode bs

instance S.Serialize NodeId where
    get = NodeId <$> S.getBytes 32
    put (NodeId bs) = S.putByteString bs

instance FiniteBits NodeId where
    finiteBitSize _ = 256

instance Read NodeId where
    readsPrec _ str
        | (bs, xs) <- Base16.decode $ C8.pack str
        , B.length bs == 32
                    = [ (NodeId bs, drop 64 str) ]
        | otherwise = []
-}

zeroID :: NodeId
zeroID = Tox.PubKey $ B.replicate 32 0

data NodeInfo = NodeInfo
  { nodeId   :: NodeId
  , nodeIP   :: IP
  , nodePort :: PortNumber
  }
 deriving (Eq,Ord)

instance ToJSON NodeInfo where
    toJSON (NodeInfo nid (IPv4 ip) port)
        = JSON.object [ "public_key" .= show nid
                      , "ipv4" .= show ip
                      , "port" .= (fromIntegral port :: Int)
                      ]
    toJSON (NodeInfo nid (IPv6 ip6) port)
        | Just ip <- un4map ip6
          = JSON.object [ "public_key" .= show nid
                        , "ipv4" .= show ip
                        , "port" .= (fromIntegral port :: Int)
                        ]
        | otherwise
          = JSON.object [ "public_key" .= show nid
                        , "ipv6" .= show ip6
                        , "port" .= (fromIntegral port :: Int)
                        ]
instance FromJSON NodeInfo where
    parseJSON (JSON.Object v) = do
        nidstr <- v JSON..: "public_key"
        ip6str <- v JSON..:? "ipv6"
        ip4str <- v JSON..:? "ipv4"
        portnum <- v JSON..: "port"
        ip <- maybe empty (return . IPv6) (ip6str >>= readMaybe)
              <|> maybe empty (return . IPv4) (ip4str >>= readMaybe)
        let (bs,_) = Base16.decode (C8.pack nidstr)
        guard (B.length bs == 32)
        return $ NodeInfo (Tox.PubKey bs) ip (fromIntegral (portnum :: Word16))

getIP :: Word8 -> S.Get IP
getIP 0x02 = IPv4 <$> S.get
getIP 0x0a = IPv6 <$> S.get
getIP 0x82 = IPv4 <$> S.get -- TODO: TCP
getIP 0x8a = IPv6 <$> S.get -- TODO: TCP
getIP x    = fail ("unsupported address family ("++show x++")")

instance S.Serialize NodeInfo where
    get = do
        addrfam <- S.get :: S.Get Word8
        ip <- getIP addrfam
        port <- S.get :: S.Get PortNumber
        nid <- S.get
        return $ NodeInfo nid ip port

    put (NodeInfo nid ip port) = do
        case ip of
            IPv4 ip4 -> S.put (2 :: Word8) >> S.put ip4
            IPv6 ip6 -> S.put (10 :: Word8) >> S.put ip6
        S.put port
        S.put nid

-- node format:
-- [uint8_t family (2 == IPv4, 10 == IPv6, 130 == TCP IPv4, 138 == TCP IPv6)]
-- [ip (in network byte order), length=4 bytes if ipv4, 16 bytes if ipv6]
-- [port (in network byte order), length=2 bytes]
-- [char array (node_id), length=32 bytes]
--


hexdigit :: Char -> Bool
hexdigit c = ('0' <= c && c <= '9') || ( 'a' <= c && c <= 'f') || ( 'A' <= c && c <= 'F')

instance Read NodeInfo where
  readsPrec i = RP.readP_to_S $ do
    RP.skipSpaces
    let n = 64 -- characters in node id.
        parseAddr = RP.between (RP.char '(') (RP.char ')') (RP.munch (/=')'))
                      RP.+++ RP.munch (not . isSpace)
        nodeidAt = do hexhash <- sequence $ replicate n (RP.satisfy hexdigit)
                      RP.char '@' RP.+++ RP.satisfy isSpace
                      addrstr <- parseAddr
                      nid <- case Base16.decode $ C8.pack hexhash of
                              (bs,_) | B.length bs==32 -> return (Tox.PubKey bs)
                              _                        -> fail "Bad node id."
                      return (nid,addrstr)
    (nid,addrstr) <- ( nodeidAt RP.+++ ( (zeroID,) <$> parseAddr) )
    let raddr = do
            ip <- RP.between (RP.char '[') (RP.char ']')
                         (IPv6 <$> RP.readS_to_P (readsPrec i))
                  RP.+++ (IPv4 <$> RP.readS_to_P (readsPrec i))
            _    <- RP.char ':'
            port <- toEnum <$> RP.readS_to_P (readsPrec i)
            return (ip, port)

    (ip,port) <- case RP.readP_to_S raddr addrstr of
                    [] -> fail "Bad address."
                    ((ip,port),_):_ -> return (ip,port)
    return $ NodeInfo nid ip port


-- The Hashable instance depends only on the IP address and port number.
instance Hashable NodeInfo where
  hashWithSalt s ni = hashWithSalt s (nodeIP ni , nodePort ni)
  {-# INLINE hashWithSalt #-}


instance Show NodeInfo where
    showsPrec _ (NodeInfo nid ip port) =
        shows nid . ('@' :) . showsip . (':' :) . shows port
     where
        showsip
            | IPv4 ip4 <- ip                          = shows ip4
            | IPv6 ip6 <- ip , Just ip4 <- un4map ip6 = shows ip4
            | otherwise                               = ('[' :) . shows ip . (']' :)

nodeAddr :: NodeInfo -> SockAddr
nodeAddr (NodeInfo _ ip port) = setPort port $ toSockAddr ip

nodeInfo :: NodeId -> SockAddr -> Either String NodeInfo
nodeInfo nid saddr
    | Just ip <- fromSockAddr saddr
    , Just port <- sockAddrPort saddr = Right $ NodeInfo nid ip port
    | otherwise                       = Left "Address family not supported."

data TransactionId = TransactionId
 { transactionKey :: Tox.Nonce8  -- ^ Used to lookup pending query.
 , cryptoNonce    :: Tox.Nonce24 -- ^ Used during the encryption layer.
 }

-- 0x18     Cookie Request
-- 0x19     Cookie Response
-- 0x1a     Crypto Handshake
-- 0x1b     Crypto Data

-- 0x21     LAN Discovery

{-
newtype Tox.Nonce24 = Tox.Nonce24 ByteString
 deriving (Eq, Ord, ByteArrayAccess)

instance show tox.nonce24 where
    showsprec d nonce = quoted (mappend $ bin2hex nonce)

instance S.Serialize Tox.Nonce24 where
    get = Tox.Nonce24 <$> S.getBytes 24
    put (Tox.Nonce24 bs) = S.putByteString bs
-}

newtype SymmetricCiphered = SymmetricCiphered ByteString
    deriving (Eq,Show)

{-
data Message a = Message
    { msgType       :: Method
    , msgOrigin     :: NodeId
    , msgNonce      :: Tox.Nonce24 -- cryptoNonce of TransactionId
    , msgReturnPath :: Maybe (Tox.Nonce24,SymmetricCiphered)
    , msgPayload    :: a
    }
 deriving (Eq, Show, Generic, Functor, Foldable, Traversable)
-}

data Msg = Msg
    { msgType     :: Tox.PacketKind
    , msgNonce    :: Tox.Nonce24
    , msgData     :: ByteString
    , msgSendBack :: Tox.Nonce8
    }
 deriving Show


-- typeHasEncryptedPayload OnionResponse1Type = False
-- typeHasEncryptedPayload _                  = True

{-
msgDHTKey Message{ msgOrigin, msgType = PingType      } = Just msgOrigin
msgDHTKey Message{ msgOrigin, msgType = PongType      } = Just msgOrigin
msgDHTKey Message{ msgOrigin, msgType = GetNodesType  } = Just msgOrigin
msgDHTKey Message{ msgOrigin, msgType = SendNodesType } = Just msgOrigin
msgDHTKey Message{ msgOrigin, msgType = OnionRequest0 } = Just msgOrigin
msgDHTKey _                                             = Nothing
-}

data Ciphered = Ciphered { cipheredMAC   :: Poly1305.Auth
                         , cipheredBytes :: ByteString }
 deriving Eq

newtype OnionPayload = OnionPayload { unpackOnionPayload :: ByteString }

instance S.Serialize OnionPayload where
    get = OnionPayload <$> (S.remaining >>= S.getBytes)
    put (OnionPayload bs) = S.putByteString bs

{-
getMessage :: S.Get (Message (Either OnionPayload Ciphered))
getMessage = do
        typ <- S.get
        (nid,nonce) <- case typ of -- Seriously... what the fuck?
            DHTRequestType -> do
                S.skip 32 -- TODO: get destination key
                          --       If it is ours, decrypt and handle.
                          --       If not ours, search routing table and forward if it's in there.
                flip (,) <$> S.get <*> S.get
            OnionRequest0  -> flip (,) <$> S.get <*> S.get
            OnionRequest1  -> flip (,) <$> S.get <*> S.get
            -- OnionRequest2  -> flip (,) <$> S.get <*> S.get
            AnnounceType   -> flip (,) <$> S.get <*> S.get
            OnionResponse1 -> (NodeId $ BA.convert zeros32,)  <$> S.get -- XXX: no msgOrigin!
            _              -> (,) <$> S.get <*> S.get
        (payload,rpath) <- case typ of
            OnionResponse1 -> do
                rpath <- Just . SymmetricCiphered <$> S.getBytes (16 + 19)
                payload <- Left . OnionPayload  <$> (S.remaining >>= S.getBytes)
                return (payload,rpath)
            _              -> do
                payload <- Right <$> getCiphered
                return (payload,Nothing)
        return Message { msgType       = typ
                       , msgOrigin     = nid
                       , msgNonce      = nonce
                       , msgReturnPath = rpath
                       , msgPayload    = payload }

putOnionPayload :: OnionPayload -> S.Put
putOnionPayload (OnionPayload bs) = S.putByteString bs

putMessage :: Message (Either OnionPayload Ciphered) -> S.Put
putMessage (Message {..}) = do
        S.put msgType
        case msgType of -- Seriously... what the fuck?
            DHTRequestType -> S.put msgNonce  >> S.put msgOrigin
            OnionRequest0  -> S.put msgNonce  >> S.put msgOrigin
            OnionRequest1  -> S.put msgNonce  >> S.put msgOrigin
            -- OnionRequest2  -> S.put msgNonce  >> S.put msgOrigin
            AnnounceType   -> S.put msgNonce  >> S.put msgOrigin
            _              -> S.put msgOrigin >> S.put msgNonce
        let putPayload    = either putOnionPayload putCiphered msgPayload
            putReturnPath = forM_ msgReturnPath
                              $ \(nonce,SymmetricCiphered bs) -> do S.put nonce
                                                                    S.putByteString bs
        case msgType of
            OnionResponse1 -> putReturnPath >> putPayload
            _              -> putPayload >> putReturnPath
-}

{-
data Plain a = Plain
    { plainId      :: Tox.Nonce8 -- transactionKey of TransactionId
    , plainPayload :: a
    }
 deriving (Eq, Show, Generic, Functor, Foldable, Traversable)

instance Serialize a => Serialize (Plain a) where
    get = flip Plain <$> get get
    put (Plain tid a) = put a >> put tid
-}

-- TODO: Cache shared symmetric keys.
data SecretsCache = SecretsCache
newEmptyCache = return SecretsCache

id2key :: NodeId -> PublicKey
id2key recipient = case publicKey recipient of
    CryptoPassed key -> key
    -- This should never happen because a NodeId is 32 bytes.
    CryptoFailed e   -> error ("Unexpected pattern fail: "++show e)

key2id :: PublicKey -> NodeId
key2id pk = case S.decode (BA.convert pk) of
                Left _ -> error "key2id"
                Right nid -> nid


zeros32 :: Nonce32
zeros32 = Nonce32 $ BA.replicate 32 0

zeros24 :: ByteString
zeros24 = BA.take 24 zs where Nonce32 zs = zeros32

hsalsa20 k n = a <> b
 where
    Salsa.State st = XSalsa.initialize 20 k n
    (_, as) = BA.splitAt 4 st
    (a, xs) = BA.splitAt 16 as
    (_, bs) = BA.splitAt 24 xs
    (b, _ ) = BA.splitAt 16 bs


computeSharedSecret :: SecretKey -> NodeId -> Tox.Nonce24 -> (Poly1305.State, XSalsa.State)
computeSharedSecret sk recipient nonce = (hash, crypt)
 where
    -- diffie helman
    shared = ecdh (Proxy :: Proxy Curve_X25519) sk (id2key recipient)
    -- shared secret XSalsa key
    k = hsalsa20 shared zeros24
    -- cipher state
    st0 = XSalsa.initialize 20 k nonce
    -- Poly1305 key
    (rs, crypt) = XSalsa.combine st0 zs where Nonce32 zs = zeros32
    -- Since rs is 32 bytes, this pattern should never fail...
    Cryptonite.CryptoPassed hash = Poly1305.initialize rs


{-
encryptMessage :: SecretKey -> SecretsCache -> NodeId -> Message ByteString -> Message (Either OnionPayload Ciphered)
encryptMessage sk _ recipient plaintext
    = if typeHasEncryptedPayload (msgType plaintext)
        then Right . withSecret encipherAndHash sk recipient (msgNonce plaintext) <$> plaintext
        else Left . OnionPayload <$> plaintext
-}

encryptAssymetric :: SecretKey -> NodeId -> NodeId -> Msg -> Tox.Assymetric
encryptAssymetric sk pk recipient (Msg typ nonce plaintext sendback) = assym
 where
    assym = Tox.Assymetric
      { senderKey = pk
      , sent = Tox.UnclaimedAssymetric
           { assymetricNonce = nonce
           , assymetricData  = withSecret encipherAndHash sk recipient nonce (plaintext <> S.encode sendback)
           }
      }

encryptUnclm :: SecretKey -> NodeId -> NodeId -> Msg -> Tox.UnclaimedAssymetric
encryptUnclm sk pk recipient (Msg typ nonce plaintext _) = unclm
 where
    unclm = Tox.UnclaimedAssymetric
       { assymetricNonce = nonce
       , assymetricData  = withSecret encipherAndHash sk recipient nonce plaintext
       }


{-
decryptMessage :: SecretKey -> SecretsCache -> Message Ciphered -> Either String (Message ByteString)
decryptMessage sk _ ciphertext
    = mapM (withSecret decipherAndAuth sk (msgOrigin ciphertext) (msgNonce ciphertext)) ciphertext
-}

decryptAssymetric :: SecretKey -> Tox.PacketKind -> Tox.Assymetric -> Either String Msg
decryptAssymetric sk typ assym
    = f <$> withSecret decipherAndAuth sk
                                       (Tox.senderKey assym)
                                       nonce
                                       (Tox.assymetricData . Tox.sent $ assym)
 where
    nonce = Tox.assymetricNonce . Tox.sent $ assym
    f bs = uncurry (Msg typ nonce)
            . second (either (const (Tox.Nonce8 0)) id . S.decode)
            $ B.splitAt (B.length bs - 8) bs

-- TODO: We should not be having to re-serialize this data... :/
--       There should be a way to pass the Tox.Assymetric value up the layers.
passThroughAssymetric :: Tox.PacketKind -> Tox.PubKey -> Tox.Assymetric -> Either String Msg
passThroughAssymetric typ k assym
    = Right $ Msg
        { msgNonce = Tox.assymetricNonce . Tox.sent $ assym -- Not used.
        , msgType = typ
        , msgData = S.encode (k,assym)
        , msgSendBack = Nonce8 0 -- Not used.
        }

{-
decryptUnclm :: SecretKey -> Tox.PacketKind -> NodeId -> Tox.Nonce8 -> Tox.UnclaimedAssymetric -> Either String Msg
decryptUnclm sk typ sender n8 unclm
    = f <$> withSecret decipherAndAuth sk
                                       sender
                                       nonce
                                       (Tox.assymetricData  unclm)
 where
    nonce = Tox.assymetricNonce unclm
    f bs = Msg typ nonce bs n8
-}

withSecret f sk recipient nonce x = f hash crypt x
 where
    (hash, crypt) = computeSharedSecret sk recipient nonce


-- Encrypt-then-Mac:  Encrypt the cleartext, then compute the MAC on the
-- ciphertext, and prepend it to the ciphertext
encipherAndHash :: Poly1305.State -> XSalsa.State -> ByteString -> Tox.ImplicitAssymetric
encipherAndHash hash crypt m = Tox.ImplicitAssymetric (Tox.Auth a) c
  where
    c = fst . XSalsa.combine crypt $ m
    a = Poly1305.finalize . Poly1305.update hash $ c

decipherAndAuth :: Poly1305.State -> XSalsa.State -> Tox.ImplicitAssymetric -> Either String ByteString
decipherAndAuth hash crypt (Tox.ImplicitAssymetric (Tox.Auth mac) c)
    | (a == mac) = Right m
    | otherwise  = Left "decipherAndAuth: auth fail"
  where
    m = fst . XSalsa.combine crypt $ c
    a = Poly1305.finalize . Poly1305.update hash $ c

nibble :: Word8 -> Char
nibble b = intToDigit (fromIntegral (b .&. 0x0F))

xxd :: Int -> ByteString -> [String]
xxd offset bs | B.null bs = []
xxd offset bs             = printf "%03x: %s" offset ds : xxd (offset + B.length xs) bs'
 where
    ds = unwords $ map (\byte -> [nibble (byte `shiftR` 4), nibble byte])
                 $ B.unpack xs
    (xs,bs') = B.splitAt 16 bs

{-
showPayloadError ciphered naddr flow err = unlines (map (prefix ++) xs)
 where
    xs = unwords [show (msgType ciphered), err]
         : xxd 0 (BA.convert mac <> ciphertext)

    Message { msgPayload = Ciphered (Poly1305.Auth mac) ciphertext } = ciphered

    prefix = show naddr <> flow

showParseError bs addr err = unlines $
        concat [ either show show (either4or6 addr), " --> ", err ]
        : xxd 0 bs

unzipMessage :: Message (Either a b) -> Either (Message a) (Message b)
unzipMessage msg = either (\x -> Left  msg { msgPayload = x })
                          (\y -> Right msg { msgPayload = y })
                          (msgPayload msg)

-- TODO:
-- Represents the encrypted portion of a Tox packet.
-- data Payload a = Payload a !Tox.Nonce8
--
-- Generic packet type: Message (Payload ByteString)

parsePacket :: SecretKey -> SecretsCache -> ByteString -> SockAddr -> Either String (Message ByteString, NodeInfo)
parsePacket sk cache bs addr = left (showParseError bs addr) $ do
    msg <- S.runGet getMessage bs
    ni <- nodeInfo (msgOrigin msg) addr
    let decrypt ciphered = left (showPayloadError ciphered ni " --> ") $ do
            msg <- decryptMessage sk cache ciphered
            return (msg, ni)
        passthrough onion = return (unpackOnionPayload <$> onion, ni)
    either passthrough decrypt $ unzipMessage msg

encodePacket :: SecretKey -> SecretsCache -> Message ByteString -> NodeInfo -> (ByteString, SockAddr)
encodePacket sk cache msg ni = ( S.runPut . putMessage $ encryptMessage sk cache (nodeId ni) msg
                               , nodeAddr ni )
-}

data ToxPath = forall n. (Tox.OnionPacket n) => ToxPath NodeInfo (Tox.ReturnPath n)

instance Show ToxPath where
    show (ToxPath ni rpath)
        | natVal rpath == 0 = show ni
        | otherwise         = "Aliased("++show ni++")"

msgLayer :: SecretKey
            -> NodeId
            -> Transport String ToxPath (Tox.PacketKind,InterediateRep)
            -> Transport String ToxPath Msg
msgLayer sk pk = layerTransport parse serialize
 where
    parse :: (Tox.PacketKind,InterediateRep) -> ToxPath -> Either String (Msg,ToxPath)
    parse (typ,Assym  x)  addr = fmap (,addr) $ decryptAssymetric sk typ x
    parse (typ,Assym' x)  addr = fmap (,addr) $ decryptAssymetric sk typ x
    parse (typ,ToRoute k x)  addr = fmap (,addr) $ passThroughAssymetric typ k x
    parse (typ,Unclm n x) addr = Right ( Msg typ (Tox.assymetricNonce x) (S.encode (Tox.assymetricData x)) n
                                       , addr)
    serialize :: Msg -> ToxPath -> ((Tox.PacketKind,InterediateRep),ToxPath)
    serialize x addr@(ToxPath ni _) = case Tox.pktClass (msgType x) of
        Tox.AssymetricClass      {} -> ((msgType x, Assym  $ encryptAssymetric sk pk (nodeId ni) x), addr)
        Tox.AliasedClass         {} -> ((msgType x, Assym' $ encryptAssymetric sk pk (nodeId ni) x), addr)
        Tox.NoncedUnclaimedClass {} -> ((msgType x, Unclm (msgSendBack x) $ encryptUnclm sk pk (nodeId ni) x),addr)

data InterediateRep = Assym Tox.Assymetric
                    | Assym' Tox.Assymetric
                    | ToRoute Tox.PubKey Tox.Assymetric
                    | Unclm Tox.Nonce8 Tox.UnclaimedAssymetric
                    | RouteResponse Tox.Packet

asymLayer :: Transport String SockAddr Tox.Packet -> Transport String ToxPath (Tox.PacketKind,InterediateRep)
asymLayer = layerTransport parse (\p@(typ,_) -> trace ("SERIALIZE "++show typ) $ serialize p)
 where
    parse :: Tox.Packet -> SockAddr -> Either String ((Tox.PacketKind,InterediateRep),ToxPath)
    parse x addr = case Tox.pktClass (Tox.pktKind x) of
        Tox.AssymetricClass top fromp      -> go Tox.senderKey  fromp Assym
        Tox.AliasedClass    top fromp      -> goalias $ fromp x
        Tox.ToRouteClass    top fromp      -> do let (key,y) = fromp x
                                                 ((typ,Assym' a),addr') <- goalias y
                                                 return ((typ,ToRoute key a),addr')
        Tox.NoncedUnclaimedClass top fromp -> go (const zeroID) fromp (uncurry Unclm)
        -- OnionClass
      where go mkaddr fromp c = let y = fromp x
                                in fmap ( ((Tox.pktKind x,c y),)
                                          . (\ni -> ToxPath ni Tox.emptyReturnPath)
                                        )
                                        $ nodeInfo (mkaddr y) addr
            goalias (Tox.Aliased a,rpath) = fmap (\ni -> ( (Tox.pktKind x, Assym' a)
                                                         , ToxPath ni rpath ))
                                                 $ nodeInfo (Tox.senderKey a) addr

    serialize :: (Tox.PacketKind,InterediateRep) -> ToxPath -> (Tox.Packet,SockAddr)
    serialize (typ,Assym assym) (ToxPath addr rpath) = (x,nodeAddr addr)
        where x = case Tox.pktClass typ of Tox.AssymetricClass top _ -> top assym
    serialize (typ,Assym' assym) (ToxPath addr rpath) = (x,nodeAddr addr) -- TODO rpath
        where x = case Tox.pktClass typ of Tox.AliasedClass    top _ -> top (Tox.Aliased assym, error "todo: ReturnPath")
    -- An unclm sent to a ToxPath is turned into an OnionResponse before being sent out.
    serialize (typ,Unclm nonce unclm) (ToxPath addr rpath) = (Tox.mkOnion rpath x,nodeAddr addr)
        where x = case Tox.pktClass typ of Tox.NoncedUnclaimedClass top _ -> top nonce unclm
    serialize (_,RouteResponse x) (ToxPath addr rpath) = (Tox.mkOnion rpath x, nodeAddr addr)
    -- OnionClass

toxLayer :: Transport String SockAddr ByteString -> Transport String SockAddr Tox.Packet
toxLayer = layerTransport (\x addr -> (,addr) <$> S.decode x)
                          (\x addr -> (S.encode x, addr))

data Routing = Routing
    { tentativeId :: NodeInfo
    , sched4      :: !( TVar (Int.PSQ POSIXTime) )
    , routing4    :: !( TVar (R.BucketList NodeInfo) )
    , committee4  :: TriadCommittee NodeId SockAddr
    , sched6      :: !( TVar (Int.PSQ POSIXTime) )
    , routing6    :: !( TVar (R.BucketList NodeInfo) )
    , committee6  :: TriadCommittee NodeId SockAddr
    }

type ToxClient = Client String Tox.PacketKind TransactionId ToxPath Msg

encodePayload :: S.Serialize b => Tox.PacketKind -> TransactionId -> addr -> addr -> b -> Msg
encodePayload typ (TransactionId nonce8 nonce24) _ _ b = Msg typ nonce24 (S.encode b) nonce8

trimPackets :: SockAddr -> ByteString -> IO (Maybe (ByteString -> ByteString))
trimPackets addr bs = do
    hPutStrLn stderr $ "GOT " ++ show (Tox.PacketKind (B.head bs))
    return $ case Tox.PacketKind (B.head bs) of
                        PingType             -> Just id
                        PongType             -> Just id
                        SendNodesType        -> Just id
                        GetNodesType         -> Just id
                        AnnounceType         -> Just id
                        AnnounceResponseType -> Just id
                        DataRequestType      -> Just id
                        -- DataResponseType     -> Just id
                        OnionResponse3Type   -> Just id
                        _                    -> Nothing

newClient :: SockAddr -> IO (ToxClient, Routing, TVar AnnouncedKeys)
newClient addr = do
    udp <- udpTransport addr
    secret <- generateSecretKey
    let pubkey = key2id $ toPublic secret
    hPutStrLn stderr $ "pubkey = " ++ show pubkey
    cache <- newEmptyCache
    (symkey, drg) <- do
        drg0 <- getSystemDRG
        return $ randomBytesGenerate 32 drg0 :: IO (ByteString, SystemDRG)
    let tentative_ip4 = fromMaybe (IPv4 $ toEnum 0) (IPv4 <$> fromSockAddr addr)
        tentative_ip6 = fromMaybe (IPv6 $ toEnum 0) (IPv6 <$> fromSockAddr addr)
        tentative_info = NodeInfo
                { nodeId   = pubkey
                , nodeIP   = fromMaybe (toEnum 0) (fromSockAddr addr)
                , nodePort = fromMaybe 0 $ sockAddrPort addr
                }
        tentative_info4 = tentative_info { nodeIP = tentative_ip4 }
    tentative_info6 <-
        maybe (tentative_info { nodeIP = tentative_ip6 })
              (\ip6 -> tentative_info { nodeIP = IPv6 ip6 })
            <$> global6
    addr4 <- atomically $ newTChan
    addr6 <- atomically $ newTChan
    routing <- atomically $ do
        let nobkts = R.defaultBucketCount :: Int
        tbl4 <- newTVar $ R.nullTable (comparing nodeId) (\s -> hashWithSalt s . nodeId) tentative_info4 nobkts
        tbl6 <- newTVar $ R.nullTable (comparing nodeId) (\s -> hashWithSalt s . nodeId) tentative_info6 nobkts
        let updateIPVote tblvar addrvar a = do
                bkts <- readTVar tblvar
                case nodeInfo (nodeId (R.thisNode bkts)) a of
                    Right ni -> writeTVar tblvar (bkts { R.thisNode = ni })
                    Left _   -> return ()
                writeTChan addrvar (a,map fst $ concat $ R.toList bkts)
        committee4 <- newTriadCommittee $ updateIPVote tbl4 addr4
        committee6 <- newTriadCommittee $ updateIPVote tbl6 addr6
        sched4 <- newTVar Int.empty
        sched6 <- newTVar Int.empty
        return $ Routing tentative_info sched4 tbl4 committee4 sched6 tbl6 committee6

    -- If we have 8-byte keys for IntMap, then use it for transaction lookups.
    -- Otherwise, use ordinary Map.  The details of which will be hidden by an
    -- existential closure (see mkclient below).
    tblvar <-
      if fitsInInt (Proxy :: Proxy Word64)
        then do
            let intmapT = transactionMethods (contramapT intKey intMapMethods) gen
            intmap_var <- atomically $ newTVar (drg, mempty)
            return $ Right (intmapT,intmap_var)
         else do
            let mapT = transactionMethods (contramapT nonceKey mapMethods) gen
            map_var <- atomically $ newTVar (drg, mempty)
            return $ Left (mapT,map_var)
    keydb <- atomically $ newTVar $ AnnouncedKeys PSQ.empty MinMaxPSQ.empty
    toks <- do
        nil <- nullSessionTokens
        atomically $ newTVar nil { maxInterval = 20 } -- 20 second timeout on announce ping-ids.
    let net = addHandler (handleMessage client)
              $ addVerbosity
              $ msgLayer secret pubkey
              $ onInbound (updateRouting client routing)
              $ asymnet
        asymnet = asymLayer
              -- $ addHandler (handleMessage aclient)
              $ toxLayer
              $ addVerbosity2
              $ addHandler trimPackets udp

        dispatch tbl var handlers = DispatchMethods
            { classifyInbound = classify
            , lookupHandler = handlers -- var
            , tableMethods = tbl
            }

        handler typ f = Just $ MethodHandler (S.decode . msgData) (encodePayload typ) (f . (\(ToxPath ni _)->ni))

        handler' typ f = Just $ MethodHandler (S.decode . msgData) (encodePayload typ) f

        -- (decryptAssymetric secret) (encryptAssymetric secret . cryptoNonce) f


        -- handlers :: TVar -> Method -> Maybe Handler
        -- handlers :: forall h u. (TVar (h, u (MVar Msg)) -> Tox.PacketKind -> Maybe Handler)
        handlers :: Tox.PacketKind -> Maybe Handler
        handlers PingType       = handler PongType pingH
        handlers GetNodesType   = handler SendNodesType $ getNodesH routing
        handlers AnnounceType   = handler' AnnounceResponseType $ announceH routing toks keydb
        handlers DataRequestType = Just $ NoReply (S.decode . msgData) $ dataToRouteH keydb asymnet
        {-
        handlers var OnionRequest0  = noreply OnionRequest0
                                      $ onionSend0H (symmetricCipher (return symkey)
                                                                     (fst <$> readTVar var)
                                                                     (modifyTVar' var . first . const))
                                                    udp
        handlers var OnionResponse1 = noreply OnionResponse1
                                      $ onionResponse1H (symmetricDecipher (return symkey))
                                                        udp
        -}
        handlers _              = Nothing
        -- TODO DHTRequest public key (onion)
        -- TODO DHTRequest NAT ping
        -- TODO BootstrapInfo 0xf0

        announceHandlers _ = Nothing

        genNonce24 var (TransactionId nonce8 _) = atomically $ do
            (g,pending) <- readTVar var
            let (bs, g') = randomBytesGenerate 24 g
            writeTVar var (g',pending)
            return $ TransactionId nonce8 (Tox.Nonce24 bs)

        client = either mkclient mkclient tblvar handlers

        mkclient :: DRG g =>
                    ( TransactionMethods (g,t (MVar Msg))
                                         TransactionId
                                         Msg
                    , TVar (g, t (MVar Msg))
                    )
                    -- -> (forall h u. (TVar (h, u (MVar Msg)) -> Tox.PacketKind -> Maybe Handler))
                    -> (Tox.PacketKind -> Maybe Handler)
                    -> ToxClient
        mkclient (tbl,var) handlers = Client
            { clientNet           = net
            , clientDispatcher    = dispatch tbl var handlers -- (fmap (contramapAddr (\(ToxPath ni _) -> ni)) . handlers)
            , clientErrorReporter = (printErrors stderr) { reportTimeout = reportTimeout ignoreErrors }
            , clientPending       = var
            , clientAddress       = \maddr -> atomically $ do
                let var = case flip prefer4or6 Nothing . (\(ToxPath ni _) -> ni) <$> maddr of
                            Just Want_IP6 -> routing6 routing
                            _             -> routing4 routing
                a <- readTVar var
                return $ ToxPath (R.thisNode a) Tox.emptyReturnPath
            , clientResponseId    = genNonce24 var
            }

    return (client, routing, keydb)

toxKademlia :: ToxClient -> TriadCommittee NodeId SockAddr -> TVar (R.BucketList NodeInfo) -> TVar (Int.PSQ POSIXTime) -> Kademlia NodeId NodeInfo
toxKademlia client committee var sched
    = Kademlia quietInsertions
               toxSpace
               (vanillaIO var $ ping client)
                   { tblTransition = \tr -> do
                        io1 <- transitionCommittee committee tr
                        io2 <- touchBucket toxSpace (15*60) var sched tr
                        return $ do
                            io1 >> io2
                            hPutStrLn stderr $ unwords
                                [ show (transitionedTo tr)
                                , show (transitioningNode tr)
                                ]
                   }

toxSpace :: R.KademliaSpace NodeId NodeInfo
toxSpace = R.KademliaSpace
    { R.kademliaLocation = nodeId
    , R.kademliaTestBit  = testIdBit
    , R.kademliaXor      = xor
    }


{-
last8 :: ByteString -> Tox.Nonce8
last8 bs
    | let len = B.length bs
    , (len >= 8)
      = Tox.Nonce8 $ let bs'     = B.drop (len - 8) bs
                     Right w = S.runGet S.getWord64be bs'
                 in w
    | otherwise
      = Tox.Nonce8 0

dropEnd8 :: ByteString -> ByteString
dropEnd8 bs = B.take (B.length bs - 8) bs
-}

data Payload a = Payload
    { payload :: a
    , sendback :: Tox.Nonce8
    }

instance S.Serialize a => S.Serialize (Payload a) where
    get = Payload <$> S.get <*> S.get
    put (Payload a nonce) = S.put a >> S.put nonce


-- Add detailed printouts for every packet.
addVerbosity tr =
    tr { awaitMessage = \kont -> awaitMessage tr $ \m -> do
            forM_ m $ mapM_ $ \(msg,addr) -> do
                hPutStrLn stderr ( (show addr)
                                    ++ " --> " ++ show (msgType msg))
            kont m
       , sendMessage = \addr msg -> do
            hPutStrLn stderr ( (show addr)
                                ++ " <-- " ++ show msg ) -- (msgType msg))
            sendMessage tr addr msg
       }

addVerbosity2 tr =
    tr { awaitMessage = \kont -> awaitMessage tr $ \m -> do
            forM_ m $ mapM_ $ \(msg,addr) -> do
                hPutStrLn stderr ( (show addr)
                                    ++ " -2-> " ++ show (Tox.PacketKind $ B.head msg))
                -- forM_ (xxd 0 msg) (hPutStrLn stderr)
            kont m
       , sendMessage = \addr msg -> do
            hPutStrLn stderr ( (show addr)
                                ++ " <-2- " ++ show (Tox.PacketKind $ B.head msg))
            forM_ (xxd 0 msg) (hPutStrLn stderr)
            sendMessage tr addr msg
       }


classify :: Msg -> MessageClass String Tox.PacketKind TransactionId
classify (Msg { msgType     = typ
              , msgData     = bs
              , msgSendBack = nonce8
              , msgNonce    = nonce24 }) = go $ TransactionId nonce8 nonce24
 where
    go = case typ of
            PingType           -> IsQuery typ
            GetNodesType       -> IsQuery typ
            PongType           -> IsResponse
            SendNodesType      -> IsResponse
            OnionResponse1Type -> IsResponse
            OnionResponse2Type -> IsResponse
            OnionResponse3Type -> IsResponse
            DHTRequestType     -> IsQuery typ
            OnionRequest0Type  -> IsQuery typ
            OnionRequest1Type  -> IsQuery typ
            OnionRequest2Type  -> IsQuery typ
            AnnounceType       -> IsQuery typ
            DataRequestType    -> IsQuery typ
            DataResponseType   -> IsResponse
            _                  -> const $ IsUnknown ("Unknown message type: "++show typ)

{-
encodePayload typ (TransactionId (Tox.Nonce8 tid) nonce) self dest b
    = Message { msgType       = typ
              , msgOrigin     = nodeId self
              , msgNonce      = nonce
              , msgReturnPath = Nothing
              , msgPayload    = S.encode b <> S.runPut (S.putWord64be tid)
              }

decodePayload :: S.Serialize a => Message ByteString -> Either String a
decodePayload msg = S.decode $ dropEnd8 $ msgPayload msg
-}

type Handler = MethodHandler String TransactionId ToxPath Msg

{-
noreply :: Tox.PacketKind
           -> (addr -> Msg -> IO ())
           -> Maybe (MethodHandler String tid addr Msg)
noreply typ f = Just $ NoReply (mapM deserialize) f
 where
    deserialize = S.decode . bool id dropEnd8 (typeHasEncryptedPayload typ)
-}

transitionCommittee :: TriadCommittee NodeId SockAddr -> RoutingTransition NodeInfo -> STM (IO ())
transitionCommittee committee (RoutingTransition ni Stranger) = do
    delVote committee (nodeId ni)
    return $ do
        hPutStrLn stderr $ "delVote "++show (nodeId ni)
transitionCommittee committee _ = return $ return ()

updateRouting :: ToxClient -> Routing -> ToxPath -> (Tox.PacketKind, InterediateRep) -> IO ()
updateRouting client routing (ToxPath naddr _) (typ,Assym msg) = do
    hPutStrLn stderr $ "updateRouting "++show typ
    case prefer4or6 naddr Nothing of
        Want_IP4 -> updateTable client naddr (routing4 routing) (committee4 routing) (sched4 routing)
        Want_IP6 -> updateTable client naddr (routing6 routing) (committee6 routing) (sched6 routing)
updateRouting _ _ _ (typ,_) = do
    hPutStrLn stderr $ "updateRouting (ignored) "++show typ

updateTable client naddr tbl committee sched = do
        self <- atomically $ R.thisNode <$> readTVar tbl
        when (nodeIP self /= nodeIP naddr) $ do
            -- TODO: IP address vote?
            insertNode (toxKademlia client committee tbl sched) naddr


data Ping = Ping deriving Show
data Pong = Pong deriving Show

instance S.Serialize Ping where
    get = do w8 <- S.get
             if (w8 :: Word8) /= 0
                then fail "Malformed ping."
                else return Ping
    put Ping = S.put (0 :: Word8)

instance S.Serialize Pong where
    get = do w8 <- S.get
             if (w8 :: Word8) /= 1
                then fail "Malformed pong."
                else return Pong
    put Pong = S.put (1 :: Word8)

newtype GetNodes = GetNodes NodeId
    deriving (Eq,Ord,Show,Read,S.Serialize)

newtype SendNodes = SendNodes [NodeInfo]
    deriving (Eq,Ord,Show,Read)

instance S.Serialize SendNodes where
    get = do
        cnt <- S.get :: S.Get Word8
        ns <- sequence $ replicate (fromIntegral cnt) S.get
        return $ SendNodes ns

    put (SendNodes ns) = do
        let ns' = take 4 ns
        S.put (fromIntegral (length ns') :: Word8)
        mapM_ S.put ns'


-- self -> A
-- OnionRequest0: Message (OnionWrap (OnionWrap (Forward msg)))
-- OnionRequest0: Message (OnionWrap (OnionWrap Ciphered))
-- OnionRequest0: Message (OnionWrap Ciphered)
-- OnionRequest0: Message Ciphered

-- A -> B
-- OnionRequest0: Message Ciphered
-- OnionRequest0: Message (OnionWrap Ciphered)
-- OnionRequest1: Message Ciphered ++ SockAddr
-- OnionRequest1: Message Ciphered ++ SymmetricCiphered
--
-- B -> C
-- OnionRequest1: Message Ciphered ++ SymmetricCiphered
-- OnionRequest1: Message (OnionWrap Ciphered) ++ SymmetricCiphered
-- OnionRequest2: Message Ciphered ++ (SockAddr ++ SymmetricCiphered)
-- OnionRequest2: Message Ciphered ++ SymmetricCiphered
--
-- C -> D
-- OnionRequest2: Message Ciphered ++ SymmetricCiphered
-- OnionRequest2: Message (Forward msg) ++ SymmetricCiphered
-- ?????????????: msg  ++ ( SockAddr ++ SymmetricCiphered)
-- ?????????????: msg  ++ SymmetricCiphered

-- D -> C
-- ?????????????: msg ++ SymmetricCiphered
-- OnionResponse3: Message SymmetricCiphered ++ response
--
-- C -> B
-- OnionResponse3: Message SymmetricCiphered               ++ response
-- OnionResponse3: Message (SockAddr ++ SymmetricCiphered) ++ response
-- OnionResponse2: Message SymmetricCiphered               ++ response
--
-- B -> A
-- OnionResponse2: Message SymmetricCiphered               ++ response
-- OnionResponse2: Message (SockAddr ++ SymmetricCiphered) ++ response
-- OnionResponse1: Message SymmetricCiphered               ++ response
--
-- A -> self
-- OnionResponse1: Message SymmetricCiphered               ++ response
-- OnionResponse1: Message SockAddr                        ++ response
-- ??????????????: response
--
-- Onion payloads:
--   AnounceRequest      (0x83)
--      = SeekingKey nid
--      | AnnouncingKey pingid nid sendback_key
--
--   AnnounceResponse    (0x84)
--      = KeyNotFound  pingid [ni]       -- is_stored=0
--      | KeyFound     sendback_key [ni] -- is_stored=1
--      | Announced    pingid [ni]       -- is_stored=2  What's the pingid for in this caes?
--                                       --              Should it be a fresh one?
--
--   -- After you find an announce node for your friend, you share your dht nodeid thus:
--   DataToRouteRequest  (0x85)
--      -- cleartext: Public key of destination node (used to lookup the sendback_key,ip,port of onion-return path)
--      -- cleartext: nonce
--      -- cleartext: alias  (just generated key)
--      -- encrypted (nonce,alias,sendback_key):
--              real public key
--              id byte
--              -- encrypted
--                  DHTPublicKey (0x9c)
--                  { no_replay   :: Word64
--                  , dhtKey      :: NodeId
--                  , nearbyNodes :: [NodeInfo]
--                  }
--              payload (optional)
--
--   -- The announce node forwards your message thus:
--   -- This is the same as 0x85, but the destination key was removed.
--   DataToRouteResponse (0x86)
--      -- cleartext: nonce
--      -- cleartext: alias
--      -- encrypted payload.

data OnionWrap a = OnionWrap
    { forwardAddress :: SockAddr
    , forwardAlias   :: NodeId
    , onionPayload   :: a
    }

instance S.Serialize (OnionWrap Ciphered) where
    get = getOnion
    put = putOnion

getOnion :: S.Get (OnionWrap Ciphered)
getOnion = do
    addr <- getForwardAddr
    alias <- S.get
    ciphered <- getCiphered
    return $ OnionWrap addr alias ciphered

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

putOnion :: OnionWrap Ciphered -> S.Put
putOnion = error "todo: putOnion"

getCiphered :: S.Get Ciphered
getCiphered = do
        mac <- Poly1305.Auth . BA.convert <$> S.getBytes 16
        cnt <- S.remaining
        bs <- S.getBytes cnt
        return $ Ciphered mac bs

putCiphered :: Ciphered -> S.Put
putCiphered (Ciphered (Poly1305.Auth mac) bs) = do
        S.putByteString (BA.convert mac)
        S.putByteString bs

newtype Nonce32 = Nonce32 ByteString
 deriving (Eq, Ord, ByteArrayAccess, Data)

instance S.Serialize Nonce32 where
    get = Nonce32 <$> S.getBytes 32
    put (Nonce32 bs) = S.putByteString bs

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
    }

instance S.Serialize AnnounceRequest where
    get = AnnounceRequest <$> S.get <*> S.get <*> S.get
    put (AnnounceRequest p s k) = S.put (p,s,k)

data KeyRecord = NotStored    Nonce32
               | SendBackKey  Tox.PubKey
               | Acknowledged Nonce32

instance S.Serialize KeyRecord where
    get = do
        is_stored <- S.get :: S.Get Word8
        case is_stored of
            1 -> SendBackKey  <$> S.get
            2 -> Acknowledged <$> S.get
            _ -> NotStored    <$> S.get
    put (NotStored n32)    = S.put (0 :: Word8) >> S.put n32
    put (SendBackKey key)  = S.put (1 :: Word8) >> S.put key
    put (Acknowledged n32) = S.put (2 :: Word8) >> S.put n32

data AnnounceResponse = AnnounceResponse
    { is_stored     :: KeyRecord
    , announceNodes :: SendNodes
    }

instance S.Serialize AnnounceResponse where
    get = AnnounceResponse <$> S.get <*> S.get
    put (AnnounceResponse st ns) = S.put st >> S.put ns

pingH :: NodeInfo -> Ping -> IO Pong
pingH _ Ping = return Pong

prefer4or6 :: NodeInfo -> Maybe WantIP -> WantIP
prefer4or6 addr iptyp = fromMaybe (ipFamily $ nodeIP addr) iptyp

-- TODO: This should cover more cases
isLocal (IPv6 ip6) = (ip6 == toEnum 0)
isLocal (IPv4 ip4) = (ip4 == toEnum 0)

isGlobal = not . isLocal

getNodesH :: Routing -> NodeInfo -> GetNodes -> IO SendNodes
getNodesH routing addr (GetNodes nid) = do
    let preferred = prefer4or6 addr Nothing

    (append4,append6) <- atomically $ do
        ni4 <- R.thisNode <$> readTVar (routing4 routing)
        ni6 <- R.thisNode <$> readTVar (routing6 routing)
        return $ case ipFamily (nodeIP addr) of
            Want_IP4 | isGlobal (nodeIP ni6) -> (id, (++ [ni6]))
            Want_IP6 | isGlobal (nodeIP ni4) -> ((++ [ni4]), id)
            _                                -> (id, id)
    ks  <- go append4 $ routing4 routing
    ks6 <- go append6 $ routing6 routing
    let (ns1,ns2) = case preferred of Want_IP6 -> (ks6,ks)
                                      Want_IP4 -> (ks,ks6)
    return $ SendNodes
           $ if null ns2 then ns1
                         else take 4 (take 3 ns1 ++ ns2)
 where
    go f var = f . R.kclosest toxSpace k nid <$> atomically (readTVar var)

    k = 4


dataToRouteH :: TVar AnnouncedKeys -> Transport err ToxPath (Tox.PacketKind,InterediateRep) -> addr -> (Tox.PubKey,Assymetric) -> IO ()
dataToRouteH keydb udp _ (k,assym) = do
    mb <- atomically $ do
        ks <- readTVar keydb
        forM (MinMaxPSQ.lookup' k (keyAssoc ks)) $ \(p,(cnt,rpath)) -> do
            writeTVar keydb $ ks { keyAssoc = MinMaxPSQ.insert' k (cnt + 1, rpath) p (keyAssoc ks) }
            return rpath
    forM_ mb $ \rpath -> do
        -- forward
        sendMessage udp rpath (DataResponseType, RouteResponse $ DataToRouteResponse $ Aliased assym)
        hPutStrLn stderr $ "Forwarding data-to-route -->"++show k

-- 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 reason for this 20 second timeout in toxcore is that it gives a reasonable
-- time (20 to 40 seconds) for a peer to announce himself while taking in count
-- all the possible delays with some extra seconds.
announceH :: Routing -> TVar SessionTokens -> TVar AnnouncedKeys -> ToxPath -> AnnounceRequest -> IO AnnounceResponse
announceH routing toks keydb (ToxPath naddr retpath) req = do
    case () of
        _ | announcePingId req == zeros32
          -> go False

        _ | Nonce32 bs <- announcePingId req
          , let tok = fromPaddedByteString 32 bs
          -> checkToken toks naddr tok >>= go
        `catch` (\(SomeException e) -> hPutStrLn stderr ("announceH Exception! "++show e) >> throw e)
 where
    go withTok = do
        ns <- getNodesH routing naddr (GetNodes (announceSeeking req))
        tm <- getPOSIXTime
        let storing = (nodeId naddr == announceSeeking req)
        record <- atomically $ do
            when (withTok && storing) $ do
                let toxpath = ToxPath naddr{ nodeId = announceKey req } retpath
                    -- Note: The following distance calculation assumes that
                    -- our nodeid doesn't change and is the same for both
                    -- routing4 and routing6.
                    d = xor (nodeId (tentativeId routing))
                            (announceSeeking req)
                modifyTVar' keydb (insertKey tm (announceSeeking req) toxpath d)
            ks <- readTVar keydb
            return $ snd . snd <$> MinMaxPSQ.lookup' (announceSeeking req) (keyAssoc ks)
        newtok <- if storing
                    then Nonce32 . toPaddedByteString 32 <$> grantToken toks naddr
                    else return $ zeros32
        let k = case record of
                Nothing                     -> NotStored newtok
                Just (ToxPath {}) | storing -> Acknowledged newtok
                Just (ToxPath ni _)         -> SendBackKey (nodeId ni)
        return $ AnnounceResponse k ns

{-
symmetricCipher :: DRG g => STM ByteString -> STM g -> (g -> STM ()) -> ByteString -> IO (Tox.Nonce24, SymmetricCiphered)
symmetricCipher currentSymmetricKey readG writeG bs = (>>= \e -> hPutStrLn stderr (show e) >> Cryptonite.throwCryptoErrorIO e) $ atomically $ do
    g <- readG
    let (sym_nonce_bytes, g') = randomBytesGenerate 12 g
    writeG g'
    symmkey <- currentSymmetricKey
    return $ do
        sym_nonce <- Symmetric.nonce12 sym_nonce_bytes
        symm <- Symmetric.initialize symmkey sym_nonce
        let (rpath_bs, symm') = Symmetric.encrypt bs symm
            auth = Symmetric.finalize symm' -- 16 bytes
            -- For a single SockAddr, bs will be 19 bytes which gives
            -- 12 + 16 + 19 = 47 bytes.
            -- We need 12 more make 59 bytes, so we'll include the nonce twice.
            nonce24 = Tox.Nonce24 $ sym_nonce <> sym_nonce
        return ( nonce24
               , SymmetricCiphered (BA.convert auth <> rpath_bs)
               )

symmetricDecipher currentSymmetricKey (Tox.Nonce24 nonce24) (SymmetricCiphered bs) = atomically $ do
    symmkey <- currentSymmetricKey
    return $ do
        let sym_nonce_bytes = B.drop 12 nonce24
            (mac, bs'')     = B.splitAt 16 bs
        symm <- left show . Cryptonite.eitherCryptoError $ do
            sym_nonce <- Symmetric.nonce12 sym_nonce_bytes
            Symmetric.initialize symmkey sym_nonce
        let (ds, symm') = Symmetric.decrypt bs'' symm
            auth = Symmetric.finalize symm'
        if BA.convert auth /= mac
            then Left "symmetricDecipher: Auth fail."
            else return $ ds
-}

{-

-- OnionRequest0
onionSend0H :: (ByteString -> IO (Tox.Nonce24,SymmetricCiphered))
            -> Transport err SockAddr ByteString
            -> NodeInfo
            -> Message (OnionWrap Ciphered)
            -> IO ()
onionSend0H symcipher udp addr Message{ msgNonce
                                      , msgPayload = OnionWrap forward alias ciphered } = do
    hPutStrLn stderr $ "onionSend0H( " ++ show addr ++ " --> " ++ either show show (either4or6 forward) ++ ")"
    (nonce,rpath) <- symcipher (S.runPut $ putForwardAddr forward)
    sendMessage udp forward $ S.runPut $ putMessage
        Message { msgType       = OnionRequest1
                , msgOrigin     = alias
                , msgNonce      = msgNonce
                , msgReturnPath = Just (nonce,rpath)
                , msgPayload    = Right ciphered
                }
    hPutStrLn stderr $ "onionSend0H SENT ( " ++ show addr ++ " --> " ++ either show show (either4or6 forward) ++ ")"

-- OnionResponse1
--
-- No public-key decryption here.
onionResponse1H ::
            (Tox.Nonce24 -> SymmetricCiphered -> IO (Either String ByteString))
            -> Transport err SockAddr ByteString
            -> NodeInfo
            -> Message OnionPayload
            -> IO ()
onionResponse1H symdecipher udp addr Message{ msgNonce
                                            , msgReturnPath
                                            , msgPayload
                                            }
    = do
        hPutStrLn stderr $ "onionResponse1H " ++ show addr ++ maybe " Nothing" (const" Just") msgReturnPath
        forM_ msgReturnPath $ \rpath -> do
            eaddr <- (>>= S.runGet getForwardAddr) <$> symdecipher msgNonce rpath
            let go forward = do
                hPutStrLn stderr $ "onionResponse1H( " ++ show addr ++ " --> " ++ either show show (either4or6 forward) ++ ")"
                sendMessage udp forward (unpackOnionPayload msgPayload)
            either (hPutStrLn stderr . mappend "onionResponse1H decipher ERROR ") (\x -> go x >> hPutStrLn stderr "onionResponse1H SENT") eaddr

-}

intKey :: TransactionId -> Int
intKey (TransactionId (Tox.Nonce8 w) _) = fromIntegral w

nonceKey :: TransactionId -> Tox.Nonce8
nonceKey (TransactionId n _) = n

-- randomBytesGenerate :: ByteArray byteArray => Int -> gen -> (byteArray, gen)
gen :: forall gen. DRG gen => gen -> (TransactionId, gen)
-- gen :: SystemDRG -> (TransactionId, SystemDRG)
gen g = let (bs, g')  = randomBytesGenerate 24 g
            (ws, g'') = randomBytesGenerate 8 g'
            Right w   = S.runGet S.getWord64be ws
        in ( TransactionId (Tox.Nonce8 w) (Tox.Nonce24 bs), g'' )



toxSend meth unwrap msg client nid addr = do
    reply <- sendQuery client serializer (msg nid) (ToxPath addr Tox.emptyReturnPath)
    -- sendQuery will return (Just (Left _)) on a parse error.  We're going to
    -- blow it away with the join-either sequence.
    -- TODO: Do something with parse errors.
    return $ join $ either (const Nothing) Just <$> reply
 where
    serializer = MethodSerializer
        { methodTimeout  = 5
        , method         = meth
        -- wrapQuery :: tid -> addr -> addr -> a -> x
        , wrapQuery      = encodePayload meth
        -- unwrapResponse :: x -> b
        , unwrapResponse = fmap unwrap . S.decode . msgData
        }

ping :: ToxClient -> NodeInfo -> IO Bool
ping client addr =
    fromMaybe False
    <$> toxSend PingType (\Pong -> True) (const Ping) client () addr

getNodes :: ToxClient -> NodeId -> NodeInfo -> IO (Maybe ([NodeInfo],[NodeInfo],()))
getNodes = toxSend GetNodesType unwrapNodes $ GetNodes

unwrapNodes (SendNodes ns) = (ns,ns,())

toxSearch qry = Search
    { searchSpace       = toxSpace
    , searchNodeAddress = nodeIP &&& nodePort
    , searchQuery       = qry
    }

nodeSearch client = toxSearch (getNodes client)


type NodeDistance = Tox.PubKey

data AnnouncedKeys = AnnouncedKeys
    { keyByAge :: PSQ NodeId (Down POSIXTime) -- timeout of 300 seconds
    , keyAssoc :: MinMaxPSQ' Tox.PubKey NodeDistance (Int,ToxPath)
    }

insertKey :: POSIXTime -> Tox.PubKey -> ToxPath -> NodeDistance -> AnnouncedKeys -> AnnouncedKeys
insertKey tm pub toxpath d keydb = AnnouncedKeys
    { keyByAge = PSQ.insert pub (Down tm) (keyByAge keydb)
    , keyAssoc = case MinMaxPSQ.lookup' pub (keyAssoc keydb) of
                    Just (_,(cnt,_)) -> MinMaxPSQ.insert' pub (cnt,toxpath) d (keyAssoc keydb)
                    Nothing          -> MinMaxPSQ.insert' pub (0  ,toxpath) d (keyAssoc keydb)
    }