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, 243 insertions, 0 deletions

diff --git a/dht/src/Network/Tox/Session.hs b/dht/src/Network/Tox/Session.hs
new file mode 100644
index 00000000..189967fa
--- /dev/null
+++ b/dht/src/Network/Tox/Session.hs
@@ -0,0 +1,243 @@
+-- | This module implements the lossless Tox session protocol.
+{-# LANGUAGE TupleSections #-}
+module Network.Tox.Session
+    ( SessionParams(..)
+    , SessionKey
+    , Session(..)
+    , sTheirUserKey
+    , sClose
+    , handshakeH
+    ) where
+
+import Control.Concurrent.STM
+import Control.Monad
+import Control.Exception
+import Data.Dependent.Sum
+import Data.Functor.Identity
+import Data.Word
+import Network.Socket         (SockAddr)
+
+import Crypto.Tox
+import Data.PacketBuffer            (PacketInboundEvent (..))
+import Data.Tox.Msg
+import DPut
+import DebugTag
+import Network.Lossless
+import Network.QueryResponse
+import Network.SessionTransports
+import Network.Tox.Crypto.Transport
+import Network.Tox.DHT.Transport    (Cookie (..), key2id, longTermKey)
+import Network.Tox.Handshake
+
+-- | Alias for 'SecretKey' to document that it is used as the temporary Tox
+-- session key corresponding to the 'PublicKey' we sent in the handshake.
+type SessionKey = SecretKey
+
+-- | These inputs to 'handshakeH' indicate how to respond to handshakes, how to
+-- assign packets to sessions, and what to do with established sessions after
+-- they are made lossless by queuing packets and appending sequence numbers.
+data SessionParams = SessionParams
+    { -- | The database of secret keys necessary to encrypt handshake packets.
+      spCrypto           :: TransportCrypto
+      -- | This is used to create sessions and dispatch packets to them.
+    , spSessions         :: Sessions (CryptoPacket Encrypted)
+      -- | This method returns the session information corresponding to the
+      -- cookie pair for the remote address.  If no handshake was sent, this
+      -- should send one immediately.  It should return 'Nothing' if anything
+      -- goes wrong.
+    , spGetSentHandshake :: SecretKey -> SockAddr
+                                      -> Cookie Identity
+                                      -> Cookie Encrypted
+                                      -> IO (Maybe (SessionKey, HandshakeData))
+      -- | This method is invoked on each new session and is responsible for
+      -- launching any threads necessary to keep the session alive.
+    , spOnNewSession     :: Session -> IO ()
+    }
+
+-- | After a session is established, this information is given to the
+-- 'spOnNewSession' callback.
+data Session = Session
+    { -- | This is the secret user (toxid) key that corresponds to the
+      -- local-end of this session.
+      sOurKey            :: SecretKey
+      -- | The remote address for this session. (Not unique, see 'sSessionID').
+    , sTheirAddr         :: SockAddr
+      -- | The information we sent in the handshake for this session.
+    , sSentHandshake     :: HandshakeData
+      -- | The information we received in a handshake for this session.
+    , sReceivedHandshake :: Handshake Identity
+      -- | This method can be used to trigger packets to be re-sent given a
+      -- list of their sequence numbers.  It should be used when the remote end
+      -- indicates they lost packets.
+    , sResendPackets     :: [Word32] -> IO ()
+      -- | This list of sequence numbers should be periodically polled and if
+      -- it is not empty, we should request they re-send these packets.  For
+      -- convenience, a lower bound for the numbers in the list is also
+      -- returned.  Suggested polling interval: a few seconds.
+    , sMissingInbound    :: IO ([Word32],Word32)
+      -- | A lossless transport for sending and receiving packets in this
+      -- session.  It is up to the caller to spawn the await-loop to handle
+      -- inbound packets.
+    , sTransport         :: Transport String () CryptoMessage
+      -- | A unique small integer that identifies this session for as long as
+      -- it is established.
+    , sSessionID         :: Int
+    }
+
+-- | Helper to obtain the remote ToxID key from the locally-issued cookie
+-- associated with the session.
+sTheirUserKey :: Session -> PublicKey
+sTheirUserKey s = longTermKey $ runIdentity cookie
+ where
+    Cookie _ cookie = handshakeCookie (sReceivedHandshake s)
+
+-- | Helper to close the 'Transport' associated with a session.
+sClose :: Session -> IO ()
+sClose s = closeTransport (sTransport s)
+
+
+-- | Call this whenever a new handshake arrives so that a session is
+-- negotiated.  It always returns Nothing which makes it convenient to use with
+-- 'Network.QueryResponse.addHandler'.
+handshakeH :: SessionParams
+              -> SockAddr
+              -> Handshake Encrypted
+              -> IO (Maybe a)
+handshakeH sp saddr handshake = do
+    decryptHandshake (spCrypto sp) handshake
+        >>= either (\err -> return ())
+                   (uncurry $ plainHandshakeH sp saddr)
+    return Nothing
+
+
+plainHandshakeH :: SessionParams
+                   -> SockAddr
+                   -> SecretKey
+                   -> Handshake Identity
+                   -> IO ()
+plainHandshakeH sp saddr skey handshake = do
+    let hd = runIdentity $ handshakeData handshake
+        prelude = show saddr ++ " --> "
+    dput XNetCrypto $ unlines $ map (prelude ++)
+        [ "handshake: auth=" ++ show (handshakeCookie handshake)
+        , "         : issuing=" ++ show (otherCookie hd)
+        , "         : baseNonce=" ++ show (baseNonce hd)
+        ]
+    sent <- spGetSentHandshake sp skey saddr (handshakeCookie handshake) (otherCookie hd)
+    -- TODO: this is always returning sent = Nothing
+    dput XNetCrypto $ " <-- (cached) handshake baseNonce " ++ show (fmap (baseNonce . snd) sent)
+    forM_ sent $ \(hd_skey,hd_sent) -> do
+    sk <- SessionKeys (spCrypto sp)
+                      hd_skey
+                      (sessionKey hd)
+                      <$> atomically (newTVar $ baseNonce hd)
+                      <*> atomically (newTVar $ baseNonce hd_sent)
+    m <- newSession (spSessions sp) (\() p -> return p) (decryptPacket sk) saddr
+    dput XNetCrypto $ prelude ++ "plainHandshakeH: session " ++ maybe "Nothing" (const "Just") m
+    forM_ m $ \(sid, t) -> do
+        (t2,resend,getMissing)
+            <- lossless (\cp a -> return $ fmap (,a) $ checkLossless $ runIdentity $ pktData cp)
+                        (\seqno p@(Pkt m :=> _) _ -> do
+                            y <- encryptPacket sk $ bookKeeping seqno p
+                            return OutgoingInfo
+                                { oIsLossy         = lossyness m == Lossy
+                                , oEncoded         = y
+                                , oHandleException = Just $ \e -> do
+                                        dput XUnexpected $ unlines
+                                            [ "<-- " ++ show e
+                                            , "<--   while sending " ++ show (seqno,p) ]
+                                        throwIO e
+                                })
+                        ()
+                        t
+        let _ = t :: TransportA String () (CryptoPacket Identity) (CryptoPacket Encrypted)
+            _ = t2 :: Transport String () CryptoMessage
+        sendMessage t2 () $ (Pkt ONLINE ==> ())
+        spOnNewSession sp Session
+            { sOurKey            = skey
+            , sTheirAddr         = saddr
+            , sSentHandshake     = hd_sent
+            , sReceivedHandshake = handshake
+            , sResendPackets     = resend
+            , sMissingInbound    = getMissing
+            , sTransport         = t2
+            , sSessionID         = sid
+            }
+    return ()
+
+
+-- | The per-session nonce and key state maintained by 'decryptPacket' and
+-- 'encryptPacket'.
+data SessionKeys = SessionKeys
+    { skCrypto        :: TransportCrypto -- ^ Cache of shared-secrets.
+    , skMe            :: SessionKey      -- ^ My session key
+    , skThem          :: PublicKey       -- ^ Their session key
+    , skNonceIncoming :: TVar Nonce24    -- ^ +21845 when a threshold is reached.
+    , skNonceOutgoing :: TVar Nonce24    -- ^ +1 on every packet
+    }
+
+-- | Decrypt an inbound session packet and update the nonce for the next one.
+decryptPacket :: SessionKeys -> SockAddr -> CryptoPacket Encrypted -> IO (Maybe (CryptoPacket Identity, ()))
+decryptPacket sk saddr (CryptoPacket n16 ciphered) = do
+    (n24,δ) <- atomically $ do
+        n <- readTVar (skNonceIncoming sk)
+        let δ = n16 - nonce24ToWord16 n
+        return ( n `addtoNonce24` fromIntegral δ, δ )
+    secret <- lookupSharedSecret (skCrypto sk) (skMe sk) (skThem sk) n24
+    case decodePlain =<< decrypt secret ciphered of
+        Left e  -> return Nothing
+        Right x -> do
+            when ( δ  > 43690 )
+                $ atomically $ writeTVar (skNonceIncoming sk) (n24 `addtoNonce24` 21845)
+
+            do let them = key2id $ skThem sk
+                   CryptoData ack seqno _ = x
+                   cm = decodeRawCryptoMsg x
+               dput XNetCrypto $ unwords [take 8 (show them),"-->",show (msgID cm),show (n24,ack,seqno)]
+
+            return $ Just ( CryptoPacket n16 (pure x), () )
+
+-- | Encrypt an outbound session packet and update the nonce for the next one.
+encryptPacket :: SessionKeys -> CryptoData -> IO (CryptoPacket Encrypted)
+encryptPacket sk plain = do
+    n24 <- atomically $ do
+        n24 <- readTVar (skNonceOutgoing sk)
+        modifyTVar' (skNonceOutgoing sk) incrementNonce24
+        return n24
+    secret <- lookupSharedSecret (skCrypto sk) (skMe sk) (skThem sk) n24
+    let ciphered = encrypt secret $ encodePlain $ plain
+
+    do let them = key2id $ skThem sk
+           CryptoData ack seqno cm = plain
+       dput XNetCrypto $ unwords [take 8 (show them),"<--",show (msgID cm),show (n24,ack,seqno)]
+
+    return $ CryptoPacket (nonce24ToWord16 n24) ciphered
+
+
+-- | Add sequence information to an outbound packet.
+--
+-- From spec.md:
+--
+--   Data in the encrypted packets:
+--
+--    [our recvbuffers buffer_start, (highest packet number handled + 1), (big endian)]
+--    [uint32_t packet number if lossless, sendbuffer buffer_end if lossy, (big endian)]
+--    [data]
+bookKeeping :: SequenceInfo -> CryptoMessage -> CryptoData
+bookKeeping (SequenceInfo seqno ack) m = CryptoData
+    { bufferStart = ack   :: Word32
+    , bufferEnd   = seqno :: Word32
+    , bufferData  = m
+    }
+
+-- | Classify an inbound packet as lossy or lossless based on its id byte.
+checkLossless :: CryptoData -> PacketInboundEvent CryptoMessage
+checkLossless cd@CryptoData{ bufferStart = ack
+                           , bufferEnd   = no
+                           , bufferData  = x   } = tag no x' ack
+ where
+    x' = decodeRawCryptoMsg cd
+    tag = case someLossyness (msgID x') of Lossy -> PacketReceivedLossy
+                                           _     -> PacketReceived
+
+