3 files changed, 86 insertions, 24 deletions

diff --git a/Tox.hs b/Tox.hs
index d8bf11bc..de702f1f 100644
--- a/Tox.hs
+++ b/Tox.hs
@@ -459,6 +459,17 @@ decryptAssymetric sk typ assym
             . second (either (const (Tox.Nonce8 0)) id . S.decode)
             $ B.splitAt (B.length bs - 8) bs
 
+-- TODO: We should not be having to re-serialize this data... :/
+--       There should be a way to pass the Tox.Assymetric value up the layers.
+passThroughAssymetric :: Tox.PacketKind -> Tox.PubKey -> Tox.Assymetric -> Either String Msg
+passThroughAssymetric typ k assym
+    = Right $ Msg
+        { msgNonce = Tox.assymetricNonce . Tox.sent $ assym -- Not used.
+        , msgType = typ
+        , msgData = S.encode (k,assym)
+        , msgSendBack = Nonce8 0 -- Not used.
+        }
+
 {-
 decryptUnclm :: SecretKey -> Tox.PacketKind -> NodeId -> Tox.Nonce8 -> Tox.UnclaimedAssymetric -> Either String Msg
 decryptUnclm sk typ sender n8 unclm
@@ -559,8 +570,9 @@ msgLayer sk pk = layerTransport parse serialize
     parse :: (Tox.PacketKind,InterediateRep) -> ToxPath -> Either String (Msg,ToxPath)
     parse (typ,Assym  x)  addr = fmap (,addr) $ decryptAssymetric sk typ x
     parse (typ,Assym' x)  addr = fmap (,addr) $ decryptAssymetric sk typ x
+    parse (typ,ToRoute k x)  addr = fmap (,addr) $ passThroughAssymetric typ k x
     parse (typ,Unclm n x) addr = Right ( Msg typ (Tox.assymetricNonce x) (S.encode (Tox.assymetricData x)) n
-                                                   , addr)
+                                       , addr)
     serialize :: Msg -> ToxPath -> ((Tox.PacketKind,InterediateRep),ToxPath)
     serialize x addr@(ToxPath ni _) = case Tox.pktClass (msgType x) of
         Tox.AssymetricClass      {} -> ((msgType x, Assym  $ encryptAssymetric sk pk (nodeId ni) x), addr)
@@ -569,7 +581,9 @@ msgLayer sk pk = layerTransport parse serialize
 
 data InterediateRep = Assym Tox.Assymetric
                     | Assym' Tox.Assymetric
+                    | ToRoute Tox.PubKey Tox.Assymetric
                     | Unclm Tox.Nonce8 Tox.UnclaimedAssymetric
+                    | RouteResponse Tox.Packet
 
 asymLayer :: Transport String SockAddr Tox.Packet -> Transport String ToxPath (Tox.PacketKind,InterediateRep)
 asymLayer = layerTransport parse (\p@(typ,_) -> trace ("SERIALIZE "++show typ) $ serialize p)
@@ -577,10 +591,10 @@ asymLayer = layerTransport parse (\p@(typ,_) -> trace ("SERIALIZE "++show typ) $
     parse :: Tox.Packet -> SockAddr -> Either String ((Tox.PacketKind,InterediateRep),ToxPath)
     parse x addr = case Tox.pktClass (Tox.pktKind x) of
         Tox.AssymetricClass top fromp      -> go Tox.senderKey  fromp Assym
-        Tox.AliasedClass    top fromp      -> let (Tox.Aliased a,rpath) = fromp x
-                                              in fmap (\ni -> ( (Tox.pktKind x, Assym' a)
-                                                              , ToxPath ni rpath ))
-                                                      $ nodeInfo (Tox.senderKey a) addr
+        Tox.AliasedClass    top fromp      -> goalias $ fromp x
+        Tox.ToRouteClass    top fromp      -> do let (key,y) = fromp x
+                                                 ((typ,Assym' a),addr') <- goalias y
+                                                 return ((typ,ToRoute key a),addr')
         Tox.NoncedUnclaimedClass top fromp -> go (const zeroID) fromp (uncurry Unclm)
         -- OnionClass
       where go mkaddr fromp c = let y = fromp x
@@ -588,14 +602,19 @@ asymLayer = layerTransport parse (\p@(typ,_) -> trace ("SERIALIZE "++show typ) $
                                           . (\ni -> ToxPath ni Tox.emptyReturnPath)
                                         )
                                         $ nodeInfo (mkaddr y) addr
+            goalias (Tox.Aliased a,rpath) = fmap (\ni -> ( (Tox.pktKind x, Assym' a)
+                                                         , ToxPath ni rpath ))
+                                                 $ nodeInfo (Tox.senderKey a) addr
 
     serialize :: (Tox.PacketKind,InterediateRep) -> ToxPath -> (Tox.Packet,SockAddr)
     serialize (typ,Assym assym) (ToxPath addr rpath) = (x,nodeAddr addr)
         where x = case Tox.pktClass typ of Tox.AssymetricClass top _ -> top assym
     serialize (typ,Assym' assym) (ToxPath addr rpath) = (x,nodeAddr addr) -- TODO rpath
         where x = case Tox.pktClass typ of Tox.AliasedClass    top _ -> top (Tox.Aliased assym, error "todo: ReturnPath")
+    -- An unclm sent to a ToxPath is turned into an OnionResponse before being sent out.
     serialize (typ,Unclm nonce unclm) (ToxPath addr rpath) = (Tox.mkOnion rpath x,nodeAddr addr)
         where x = case Tox.pktClass typ of Tox.NoncedUnclaimedClass top _ -> top nonce unclm
+    serialize (_,RouteResponse x) (ToxPath addr rpath) = (Tox.mkOnion rpath x, nodeAddr addr)
     -- OnionClass
 
 toxLayer :: Transport String SockAddr ByteString -> Transport String SockAddr Tox.Packet
@@ -627,10 +646,12 @@ trimPackets addr bs = do
                         GetNodesType         -> Just id
                         AnnounceType         -> Just id
                         AnnounceResponseType -> Just id
+                        DataRequestType      -> Just id
+                        -- DataResponseType     -> Just id
                         OnionResponse3Type   -> Just id
                         _                    -> Nothing
 
-newClient :: SockAddr -> IO (ToxClient, Routing)
+newClient :: SockAddr -> IO (ToxClient, Routing, TVar AnnouncedKeys)
 newClient addr = do
     udp <- udpTransport addr
     secret <- generateSecretKey
@@ -691,7 +712,8 @@ newClient addr = do
               $ addVerbosity
               $ msgLayer secret pubkey
               $ onInbound (updateRouting client routing)
-              $ asymLayer
+              $ asymnet
+        asymnet = asymLayer
               -- $ addHandler (handleMessage aclient)
               $ toxLayer
               $ addVerbosity2
@@ -716,6 +738,7 @@ newClient addr = do
         handlers PingType       = handler PongType pingH
         handlers GetNodesType   = handler SendNodesType $ getNodesH routing
         handlers AnnounceType   = handler' AnnounceResponseType $ announceH routing toks keydb
+        handlers DataRequestType = Just $ NoReply (S.decode . msgData) $ dataToRouteH keydb asymnet
         {-
         handlers var OnionRequest0  = noreply OnionRequest0
                                       $ onionSend0H (symmetricCipher (return symkey)
@@ -764,7 +787,7 @@ newClient addr = do
             , clientResponseId    = genNonce24 var
             }
 
-    return (client, routing)
+    return (client, routing, keydb)
 
 toxKademlia :: ToxClient -> TriadCommittee NodeId SockAddr -> TVar (R.BucketList NodeInfo) -> TVar (Int.PSQ POSIXTime) -> Kademlia NodeId NodeInfo
 toxKademlia client committee var sched
@@ -862,6 +885,8 @@ classify (Msg { msgType     = typ
             OnionRequest1Type  -> IsQuery typ
             OnionRequest2Type  -> IsQuery typ
             AnnounceType       -> IsQuery typ
+            DataRequestType    -> IsQuery typ
+            DataResponseType   -> IsResponse
             _                  -> const $ IsUnknown ("Unknown message type: "++show typ)
 
 {-
@@ -1151,6 +1176,19 @@ getNodesH routing addr (GetNodes nid) = do
 
     k = 4
 
+
+dataToRouteH :: TVar AnnouncedKeys -> Transport err ToxPath (Tox.PacketKind,InterediateRep) -> addr -> (Tox.PubKey,Assymetric) -> IO ()
+dataToRouteH keydb udp _ (k,assym) = do
+    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
+    forM_ mb $ \rpath -> do
+        -- forward
+        sendMessage udp rpath (DataResponseType, RouteResponse $ DataToRouteResponse $ Aliased assym)
+        hPutStrLn stderr $ "Forwarding data-to-route -->"++show k
+
 -- 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
@@ -1187,7 +1225,7 @@ announceH routing toks keydb (ToxPath naddr retpath) req = do
                             (announceSeeking req)
                 modifyTVar' keydb (insertKey tm (announceSeeking req) toxpath d)
             ks <- readTVar keydb
-            return $ snd <$> MinMaxPSQ.lookup' (announceSeeking req) (keyAssoc ks)
+            return $ snd . snd <$> MinMaxPSQ.lookup' (announceSeeking req) (keyAssoc ks)
         newtok <- if storing
                     then Nonce32 . toPaddedByteString 32 <$> grantToken toks naddr
                     else return $ zeros32
@@ -1332,11 +1370,13 @@ type NodeDistance = Tox.PubKey
 
 data AnnouncedKeys = AnnouncedKeys
     { keyByAge :: PSQ NodeId (Down POSIXTime) -- timeout of 300 seconds
-    , keyAssoc :: MinMaxPSQ' Tox.PubKey NodeDistance ToxPath
+    , keyAssoc :: MinMaxPSQ' Tox.PubKey NodeDistance (Int,ToxPath)
     }
 
 insertKey :: POSIXTime -> Tox.PubKey -> ToxPath -> NodeDistance -> AnnouncedKeys -> AnnouncedKeys
 insertKey tm pub toxpath d keydb = AnnouncedKeys
     { keyByAge = PSQ.insert pub (Down tm) (keyByAge keydb)
-    , keyAssoc = MinMaxPSQ.insert' pub toxpath d (keyAssoc 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)
     }
diff --git a/ToxMessage.hs b/ToxMessage.hs
index 56758e48..c77f1ad7 100644
--- a/ToxMessage.hs
+++ b/ToxMessage.hs
@@ -220,14 +220,6 @@ data Packet where
 
     OnionRequest3 :: ByteString -> Symmetric -> Packet -- 0x82
 
-    -- TODO:
-    --   Announce has a return path appended to it.
-    --   We'll need a type-level natural to indicate how may bytes to
-    --   get in the ImplicitAssymetric data.  (Or we could force the size
-    --   of the return path).
-    --
-    --   If the return path is non empty, we should respond with OnionResponse3
-    --   rather than AnnounceResponse directly.
     Announce :: Aliased Assymetric -> ReturnPath 3 -> Packet --0x83
     AnnounceResponse :: Nonce8 -> UnclaimedAssymetric -> Packet -- 0x84
 
@@ -256,8 +248,9 @@ pattern OnionRequest1Type = PacketKind 129 -- 0x81     Onion Request 1
 pattern OnionRequest2Type = PacketKind 130 -- 0x82     Onion Request 2
 pattern AnnounceType  = PacketKind 131 -- 0x83     Announce Request
 pattern AnnounceResponseType = PacketKind 132 -- 0x84     Announce Response
--- 0x85     Onion Data Request (data to route request packet)
--- 0x86     Onion Data Response (data to route response packet)
+
+pattern DataRequestType = PacketKind 133 -- 0x85     Onion Data Request (data to route request packet)
+pattern DataResponseType = PacketKind 134 -- 0x86     Onion Data Response (data to route response packet)
 -- 0x8c     Onion Response 3
 -- 0x8d     Onion Response 2
 pattern OnionResponse3Type = PacketKind 140 -- 0x8c     Onion Response 3
@@ -291,7 +284,10 @@ instance Show PacketKind where
     showsPrec d OnionRequest0Type = mappend "OnionRequest0"
     showsPrec d OnionResponse1Type = mappend "OnionResponse1"
     showsPrec d OnionResponse3Type = mappend "OnionResponse3"
-    showsPrec d AnnounceType = mappend "AnnounceType"
+    showsPrec d AnnounceType = mappend "Announce"
+    showsPrec d AnnounceResponseType = mappend "AnnounceResponse"
+    showsPrec d DataRequestType = mappend "DataRequestType"
+    showsPrec d DataResponseType = mappend "DataResponseType"
     showsPrec d (PacketKind x) = mappend "PacketKind " . showsPrec (d+1) x
 
 pktKind :: Packet -> PacketKind
@@ -356,6 +352,7 @@ pktKind OnionResponse3   {} = PacketKind 0x8c
 data PacketClass =
     AssymetricClass (Assymetric -> Packet) (Packet -> Assymetric)
     | forall n. OnionPacket n => AliasedClass ((Aliased Assymetric,ReturnPath n) -> Packet) (Packet -> (Aliased Assymetric,ReturnPath n))
+    | forall n. OnionPacket n => ToRouteClass ((PubKey,(Aliased Assymetric,ReturnPath n)) -> Packet) (Packet -> (PubKey,(Aliased Assymetric,ReturnPath n)))
     | forall n. OnionPacket n => OnionClass ((Packet,ReturnPath n) -> Packet) (Packet -> (Packet,ReturnPath n))
     | NoncedUnclaimedClass (Nonce8 -> UnclaimedAssymetric -> Packet)
                            (Packet -> (Nonce8, UnclaimedAssymetric))
@@ -383,13 +380,16 @@ pktClass (PacketKind 4) = AssymetricClass SendNodes (\(SendNodes a) -> a)
 
 pktClass (PacketKind 0x18) = AssymetricClass CookieRequest (\(CookieRequest a) -> a)
 pktClass (PacketKind 0x80) = AssymetricClass OnionRequest0 (\(OnionRequest0 a) -> a)
--- pktClass (PacketKind 0x86) = AssymetricClass (DataToRouteResponse . Aliased) (\(DataToRouteResponse (Aliased a)) -> a)
+pktClass (PacketKind 0x86) = AssymetricClass (DataToRouteResponse . Aliased) (\(DataToRouteResponse (Aliased a)) -> a)
 
 pktClass (PacketKind 0x83) = AliasedClass (uncurry Announce) (\(Announce a r)-> (a,r))
 pktClass (PacketKind 0x84) = NoncedUnclaimedClass AnnounceResponse (\(AnnounceResponse n8 uncl)-> (n8,uncl))
 
 pktClass (PacketKind 0x8c) = OnionClass (uncurry OnionResponse3 . swap) (\(OnionResponse3 r a)-> (a,r))
 
+pktClass DataRequestType = ToRouteClass (\(k,(a,r))-> DataToRoute k a r)
+                                        (\(DataToRoute k a r) -> (k,(a,r)))
+
 pktClass _ = Unclassified
 
 
@@ -408,6 +408,13 @@ getPacket = do
             r <- get
             trace ("PARSED "++show typ) $ return ()
             return $ toPacket (a,r)
+        ToRouteClass toPacket _      -> do
+            trace ("R-PARSE "++show typ) $ return ()
+            cnt <- remaining
+            (pub,a) <- isolate (cnt - 59*3) get
+            r <- get
+            trace ("R-PARSED "++show typ) $ return ()
+            return $ toPacket (pub,(a,r))
         OnionClass      toPacket _      -> do
             trace ("ONION-PARSE "++show typ) $ return ()
             p <- get
@@ -421,6 +428,7 @@ putPacket p = do
     case pktClass (pktKind p) of
         AssymetricClass _ fromPacket      -> put $ fromPacket p
         AliasedClass    _ fromPacket      -> put $ fromPacket p
+        ToRouteClass    _ fromPacket      -> put $ fromPacket p
         OnionClass      _ fromPacket      -> put $ swap $ fromPacket p
         NoncedUnclaimedClass _ fromPacket -> put $ fromPacket p -- putting a pair.
         Unclassified -> fail $ "todo: serialize packet "++show (pktKind p)
diff --git a/examples/dhtd.hs b/examples/dhtd.hs
index 8e8d47a2..3f6dcaf4 100644
--- a/examples/dhtd.hs
+++ b/examples/dhtd.hs
@@ -8,6 +8,7 @@
 {-# LANGUAGE NondecreasingIndentation  #-}
 {-# LANGUAGE OverloadedStrings         #-}
 {-# LANGUAGE PartialTypeSignatures     #-}
+{-# LANGUAGE PatternSynonyms           #-}
 {-# LANGUAGE RankNTypes                #-}
 {-# LANGUAGE RecordWildCards           #-}
 {-# LANGUAGE ScopedTypeVariables       #-}
@@ -59,6 +60,10 @@ import System.IO.Error
 import qualified Data.Serialize as S
 import Network.BitTorrent.DHT.ContactInfo as Peers
 import qualified Data.MinMaxPSQ as MM
+import Data.Wrapper.PSQ as PSQ (pattern (:->))
+import qualified Data.Wrapper.PSQ as PSQ
+import Data.Ord
+import Data.Time.Clock.POSIX
 
 showReport :: [(String,String)] -> String
 showReport kvs = showColumns $ map (\(x,y)->[x,y]) kvs
@@ -260,6 +265,7 @@ data Session = Session
     , dhts              :: Map.Map String DHT
     , externalAddresses :: IO [SockAddr]
     , swarms            :: Mainline.SwarmsDatabase
+    , toxkeys           :: TVar Tox.AnnouncedKeys
     , signalQuit        :: MVar ()
     }
 
@@ -436,6 +442,13 @@ clientSession s@Session{..} sock cnum h = do
                             ps <- atomically $ Peers.lookup ih <$> readTVar (Mainline.contactInfo swarms)
                             hPutClient h $ showReport $ map (((,) "") . show . pPrint) ps
                         Left er -> hPutClient h er
+        ("keys", s) -> cmd0 $ do
+                        keydb <- atomically $ readTVar toxkeys
+                        now <- getPOSIXTime
+                        let entries = map mkentry $ PSQ.toList (Tox.keyByAge keydb)
+                            mkentry (k :-> Down tm) = [ show cnt, show k, show (now - tm) ]
+                                where Just (_,(cnt,_)) = MM.lookup' k (Tox.keyAssoc keydb)
+                        hPutClient h $ showColumns entries
 
         (n, _) | n `elem` Map.keys dhts -> switchNetwork n
 
@@ -473,7 +486,7 @@ main = do
 
     let toxport = succ $ fromMaybe 33445 (fromIntegral <$> sockAddrPort addr)
     addrTox <- getBindAddress (show toxport) True
-    (tox,toxR) <- Tox.newClient addrTox
+    (tox,toxR,toxkeys) <- Tox.newClient addrTox
 
     quitTox <- forkListener (clientNet tox)
 
@@ -529,6 +542,7 @@ main = do
                 , dhts              = dhts  -- all DHTs
                 , signalQuit        = signalQuit
                 , swarms            = swarms
+                , toxkeys           = toxkeys
                 , externalAddresses = readExternals
                                         [ Mainline.routing4 btR
                                         , Mainline.routing6 btR