Forward DHTRequest messages.

1 files changed, 84 insertions, 107 deletions

diff --git a/ToxTransport.hs b/ToxTransport.hs
index 855b0c7e..694d9d79 100644
--- a/ToxTransport.hs
+++ b/ToxTransport.hs
@@ -8,13 +8,43 @@
 {-# LANGUAGE TypeOperators              #-}
 module ToxTransport
     ( toxTransport
-    , TransportCrypto
+
+    , TransportCrypto(..)
+    , SymmetricKey(..)
+    , Encrypted8(..)
+
     , UDPTransport
-    , DirectMessage
-    , Encrypted8
-    , OnionToOwner
-    , OnionMessage
-    , NetCrypto
+
+    -- DHTTransport
+    , DHTMessage(..)
+    , Ping
+    , Pong
+    , GetNodes
+    , SendNodes
+    , CookieRequest
+    , Cookie
+    , DHTRequest
+
+    -- OnionTransport
+    , OnionToOwner(..)
+    , OnionMessage(..)
+    , DataToRoute(..)
+    , AnnounceResponse(..)
+    , AnnounceRequest(..)
+    , Forwarding(..)
+    , ReturnPath(..)
+    , OnionRequest(..)
+    , OnionResponse(..)
+    , Addressed(..)
+
+    -- CryptoTransport
+    , NetCrypto(..)
+    , CryptoData(..)
+    , CryptoMessage(..)
+    , CryptoPacket(..)
+    , HandshakeData(..)
+    , Handshake(..)
+
     ) where
 
 import Network.QueryResponse
@@ -25,6 +55,7 @@ import ToxPacket
 import Control.Applicative
 import Control.Arrow
 import Control.Concurrent.STM
+import Control.Monad
 import Crypto.Hash
 import Crypto.Hash.Algorithms
 import qualified Data.ByteString as B
@@ -44,59 +75,37 @@ data TransportCrypto = TransportCrypto
     , transportSymmetric :: STM SymmetricKey
     }
 
-transportDecrypt :: TransportCrypto -> Assym (Encrypted a) -> Either String a
-transportDecrypt = _todo
-
--- layer :: TransportCrypto
-          -- -> Transport String SockAddr    ByteString
-          -- -> Transport String Tox.Address ByteString
--- layer crypto = layerTransport (toxParse crypto) (toxEncode crypto)
-
-toxEncode :: TransportCrypto -> ByteString -> Tox.Address -> (ByteString, SockAddr)
-toxEncode = _todo
-
--- toxParse :: TransportCrypto -> ByteString -> SockAddr -> Either String (ByteString, Tox.Address)
--- toxParse crypto bs saddr = case B.head bs of _todo
-
-data Message = Todo | DHTReq DHTRequest | AnnounceReq AnnounceRequest
-
--- awaitMessage :: forall a. (Maybe (Either err (x, addr)) -> IO a) -> IO a
-
 type UDPTransport = Transport String SockAddr ByteString
+type DHTTransport = Transport String NodeInfo (DHTMessage Encrypted8)
 
-{-
-toxTransport :: TransportCrypto -> Transport String SockAddr ByteString -> Transport String Tox.Address Message
-toxTransport crypto (Transport await send close) = Transport await' send' close
- where
-    await' :: HandleHi a -> IO a
-    await' forMe = fix $ await . handleOnion crypto forMe
-
-    send' = _todo
--}
 toxTransport ::
       TransportCrypto
+          -> (PublicKey -> IO (Maybe NodeInfo))
           -> UDPTransport
-          -> IO ( Transport String NodeInfo (DirectMessage Encrypted8)
+          -> IO ( Transport String NodeInfo (DHTMessage Encrypted8)
                 , Transport String OnionToOwner (OnionMessage Encrypted)
                 , Transport String SockAddr NetCrypto )
-toxTransport crypto udp = do
-    (dht,udp1) <- partitionTransport parseDHTAddr encodeDHTAddr id $ handleOnion crypto udp
+toxTransport crypto closeLookup udp = do
+    (dht,udp1) <- partitionTransport parseDHTAddr encodeDHTAddr id $ forwardOnions crypto udp
     (onion,udp2) <- partitionTransport parseOnionAddr encodeOnionAddr id udp1
     let netcrypto = layerTransport parseNetCrypto encodeNetCrypto udp2
-    return (dht,onion,netcrypto)
+    return ( forwardDHTRequests crypto closeLookup dht
+           , onion
+           , netcrypto
+           )
 
 
-type HandleHi a = Maybe (Either String (Message, Tox.Address)) -> IO a
+type HandleHi a = Maybe (Either String (DHTMessage Encrypted8, NodeInfo)) -> IO a
 type HandleLo a = Maybe (Either String (ByteString, SockAddr)) -> IO a
 
-data DirectMessage (f :: * -> *)
-    = DirectPing (Assym (f Ping))
-    | DirectPong (Assym (f Pong))
-    | DirectGetNodes (Assym (f GetNodes))
-    | DirectSendNodes (Assym (f SendNodes))
-    | DirectCookieRequest (Assym (f CookieRequest))
-    | DirectCookie Nonce24 (f Cookie)
-    | DirectDHTRequest PublicKey (Assym (f DHTRequest))
+data DHTMessage (f :: * -> *)
+    = DHTPing (Assym (f Ping))
+    | DHTPong (Assym (f Pong))
+    | DHTGetNodes (Assym (f GetNodes))
+    | DHTSendNodes (Assym (f SendNodes))
+    | DHTCookieRequest (Assym (f CookieRequest))
+    | DHTCookie Nonce24 (f Cookie)
+    | DHTDHTRequest PublicKey (Assym (f DHTRequest))
 
 instance Sized GetNodes where
     size = ConstSize 32 -- TODO This right?
@@ -112,8 +121,8 @@ newtype Encrypted8 a = E8 (Encrypted (a,Nonce8))
 
 -- instance (Sized a, Sized b) => Sized (a,b) where size = _todo
 
-getDirect :: Sized a => Get (Assym (Encrypted8 a))
-getDirect = _todo
+getDHT :: Sized a => Get (Assym (Encrypted8 a))
+getDHT = _todo
 
 getOnionAssym :: Get (Assym (Encrypted DataToRoute))
 getOnionAssym = _todo
@@ -131,9 +140,9 @@ fanGet bs getIt f nid = fmap (f &&& nid) $ runGet getIt bs
 direct :: Sized a => ByteString
                   -> SockAddr
                   -> (Assym (Encrypted8 a)
-                  -> DirectMessage Encrypted8)
-                  -> Either String (DirectMessage Encrypted8, NodeInfo)
-direct bs saddr f = fanGet bs getDirect f (asymNodeInfo saddr)
+                  -> DHTMessage Encrypted8)
+                  -> Either String (DHTMessage Encrypted8, NodeInfo)
+direct bs saddr f = fanGet bs getDHT f (asymNodeInfo saddr)
 
 -- Throws an error if called with a non-internet socket.
 asymNodeInfo saddr asym = either (error . mappend "asymNodeInfo: ") id $ nodeInfo (NodeId $ senderKey asym) saddr
@@ -141,22 +150,22 @@ asymNodeInfo saddr asym = either (error . mappend "asymNodeInfo: ") id $ nodeInf
 -- Throws an error if called with a non-internet socket.
 noReplyAddr saddr = either (error . mappend "noReplyAddr: ") id $ nodeInfo zeroID saddr
 
-parseDHTAddr :: (ByteString, SockAddr) -> Either (DirectMessage Encrypted8,NodeInfo) (ByteString,SockAddr)
+parseDHTAddr :: (ByteString, SockAddr) -> Either (DHTMessage Encrypted8,NodeInfo) (ByteString,SockAddr)
 parseDHTAddr (msg,saddr)
     | Just (typ,bs) <- B.uncons msg
     , let right = Right (msg,saddr)
           left  = either (const right) Left
     = case typ of
-    0x00 -> left $ direct bs saddr DirectPing
-    0x01 -> left $ direct bs saddr DirectPong
-    0x02 -> left $ direct bs saddr DirectGetNodes
-    0x04 -> left $ direct bs saddr DirectSendNodes
-    0x18 -> left $ direct bs saddr DirectCookieRequest
-    0x19 -> left $ fanGet bs getCookie (uncurry DirectCookie) (const $ noReplyAddr saddr)
-    0x20 -> left $ fanGet bs getDHTReqest (uncurry DirectDHTRequest) (asymNodeInfo saddr . snd)
+    0x00 -> left $ direct bs saddr DHTPing
+    0x01 -> left $ direct bs saddr DHTPong
+    0x02 -> left $ direct bs saddr DHTGetNodes
+    0x04 -> left $ direct bs saddr DHTSendNodes
+    0x18 -> left $ direct bs saddr DHTCookieRequest
+    0x19 -> left $ fanGet bs getCookie (uncurry DHTCookie) (const $ noReplyAddr saddr)
+    0x20 -> left $ fanGet bs getDHTReqest (uncurry DHTDHTRequest) (asymNodeInfo saddr . snd)
     _ -> right
 
-encodeDHTAddr :: (DirectMessage Encrypted8,NodeInfo) -> (ByteString, SockAddr)
+encodeDHTAddr :: (DHTMessage Encrypted8,NodeInfo) -> (ByteString, SockAddr)
 encodeDHTAddr = _todo
 
 
@@ -327,8 +336,8 @@ data CryptoMessage      -- First byte indicates data
 --   `0x8d`       Onion Response 2      -return
 --   `0x8e`       Onion Response 1      -return
 
-handleOnion :: TransportCrypto -> UDPTransport -> UDPTransport -- HandleHi a -> IO a -> HandleLo a
-handleOnion crypto udp = udp { awaitMessage = await' }
+forwardOnions :: TransportCrypto -> UDPTransport -> UDPTransport -- HandleHi a -> IO a -> HandleLo a
+forwardOnions crypto udp = udp { awaitMessage = await' }
  where
     -- forMe :: HandleHi
     -- forThem :: handleLo
@@ -349,45 +358,24 @@ forward :: forall c b b1.
               (Maybe (Either String b1) -> c) -> ByteString -> (b -> c) -> c
 forward forMe bs f = either (forMe . Just . Left) f $ decode $ B.tail bs
 
-parseMessage :: Word8 -> ByteString -> Either String (Message,Address)
---     Announce :: Aliased Assymetric -> ReturnPath 3 -> Packet --0x83
-parseMessage 0x83 bs = _todo -- Announce Request      OnionToOwner
-parseMessage _ _ = _todo
 
-handleDHTRequest :: forall a. TransportCrypto -> SockAddr -> HandleHi a -> IO a -> DHTRequestPacket -> IO a
-handleDHTRequest crypto saddr forMe forThem (DHTRequestPacket target payload)
-    | target == transportPublic crypto = forMe' payload
-    | otherwise                        = _todo -- lookup target in close list, forward message
-                                         >> forThem
+forwardDHTRequests :: TransportCrypto -> (PublicKey -> IO (Maybe NodeInfo)) -> DHTTransport -> DHTTransport
+forwardDHTRequests crypto closeLookup dht = dht { awaitMessage = await' }
  where
-    forMe' :: Assym (Encrypted DHTRequest) -> IO a
-    forMe' payload = do
-        case (,) <$> transportDecrypt crypto payload <*> eaddr of
-            Left e         -> forMe (Just (Left e))
-            Right (p,addr) -> forMe (Just (Right (DHTReq p,addr)))
-
-    eaddr :: Either String Tox.Address
-    eaddr = fmap DHTNode $ nodeInfo (NodeId $ senderKey payload) saddr
-
-data Attributed a = Attributed
-    { author          :: PublicKey
-    , attributedNonce :: Nonce24
-    , attributed      :: a
-    }
-
---   `0x83`       Announce Request      OnionToOwner
---   `0x85`       Onion Data Request    OnionToOwner
-data OPacket -- payload of an onion request
-
+    await' :: HandleHi a -> IO a
+    await' pass = awaitMessage dht $ \case
+        Just (Right (m@(DHTDHTRequest target payload),src)) | target /= transportPublic crypto
+            -> do mni <- closeLookup target
+                  -- Forward the message if the target is in our close list.
+                  forM_ mni $ \ni -> sendMessage dht ni m
+                  await' pass
+        m -> pass m
 
---   `0x84`       Announce Response     -
---   `0x86`       Onion Data Response   -
-data RPacket -- payload of an onion response
 
 -- n = 0, 1, 2
 data OnionRequest (n :: Nat) = OnionRequest
     { onionNonce    :: Nonce24
-    , onionForward  :: Forwarding (3 - n) OPacket
+    , onionForward  :: Forwarding (3 - n) (OnionMessage Encrypted)
     , pathFromOwner :: ReturnPath n
     }
 
@@ -399,7 +387,7 @@ instance Serialize (OnionResponse n) where { get = _todo; put = _todo }
 
 data OnionResponse (n :: Nat) = OnionResponse
     { pathToOwner :: ReturnPath n
-    , msgToOwner  :: RPacket
+    , msgToOwner  :: OnionMessage Encrypted
     }
 
 data Addressed a = Addressed { sockAddr :: SockAddr, unaddressed :: a }
@@ -410,7 +398,7 @@ data ReturnPath (n :: Nat) where
 
 data Forwarding (n :: Nat) msg where
     NotForwarded :: msg -> Forwarding 0 msg
-    Forwarding :: Attributed (Encrypted (Addressed (Forwarding n msg))) -> Forwarding (n + 1) msg
+    Forwarding :: Assym (Encrypted (Addressed (Forwarding n msg))) -> Forwarding (n + 1) msg
 
 handleOnionRequest :: KnownNat n => proxy n -> TransportCrypto -> SockAddr -> IO a -> OnionRequest n -> IO a
 handleOnionRequest = _todo
@@ -418,17 +406,6 @@ handleOnionRequest = _todo
 handleOnionResponse :: KnownNat n => proxy n -> TransportCrypto -> SockAddr -> IO a -> OnionResponse n -> IO a
 handleOnionResponse = _todo
 
-{-
-data Size a = ConstSize Int
-            | VarSize (a -> Int)
-
-data PacketChunk a
-    = Plain a
-    | Assymetric a
-    | Symmetric a
-    -}
-
-
 data AnnounceRequest = AnnounceRequest
     { announcePingId  :: Nonce32 -- Ping ID
     , announceSeeking :: NodeId  -- Public key we are searching for