path: root/src/Network/Tox/DHT/Handlers.hs

{-# LANGUAGE CPP                        #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE NamedFieldPuns             #-}
{-# LANGUAGE PatternSynonyms            #-}
{-# LANGUAGE TupleSections              #-}
module Network.Tox.DHT.Handlers where

import Network.Tox.DHT.Transport as DHTTransport
import Network.QueryResponse as QR hiding (Client)
import qualified Network.QueryResponse as QR (Client)
import Crypto.Tox
import Network.Kademlia.Search
import qualified Data.Wrapper.PSQInt as Int
import Network.Kademlia
import Network.Kademlia.Bootstrap
import Network.Address               (WantIP (..), ipFamily, testIdBit,fromSockAddr, sockAddrPort)
import qualified Network.Kademlia.Routing as R
import Control.TriadCommittee
import System.Global6
import OnionRouter

import qualified Data.ByteArray as BA
import qualified Data.ByteString.Char8 as C8
import qualified Data.ByteString.Base16 as Base16
import Control.Arrow
import Control.Monad
import Control.Concurrent.Lifted.Instrument
import Control.Concurrent.STM
import Data.Time.Clock.POSIX  (POSIXTime, getPOSIXTime)
import Network.Socket
import Data.Hashable
import Data.IP
import Data.Ord
import Data.Maybe
import Data.Bits
import Data.Serialize (Serialize)
import Data.Word
import Data.List
import System.IO

data TransactionId = TransactionId
 { transactionKey :: Nonce8  -- ^ Used to lookup pending query.
 , cryptoNonce    :: Nonce24 -- ^ Used during the encryption layer.
 }
 deriving (Eq,Ord,Show)

newtype PacketKind = PacketKind Word8
 deriving (Eq, Ord, Serialize)

pattern OnionRequest0Type = PacketKind 128 -- 0x80     Onion Request 0
pattern OnionRequest1Type = PacketKind 129 -- 0x81     Onion Request 1
pattern OnionRequest2Type = PacketKind 130 -- 0x82     Onion Request 2
pattern AnnounceType  = PacketKind 131 -- 0x83     Announce Request
pattern AnnounceResponseType = PacketKind 132 -- 0x84     Announce Response

pattern DataRequestType = PacketKind 133 -- 0x85     Onion Data Request (data to route request packet)
pattern DataResponseType = PacketKind 134 -- 0x86     Onion Data Response (data to route response packet)
-- 0x8c     Onion Response 3
-- 0x8d     Onion Response 2
pattern OnionResponse3Type = PacketKind 140 -- 0x8c     Onion Response 3
pattern OnionResponse2Type = PacketKind 141 -- 0x8d     Onion Response 2
pattern OnionResponse1Type = PacketKind 142 -- 0x8e     Onion Response 1
-- 0xf0     Bootstrap Info

pattern DHTRequestType = PacketKind 32 -- 0x20     DHT Request

pattern CookieRequestType = PacketKind 0x18
pattern CookieResponseType = PacketKind 0x19

pattern PingType      = PacketKind 0 -- 0x00     Ping Request
pattern PongType      = PacketKind 1 -- 0x01     Ping Response
pattern GetNodesType  = PacketKind 2 -- 0x02     Nodes Request
pattern SendNodesType = PacketKind 4 -- 0x04     Nodes Response


instance Show PacketKind where
    showsPrec d PingType = mappend "PingType"
    showsPrec d PongType = mappend "PongType"
    showsPrec d GetNodesType = mappend "GetNodesType"
    showsPrec d SendNodesType = mappend "SendNodesType"
    showsPrec d DHTRequestType = mappend "DHTRequestType"
    showsPrec d OnionRequest0Type = mappend "OnionRequest0Type"
    showsPrec d OnionResponse1Type = mappend "OnionResponse1Type"
    showsPrec d OnionResponse3Type = mappend "OnionResponse3Type"
    showsPrec d AnnounceType = mappend "AnnounceType"
    showsPrec d AnnounceResponseType = mappend "AnnounceResponseType"
    showsPrec d DataRequestType = mappend "DataRequestType"
    showsPrec d DataResponseType = mappend "DataResponseType"
    showsPrec d CookieRequestType = mappend "CookieRequestType"
    showsPrec d CookieResponseType = mappend "CookieResponseType"
    showsPrec d (PacketKind x) = mappend "PacketKind " . showsPrec (d+1) x

msgType :: ( Serialize (f DHTRequest)
           , Serialize (f Cookie), Serialize (f CookieRequest)
           , Serialize (f SendNodes), Serialize (f GetNodes)
           , Serialize (f Pong), Serialize (f Ping)
           ) => DHTMessage f -> PacketKind
msgType msg = PacketKind $ fst $ dhtMessageType msg

classify :: Client -> Message -> MessageClass String PacketKind TransactionId NodeInfo Message
classify client (DHTLanDiscovery {}) = IsUnsolicited (lanDiscoveryH client)
classify client msg = fromMaybe (IsUnknown "unknown")
                      $ mapMessage (\nonce24 (nonce8,_) -> go msg (TransactionId nonce8 nonce24)) msg
 where
    go (DHTPing          {}) = IsQuery PingType
    go (DHTGetNodes      {}) = IsQuery GetNodesType
    go (DHTPong          {}) = IsResponse
    go (DHTSendNodes     {}) = IsResponse
    go (DHTCookieRequest {}) = IsQuery CookieRequestType
    go (DHTCookie        {}) = IsResponse
    go (DHTDHTRequest    {}) = IsQuery DHTRequestType

data Routing = Routing
    { tentativeId :: NodeInfo
    , committee4  :: TriadCommittee NodeId SockAddr
    , committee6  :: TriadCommittee NodeId SockAddr
    , refresher4  :: BucketRefresher NodeId NodeInfo
    , refresher6  :: BucketRefresher NodeId NodeInfo
    }

sched4 :: Routing -> TVar (Int.PSQ POSIXTime)
sched4 Routing { refresher4 = BucketRefresher { refreshQueue } } = refreshQueue

sched6 :: Routing -> TVar (Int.PSQ POSIXTime)
sched6 Routing { refresher6 = BucketRefresher { refreshQueue } } = refreshQueue

routing4 :: Routing -> TVar (R.BucketList NodeInfo)
routing4 Routing { refresher4 = BucketRefresher { refreshBuckets } } = refreshBuckets

routing6 :: Routing -> TVar (R.BucketList NodeInfo)
routing6 Routing { refresher6 = BucketRefresher { refreshBuckets } } = refreshBuckets

newRouting :: SockAddr -> TransportCrypto
                       -> (TVar (R.BucketList NodeInfo) -> SockAddr -> STM ()) -- ^ invoked on IPv4 change
                       -> (TVar (R.BucketList NodeInfo) -> SockAddr -> STM ()) -- ^ invoked on IPv6 change
                       -> IO (Client -> Routing)
newRouting addr crypto update4 update6 = do
    let tentative_ip4 = fromMaybe (IPv4 $ toEnum 0) (IPv4 <$> fromSockAddr addr)
        tentative_ip6 = fromMaybe (IPv6 $ toEnum 0) (IPv6 <$> fromSockAddr addr)
        tentative_info = NodeInfo
                { nodeId   = key2id $ transportPublic crypto
                , 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 })
            <$> case addr of
                    SockAddrInet {} -> return Nothing
                    _               -> global6
    atomically $ do
        -- We defer initializing the refreshSearch and refreshPing until we
        -- have a client to send queries with.
        let nullPing = const $ return False
            nullSearch = Search
                { searchSpace       = toxSpace
                , searchNodeAddress = nodeIP &&& nodePort
                , searchQuery       = \_ _ -> return Nothing
                }
        refresher4 <- newBucketRefresher tentative_info nullSearch nullPing
        refresher6 <- newBucketRefresher tentative_info6 nullSearch nullPing
        let tbl4 = refreshBuckets refresher4
            tbl6 = refreshBuckets refresher6
        committee4 <- newTriadCommittee (update4 tbl4) -- updateIPVote tbl4 addr4
        committee6 <- newTriadCommittee (update6 tbl6) -- updateIPVote tbl6 addr6
        return $ \client ->
            -- Now we have a client, so tell the BucketRefresher how to search and ping.
            let updIO r = updateRefresherIO (nodeSearch client) (ping client) r
            in Routing tentative_info committee4 committee6 (updIO refresher4) (updIO refresher6)


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

isGlobal :: IP -> Bool
isGlobal = not . isLocal

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

toxSpace :: R.KademliaSpace NodeId NodeInfo
toxSpace = R.KademliaSpace
    { R.kademliaLocation = nodeId
    , R.kademliaTestBit  = testNodeIdBit
    , R.kademliaXor      = xorNodeId
    , R.kademliaSample   = sampleNodeId
    }


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

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)
                                      Want_Both -> error $ "BUG:unreachable at " ++ __FILE__ ++ ":" ++ show __LINE__
    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

createCookie :: TransportCrypto -> NodeInfo -> PublicKey -> IO Cookie
createCookie crypto ni remoteUserKey = do
    (n24,sym) <- atomically $ do
        n24 <- transportNewNonce crypto
        sym <- transportSymmetric crypto
        return (n24,sym)
    timestamp <- round . (* 1000000) <$> getPOSIXTime
    let dta = encodePlain $ CookieData
            { cookieTime  = timestamp
            , longTermKey = remoteUserKey
            , dhtKey      = transportPublic crypto
            }
        edta = encryptSymmetric sym n24 dta
    hPutStrLn stderr $ "Created cookie with n24 = 0x" ++ show n24 ++ "\n    sym=" ++ show sym
    return $ Cookie n24 edta

cookieRequestH :: TransportCrypto -> NodeInfo -> CookieRequest -> IO Cookie
cookieRequestH crypto ni (CookieRequest remoteUserKey) = do
    hPutStrLn stderr $ unlines
        [ "CookieRequest! remoteUserKey=" ++ show (key2id remoteUserKey)
        , "                      sender=" ++ show ni ]
    x <- createCookie crypto ni remoteUserKey
    hPutStrLn stderr $ "CookieRequest! responding to " ++ show (key2id remoteUserKey)
    return x

lanDiscoveryH :: Client -> NodeInfo -> NodeInfo -> IO (Maybe (Message -> Message))
lanDiscoveryH client _ ni = do
    forkIO $ do
        myThreadId >>= flip labelThread "lan-discover-ping"
        ping client ni
        return ()
    return Nothing

type Message = DHTMessage ((,) Nonce8)

type Client = QR.Client String PacketKind TransactionId NodeInfo Message


wrapAsymm :: TransactionId -> NodeInfo -> NodeInfo -> (Nonce8 -> dta) -> Asymm dta
wrapAsymm (TransactionId n8 n24) src dst dta = Asymm
    { senderKey = id2key $ nodeId src
    , asymmNonce = n24
    , asymmData = dta n8
    }

serializer :: PacketKind
                -> (Asymm (Nonce8,ping) -> Message)
                -> (Message -> Maybe (Asymm (Nonce8,pong)))
                -> MethodSerializer TransactionId NodeInfo Message PacketKind ping (Maybe pong)
serializer pktkind mkping mkpong = MethodSerializer
        { methodTimeout  = \tid addr -> return (addr, 5000000)
        , method         = pktkind
        -- wrapQuery :: tid -> addr -> addr -> qry -> x
        , wrapQuery      = \tid src dst ping -> mkping $ wrapAsymm tid src dst (, ping)
        -- unwrapResponse :: x -> b
        , unwrapResponse = fmap (snd . asymmData) . mkpong
        }


unpong :: Message -> Maybe (Asymm (Nonce8,Pong))
unpong (DHTPong asymm) = Just asymm
unpong _               = Nothing

showHex :: BA.ByteArrayAccess ba => ba -> String
showHex bs = C8.unpack $ Base16.encode $ BA.convert bs

ping :: Client -> NodeInfo -> IO Bool
ping client addr = do
    hPutStrLn stderr $ show addr ++ " <-- ping"
    reply <- QR.sendQuery client (serializer PingType DHTPing unpong) Ping addr
    hPutStrLn stderr $ show addr ++ " -pong-> " ++ show reply
    maybe (return False) (\Pong -> return True) $ join reply


saveCookieKey :: TVar [(SockAddr, (Int, PublicKey))] -> SockAddr -> PublicKey -> STM ()
saveCookieKey var saddr pk = do
    cookiekeys <- readTVar var
    case break (\(stored,_) -> stored == saddr) cookiekeys of
        (xs,[])                               -> writeTVar var $ (saddr, (1  ,pk)) : xs
        (xs,(_,(c,stored)):ys) | stored == pk -> writeTVar var $ (saddr, (c+1,pk)) : xs ++ ys
        _                                     -> retry -- Wait for requests to this address
                                                       -- under a different key to time out
                                                       -- before we try this key.

loseCookieKey :: TVar [(SockAddr, (Int, PublicKey))] -> SockAddr -> PublicKey -> STM ()
loseCookieKey var saddr pk = do
    cookiekeys <- readTVar var
    case break (\(stored,_) -> stored == saddr) cookiekeys of
        (xs,(_,(1,stored)):ys) | stored == pk -> writeTVar var $                     xs ++ ys
        (xs,(_,(c,stored)):ys) | stored == pk -> writeTVar var $ (saddr, (c-1,pk)) : xs ++ ys
        _                                     -> return () -- unreachable?


cookieRequest :: TransportCrypto -> Client -> PublicKey -> NodeInfo -> IO (Maybe Cookie)
cookieRequest crypto client localUserKey addr = do
    let sockAddr = nodeAddr addr
        nid = id2key $ nodeId addr
        cookieSerializer
            = MethodSerializer
                   { methodTimeout  = \tid addr -> return (addr, 5000000)
                   , method    = CookieRequestType
                   , wrapQuery = \tid src dst cr -> DHTCookieRequest $ wrapAsymm tid src dst (, cr)
                   , unwrapResponse = fmap snd . unCookie
                   }
        cookieRequest = CookieRequest localUserKey
    atomically $ saveCookieKey (pendingCookies crypto) sockAddr nid
    hPutStrLn stderr $ show addr ++ " <-- cookieRequest"
    reply <- QR.sendQuery client cookieSerializer cookieRequest addr
    atomically $ loseCookieKey (pendingCookies crypto) sockAddr nid
    hPutStrLn stderr $ show addr ++ " -cookieResponse-> " ++ show reply
    return $ join reply

unCookie :: DHTMessage t -> Maybe (t Cookie)
unCookie (DHTCookie n24 fcookie) = Just fcookie
unCookie _ = Nothing

unsendNodes :: Message -> Maybe (Asymm (Nonce8,SendNodes))
unsendNodes (DHTSendNodes asymm) = Just asymm
unsendNodes _                    = Nothing

unwrapNodes :: SendNodes -> ( [NodeInfo], [NodeInfo], Maybe () )
unwrapNodes (SendNodes ns) = (ns,ns,Just ())

getNodes :: Client -> NodeId -> NodeInfo -> IO (Maybe ([NodeInfo],[NodeInfo],Maybe ()))
getNodes client nid addr = do
    -- hPutStrLn stderr $ show addr ++ " <-- getnodes " ++ show nid
    reply <- QR.sendQuery client (serializer GetNodesType DHTGetNodes unsendNodes) (GetNodes nid) addr
    -- hPutStrLn stderr $ show addr ++ " -sendnodes-> " ++ show reply
    return $ fmap unwrapNodes $ join reply

updateRouting :: Client -> Routing -> OnionRouter -> NodeInfo -> Message -> IO ()
updateRouting client routing orouter naddr msg
    | PacketKind 0x21 <- msgType msg = return () -- ignore lan discovery
    | otherwise                      = do
    case prefer4or6 naddr Nothing of
        Want_IP4 -> updateTable client naddr orouter (committee4 routing) (refresher4 routing)
        Want_IP6 -> updateTable client naddr orouter (committee6 routing) (refresher4 routing)
        Want_Both -> error $ "BUG:unreachable at " ++ __FILE__ ++ ":" ++ show __LINE__

updateTable :: Client -> NodeInfo -> OnionRouter -> TriadCommittee NodeId SockAddr -> BucketRefresher NodeId NodeInfo -> IO ()
updateTable client naddr orouter committee refresher = do
        self <- atomically $ R.thisNode <$> readTVar (refreshBuckets refresher)
        when (nodeIP self /= nodeIP naddr) $ do
            -- TODO: IP address vote?
            insertNode (toxKademlia client committee orouter refresher) naddr

toxKademlia :: Client -> TriadCommittee NodeId SockAddr -> OnionRouter
                -> BucketRefresher NodeId NodeInfo
                -> Kademlia NodeId NodeInfo
toxKademlia client committee orouter refresher
    = Kademlia quietInsertions
               toxSpace
               (vanillaIO (refreshBuckets refresher) $ ping client)
                   { tblTransition = \tr -> do
                        io1 <- transitionCommittee committee tr
                        io2 <- touchBucket refresher tr -- toxSpace (15*60) var sched tr
                        hookBucketList toxSpace (refreshBuckets refresher) orouter tr
                        return $ do
                            io1 >> io2
                            {-
                            hPutStrLn stderr $ unwords
                                [ show (transitionedTo tr)
                                , show (transitioningNode tr)
                                ]
                            -}
                            return ()
                   }

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)
        return ()
transitionCommittee committee _ = return $ return ()

type Handler = MethodHandler String TransactionId NodeInfo Message

isPing :: (f Ping -> Ping) ->  DHTMessage f -> Either String Ping
isPing unpack (DHTPing a) = Right $ unpack $ asymmData a
isPing _      _           = Left "Bad ping"

mkPong :: TransactionId -> NodeInfo -> NodeInfo -> Pong -> DHTMessage ((,) Nonce8)
mkPong tid src dst pong = DHTPong $ wrapAsymm tid src dst (, pong)

isGetNodes :: (f GetNodes -> GetNodes) ->  DHTMessage f -> Either String GetNodes
isGetNodes unpack (DHTGetNodes a) = Right $ unpack $ asymmData a
isGetNodes _      _               = Left "Bad GetNodes"

mkSendNodes :: TransactionId -> NodeInfo -> NodeInfo -> SendNodes -> DHTMessage ((,) Nonce8)
mkSendNodes tid src dst sendnodes = DHTSendNodes $ wrapAsymm tid src dst (, sendnodes)

isCookieRequest :: (f CookieRequest -> CookieRequest) -> DHTMessage f -> Either String CookieRequest
isCookieRequest unpack (DHTCookieRequest a) = Right $ unpack $ asymmData a
isCookieRequest _      _                    = Left "Bad cookie request"

mkCookie :: TransactionId -> NodeInfo -> NodeInfo -> Cookie -> DHTMessage ((,) Nonce8)
mkCookie (TransactionId n8 n24) src dst cookie = DHTCookie n24 (n8,cookie)

isDHTRequest :: (f DHTRequest -> DHTRequest) -> DHTMessage f -> Either String DHTRequest
isDHTRequest unpack (DHTDHTRequest pubkey a) = Right $ unpack $ asymmData a
isDHTRequest _      _                        = Left "Bad dht relay request"

dhtRequestH :: NodeInfo -> DHTRequest -> IO ()
dhtRequestH ni req = do
    hPutStrLn stderr $ "Unhandled DHT Request: " ++ show req

handlers :: TransportCrypto -> Routing -> PacketKind -> Maybe Handler
handlers _      routing PingType          = Just $ MethodHandler (isPing snd) mkPong            $ pingH
handlers _      routing GetNodesType      = Just $ MethodHandler (isGetNodes snd) mkSendNodes   $ getNodesH routing
handlers crypto _       CookieRequestType = Just $ MethodHandler (isCookieRequest snd) mkCookie $ cookieRequestH crypto
handlers _      _       DHTRequestType    = Just $ NoReply (isDHTRequest snd) $ dhtRequestH
handlers _      _       typ               = error $ "TODO DHT handlers " ++ show typ

nodeSearch :: Client -> Search NodeId (IP,PortNumber) () NodeInfo NodeInfo
nodeSearch client  = Search
    { searchSpace       = toxSpace
    , searchNodeAddress = nodeIP &&& nodePort
    , searchQuery       = getNodes client
    }