WIP Onion routing.

1 files changed, 72 insertions, 9 deletions

diff --git a/src/Network/Tox/Onion/Handlers.hs b/src/Network/Tox/Onion/Handlers.hs
index 08f5cabd..91dd843e 100644
--- a/src/Network/Tox/Onion/Handlers.hs
+++ b/src/Network/Tox/Onion/Handlers.hs
@@ -1,6 +1,8 @@
-{-# LANGUAGE PatternSynonyms            #-}
+{-# 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
@@ -11,9 +13,11 @@ import qualified Data.Wrapper.PSQ             as PSQ
          ;import Data.Wrapper.PSQ             (PSQ)
 import Crypto.Error.Types                     (CryptoFailable (..),
                                                throwCryptoError)
+import Control.Arrow
 
 import System.IO
 import qualified Data.ByteArray               as BA
+import Data.Function
 import Data.Serialize as S
 import qualified Data.Wrapper.PSQInt as Int
 import Network.Kademlia
@@ -59,23 +63,27 @@ classify msg = go msg
 -- 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.
+-- dhtd: src/Network/Tox/Onion/Handlers.hs:(67,1)-(101,23): Non-exhaustive patterns in function announceH
 announceH :: Routing -> TVar SessionTokens -> TVar AnnouncedKeys -> OnionDestination r -> AnnounceRequest -> IO AnnounceResponse
-announceH routing toks keydb (OnionToOwner naddr retpath) req = do
+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 naddr tok >>= go
+             in checkToken toks (onionNodeInfo oaddr) tok >>= go
         `catch` (\(SomeException e) -> hPutStrLn stderr ("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 = (nodeId naddr == announceSeeking req)
+        let storing = case oaddr of
+                        OnionToOwner _ pth -> guard (nodeId naddr == announceSeeking req) >> Just pth
+                        _                  -> Nothing
         record <- atomically $ do
-            when (withTok && storing) $ 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
@@ -85,12 +93,12 @@ announceH routing toks keydb (OnionToOwner naddr retpath) req = do
                 modifyTVar' keydb (insertKey tm (announceSeeking req) toxpath d)
             ks <- readTVar keydb
             return $ snd . snd <$> MinMaxPSQ.lookup' (announceSeeking req) (keyAssoc ks)
-        newtok <- if storing
-                    then Nonce32 . toPaddedByteString 32 <$> grantToken toks naddr
-                    else return $ zeros32
+        newtok <- maybe (return $ zeros32)
+                        (const $ Nonce32 . toPaddedByteString 32 <$> grantToken toks naddr)
+                        storing
         let k = case record of
                 Nothing                    -> NotStored newtok
-                Just _  | storing          -> Acknowledged newtok
+                Just _  | isJust storing   -> Acknowledged newtok
                 Just (AnnouncedRoute ni _) -> SendBackKey $ id2key (nodeId ni)
         let response = AnnounceResponse k ns
         hPutStrLn stderr $ unwords ["Announce:", show req, "-reply->", show response]
@@ -151,3 +159,58 @@ handlers net routing toks keydb AnnounceType
     $ announceH routing toks keydb
 handlers net _ _ keydb _ = Just $ NoReply Right $ dataToRouteH keydb net
 
+toxidSearch :: (TransactionId -> OnionDestination r -> STM (OnionDestination r, Int))
+               -> Client r
+               -> Search NodeId (IP, PortNumber) (Maybe Nonce32) NodeInfo PublicKey
+toxidSearch getTimeout client = Search
+    { searchSpace       = toxSpace
+    , searchNodeAddress = nodeIP &&& nodePort
+    , searchQuery       = announce getTimeout client
+    }
+
+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 $ Assym
+            { -- 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 = fromJust $ onionKey src -- TODO: FIXME: this should be a temporary alias key
+            , assymNonce = n24
+            , assymData = Identity (req, n8)
+            }
+    , unwrapResponse = \case -- :: OnionMessage Identity -> b
+        OnionAnnounceResponse _ _ resp -> Just $ runIdentity resp
+        _                              -> Nothing
+    }
+
+unwrapAnnounceResponse :: AnnounceResponse -> ([NodeInfo], [PublicKey], Maybe Nonce32)
+unwrapAnnounceResponse (AnnounceResponse is_stored (SendNodes ns))
+    = case is_stored of
+        NotStored n32    -> (ns, [],  Just n32)
+        SendBackKey k    -> (ns, [k], Nothing)
+        Acknowledged n32 -> (ns, [],  Just n32)
+
+announce :: (TransactionId -> OnionDestination r -> STM (OnionDestination r, Int))
+            -> Client r
+            -> NodeId
+            -> NodeInfo
+            -> IO (Maybe ([NodeInfo],[PublicKey],Maybe Nonce32))
+announce getTimeout client nid ni =
+    -- Four tries and then we tap out.
+    flip fix 4 $ \loop n -> do
+    let oaddr = OnionDestination ni Nothing
+    mb <- QR.sendQuery client (announceSerializer getTimeout) (AnnounceRequest zeros32 nid zeroID) oaddr
+    maybe (if n>0 then loop $! n - 1 else return Nothing)
+          (return . Just . unwrapAnnounceResponse)
+          $ join mb