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

{-# LANGUAGE RecursiveDo #-}
{-# LANGUAGE PartialTypeSignatures #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE FlexibleContexts #-}
module Network.Tox.TCP where

import Control.Arrow
import Control.Concurrent
import Control.Concurrent.STM
import Control.Monad
import Crypto.Random
import Data.Aeson (ToJSON(..),FromJSON(..))
import qualified Data.Aeson as JSON
import Data.Functor.Contravariant
import Data.Functor.Identity
import Data.Hashable
import qualified Data.HashMap.Strict as HashMap
import Data.IP
import Data.Maybe
import Data.Monoid
import Data.Serialize
import Data.Word
import qualified Data.Vector as Vector
import Network.Socket (SockAddr(..))
import qualified Text.ParserCombinators.ReadP as RP
import System.IO.Error

import ControlMaybe
import Crypto.Tox
import Data.ByteString (hPut,hGet,ByteString,length)
import Data.Tox.Relay
import qualified Data.Word64Map
import DebugTag
import DPut
import Network.Address (setPort,PortNumber,localhost4,fromSockAddr)
import Network.Kademlia.Routing
import Network.Kademlia.Search hiding (sendQuery)
import Network.QueryResponse
import Network.QueryResponse.TCP
import Network.Tox.DHT.Handlers (toxSpace)
import Network.Tox.Onion.Transport hiding (encrypt,decrypt)
import Network.Tox.Onion.Handlers (unwrapAnnounceResponse)
import qualified Network.Tox.NodeId as UDP


withSize :: Sized x => (Size x -> m (p x)) -> m (p x)
withSize f = case size of len -> f len

data NodeInfo = NodeInfo
    { udpNodeInfo :: UDP.NodeInfo
    , tcpPort     :: PortNumber
    }
 deriving (Eq,Ord)

type NodeId = UDP.NodeId

-- example:
-- KEyW2Bm.S-DpIGp72380BAfgintUWX1KX.6ZU.4m5Ex@80.99.99.99:33400{tcp:443}
instance Show NodeInfo where
    show (NodeInfo udp port) = show udp ++ "{tcp:"++show port++"}"

instance Read NodeInfo where
    readsPrec _ = RP.readP_to_S $ do
        udp <- RP.readS_to_P reads
        port <- RP.between (RP.char '{') (RP.char '}') $ do
                    mapM_ RP.char ("tcp:" :: String)
                    w16 <- RP.readS_to_P reads
                    return $ fromIntegral (w16 :: Word16)
        return $ NodeInfo udp port

instance ToJSON NodeInfo where
    toJSON (NodeInfo udp port) = case (toJSON udp) of
        JSON.Object tbl -> JSON.Object $ HashMap.insert "tcp_ports"
                                                        (JSON.Array $ Vector.fromList
                                                            [JSON.Number (fromIntegral port)])
                                                        tbl
        x               -> x -- Shouldn't happen.

instance FromJSON NodeInfo where
    parseJSON json = do
        udp <- parseJSON json
        port <- case json of
            JSON.Object v -> do
                portnum:_ <- v JSON..: "tcp_ports"
                return  (fromIntegral (portnum :: Word16))
            _ -> fail "TCP.NodeInfo: Expected JSON object."
        return $ NodeInfo udp port

instance Hashable NodeInfo where
    hashWithSalt s n = hashWithSalt s (udpNodeInfo n)

nodeId :: NodeInfo -> NodeId
nodeId ni = UDP.nodeId $ udpNodeInfo ni

nodeAddr :: NodeInfo -> SockAddr
nodeAddr ni = setPort (tcpPort ni) $ UDP.nodeAddr $ udpNodeInfo ni

nodeIP :: NodeInfo -> IP
nodeIP ni = UDP.nodeIP $ udpNodeInfo ni

tcpStream :: (Show y, Show x, Serialize y, Sized y, Serialize x, Sized x) =>
                   TransportCrypto -> StreamHandshake NodeInfo x y
tcpStream crypto = StreamHandshake
    { streamHello = \addr h -> do
        (skey, hello) <- atomically $ do
            n24 <- transportNewNonce crypto
            skey <- transportNewKey crypto
            base24 <- transportNewNonce crypto
            return $ (,) skey $ Hello $ Asymm
                { senderKey  = transportPublic crypto
                , asymmNonce = n24
                , asymmData  = pure HelloData
                                { sessionPublicKey = toPublic $ skey
                                , sessionBaseNonce = base24
                                }
                }
        noncef <- lookupNonceFunction crypto (transportSecret crypto) (UDP.id2key $ nodeId addr)
        dput XTCP $ "TCP:" ++ show addr ++ " <-- " ++ show hello
        hPut h $ encode $ encryptPayload (noncef $ helloNonce hello) hello
        welcomeE <- withSize $ fmap decode . hGet h . constSize
        let mwelcome = welcomeE >>= \w -> decryptPayload (noncef $ welcomeNonce w) w
            nil = SessionProtocol
                { streamGoodbye = return ()
                , streamDecode = return Nothing
                , streamEncode = \y -> return ()
                }
        either (\_ -> return nil) id $ mwelcome <&> \welcome -> do
        dput XTCP $ "TCP:" ++ show addr ++ " --> " ++ show welcome
        noncef' <- lookupNonceFunction crypto skey (sessionPublicKey $ runIdentity $ welcomeData welcome)
        nsend <- newMVar (sessionBaseNonce $ runIdentity $ helloData hello)
        nread <- newMVar (sessionBaseNonce $ runIdentity $ welcomeData welcome)
        let them = sessionPublicKey $ runIdentity $ welcomeData welcome
        return SessionProtocol
            { streamGoodbye = do
                dput XTCP $ "Closing " ++ show addr
                return () -- No goodbye packet?  Seems rude.
            , streamDecode =
                let go = decode <$> hGet h 2 >>= \case
                        Left e    -> do
                            dput XTCP $ "TCP: Failed to get length: " ++ e
                            return Nothing
                        Right len -> do
                            decode <$> hGet h (fromIntegral (len :: Word16)) >>= \case
                                Left e  -> do
                                    dput XTCP $ "TCP: Failed to decode packet."
                                    return Nothing
                                Right x -> do
                                    n24 <- takeMVar nread
                                    let r = decrypt (noncef' n24) x >>= decodePlain
                                    putMVar nread (incrementNonce24 n24)
                                    either (dput XTCP)
                                           (\x' -> do
                                                dput XTCP $ "TCP:" ++ show addr ++ " --> " ++ show x'
                                                return ())
                                           r
                                    return $ either (const Nothing) Just r
                 in go `catchIOError` \e -> do
                            dput XTCP $ "TCP exception: " ++ show e
                            return Nothing
            , streamEncode = \y -> do
                n24 <- takeMVar nsend
                dput XTCP $ "TCP:" ++ show addr ++ " <-- " ++ show y
                let bs = encode $ encrypt (noncef' n24) $ encodePlain y
                hPut h $ encode (fromIntegral $ Data.ByteString.length bs :: Word16)
                            <> bs
                putMVar nsend (incrementNonce24 n24)
            }
    , streamAddr = nodeAddr
    }

toxTCP :: TransportCrypto -> IO (Transport err NodeInfo RelayPacket)
toxTCP crypto = tcpTransport 30 (tcpStream crypto)

tcpSpace :: KademliaSpace NodeId NodeInfo
tcpSpace = contramap udpNodeInfo toxSpace

{-
nodeSearch :: TCPClient err () Nonce8 -> Search NodeId (IP, PortNumber) () NodeInfo NodeInfo
nodeSearch tcp = Search
    { searchSpace       = tcpSpace
    , searchNodeAddress = nodeIP &&& tcpPort
    , searchQuery       = getNodes tcp
    }
-}

data TCPClient err meth tid = TCPClient
    { tcpCrypto     :: TransportCrypto
    , tcpClient     :: Client err () tid NodeInfo RelayPacket
    , tcpGetGateway :: UDP.NodeInfo -> STM (Maybe NodeInfo)
    }

{-
getTCPNodes :: TCPClient err () Nonce8 -> NodeId -> NodeInfo -> IO (Maybe ([NodeInfo],[NodeInfo],Maybe ()))
getTCPNodes tcp seeking dst = do
    r <- getUDPNodes' tcp seeking (udpNodeInfo dst)
    let tcps (ns,_,mb) = (ns',ns',mb)
         where ns' = do
                    n <- ns
                    [ NodeInfo n (fromIntegral 443) , NodeInfo n (fromIntegral 80) , NodeInfo n (UDP.nodePort n) ]
    fmap join $ forM r $ \(ns,gw) -> do
        let ts = tcps ns
        {-
        if nodeId gw == nodeId dst
            then return $ Just ts
            else do
                forkIO $ void $ tcpPing (tcpClient tcp) dst
                return $ Just ts
        -}
        forM_ ((\(xs,_,_) -> xs) ts) (forkIO . void . tcpPing (tcpClient tcp))
        return $ Just ts
-}

getUDPNodes :: TCPClient err () Nonce8 -> NodeId -> UDP.NodeInfo -> IO (Maybe ([UDP.NodeInfo], [UDP.NodeInfo], Maybe ()))
getUDPNodes tcp seeking dst = fmap fst <$> getUDPNodes' tcp seeking dst

getUDPNodes' :: TCPClient err () Nonce8 -> NodeId -> UDP.NodeInfo -> IO (Maybe (([UDP.NodeInfo], [UDP.NodeInfo], Maybe ()), NodeInfo))
getUDPNodes' tcp seeking dst0 = do
    mgateway <- atomically $ tcpGetGateway tcp dst0
    fmap join $ forM mgateway $ \gateway -> do
        (b,c,n24) <- atomically $ do
            b <- transportNewKey (tcpCrypto tcp)
            c <- transportNewKey (tcpCrypto tcp)
            n24 <- transportNewNonce (tcpCrypto tcp)
            return (b,c,n24)
        let (dst,gateway') = if UDP.nodeId dst0 == nodeId gateway
                                then ( dst0 { UDP.nodeIP = fromJust $ fromSockAddr localhost4 }
                                     , gateway { udpNodeInfo = (udpNodeInfo gateway)
                                                    { UDP.nodeIP = fromJust $ fromSockAddr localhost4 }})
                                else (dst0,gateway)
        wrap2 <- lookupNonceFunction (tcpCrypto tcp) b (UDP.id2key $ UDP.nodeId dst)
        wrap1 <- lookupNonceFunction (tcpCrypto tcp) c (UDP.id2key $ nodeId gateway)
        wrap0 <- lookupNonceFunction (tcpCrypto tcp) (transportSecret $ tcpCrypto tcp) (UDP.id2key $ UDP.nodeId dst)
        let meth = MethodSerializer -- MethodSerializer Nonce8 NodeInfo RelayPacket meth AnnounceRequest (Either String AnnounceResponse)
                    { methodTimeout = \tid addr -> return (addr,8000000) -- 8 second timeout
                    , method = () -- meth
                    , wrapQuery = \n8 src gateway x ->
                        OnionPacket n24 $ Addressed (UDP.nodeAddr dst)
                            $ wrapOnionPure b (wrap2 n24) (nodeAddr gateway')
                                $ wrapOnionPure c (wrap1 n24) (UDP.nodeAddr dst)
                                    $ NotForwarded $ encryptPayload (wrap0 n24)
                                       $ OnionAnnounce Asymm
                                            { senderKey  = transportPublic (tcpCrypto tcp)
                                            , asymmNonce = n24
                                            , asymmData  = pure (x,n8)
                                            }
                    , unwrapResponse = \case
                        OnionPacketResponse (OnionAnnounceResponse _ n24' r)
                            -> decrypt (wrap0 n24') r >>= decodePlain
                        x   -> Left $ "getUDPNodes: unwrapResponse fail " ++ show x
                    }
        r <- sendQuery (tcpClient tcp) meth (AnnounceRequest zeros32 seeking UDP.zeroID) gateway
        forM r $ \response -> do
            let (ns,_,mb) = either (const ([],[],Nothing)) (unwrapAnnounceResponse Nothing dst) $ response
            return ( (ns,ns, const () <$> mb), gateway )


handleOOB :: PublicKey -> ByteString -> NodeInfo -> NodeInfo -> IO (Maybe (RelayPacket -> RelayPacket))
handleOOB k bs src dst = do
    dput XMisc $ "TODO: handleOOB " ++ show src
    return Nothing

handle2route :: OnionMessage Encrypted -> NodeInfo -> NodeInfo -> IO (Maybe (RelayPacket -> RelayPacket))
handle2route o src dst = do
    dput XMisc $ "TODO: handle2route " ++ show src
    return Nothing

tcpPing :: Client err () Nonce8 addr RelayPacket -> addr -> IO (Maybe ())
tcpPing client dst = sendQuery client meth () dst
 where meth = MethodSerializer
                { wrapQuery      = \n8 src dst () -> RelayPing n8
                , unwrapResponse = \_ -> ()
                , methodTimeout  = \n8 dst -> return (dst,5000000)
                , method         = ()
                }

type RelayClient = Client String () Nonce8 NodeInfo RelayPacket

newClient :: TransportCrypto -> IO RelayClient
newClient crypto = do
    net <- toxTCP crypto
    drg <- drgNew
    map_var <- atomically $ newTVar (drg, Data.Word64Map.empty)
    return Client
        { clientNet = net
        , clientDispatcher = DispatchMethods
            { classifyInbound = \case
                RelayPing n           -> IsQuery () n
                RelayPong n           -> IsResponse n
                OnionPacketResponse (OnionAnnounceResponse n8 n24 ciphered) -> IsResponse n8
                OnionPacketResponse o@(OnionToRouteResponse _) -> IsUnsolicited $ handle2route o
                OOBRecv k bs          -> IsUnsolicited $ handleOOB k bs
            , lookupHandler   = \() -> Just MethodHandler
                    { methodParse     = \(RelayPing n8) -> Right ()
                    , methodSerialize = \n8 src dst () -> RelayPong n8
                    , methodAction    = \src () -> return ()
                    }
            , tableMethods = transactionMethods (contramap (\(Nonce8 w64) -> w64) w64MapMethods)
                                $ first (either error Nonce8 . decode) . randomBytesGenerate 8
            }
        , clientErrorReporter = logErrors
        , clientPending = map_var
        , clientAddress = \_ -> return $ NodeInfo
            { udpNodeInfo = either error id $ UDP.nodeInfo (UDP.key2id $ transportPublic crypto) (SockAddrInet 0 0)
            , tcpPort = 0
            }
        , clientResponseId = return
        , clientEnterQuery = \_ -> return ()
        , clientLeaveQuery = \_ _ -> return ()
        }