Implemented more stubs for DHT transport.

4 files changed, 192 insertions, 49 deletions

diff --git a/DHTHandlers.hs b/DHTHandlers.hs
index 41a4bc06..437b05f3 100644
--- a/DHTHandlers.hs
+++ b/DHTHandlers.hs
@@ -6,19 +6,24 @@ import DHTTransport
 import Network.QueryResponse as QR hiding (Client)
 import qualified Network.QueryResponse as QR (Client)
 import ToxCrypto
-import ToxMessage  as Tox (PacketKind(..), pattern PingType, pattern GetNodesType, pattern DHTRequestType)
+import ToxMessage  as Tox (PacketKind(..), pattern PingType, pattern PongType, pattern GetNodesType, pattern SendNodesType, pattern DHTRequestType)
+import Network.BitTorrent.DHT.Search
 
+import Control.Arrow
 import qualified Data.Wrapper.PSQInt as Int
 import Kademlia
-import Network.Address               (WantIP (..), ipFamily, testIdBit)
+import Network.Address               (WantIP (..), ipFamily, testIdBit,fromSockAddr, sockAddrPort)
 import qualified Network.DHT.Routing as R
 import TriadCommittee
+import Global6
 
 import Control.Monad
 import Control.Concurrent.STM
 import Data.Time.Clock.POSIX  (POSIXTime, getPOSIXTime)
 import Network.Socket
+import Data.Hashable
 import Data.IP
+import Data.Ord
 import Data.Maybe
 import Data.Bits
 
@@ -77,9 +82,11 @@ newRouting addr crypto update4 update6 = do
 
 
 -- TODO: This should cover more cases
+isLocal :: IP -> Bool
 isLocal (IPv6 ip6) = (ip6 == toEnum 0)
 isLocal (IPv4 ip4) = (ip4 == toEnum 0)
 
+isGlobal :: IP -> Bool
 isGlobal = not . isLocal
 
 prefer4or6 :: NodeInfo -> Maybe WantIP -> WantIP
@@ -210,6 +217,27 @@ transitionCommittee committee _ = return $ return ()
 
 type Handler = MethodHandler String TransactionId NodeInfo Message
 
+isPing :: (f Ping -> Ping) ->  DHTMessage f -> Either String Ping
+isPing unpack (DHTPing a) = Right $ unpack $ assymData a
+isPing _      _           = Left "Bad ping"
+
+mkPong :: TransactionId -> NodeInfo -> NodeInfo -> Pong -> DHTMessage ((,) Nonce8)
+mkPong tid src dst pong = DHTPong $ wrapAssym tid src dst (, pong)
+
+isGetNodes :: (f GetNodes -> GetNodes) ->  DHTMessage f -> Either String GetNodes
+isGetNodes unpack (DHTGetNodes a) = Right $ unpack $ assymData a
+isGetNodes _      _               = Left "Bad GetNodes"
+
+mkSendNodes :: TransactionId -> NodeInfo -> NodeInfo -> SendNodes -> DHTMessage ((,) Nonce8)
+mkSendNodes tid src dst sendnodes = DHTSendNodes $ wrapAssym tid src dst (, sendnodes)
+
 handlers :: Routing -> Tox.PacketKind -> Maybe Handler
-handlers routing PingType     = handler PongType pingH
-handlers routing GetNodesType = handler SendNodesType $ getNodesH routing
+handlers routing PingType     = Just $ MethodHandler (isPing snd) mkPong pingH
+handlers routing GetNodesType = Just $ MethodHandler (isGetNodes snd) mkSendNodes $ getNodesH routing
+
+nodeSearch :: Client -> Search NodeId (IP,PortNumber) () NodeInfo NodeInfo
+nodeSearch client  = Search
+    { searchSpace       = toxSpace
+    , searchNodeAddress = nodeIP &&& nodePort
+    , searchQuery       = getNodes client
+    }
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
diff --git a/ToxAddress.hs b/ToxAddress.hs
index ea69f6e3..04ee7d6f 100644
--- a/ToxAddress.hs
+++ b/ToxAddress.hs
@@ -13,7 +13,7 @@
 {-# LANGUAGE ScopedTypeVariables        #-}
 {-# LANGUAGE TupleSections              #-}
 {-# LANGUAGE TypeApplications           #-}
-module ToxAddress (NodeInfo(..),NodeId(..),nodeInfo,zeroID) where
+module ToxAddress (NodeInfo(..),NodeId(..),nodeInfo,nodeAddr,zeroID,key2id,id2key) where
 
 import Control.Applicative
 import Control.Monad
@@ -42,6 +42,7 @@ import System.IO.Unsafe                       (unsafeDupablePerformIO)
 import qualified Text.ParserCombinators.ReadP as RP
 import Text.Read
 import Data.Bits
+import ToxCrypto
 
 -- | perform io for hashes that do allocation and ffi.
 -- unsafeDupablePerformIO is used when possible as the
@@ -66,6 +67,26 @@ unpackPublicKey bs = loop 0
 newtype NodeId = NodeId PublicKey
  deriving (Eq,ByteArrayAccess) -- (Eq,Ord,ByteArrayAccess, Bits, Hashable)
 
+key2id :: PublicKey -> NodeId
+key2id = NodeId
+
+id2key :: NodeId -> PublicKey
+id2key (NodeId key) = key
+
+{-
+id2key :: NodeId -> PublicKey
+id2key recipient = case publicKey recipient of
+    CryptoPassed key -> key
+    -- This should never happen because a NodeId is 32 bytes.
+    CryptoFailed e   -> error ("Unexpected pattern fail: "++show e)
+
+key2id :: PublicKey -> NodeId
+key2id pk = case S.decode (BA.convert pk) of
+                Left _ -> error "key2id"
+                Right nid -> nid
+
+-}
+
 instance Ord NodeId where
     compare (NodeId a) (NodeId b) = compare (unpackPublicKey a) (unpackPublicKey b)
 
@@ -83,8 +104,8 @@ instance Show NodeId where
     show (NodeId bs) = C8.unpack $ Base16.encode $ BA.convert bs
 
 instance S.Serialize NodeId where
-    get = NodeId . throwCryptoError . publicKey <$> S.getBytes 32
-    put (NodeId bs) = S.putByteString $ BA.convert bs
+    get = NodeId <$> getPublicKey
+    put (NodeId bs) = putPublicKey bs
 
 instance Bits NodeId where -- TODO
 
@@ -144,6 +165,12 @@ getIP 0x82 = IPv4 <$> S.get -- TODO: TCP
 getIP 0x8a = IPv6 <$> S.get -- TODO: TCP
 getIP x    = fail ("unsupported address family ("++show x++")")
 
+instance Sized NodeInfo where
+    size = VarSize $ \(NodeInfo nid ip port) ->
+            case ip of
+                IPv4 _ -> 39 -- 35 +  4 = 1 + 4 + 2 + 32
+                IPv6 _ -> 51 -- 35 + 16 = 1 + 16 + 2 + 32
+
 instance S.Serialize NodeInfo where
     get = do
         addrfam <- S.get :: S.Get Word8
@@ -354,9 +381,6 @@ instance Show NodeInfo where
             | IPv6 ip6 <- ip , Just ip4 <- un4map ip6 = shows ip4
             | otherwise                               = ('[' :) . shows ip . (']' :)
 
-nodeAddr :: NodeInfo -> SockAddr
-nodeAddr (NodeInfo _ ip port) = setPort port $ toSockAddr ip
-
 nodeInfo :: NodeId -> SockAddr -> Either String NodeInfo
 nodeInfo nid saddr
     | Just ip <- fromSockAddr saddr
@@ -368,6 +392,10 @@ zeroID = PubKey $ B.replicate 32 0
 
 -}
 
+nodeAddr :: NodeInfo -> SockAddr
+nodeAddr (NodeInfo _ ip port) = setPort port $ toSockAddr ip
+
+
 newtype ForwardPath (n::Nat) = ForwardPath ByteString
  deriving (Eq, Ord,Data)
 
diff --git a/ToxCrypto.hs b/ToxCrypto.hs
index c2e2bbeb..e3bc57f9 100644
--- a/ToxCrypto.hs
+++ b/ToxCrypto.hs
@@ -9,6 +9,8 @@
 module ToxCrypto
     ( PublicKey
     , publicKey
+    , getPublicKey
+    , putPublicKey
     , SecretKey
     , SymmetricKey(..)
     , TransportCrypto(..)
@@ -16,6 +18,10 @@ module ToxCrypto
     , Encrypted8(..)
     , type (∘)(..)
     , Assym(..)
+    , getAssym
+    , getAliasedAssym
+    , putAssym
+    , putAliasedAssym
     , Plain
     , encodePlain
     , decodePlain
@@ -49,7 +55,7 @@ import qualified Data.ByteString.Char8  as C8
 import Data.Data
 import Data.Kind
 import Data.Ord
-import Data.Serialize
+import Data.Serialize as S
 import Data.Word
 import Foreign.Marshal.Alloc
 import Foreign.Ptr
@@ -57,6 +63,7 @@ import Foreign.Storable
 import System.Endian
 import qualified Data.ByteString.Internal
 import Control.Concurrent.STM
+import Crypto.Error.Types                     (CryptoFailable (..), throwCryptoError)
 
 -- | A 16-byte mac and an arbitrary-length encrypted stream.
 newtype Encrypted a = Encrypted ByteString
@@ -76,6 +83,7 @@ instance Data Auth where
     gunfold k z c = k (z (Auth . Poly1305.Auth . (BA.convert :: ByteString -> Bytes)))
     toConstr _ = con_Auth
     dataTypeOf _ = mkDataType "ToxMessage" [con_Auth]
+con_Auth :: Constr
 con_Auth = mkConstr (dataTypeOf (Auth (error "con_Auth"))) "Auth" [] Prefix
 instance Serialize Auth where
     get = Auth . Poly1305.Auth . BA.convert <$> getBytes 16
@@ -165,6 +173,7 @@ computeSharedSecret sk recipient nonce = State hash crypt
     -- Since rs is 32 bytes, this pattern should never fail...
     Cryptonite.CryptoPassed hash = Poly1305.initialize rs
 
+hsalsa20 :: (ByteArrayAccess t, ByteArrayAccess t1) => t1 -> t -> BA.ScrubbedBytes
 hsalsa20 k n = BA.append a b
  where
     Salsa.State st = XSalsa.initialize 20 k n
@@ -241,6 +250,23 @@ data Assym a = Assym
     }
  deriving (Functor,Foldable,Traversable)
 
+-- | Field order: senderKey, then nonce This is the format used by
+-- Ping/Pong/GetNodes/SendNodes.
+--
+-- See 'getAliasedAssym' if the nonce precedes the key.
+getAssym :: Serialize a => Get (Assym a)
+getAssym = Assym <$> getPublicKey <*> get <*> get
+
+putAssym :: Serialize a => Assym a -> Put
+putAssym (Assym key nonce dta) = putPublicKey key >> put nonce >> put dta
+
+-- | Field order: nonce, and then senderKey.
+getAliasedAssym :: Serialize a => Get (Assym a)
+getAliasedAssym = flip Assym <$> get <*> getPublicKey <*> get
+
+putAliasedAssym :: Serialize a => Assym a -> Put
+putAliasedAssym (Assym key nonce dta) = put nonce >> putPublicKey key >> put dta
+
 newtype SymmetricKey = SymmetricKey ByteString
 
 data TransportCrypto = TransportCrypto
@@ -249,3 +275,9 @@ data TransportCrypto = TransportCrypto
     , transportSymmetric :: STM SymmetricKey
     }
 
+getPublicKey :: S.Get PublicKey
+getPublicKey = throwCryptoError . publicKey <$> S.getBytes 32
+
+putPublicKey :: PublicKey -> S.Put
+putPublicKey bs = S.putByteString $ BA.convert bs
+