path: root/dht/src/Network/Tox.hs

{-# LANGUAGE CPP                        #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE DeriveDataTypeable         #-}
{-# LANGUAGE DeriveFoldable             #-}
{-# LANGUAGE DeriveFunctor              #-}
{-# LANGUAGE DeriveGeneric              #-}
{-# LANGUAGE DeriveTraversable          #-}
{-# LANGUAGE ExistentialQuantification  #-}
{-# LANGUAGE FlexibleInstances          #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase                 #-}
{-# LANGUAGE NamedFieldPuns             #-}
{-# LANGUAGE PatternSynonyms            #-}
{-# LANGUAGE RankNTypes                 #-}
{-# LANGUAGE RecursiveDo                #-}
{-# LANGUAGE ScopedTypeVariables        #-}
{-# LANGUAGE TupleSections              #-}
{-# LANGUAGE ViewPatterns               #-}
module Network.Tox where

#ifdef THREAD_DEBUG
import Control.Concurrent.Lifted.Instrument
#else
import Control.Concurrent.Lifted
#endif
import Control.Arrow
import Control.Concurrent.STM
import Control.Exception                      (throwIO)
import Control.Monad
import Crypto.PubKey.Curve25519
import Crypto.Random
import Data.Bits.ByteString                   ()
import qualified Data.ByteString              as B
         ;import Data.ByteString              (ByteString)
import qualified Data.ByteString.Char8        as C8
import Data.Data
import qualified Data.Dependent.Map           as DMap
import Data.Dependent.Sum
import Data.Functor.Identity
import Data.Functor.Contravariant
import Data.Maybe
import qualified Data.MinMaxPSQ               as MinMaxPSQ
import qualified Data.Serialize               as S
import Data.Time.Clock.POSIX                  (getPOSIXTime)
import Data.Word
import Network.Socket
import System.Endian
import System.IO.Error

import Crypto.Tox
import Data.TableMethods
import qualified Data.Tox.DHT.Multi          as Multi
import Data.Tox.Onion                        (substituteLoopback)
import qualified Data.Word64Map
import qualified Data.Word64Map              (empty)
         ;import Data.Word64Map              (fitsInInt)
import qualified Data.Wrapper.PSQ            as PSQ
import Network.Address                       (IP, WantIP (..), getBindAddress)
import Network.BitTorrent.DHT.Token          as Token
import Network.Kademlia.Bootstrap            (bootstrap, forkPollForRefresh)
import qualified Network.Kademlia.Routing    as R
import Network.QueryResponse
import Network.StreamServer                  (ServerHandle, quitListening)
import Network.Tox.Crypto.Transport          (CryptoPacket, Handshake (..))
import qualified Network.Tox.DHT.Handlers    as DHT
import qualified Network.Tox.DHT.Transport   as DHT
import Network.Tox.NodeId
import qualified Network.Tox.Onion.Handlers  as Onion
import qualified Network.Tox.Onion.Transport as Onion
import Network.Tox.RelayPinger
import System.Global6
import Network.Tox.Transport
import Network.Tox.TCP (tcpClient)
import Network.Tox.Onion.Routes
import Network.Tox.ContactInfo
import Text.XXD
import DPut
import DebugTag
import TCPProber
import Network.Tox.Avahi
import Network.Tox.Session
import qualified Data.Tox.Relay as TCP
import Network.Tox.Relay
import Network.SessionTransports
import Network.Kademlia.Search
import HandshakeCache
import Data.ByteString.Base16 as Base16

updateIP :: TVar (R.BucketList NodeInfo) -> SockAddr -> STM ()
updateIP tblvar a = do
    bkts <- readTVar tblvar
    case nodeInfo (nodeId (R.thisNode bkts)) a of
        Right ni -> writeTVar tblvar (bkts { R.thisNode = ni })
        Left _   -> return ()

genNonce24 :: DRG g =>
              TVar (g, pending) -> DHT.TransactionId -> IO DHT.TransactionId
genNonce24 var (DHT.TransactionId nonce8 _) = atomically $ do
    (g,pending) <- readTVar var
    let (bs, g') = randomBytesGenerate 24 g
    writeTVar var (g',pending)
    return $ DHT.TransactionId nonce8 (Nonce24 bs)


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

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

w64Key :: DHT.TransactionId -> Word64
w64Key (DHT.TransactionId (Nonce8 w) _) = w

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

-- | Return my own address.
myAddr :: TVar (R.BucketList NodeInfo) -- ^ IPv4 buckets
       -> TVar (R.BucketList NodeInfo) -- ^ IPv6 buckets
       -> Maybe Multi.NodeInfo         -- ^ Interested remote address
       -> IO Multi.NodeInfo
myAddr routing4 routing6 maddr = atomically $ do
    let var = case flip DHT.prefer4or6 Nothing <$> maddr of
                Just Want_IP6 -> routing4
                _             -> routing6
    a <- readTVar var
    return $ Multi.UDP ==> R.thisNode a

newClient :: (DRG g, Show addr, Show meth) =>
              g -> Transport String addr x
                -> (Client String meth DHT.TransactionId addr x
                    -> x
                    -> MessageClass String meth DHT.TransactionId addr x)
                -> (Maybe addr -> IO addr)
                -> (Client String meth DHT.TransactionId addr x
                    -> meth
                    -> Maybe (MethodHandler String DHT.TransactionId addr x))
                -> (forall d. TransactionMethods d DHT.TransactionId addr x
                    -> TransactionMethods d DHT.TransactionId addr x)
                -> (Client String meth DHT.TransactionId addr x
                    -> Transport String addr x -> Transport String addr x)
                -> IO (Client String meth DHT.TransactionId addr x)
newClient drg net classify selfAddr handlers modifytbl modifynet = do
    -- 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 (contramap intKey intMapMethods) gen
            intmap_var <- atomically $ newTVar (drg, mempty)
            return $ Right (intmapT,intmap_var)
         else do
            let word64mapT = transactionMethods (contramap w64Key w64MapMethods) gen
            map_var <- atomically $ newTVar (drg, Data.Word64Map.empty)
            return $ Left (word64mapT,map_var)
    let dispatch tbl var handlers client = DispatchMethods
                { classifyInbound = classify client
                , lookupHandler   = handlers -- var
                , tableMethods    = modifytbl tbl
                }
        eprinter = logErrors -- printErrors stderr
        mkclient (tbl,var) handlers =
            let client = Client
                    { clientNet           = addHandler (reportParseError eprinter) (handleMessage client) $ modifynet client net
                    , clientDispatcher    = dispatch tbl var (handlers client) client
                    , clientErrorReporter = eprinter
                    , clientPending       = var
                    , clientAddress       = selfAddr
                    , clientResponseId    = genNonce24 var
                    }
            in client
    return $ either mkclient mkclient tblvar handlers

data Tox extra  = Tox
    { toxDHT            :: DHT.Client
    , toxOnion          :: Onion.Client RouteId
    , toxToRoute        :: Transport String Onion.AnnouncedRendezvous (PublicKey,Onion.OnionData)
    , toxCrypto         :: Transport String Multi.SessionAddress (CryptoPacket Encrypted)
    , toxHandshakes     :: Transport String Multi.SessionAddress (Handshake Encrypted)
    , toxHandshakeCache :: HandshakeCache
    , toxCryptoKeys     :: TransportCrypto
    , toxRouting        :: DHT.Routing
    , toxTokens         :: TVar SessionTokens
    , toxAnnouncedKeys  :: TVar Onion.AnnouncedKeys
    , toxOnionRoutes    :: OnionRouter
    , toxContactInfo    :: ContactInfo extra
    , toxAnnounceToLan  :: IO ()
    , toxBindAddress    :: SockAddr
    , toxRelayServer    :: Maybe ServerHandle
    }



-- | Create a DHTPublicKey packet to send to a remote contact.
getContactInfo :: Tox extra -> IO DHT.DHTPublicKey
getContactInfo Tox{toxCryptoKeys,toxRouting,toxOnionRoutes} = join $ atomically $ do
    (rcnt,relays) <- currentRelays (tcpRelayPinger toxOnionRoutes)
    r4 <- readTVar $ DHT.routing4 toxRouting
    r6 <- readTVar $ DHT.routing6 toxRouting
    nonce <- transportNewNonce toxCryptoKeys
    let self = nodeId n4
        n4 = R.thisNode r4
        n6 = R.thisNode r6
        n4s = R.kclosest DHT.toxSpace 4 self r4
        n6s = R.kclosest DHT.toxSpace 4 self r6
        ns = filter (DHT.isGlobal . nodeIP) [n4,n6]
              ++ concat (zipWith (\a b -> [a,b]) n4s n6s)
    return $ do
        timestamp <- round . (* 1000000) <$> getPOSIXTime
        return DHT.DHTPublicKey
            { dhtpkNonce = timestamp
            , dhtpk      = id2key self
            , dhtpkNodes = DHT.SendNodes $ take 4 $ relays ++ map TCP.fromUDPNode ns
            }

isLocalHost :: SockAddr -> Bool
isLocalHost (SockAddrInet _ host32) = (fromBE32 host32 == 0x7f000001)
isLocalHost _                       = False

addVerbosity :: Transport err SockAddr ByteString -> Transport err SockAddr ByteString
addVerbosity tr =
    tr { awaitMessage = \kont -> awaitMessage tr $ \m -> do
            case m of
              Arrival addr msg -> do
                when (not (B.null msg || elem (B.head msg) [0,1,2,4,0x81,0x82,0x8c,0x8d])) $ do
                    mapM_ (\x -> dput XMisc ( (show addr) ++ " --> " ++ x))
                          $ xxd 0 msg
              _ -> return ()
            kont m
       , sendMessage = \addr msg -> do
            when (not (B.null msg || elem (B.head msg) [0,1,2,4,0x81,0x8c,0x8d])) $ do
                mapM_ (\x -> dput XMisc ( (show addr) ++ " <-- " ++ x))
                      $ xxd 0 msg
            sendMessage tr addr msg
       }

newKeysDatabase :: IO (TVar Onion.AnnouncedKeys)
newKeysDatabase =
    atomically $ newTVar $ Onion.AnnouncedKeys PSQ.empty MinMaxPSQ.empty


getOnionAlias :: TransportCrypto -> STM NodeInfo -> Maybe (Onion.OnionDestination r) -> IO (Onion.OnionDestination r)
getOnionAlias crypto dhtself remoteNode = atomically $ do
    ni <- dhtself
    let alias = case remoteNode of
            Just (Onion.OnionDestination (Onion.AnnouncingAlias _ uk) _ _)
              -> ni { nodeId = key2id uk }
            _ -> ni { nodeId = key2id (onionAliasPublic crypto) }
    return $ Onion.OnionDestination Onion.SearchingAlias alias Nothing


newTox :: TVar Onion.AnnouncedKeys   -- ^ Store of announced keys we are a rendezvous for.
       -> [String]                   -- ^ Bind-address to listen on. Must provide at least one.
       -> ( ContactInfo extra -> SockAddr -> Session -> IO () )
       -> (TransportCrypto, ContactInfo extra)
       -> Bool -- Enable TCP messages.
        --  ( Int -> Onion.OnionMessage Encrypted -> IO () ) -- ^ TCP-bound onion responses. XXX ignored
       -> IO (Tox extra)
newTox keydb bindspecs onsess crypto usetcp = do
    addrs <- mapM (`getBindAddress` True) bindspecs
    let tryBind addr next _ = udpTransport' addr `catchIOError` (next . Just)
        failedBind mbe = do
            forM_ mbe $ \e -> do
                dput XDHT $ "tox udp bind error: " ++ show addrs ++ " " ++ show e
                throwIO e
            throwIO $ userError "Tox UDP listen port?"
    (udp,sock) <- foldr tryBind failedBind addrs Nothing
    addr <- getSocketName sock
    dput XOnion $ "UDP bind address: " ++ show addr
    (relay,sendTCP) <-
        if usetcp then do
            fmap (Just *** Just) $ tcpRelay (fst crypto) addr $ \a x -> do
                let bs = S.runPut $ Onion.putRequest x
                dput XOnion $ "Sending onion(0x" ++ (C8.unpack . Base16.encode) (B.take 1 bs) ++ ") from tcp-client to " ++ show a
                -- mapM_ (dput XOnion) (xxd2 0 bs)
                sendMessage udp (substituteLoopback addr a) bs
        else return (Nothing, Nothing)
    tox <- newToxOverTransport keydb addr onsess crypto udp sendTCP
    return tox { toxAnnounceToLan = announceToLan sock (key2id $ transportPublic $ toxCryptoKeys tox)
               , toxRelayServer   = relay
               }

newToxCrypto :: Maybe SecretKey -> IO (TransportCrypto, ContactInfo extra)
newToxCrypto suppliedDHTKey = do
    roster <- newContactInfo
    crypto0 <- newCrypto
    let -- patch in supplied DHT key
        crypto1 = fromMaybe crypto0 $do
            k <- suppliedDHTKey
            return crypto0
                { transportSecret = k
                , transportPublic = toPublic k
                }
        -- patch in newly allocated roster state.
    forM_ suppliedDHTKey $ \k -> do
        maybe (dput XMisc "failed to encode suppliedDHTKey")
              (dputB XMisc . C8.append "Using suppliedDHTKey: ")
              $ encodeSecret k
    return (crypto1 { userKeys = myKeyPairs roster }, roster )

-- | This version of 'newTox' is useful for automated tests using 'testPairTransport'.
newToxOverTransport :: TVar Onion.AnnouncedKeys
        -> SockAddr
        -> ( ContactInfo extra -> SockAddr -> Session -> IO () )
        -> (TransportCrypto, ContactInfo extra)
        -> Onion.UDPTransport
        -> Maybe ( Int -> Onion.OnionMessage Encrypted -> IO () ) -- ^ TCP-bound onion responses.
        -> IO (Tox extra)
newToxOverTransport keydb addr onNewSession (crypto,roster) udp tcp = do
    drg <- drgNew
    let lookupClose _ = return Nothing

    mkrouting <- DHT.newRouting addr crypto updateIP updateIP
    (orouter,relaynet,onioncryptTCP) <- newOnionRouter crypto (dput XRoutes) (maybe False (const True) tcp)
    (cryptonet,dhtcrypt,onioncryptUDP,dtacrypt,handshakes)
        <- toxTransport crypto orouter lookupClose addr udp relaynet
                (\dst x -> sendMessage (clientNet $ tcpClient $ tcpKademliaClient orouter) dst (True,x))
                (fromMaybe (\_ _ -> return ()) tcp)
    sessions <- initSessions (sendMessage cryptonet)

    let dhtnet0 = layerTransportM (DHT.decrypt crypto Multi.nodeId) (DHT.encrypt crypto Multi.nodeId) dhtcrypt
        tbl4 = DHT.routing4 $ mkrouting (error "missing client")
        tbl6 = DHT.routing6 $ mkrouting (error "missing client")
        updateOnion bkts tr = hookBucketList DHT.toxSpace bkts orouter (trampolinesUDP orouter) tr

    dhtclient <- newClient drg dhtnet0 DHT.classify (myAddr tbl4 tbl6) (DHT.handlers crypto . mkrouting) id
                    (\client net -> onInbound (DHT.updateRouting client (mkrouting client) updateOnion) net)

    hscache <- newHandshakeCache crypto (sendMessage handshakes)
    let sparams = SessionParams
            { spCrypto           = crypto
            , spSessions         = sessions
            , spGetSentHandshake = getSentHandshake hscache
            , spOnNewSession     = onNewSession roster addr
            }

    -- TODO: Refactor so that these threads are forked when 'forkTox' is invoked.
    --       This function should only initialize state.
    orouter' <- forkRouteBuilder orouter
        $ \nid ni -> fmap (\(_,ns,_)->ns)
                     <$> DHT.getNodes dhtclient (DHT.nodesOfInterest $ mkrouting dhtclient) nid (Multi.UDP ==> ni)

    toks <- do
        nil <- nullSessionTokens
        atomically $ newTVar nil { maxInterval = 20 } -- 20 second timeout on announce ping-ids.

    onioncrypt <- mergeTransports $ DMap.fromList
        [ Multi.OnionUDP :=> ByAddress onioncryptUDP
        , Multi.OnionTCP :=> ByAddress onioncryptTCP ]
    oniondrg <- drgNew
    let onionnet = layerTransportM
                        (\msg od -> Onion.decrypt crypto msg $ Multi.untagOnion od)
                        (\msg od -> do
                            (msg', od') <- Onion.encrypt crypto msg od
                            -- TODO: lookupRoute is unnecessarily done twice
                            -- because that was convenient for me.  The other
                            -- call was done when building the transport.
                            -- Consider simplifying this.
                            mtcp <- case od' of
                               Onion.OnionDestination _ ni (Just rid)
                                    -> (>>= Onion.routeRelayPort) <$> lookupRoute orouter' ni rid
                               _    -> return Nothing
                            return (msg', maybe (Multi.OnionUDP ==> od') (const $ Multi.OnionTCP ==> od') mtcp))
                        onioncrypt
    onionclient <- newClient oniondrg onionnet (const Onion.classify)
                    (getOnionAlias crypto $ R.thisNode <$> readTVar (DHT.routing4 $ mkrouting dhtclient))
                    (const $ Onion.handlers onionnet (mkrouting dhtclient) toks keydb)
                    (hookQueries orouter' DHT.transactionKey)
                    (const id)

    return Tox
        { toxDHT            = dhtclient
        , toxOnion          = onionclient
        , toxToRoute        = onInbound (updateContactInfo roster) dtacrypt
        , toxCrypto         = addHandler (dput XMisc) (sessionHandler sessions) cryptonet
        , toxHandshakes     = addHandler (dput XMisc) (handshakeH sparams) handshakes
        , toxHandshakeCache = hscache
        , toxCryptoKeys     = crypto
        , toxRouting        = mkrouting dhtclient
        , toxTokens         = toks
        , toxAnnouncedKeys  = keydb
        , toxOnionRoutes    = orouter' -- TODO: see above
        , toxContactInfo    = roster
        , toxAnnounceToLan  = return ()
        , toxBindAddress    = addr
        , toxRelayServer    = Nothing
        }

onionTimeout :: Tox extra -> Onion.OnionDestination RouteId -> STM (Onion.OnionDestination RouteId, Int)
onionTimeout Tox { toxOnionRoutes = or } od = lookupTimeout or od

routing4nodeInfo :: DHT.Routing -> IO NodeInfo
routing4nodeInfo (DHT.routing4 -> tv) = R.thisNode <$> readTVarIO tv

dnssdAnnounce :: Tox extra -> IO ()
dnssdAnnounce tox = do
  ni   <- routing4nodeInfo (toxRouting tox)
  keys <- fmap (key2id . snd) <$> atomically (userKeys $ toxCryptoKeys tox)
  announceToxService (nodePort ni) (nodeId ni) (listToMaybe keys)

dnssdDiscover :: Tox extra -> NodeInfo -> (Maybe NodeId) -> IO ()
dnssdDiscover tox ni toxid = do
  acts <- atomically $ readTVar $ accounts $ toxContactInfo tox
  now  <- getPOSIXTime
  forM toxid $ \tid ->
    forM acts $ \act ->
      atomically $ setContactAddr now (id2key tid) ni act

  void $ DHT.pingUDP (toxDHT tox) ni

-- | Returns:
--
--   * action to shutdown this node, terminating all threads.
--
--   * action to bootstrap an IPv4 Kademlia table.
--
--   * action to bootstrap an IPv6 Kademlia table.
forkTox :: Tox extra
            -> Bool -- avahi
            -> Bool -- tcp
            -> IO (IO (), [NodeInfo] -> [NodeInfo] -> IO (), [NodeInfo] -> [NodeInfo] -> IO ())
forkTox tox with_avahi with_tcp = do
    quitHs      <- forkListener "toxHandshakes" (toxHandshakes tox)
    quitToRoute <- forkListener "toxToRoute" (toxToRoute tox)
    quitOnion   <- forkListener "toxOnion" (clientNet $ toxOnion tox)
    quitDHT     <- forkListener "toxDHT" (clientNet $ toxDHT tox)
    quitNC      <- forkListener "toxCrypto" (toxCrypto tox)
    quitTCP     <- if with_tcp
                    then forkListener "relay-client" (clientNet $ tcpClient $ tcpKademliaClient $ toxOnionRoutes tox)
                    else return $ return ()
    refresher4 <- forkPollForRefresh (DHT.refresher4 $ toxRouting tox)
    refresher6 <- forkPollForRefresh (DHT.refresher6 $ toxRouting tox)
    quitAvahi <- if with_avahi then do
                    dnssdIn <- forkIO $ queryToxService (dnssdDiscover tox)
                    dnssdOut <- forkIO $ dnssdAnnounce tox
                    labelThread dnssdIn  "tox-avahi-monitor"
                    labelThread dnssdOut "tox-avahi-publish"
                    return $ forM_ [dnssdIn,dnssdOut] killThread
                 else return $ return ()
    keygc <- Onion.forkAnnouncedKeysGC (toxAnnouncedKeys tox)
    return ( do killThread refresher4
                killThread refresher6
                quitAvahi
                killThread keygc
                quitNC
                quitDHT
                quitOnion
                quitTCP
                quitRouteBuilder (toxOnionRoutes tox)
                quitToRoute
                quitHs
                mapM_ quitListening (toxRelayServer tox)
           , bootstrap (DHT.refresher4 $ toxRouting tox)
           , bootstrap (DHT.refresher6 $ toxRouting tox)
           )

-- TODO: Don't export this.  The exported interface is 'toxAnnounceToLan'.
announceToLan :: Socket -> NodeId -> IO ()
announceToLan sock nid = do
    addrs <- broadcastAddrs
    forM_ addrs $ \addr -> do
    (broadcast_info:_) <- getAddrInfo (Just defaultHints { addrFlags = [AI_NUMERICHOST], addrSocketType = Datagram })
                                      (Just addr)
                                      (Just "33445")
    let broadcast = addrAddress broadcast_info
        bs = S.runPut $ DHT.putMessage (DHT.DHTLanDiscovery nid)
    dput XLan $ show broadcast ++ " <-- LanAnnounce " ++ show nid
    saferSendTo sock bs broadcast


toxQSearch :: Tox extra -> Search NodeId (IP, PortNumber) Nonce32 NodeInfo Onion.Rendezvous
toxQSearch tox = Onion.toxidSearch (onionTimeout tox) (toxCryptoKeys tox) (toxOnion tox)