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

diff --git a/dht/src/Network/Tox/Onion/Handlers.hs b/dht/src/Network/Tox/Onion/Handlers.hs
new file mode 100644
index 00000000..f44dd79c
--- /dev/null
+++ b/dht/src/Network/Tox/Onion/Handlers.hs
@@ -0,0 +1,369 @@
+{-# LANGUAGE CPP             #-}
+{-# LANGUAGE LambdaCase      #-}
+{-# LANGUAGE PatternSynonyms #-}
+module Network.Tox.Onion.Handlers where
+
+import Network.Kademlia.Search
+import Network.Tox.DHT.Transport
+import Network.Tox.DHT.Handlers hiding (Message,Client)
+import Network.Tox.Onion.Transport
+import Network.QueryResponse as QR hiding (Client)
+import qualified Network.QueryResponse as QR (Client)
+import Crypto.Tox
+import qualified Data.Wrapper.PSQ             as PSQ
+         ;import Data.Wrapper.PSQ             (PSQ,pattern (:->))
+import Control.Arrow
+
+import Data.Function
+import qualified Data.MinMaxPSQ               as MinMaxPSQ
+         ;import Data.MinMaxPSQ               (MinMaxPSQ')
+import Network.BitTorrent.DHT.Token           as Token
+
+import Control.Exception hiding (Handler)
+import Control.Monad
+#ifdef THREAD_DEBUG
+import Control.Concurrent.Lifted.Instrument
+#else
+import Control.Concurrent
+import GHC.Conc (labelThread)
+#endif
+import Control.Concurrent.STM
+import Data.Time.Clock.POSIX  (POSIXTime, getPOSIXTime)
+import Network.Socket
+#if MIN_VERSION_iproute(1,7,4)
+import Data.IP hiding (fromSockAddr)
+#else
+import Data.IP
+#endif
+import Data.Maybe
+import Data.Functor.Identity
+import DPut
+import DebugTag
+
+type Client r = QR.Client String PacketKind TransactionId (OnionDestination r) Message
+type Message = OnionMessage Identity
+
+classify :: Message -> MessageClass String PacketKind TransactionId (OnionDestination r) Message
+classify msg = go msg
+ where
+    go (OnionAnnounce         announce)    = IsQuery AnnounceType
+                                                $ TransactionId (snd $ runIdentity $ asymmData announce)
+                                                                (asymmNonce announce)
+    go (OnionAnnounceResponse n8 n24 resp) = IsResponse (TransactionId n8 n24)
+    go (OnionToRoute          {})          = IsQuery DataRequestType (TransactionId (Nonce8 0) (Nonce24 zeros24))
+    go (OnionToRouteResponse  {})          = IsResponse              (TransactionId (Nonce8 0) (Nonce24 zeros24))
+
+-- Toxcore generates `ping_id`s by taking a 32 byte sha hash of the current time,
+-- some secret bytes generated when the instance is created, the current time
+-- divided by a 20 second timeout, the public key of the requester and the source
+-- ip/port that the packet was received from. Since the ip/port that the packet
+-- was received from is in the `ping_id`, the announce packets being sent with a
+-- ping id must be sent using the same path as the packet that we received the
+-- `ping_id` from or announcing will fail.
+--
+-- The reason for this 20 second timeout in toxcore is that it gives a reasonable
+-- time (20 to 40 seconds) for a peer to announce himself while taking in count
+-- all the possible delays with some extra seconds.
+announceH :: Routing -> TVar SessionTokens -> TVar AnnouncedKeys -> OnionDestination r -> AnnounceRequest -> IO AnnounceResponse
+announceH routing toks keydb oaddr req = do
+    case () of
+        _ | announcePingId req == zeros32
+          -> go False
+
+        _ -> let Nonce32 bs = announcePingId req
+                 tok        = fromPaddedByteString 32 bs
+             in checkToken toks (onionNodeInfo oaddr) tok >>= go
+        `catch` (\(SomeException e) -> dput XAnnounce ("announceH Exception! "++show e) >> throw e)
+ where
+    go withTok = do
+        let naddr = onionNodeInfo oaddr
+        ns <- getNodesH routing naddr (GetNodes (announceSeeking req))
+        tm <- getPOSIXTime
+
+        let storing = case oaddr of
+                        OnionToOwner _ pth -> guard (nodeId naddr == announceSeeking req) >> Just pth
+                        _                  -> Nothing
+        dput XAnnounce   $ unlines [ "announceH: nodeId          = " ++ show (nodeId naddr)
+                                   , "           announceSeeking = " ++ show (announceSeeking req)
+                                   , "           withTok         = " ++ show withTok
+                                   , "           storing         = " ++ maybe "False" (const "True") storing
+                                   ]
+        record <- atomically $ do
+            forM_ storing $ \retpath -> when withTok $ do
+                let toxpath = AnnouncedRoute naddr{ nodeId = announceKey req } retpath
+                    -- Note: The following distance calculation assumes that
+                    -- our nodeid doesn't change and is the same for both
+                    -- routing4 and routing6.
+                    d = xorNodeId (nodeId (tentativeId routing))
+                                  (announceSeeking req)
+                modifyTVar' keydb (insertKey tm (announceSeeking req) toxpath d)
+            ks <- readTVar keydb
+            return $ snd . snd <$> MinMaxPSQ.lookup' (announceSeeking req) (keyAssoc ks)
+        newtok <- maybe (return $ zeros32)
+                        (const $ Nonce32 . toPaddedByteString 32 <$> grantToken toks naddr)
+                        storing
+        let k = case record of
+                Nothing                    -> NotStored newtok
+                Just _  | isJust storing   -> Acknowledged newtok
+                Just (AnnouncedRoute ni _) -> SendBackKey $ id2key (nodeId ni)
+        let response = AnnounceResponse k ns
+        dput XAnnounce $ unwords ["Announce:", show req, "-reply->", show response]
+        return response
+
+dataToRouteH ::
+          TVar AnnouncedKeys
+          -> Transport err (OnionDestination r) (OnionMessage f)
+          -> addr
+          -> OnionMessage f
+          -> IO ()
+dataToRouteH keydb udp _ (OnionToRoute pub asymm) = do
+    let k = key2id pub
+    dput XOnion $ "dataToRouteH "++ show k
+    mb <- atomically $ do
+        ks <- readTVar keydb
+        forM (MinMaxPSQ.lookup' k (keyAssoc ks)) $ \(p,(cnt,rpath)) -> do
+            writeTVar keydb $ ks { keyAssoc = MinMaxPSQ.insert' k (cnt + 1, rpath) p (keyAssoc ks) }
+            return rpath
+    dput XOnion $ "dataToRouteH "++ show (fmap (const ()) mb)
+    forM_ mb $ \rpath -> do
+        -- forward
+        dput XOnion $ "dataToRouteH sendMessage"
+        sendMessage udp (toOnionDestination rpath) $ OnionToRouteResponse asymm
+        dput XOnion $ "Forwarding data-to-route -->"++show k
+
+type NodeDistance = NodeId
+
+data AnnouncedRoute = AnnouncedRoute NodeInfo (ReturnPath N3)
+
+toOnionDestination :: AnnouncedRoute -> OnionDestination r
+toOnionDestination (AnnouncedRoute ni rpath) = OnionToOwner ni rpath
+
+-- |
+-- The type 'NodeId' was originally made for the DHT key, but here
+-- we reuse it for user keys (public key/real key).
+--
+-- To find someone using their user (public) key, you search for it on
+-- kademlia. At each iteration of the search, you get a response with
+-- closest known nodes(DHT keys) to the key you are searching for.
+--
+-- To do an 'Announce' so your friends can find you, you do a search to
+-- find the closest nodes to your own user(public) key. At those nodes,
+-- you store a route back to yourself (using Announce message) so your
+-- friends can contact you. This means each node needs to store the
+-- saved routes, and that is the purpose of the 'AnnouncedKeys' data
+-- structure.
+--
+data AnnouncedKeys = AnnouncedKeys
+    { keyByAge :: !(PSQ NodeId (POSIXTime{-Time at which they announced to you-}))
+    , keyAssoc :: !(MinMaxPSQ' NodeId NodeDistance (Int{-count of route usage-},AnnouncedRoute))
+        -- ^ PSQ using NodeId(user/public key) as Key
+        --   and using 'NodeDistance' as priority.
+        --   (smaller number is higher priority)
+        --
+        --  Keeping in a MinMaxPSQ will help us later when we want to make the structure
+        --  bounded. (We simply throw away the most NodeDistant keys.
+    }
+
+
+insertKey :: POSIXTime -> NodeId -> AnnouncedRoute -> NodeDistance -> AnnouncedKeys -> AnnouncedKeys
+insertKey tm pub toxpath d keydb = AnnouncedKeys
+    { keyByAge = PSQ.insert pub tm (keyByAge keydb)
+    , keyAssoc = case MinMaxPSQ.lookup' pub (keyAssoc keydb) of
+                    Just (_,(cnt,_)) -> MinMaxPSQ.insert' pub (cnt,toxpath) d (keyAssoc keydb)
+                    Nothing          -> MinMaxPSQ.insert' pub (0  ,toxpath) d (keyAssoc keydb)
+    }
+
+-- | Forks a thread to garbage-collect old key announcements.  Keys may be
+-- discarded after 5 minutes.
+forkAnnouncedKeysGC :: TVar AnnouncedKeys -> IO ThreadId
+forkAnnouncedKeysGC db = forkIO $ do
+    myThreadId >>= flip labelThread "gc:toxids"
+    fix $ \loop -> do
+    cutoff <- getPOSIXTime
+    threadDelay 300000000 -- 300 seconds
+    join $ atomically $ do
+        fix $ \gc -> do
+        keys <- readTVar db
+        case PSQ.minView (keyByAge keys) of
+            Nothing -> return loop
+            Just (pub :-> tm,kba')
+                | tm > cutoff -> return loop
+                | otherwise   -> do writeTVar db keys
+                                        { keyByAge = kba'
+                                        , keyAssoc = MinMaxPSQ.delete pub (keyAssoc keys)
+                                        }
+                                    gc
+
+areq :: Message -> Either String AnnounceRequest
+areq (OnionAnnounce asymm) = Right $ fst $ runIdentity $ asymmData asymm
+areq _                     = Left "Unexpected non-announce OnionMessage"
+
+handlers :: Transport err (OnionDestination r) Message
+            -> Routing
+            -> TVar SessionTokens
+            -> TVar AnnouncedKeys
+            -> PacketKind
+            -> Maybe (MethodHandler String TransactionId (OnionDestination r) Message)
+handlers net routing toks keydb AnnounceType
+    = Just
+    $ MethodHandler areq (\(TransactionId n8 n24) src dst -> OnionAnnounceResponse n8 n24 . Identity)
+    $ announceH routing toks keydb
+handlers net _ _ keydb _ = Just $ NoReply Right $ dataToRouteH keydb net
+
+
+toxidSearch :: (TransactionId -> OnionDestination r -> STM (OnionDestination r, Int))
+               -> TransportCrypto
+               -> Client r
+               -> Search NodeId (IP, PortNumber) Nonce32 NodeInfo Rendezvous
+toxidSearch getTimeout crypto client = Search
+    { searchSpace       = toxSpace
+    , searchNodeAddress = nodeIP &&& nodePort
+    , searchQuery       = Right $ asyncGetRendezvous getTimeout crypto client
+    , searchAlpha = 3
+    , searchK     = 6
+    }
+
+announceSerializer :: (TransactionId -> OnionDestination r -> STM (OnionDestination r, Int))
+                   -> MethodSerializer
+                        TransactionId
+                        (OnionDestination r)
+                        (OnionMessage Identity)
+                        PacketKind
+                        AnnounceRequest
+                        (Maybe AnnounceResponse)
+announceSerializer getTimeout = MethodSerializer
+    { methodTimeout = getTimeout
+    , method = AnnounceType
+    , wrapQuery = \(TransactionId n8 n24) src dst req ->
+        -- :: tid -> addr -> addr -> a -> OnionMessage Identity
+        OnionAnnounce $ Asymm
+            { -- The public key is our real long term public key if we want to
+              -- announce ourselves, a temporary one if we are searching for
+              -- friends.
+              senderKey = onionKey src
+            , asymmNonce = n24
+            , asymmData = Identity (req, n8)
+            }
+    , unwrapResponse = \case -- :: OnionMessage Identity -> b
+        OnionAnnounceResponse _ _ resp -> Just $ runIdentity resp
+        _                              -> Nothing
+    }
+
+unwrapAnnounceResponse :: Maybe NodeId -> NodeInfo -> AnnounceResponse -> ([NodeInfo], [Rendezvous], Maybe Nonce32)
+unwrapAnnounceResponse alias ni (AnnounceResponse is_stored (SendNodes ns))
+    = case is_stored of
+        NotStored n32    -> ( ns , []                                                        , Just n32)
+        SendBackKey k    -> ( ns , [Rendezvous k ni]                                         , Nothing )
+        Acknowledged n32 -> ( ns , maybeToList $ fmap (\k -> Rendezvous (id2key k) ni) alias , Just n32)
+
+-- TODO Announce key to announce peers.
+--
+--   Announce Peers are only put in the 8 closest peers array if they respond
+--   to an announce request. If the peers fail to respond to 3 announce
+--   requests they are deemed timed out and removed.
+--
+--   ...
+--
+--   For this reason, after the peer is announced successfully for 17 seconds,
+--   announce packets are sent aggressively every 3 seconds to each known close
+--   peer (in the list of 8 peers) to search aggressively for peers that know
+--   the peer we are searching for.
+
+-- TODO
+-- If toxcore goes offline (no onion traffic for 20 seconds) toxcore will
+-- aggressively reannounce itself and search for friends as if it was just
+-- started.
+
+
+sendOnion :: (TransactionId -> OnionDestination r -> STM (OnionDestination r, Int))
+            -> Client r
+            -> AnnounceRequest
+            -> OnionDestination r
+            -> (NodeInfo -> AnnounceResponse -> t)
+            -> IO (Maybe t)
+sendOnion getTimeout client req oaddr unwrap =
+    -- Four tries and then we tap out.
+    flip fix 4 $ \loop n -> do
+    mb <- QR.sendQuery client (announceSerializer getTimeout) req oaddr
+    forM_ mb $ \r -> dput XAnnounce $ show (onionNodeInfo oaddr) ++ " sent response: " ++ show r
+    maybe (if n>0 then loop $! n - 1 else return Nothing)
+          (return . Just . unwrap (onionNodeInfo oaddr))
+          $ join mb
+
+asyncOnion :: (TransactionId
+                     -> OnionDestination r -> STM (OnionDestination r, Int))
+                    -> QR.Client
+                         err
+                         PacketKind
+                         TransactionId
+                         (OnionDestination r)
+                         (OnionMessage Identity)
+                    -> AnnounceRequest
+                    -> OnionDestination r
+                    -> (NodeInfo -> AnnounceResponse -> a)
+                    -> (Maybe a -> IO ())
+                    -> IO ()
+asyncOnion getTimeout client req oaddr unwrap go =
+    -- Four tries and then we tap out.
+    flip fix 4 $ \loop n -> do
+    QR.asyncQuery client (announceSerializer getTimeout) req oaddr
+        $ \mb -> do
+            forM_ mb $ \r -> dput XAnnounce $ show (onionNodeInfo oaddr) ++ " sent response: " ++ show r
+            maybe (if n>0 then loop $! n - 1 else go Nothing)
+                  (go . Just . unwrap (onionNodeInfo oaddr))
+                  $ join mb
+
+
+-- | Lookup the secret counterpart for a given alias key.
+getRendezvous :: (TransactionId -> OnionDestination r -> STM (OnionDestination r, Int))
+            -> TransportCrypto
+            -> Client r
+            -> NodeId
+            -> NodeInfo
+            -> IO (Maybe ([NodeInfo],[Rendezvous],Maybe Nonce32))
+getRendezvous getTimeout crypto client nid ni = do
+    asel <- atomically $ selectAlias crypto nid
+    let oaddr = OnionDestination asel ni Nothing
+        rkey  = case asel of
+                    SearchingAlias -> Nothing
+                    _              -> Just $ key2id $ rendezvousPublic crypto
+    sendOnion getTimeout client
+        (AnnounceRequest zeros32 nid $ fromMaybe zeroID rkey)
+        oaddr
+        (unwrapAnnounceResponse rkey)
+
+asyncGetRendezvous
+    :: (TransactionId -> OnionDestination r -> STM (OnionDestination r, Int))
+       -> TransportCrypto
+       -> Client r
+       -> NodeId
+       -> NodeInfo
+       -> (Maybe ([NodeInfo], [Rendezvous], Maybe Nonce32) -> IO ())
+       -> IO ()
+asyncGetRendezvous getTimeout crypto client nid ni go = do
+    asel <- atomically $ selectAlias crypto nid
+    let oaddr = OnionDestination asel ni Nothing
+        rkey  = case asel of
+                    SearchingAlias -> Nothing
+                    _              -> Just $ key2id $ rendezvousPublic crypto
+    asyncOnion getTimeout client
+        (AnnounceRequest zeros32 nid $ fromMaybe zeroID rkey)
+        oaddr
+        (unwrapAnnounceResponse rkey)
+        go
+
+putRendezvous :: (TransactionId -> OnionDestination r -> STM (OnionDestination r, Int))
+               -> TransportCrypto
+               -> Client r
+               -> PublicKey
+               -> Nonce32
+               -> NodeInfo
+               -> IO (Maybe (Rendezvous, AnnounceResponse))
+putRendezvous getTimeout crypto client pubkey nonce32 ni = do
+    let longTermKey   = key2id pubkey
+        rkey          = rendezvousPublic crypto
+        rendezvousKey = key2id rkey
+    asel <- atomically $ selectAlias crypto longTermKey
+    let oaddr = OnionDestination asel ni Nothing
+    sendOnion getTimeout client (AnnounceRequest nonce32 longTermKey rendezvousKey) oaddr
+        $ \ni resp -> (Rendezvous rkey ni, resp)