path: root/Tox.hs

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

import Control.Applicative
import Control.Arrow
import Control.Concurrent (MVar)
import Control.Concurrent.STM
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 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.Data
import Data.IP
import Data.Maybe
import Data.Monoid
import qualified Data.Serialize         as S
import Data.Typeable
import Data.Word
import Foreign.Marshal.Alloc
import Foreign.Ptr
import Foreign.Storable
import GHC.Generics                     (Generic)
import Network.Address                  (Address, fromSockAddr, sockAddrPort, testIdBit,
                                         toSockAddr, setPort, un4map, WantIP(..), ipFamily,
                                         either4or6)
import Network.QueryResponse
import Network.Socket
import System.Endian
import Data.Hashable
import Data.Bits
import Data.Bits.ByteString ()
import qualified Text.ParserCombinators.ReadP as RP
import Data.Char
import TriadCommittee
import qualified Network.DHT.Routing          as R
import qualified Data.Wrapper.PSQInt          as Int
import Data.Time.Clock.POSIX                  (POSIXTime)
import Global6
import Data.Ord
import System.IO
import qualified Data.Aeson as JSON
         ;import Data.Aeson (FromJSON, ToJSON, (.=))
import Control.Monad
import Text.Read
import Kademlia
import Network.BitTorrent.DHT.Search          (Search (..))
import Text.Printf

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

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 = NodeId $ 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 (NodeId bs) ip (fromIntegral (portnum :: Word16))


instance S.Serialize NodeInfo where
    get = do
        addrfam <- S.get :: S.Get Word8
        ip <- case addrfam of
            0x02 -> IPv4 <$> S.get
            0x0a -> IPv6 <$> S.get
            0x82 -> IPv4 <$> S.get -- TODO: TCP
            0x8a -> IPv6 <$> S.get -- TODO: TCP
            -- "Failed reading: unsupported address family (118)\nEmpty call stack\n" 0x76
            x   -> fail ("unsupported address family ("++show x++")")
        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 (NodeId 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 :: Nonce8  -- ^ Used to lookup pending query.
 , cryptoNonce    :: Nonce24 -- ^ Used during the encryption layer.
 }

-- https://toktok.ltd/spec#packet-kind
--  calls this "Packet Kind"
newtype Method = MessageType Word8
 deriving (Eq, Ord, S.Serialize)

pattern PingType      = MessageType 0 -- 0x00     Ping Request
pattern PongType      = MessageType 1 -- 0x01     Ping Response
pattern GetNodesType  = MessageType 2 -- 0x02     Nodes Request
pattern SendNodesType = MessageType 4 -- 0x04     Nodes Response
-- 0x18     Cookie Request
-- 0x19     Cookie Response
-- 0x1a     Crypto Handshake
-- 0x1b     Crypto Data

-- TODO: Auth fail:
pattern DHTRequestType = MessageType 32 -- 0x20     DHT Request

-- 0x21     LAN Discovery

-- TODO: Auth fail:
pattern OnionRequest0 = MessageType 128 -- 0x80     Onion Request 0
pattern OnionRequest1 = MessageType 129 -- 0x81     Onion Request 1
pattern OnionRequest2 = MessageType 130 -- 0x82     Onion Request 2
pattern AnnounceType  = MessageType 131 -- 0x83     Announce Request

-- 0x84     Announce Response
-- 0x85     Onion Data Request
-- 0x86     Onion Data Response
-- 0x8c     Onion Response 3
-- 0x8d     Onion Response 2
-- 0x8e     Onion Response 1
-- 0xf0     Bootstrap Info

--  TODO Fix these fails...
--  GetNodesType decipherAndAuth: auth fail
--  MessageType 128 decipherAndAuth: auth fail
--  MessageType 129 decipherAndAuth: auth fail
--  MessageType 130 decipherAndAuth: auth fail
--  MessageType 131 decipherAndAuth: auth fail
--  MessageType 32 decipherAndAuth: auth fail


instance Show Method where
    showsPrec d PingType        = mappend "PingType"
    showsPrec d PongType        = mappend "PongType"
    showsPrec d GetNodesType    = mappend "GetNodesType"
    showsPrec d SendNodesType   = mappend "SendNodesType"
    showsPrec d (MessageType x) = mappend "MessageType " . showsPrec (d+1) x

newtype Nonce8 = Nonce8 Word64
 deriving (Eq, Ord)

instance ByteArrayAccess Nonce8 where
    length _ = 8
    withByteArray (Nonce8 w64) kont =
        allocaBytes 8 $ \p -> do
            poke (castPtr p :: Ptr Word64) $ toBE64 w64
            kont p

instance Show Nonce8 where
    showsPrec d nonce = quoted (mappend $ bin2hex nonce)

newtype Nonce24 = Nonce24 ByteString
 deriving (Eq, Ord, ByteArrayAccess)

instance Show Nonce24 where
    showsPrec d nonce = quoted (mappend $ bin2hex nonce)

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

quoted :: ShowS -> ShowS
quoted shows s = '"':shows ('"':s)

bin2hex :: ByteArrayAccess bs => bs -> String
bin2hex = C8.unpack . Base16.encode . BA.convert


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

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

getMessage :: S.Get (Message Ciphered)
getMessage = do
        typ <- S.get
        (nid,tid) <- case typ of -- Seriously... what the fuck?
            DHTRequestType -> 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
            _              -> (,) <$> S.get <*> S.get
        mac <- Poly1305.Auth . BA.convert <$> S.getBytes 16
        cnt <- S.remaining
        bs <- S.getBytes cnt
        return Message { msgType    = typ
                       , msgOrigin  = nid
                       , msgNonce   = tid
                       , msgPayload = Ciphered mac bs }

putMessage :: Message 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 Ciphered (Poly1305.Auth mac) bs = msgPayload
        S.putByteString (BA.convert mac)
        S.putByteString bs

{-
data Plain a = Plain
    { plainId      :: 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 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 :: Bytes
zeros32 = BA.replicate 32 0

zeros24 :: Bytes
zeros24 = BA.take 24 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 -> 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 zeros32
    -- Since rs is 32 bytes, this pattern should never fail...
    Cryptonite.CryptoPassed hash = Poly1305.initialize rs


encryptMessage :: SecretKey -> SecretsCache -> NodeId -> Message ByteString -> Message Ciphered
encryptMessage sk _ recipient plaintext
    = withSecret encipherAndHash sk recipient (msgNonce plaintext) <$> plaintext

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

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 -> Ciphered
encipherAndHash hash crypt m = Ciphered a c
  where
    c = fst . XSalsa.combine crypt $ m
    a = Poly1305.finalize . Poly1305.update hash $ c

decipherAndAuth :: Poly1305.State -> XSalsa.State -> Ciphered -> Either String ByteString
decipherAndAuth hash crypt (Ciphered 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

-- TODO:
-- Represents the encrypted portion of a Tox packet.
-- data Payload a = Payload a !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
    ciphered <- S.runGet getMessage bs
    ni <- nodeInfo (msgOrigin ciphered) addr
    left (showPayloadError ciphered ni " --> ") $ do
    msg <- decryptMessage sk cache ciphered
    return (msg, ni)

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 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 Method TransactionId NodeInfo (Message ByteString)

newClient :: SockAddr -> IO (ToxClient, Routing)
newClient addr = do
    udp <- udpTransport addr
    secret <- generateSecretKey
    let pubkey = key2id $ toPublic secret
    cache <- newEmptyCache
    drg <- getSystemDRG
    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)
    let net = onInbound (updateRouting outgoingClient routing)
              $ addVerbosity
              $ layerTransport (parsePacket secret cache)
                               (encodePacket secret cache)
              $ udp

        -- Paranoid: It's safe to define /net/ and /client/ to be mutually
        -- recursive since 'updateRouting' does not invoke 'awaitMessage' which
        -- which was modified by 'onInbound'.  However, I'm going to avoid the
        -- mutual reference just to be safe.
        outgoingClient = client { clientNet = net { awaitMessage = return Nothing } }

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

        handlers :: Method -> Maybe Handler
        handlers PingType     = handler PongType pingH
        handlers GetNodesType = handler SendNodesType $ getNodesH routing
        handlers _            = Nothing
        -- TODO DHTRequest public key (onion)
        -- TODO DHTRequest NAT ping
        -- TODO BootstrapInfo 0xf0
        -- 

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

        client = either mkclient mkclient tblvar

        mkclient :: DRG g =>
                    ( TransactionMethods (g,t (MVar (Message ByteString)))
                                         TransactionId
                                         (Message ByteString)
                    , TVar (g, t (MVar (Message ByteString)))
                    ) -> ToxClient
        mkclient (tbl,var) = Client
            { clientNet           = net
            , clientDispatcher    = dispatch tbl
            , clientErrorReporter = printErrors stderr
            , clientPending       = var
            , clientAddress       = \maddr -> atomically $ do
                let var = case flip prefer4or6 Nothing <$> maddr of
                            Just Want_IP6 -> routing6 routing
                            _             -> routing4 routing
                R.thisNode <$> readTVar var
            , clientResponseId    = genNonce24 var
            }

    return (client, routing)

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 -> Nonce8
last8 bs
    | let len = B.length bs
    , (len >= 8)
      = Nonce8 $ let bs'     = B.drop (len - 8) bs
                     Right w = S.runGet S.getWord64be bs'
                 in w
    | otherwise
      = Nonce8 0

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


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

classify :: Message ByteString -> MessageClass String Method TransactionId
classify (Message { msgType    = typ
                  , msgPayload = bs
                  , msgNonce   = nonce24 }) = go $ TransactionId (last8 bs) nonce24
 where
    go = case typ of
            PingType       -> IsQuery typ
            GetNodesType   -> IsQuery typ
            PongType       -> IsResponse
            SendNodesType  -> IsResponse
            DHTRequestType -> IsQuery typ
            OnionRequest0  -> IsQuery typ
            OnionRequest1  -> IsQuery typ
            OnionRequest2  -> IsQuery typ
            AnnounceType   -> IsQuery typ
            _              -> const $ IsUnknown ("Unknown message type: "++show typ)

encodePayload typ (TransactionId (Nonce8 tid) nonce) self dest b
    = Message { msgType    = typ
              , msgOrigin  = nodeId self
              , msgNonce   = nonce
              , 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 NodeInfo (Message ByteString)

handler typ f = Just $ MethodHandler decodePayload (encodePayload typ) f

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 -> NodeInfo -> Message ByteString -> IO ()
updateRouting client routing naddr msg = do
    case prefer4or6 naddr Nothing of
        Want_IP4 -> go (routing4 routing) (committee4 routing) (sched4 routing)
        Want_IP6 -> go (routing6 routing) (committee6 routing) (sched6 routing)
 where
    go 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'


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

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

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

-- randomBytesGenerate :: ByteArray byteArray => Int -> gen -> (byteArray, gen)
-- gen :: forall gen. DRG gen => gen -> ((Nonce8, Nonce24), 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 (Nonce8 w) (Nonce24 bs), g'' )


toxSend meth unwrap msg client nid addr = do
    reply <- sendQuery client serializer (msg nid) addr
    -- 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 . decodePayload
        }

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)