Implemented more stubs for DHT transport.

1 files changed, 93 insertions, 38 deletions

diff --git a/DHTTransport.hs b/DHTTransport.hs
index 690ee346..778390cf 100644
--- a/DHTTransport.hs
+++ b/DHTTransport.hs
@@ -29,10 +29,11 @@ import Network.QueryResponse
 
 import Control.Arrow
 import Control.Monad
+import Data.Bool
 import qualified Data.ByteString as B
          ;import Data.ByteString (ByteString)
 import Data.Tuple
-import Data.Serialize            as S (Get, Serialize, get, put, runGet)
+import Data.Serialize            as S
 import Data.Word
 import Network.Socket
 
@@ -50,13 +51,14 @@ data DHTMessage (f :: * -> *)
     | DHTDHTRequest PublicKey (Assym (f DHTRequest))
 
 mapMessage :: forall f b. (forall a. Nonce24 -> f a -> b) -> DHTMessage f -> b
-mapMessage f msg = f _todo _todo
+mapMessage f (DHTPing          a) = f (assymNonce a) (assymData a)
+mapMessage f (DHTPong          a) = f (assymNonce a) (assymData a)
+mapMessage f (DHTGetNodes      a) = f (assymNonce a) (assymData a)
+mapMessage f (DHTSendNodes     a) = f (assymNonce a) (assymData a)
+mapMessage f (DHTCookieRequest a) = f (assymNonce a) (assymData a)
+mapMessage f (DHTDHTRequest  _ a) = f (assymNonce a) (assymData a)
+mapMessage f (DHTCookie nonce fcookie) = f nonce fcookie
 
-instance Sized GetNodes where
-    size = ConstSize 32 -- TODO This right?
-
-instance Sized SendNodes where
-    size = VarSize $ \(SendNodes ns) -> _nodeFormatSize * length ns
 
 instance Sized Ping where size = ConstSize 1
 instance Sized Pong where size = ConstSize 1
@@ -77,27 +79,48 @@ parseDHTAddr (msg,saddr)
     _ -> right
 
 encodeDHTAddr :: (DHTMessage Encrypted8,NodeInfo) -> (ByteString, SockAddr)
-encodeDHTAddr = _todo
+encodeDHTAddr (msg,ni) = (runPut $ putMessage msg, nodeAddr ni)
+
+dhtMessageType :: DHTMessage Encrypted8 -> ( Word8, Put )
+dhtMessageType (DHTPing           a) = (0x00, putAssym a)
+dhtMessageType (DHTPong           a) = (0x01, putAssym a)
+dhtMessageType (DHTGetNodes       a) = (0x02, putAssym a)
+dhtMessageType (DHTSendNodes      a) = (0x04, putAssym a)
+dhtMessageType (DHTCookieRequest  a) = (0x18, putAssym a)
+dhtMessageType (DHTCookie       n x) = (0x19, put n >> put x)
+dhtMessageType (DHTDHTRequest   k a) = (0x20, putPublicKey k >> putAssym a)
+
+putMessage :: DHTMessage Encrypted8 -> Put
+putMessage msg = case dhtMessageType msg of (typ,p) -> put typ >> p
 
 getCookie :: Get (Nonce24, Encrypted8 Cookie)
 getCookie = get
 
 getDHTReqest :: Get (PublicKey, Assym (Encrypted8 DHTRequest))
-getDHTReqest = _todo
+getDHTReqest = (,) <$> getPublicKey <*> getAssym
+
+-- ## DHT Request packets
+--
+-- | Length | Contents                  |
+-- |:-------|:--------------------------|
+-- | `1`    | `uint8_t` (0x20)          |
+-- | `32`   | receiver's DHT public key |
+--   ...      ...
+
 
 getDHT :: Sized a => Get (Assym (Encrypted8 a))
-getDHT = _todo
+getDHT = getAssym
 
 
 -- Throws an error if called with a non-internet socket.
 direct :: Sized a => ByteString
                   -> SockAddr
-                  -> (Assym (Encrypted8 a)
-                  -> DHTMessage Encrypted8)
+                  -> (Assym (Encrypted8 a) -> 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 :: SockAddr -> Assym a -> NodeInfo
 asymNodeInfo saddr asym = either (error . mappend "asymNodeInfo: ") id $ nodeInfo (NodeId $ senderKey asym) saddr
 
 
@@ -105,35 +128,49 @@ fanGet :: ByteString -> Get x -> (x -> a) -> (x -> b) -> Either String (a,b)
 fanGet bs getIt f nid = fmap (f &&& nid) $ runGet getIt bs
 
 -- Throws an error if called with a non-internet socket.
+noReplyAddr :: SockAddr -> NodeInfo
 noReplyAddr saddr = either (error . mappend "noReplyAddr: ") id $ nodeInfo zeroID saddr
 
 
--- ## DHT Request packets
---
--- | Length | Contents                  |
--- |:-------|:--------------------------|
--- | `1`    | `uint8_t` (0x20)          |
--- | `32`   | receiver's DHT public key |
---   ...      ...
-
-data DHTRequestPacket = DHTRequestPacket
-    { requestTarget :: PublicKey
-    , request       :: Assym (Encrypted DHTRequest)
-    }
-
-instance Serialize DHTRequestPacket where
-    get = _todo
-    put = _todo
-
-
 data DHTRequest
+-- #### NAT ping request
+--
+--   Length   Contents
+--  :------- :-------------------------
+--   `1`      `uint8_t` (0xfe)
+--   `1`      `uint8_t` (0x00)
+--   `8`      `uint64_t` random number
     = NATPing Nonce8
+-- #### NAT ping response
+--
+--   Length   Contents
+--  :------- :-----------------------------------------------------------------
+--   `1`      `uint8_t` (0xfe)
+--   `1`      `uint8_t` (0x01)
+--   `8`      `uint64_t` random number (the same that was received in request)
     | NATPong Nonce8
     | DHTPK DHTPublicKey
 
+instance Sized DHTRequest where
+    size = VarSize $ \case
+        NATPing   _ -> 10
+        NATPong   _ -> 10
+        DHTPK dhtpk -> 41 + case size of
+                                ConstSize nodes -> nodes
+                                VarSize sznodes -> sznodes (dhtpkNodes dhtpk)
+
 instance Serialize DHTRequest where
-    get = return _todo
-    put _ = return () -- todo
+    get = do
+        tag <- get
+        case tag :: Word8 of
+            0xfe -> do
+                direction <- get
+                bool NATPong NATPing (direction==(0::Word8)) <$> get
+            0x9c -> DHTPK <$> get
+            _ -> fail ("unrecognized DHT request: "++show tag)
+    put (NATPing n) = put (0xfe00 :: Word16) >> put n
+    put (NATPong n) = put (0xfe01 :: Word16) >> put n
+    put (DHTPK pk)  = put (0x9c :: Word8) >> put pk
 
 -- | Length      | Contents                            |
 -- |:------------|:------------------------------------|
@@ -147,12 +184,27 @@ data DHTPublicKey = DHTPublicKey
     , dhtpkNodes :: SendNodes
     }
 
+instance Serialize DHTPublicKey where
+    get = DHTPublicKey <$> get <*> getPublicKey <*> get
+    put (DHTPublicKey nonce key nodes) = do
+        put nonce
+        putPublicKey key
+        put nodes
+
 newtype GetNodes = GetNodes NodeId
     deriving (Eq,Ord,Show,Read,S.Serialize)
 
+instance Sized GetNodes where
+    size = ConstSize 32 -- TODO This right?
+
 newtype SendNodes = SendNodes [NodeInfo]
     deriving (Eq,Ord,Show,Read)
 
+instance Sized SendNodes where
+    size = VarSize $ \(SendNodes ns) -> case size of
+            ConstSize nodeFormatSize -> nodeFormatSize * length ns
+            VarSize   nsize          -> sum $ map nsize ns
+
 instance S.Serialize SendNodes where
     get = do
         cnt <- S.get :: S.Get Word8
@@ -189,8 +241,8 @@ data Cookie = Cookie Nonce24 (Encrypted CookieData)
 instance Sized Cookie where size = ConstSize 112 -- 24 byte nonce + 88 byte cookie data
 
 instance Serialize Cookie where
-    get = return $ Cookie _todo _todo
-    put _ = return () -- todo
+    get = Cookie <$> get <*> get
+    put (Cookie nonce dta) = put nonce >> put dta
 
 data CookieData = CookieData   --   16 (mac)
     { cookieTime  :: Word64    --    8
@@ -198,12 +250,15 @@ data CookieData = CookieData   --   16 (mac)
     , dhtKey      :: PublicKey -- + 32
     }                          -- = 88 bytes when encrypted.
 
+instance Sized CookieData where
+    size = ConstSize 72
+
 instance Sized CookieRequest where
     size = ConstSize 64 -- 32 byte key + 32 byte padding
 
 instance Serialize CookieRequest where
-    get = CookieRequest <$> return _todo
-    put (CookieRequest _) = return () -- todo
+    get = CookieRequest <$> getPublicKey <* {- padding -} getPublicKey
+    put (CookieRequest k) = putPublicKey k >> {- padding -} putPublicKey k
 
 forwardDHTRequests :: TransportCrypto -> (PublicKey -> IO (Maybe NodeInfo)) -> DHTTransport -> DHTTransport
 forwardDHTRequests crypto closeLookup dht = dht { awaitMessage = await' }
@@ -226,7 +281,7 @@ encryptMessage crypto n (Right assym) = E8 $ ToxCrypto.encrypt secret plain
  where
     secret = computeSharedSecret (transportSecret crypto) (senderKey assym) n
     plain  = encodePlain $ swap $ assymData assym
-encryptMessage crypto n (Left plain) = _todo
+encryptMessage crypto n (Left plain) = _todo -- need cached public key.
 
 decrypt :: TransportCrypto -> DHTMessage Encrypted8 -> NodeInfo -> Either String (DHTMessage ((,) Nonce8), NodeInfo)
 decrypt crypto msg ni = (, ni) <$> (sequenceMessage $ transcode (decryptMessage crypto) msg)
@@ -241,7 +296,7 @@ decryptMessage crypto n (Right assymE) = plain8 $ ToxCrypto.decrypt secret e
     secret = computeSharedSecret (transportSecret crypto) (senderKey assymE) n
     E8 e   = assymData assymE
     plain8 = Composed . fmap swap . (>>= decodePlain)
-decryptMessage crypto n (Left (E8 e)) = _todo
+decryptMessage crypto n (Left (E8 e)) = _todo -- need cached public key
 
 sequenceMessage :: Applicative m => DHTMessage (m ∘ f) -> m (DHTMessage f)
 sequenceMessage (DHTPing asym)              = fmap DHTPing          $ sequenceA $ fmap uncomposed asym