Factor out some new libraries

	word64-map:
		Data.Word64Map
	network-addr:
		Network.Address
	tox-crypto:
		Crypto.Tox
	lifted-concurrent:
		Control.Concurrent.Lifted.Instrument
		Control.Concurrent.Async.Lifted.Instrument
	psq-wrap:
		Data.Wrapper.PSQInt
		Data.Wrapper.PSQ
	minmax-psq:
		Data.MinMaxPSQ
        tasks:
                Control.Concurrent.Tasks
	kad:
		Network.Kademlia
		Network.Kademlia.Bootstrap
		Network.Kademlia.Routing
		Network.Kademlia.CommonAPI
		Network.Kademlia.Persistence
		Network.Kademlia.Search

1 files changed, 313 insertions, 0 deletions

diff --git a/dht/src/Network/Tox/TCP.hs b/dht/src/Network/Tox/TCP.hs
new file mode 100644
index 00000000..13da804f
--- /dev/null
+++ b/dht/src/Network/Tox/TCP.hs
@@ -0,0 +1,313 @@
+{-# LANGUAGE RecursiveDo #-}
+{-# LANGUAGE PartialTypeSignatures #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE FlexibleContexts #-}
+module Network.Tox.TCP
+    ( module Network.Tox.TCP
+    , NodeInfo(..)
+    ) where
+
+import Debug.Trace
+import Control.Arrow
+import Control.Concurrent
+import Control.Concurrent.STM
+import Control.Exception
+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 System.Timeout
+
+import ControlMaybe
+import Crypto.Tox
+import Data.ByteString (hPut,hGet,ByteString,length)
+import Data.TableMethods
+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
+
+
+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++"}"
+
+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 -> dput XTCP $ "TCP nil <-- " ++ show y
+                }
+        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
+        hvar <- newMVar h
+        return SessionProtocol
+            { streamGoodbye = do
+                dput XTCP $ "Closing " ++ show addr
+                return () -- No goodbye packet?  Seems rude.
+            , streamDecode =
+                let go h = decode <$> hGet h 2 >>= \case
+                        Left e    -> do
+                            dput XTCP $ "TCP: (" ++ show addr ++ ") 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
+                                    m24 <- timeout 1000000 (takeMVar nread)
+                                    fmap join $ forM m24 $ \n24 -> do
+                                        let r = decrypt (noncef' n24) x >>= decodePlain
+                                        putMVar nread (incrementNonce24 n24)
+                                        either (dput XTCP . ("TCP decryption: " ++))
+                                               (\x' -> do
+                                                    dput XTCP $ "TCP:" ++ show addr ++ " --> " ++ show x'
+                                                    return ())
+                                               r
+                                        return $ either (const Nothing) Just r
+                 in bracket (takeMVar hvar) (putMVar hvar)
+                     $ \h -> go h `catchIOError` \e -> do
+                                        dput XTCP $ "TCP exception: " ++ show e
+                                        return Nothing
+            , streamEncode = \y -> do
+                dput XTCP $ "TCP(acquire nonce):" ++ show addr ++ " <-- " ++ show y
+                n24 <- takeMVar nsend
+                dput XTCP $ "TCP(got nonce):" ++ show addr ++ " <-- " ++ show y
+                let bs = encode $ encrypt (noncef' n24) $ encodePlain y
+                ($ h) -- bracket (takeMVar hvar) (putMVar hvar)
+                    $ \h -> hPut h (encode (fromIntegral $ Data.ByteString.length bs :: Word16) <> bs)
+                                `catchIOError` \e -> dput XTCP $ "TCP write exception: " ++ show e
+                dput XTCP $ "TCP(incrementing nonce): " ++ show addr ++ " <-- " ++ show y
+                putMVar nsend (incrementNonce24 n24)
+                dput XTCP $ "TCP(finished): " ++ show addr ++ " <-- " ++ show y
+            }
+    , streamAddr = nodeAddr
+    }
+
+toxTCP :: TransportCrypto -> IO ( TCPCache (SessionProtocol RelayPacket RelayPacket)
+                                , TransportA err NodeInfo RelayPacket (Bool,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 tid = TCPClient
+    { tcpCrypto     :: TransportCrypto
+    , tcpClient     :: Client err PacketNumber tid NodeInfo (Bool,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 $ Network.Address.fromSockAddr localhost4 }
+                                     , gateway { udpNodeInfo = (udpNodeInfo gateway)
+                                                    { UDP.nodeIP = fromJust $ Network.Address.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
+                        Nonce8
+                        a -- NodeInfo
+                        (Bool, RelayPacket)
+                        PacketNumber
+                        AnnounceRequest
+                        (Either String AnnounceResponse)
+            meth = MethodSerializer
+                    { methodTimeout = \tid addr -> return (addr,12000000) -- 12 second timeout
+                    , method = OnionPacketID -- meth
+                    , wrapQuery = \n8 src gateway x -> (,) True $
+                        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 (x -> x))
+handleOOB k bs src dst = do
+    dput XMisc $ "TODO: handleOOB " ++ show src
+    return Nothing
+
+handle2route :: OnionMessage Encrypted -> NodeInfo -> NodeInfo -> IO (Maybe (x -> x))
+handle2route o src dst = do
+    dput XMisc $ "TODO: handle2route " ++ show src
+    return Nothing
+
+tcpPing :: Show addr => Client err PacketNumber Nonce8 addr (Bool,RelayPacket) -> addr -> IO (Maybe ())
+tcpPing client dst = do
+    dput XTCP $ "tcpPing " ++ show dst
+    sendQuery client meth () dst
+ where meth = MethodSerializer
+                { wrapQuery      = \n8 src dst () -> (True,RelayPing n8)
+                , unwrapResponse = \_ -> ()
+                , methodTimeout  = \n8 dst -> return (dst,5000000)
+                , method         = PingPacket
+                }
+
+type RelayClient = Client String PacketNumber Nonce8 NodeInfo (Bool,RelayPacket)
+
+-- | Create a new TCP relay client.  Because polymorphic existential record
+-- updates are currently hard with GHC, this function accepts parameters for
+-- generalizing the table-entry type for pending transactions.  Safe trivial
+-- defaults are 'id' and 'tryPutMVar'.  The resulting customized table state
+-- will be returned to the caller along with the new client.
+newClient :: TransportCrypto
+               -> ((Maybe (Bool,RelayPacket) -> IO ()) -> a) -- ^ store mvar for query
+               -> (a -> RelayPacket -> IO void)  -- ^ load mvar for query
+               -> IO ( ( TVar (ChaChaDRG, Data.Word64Map.Word64Map a)
+                       , TCPCache (SessionProtocol RelayPacket RelayPacket) )
+                     , Client String PacketNumber Nonce8 NodeInfo (Bool,RelayPacket))
+newClient crypto store load = do
+    (tcpcache,net) <- toxTCP crypto
+    drg <- drgNew
+    map_var <- atomically $ newTVar (drg, Data.Word64Map.empty)
+    return $ (,) (map_var,tcpcache) Client
+        { clientNet = {- XXX: Client type forces this pointless layering. -} layerTransport ((Right .) . (,) . (,) False) (,) net
+        , clientDispatcher = DispatchMethods
+            { classifyInbound = (. snd) $ \case
+                RelayPing n           -> IsQuery PingPacket 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
+                wut                   -> IsUnknown (show wut)
+            , lookupHandler   = \case
+                PingPacket -> trace ("tcp-received-ping") $ Just MethodHandler
+                    { methodParse     = \case (_,RelayPing n8) -> Right ()
+                                              _                -> trace ("tcp-non-ping") $ Left "TCP: Non-ping?"
+                    , methodSerialize = \n8 src dst () -> trace ("tcp-made-pong-"++show n8) (False, RelayPong n8)
+                    , methodAction    = \src () -> dput XTCP $ "TCP pinged by "++show src
+                    }
+                w -> trace ("tcp-lookupHandler: "++show w) $ Just NoReply
+                            { methodParse = \x -> Left "tcp-lookuphandler?" -- :: x -> Either err a
+                            , noreplyAction = \addr a -> dput XTCP $ "tcp-lookupHandler: "++show w
+                            }
+            , tableMethods = transactionMethods' store (\x -> mapM_ (load x . snd)) (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
+        }