WIP: Adapting DHT to Tox network (part 4).

5 files changed, 169 insertions, 41 deletions

diff --git a/src/Data/Tox.hs b/src/Data/Tox.hs
index 448b39eb..4449ce65 100644
--- a/src/Data/Tox.hs
+++ b/src/Data/Tox.hs
@@ -1,5 +1,7 @@
 {-# LANGUAGE DeriveDataTypeable #-}
 {-# LANGUAGE DeriveGeneric      #-}
+{-# LANGUAGE DeriveTraversable  #-}
+{-# LANGUAGE DeriveFunctor      #-}
 {-# LANGUAGE PatternSynonyms    #-}
 {-# LANGUAGE RecordWildCards    #-}
 {-# LANGUAGE TupleSections      #-}
@@ -15,6 +17,9 @@ import Data.Serialize
 import Network.BitTorrent.Address () -- Serialize IP
 import GHC.Generics (Generic)
 import Network.Socket
+import Network.RPC hiding (NodeId)
+import qualified Network.RPC as Envelope (NodeId)
+import Crypto.PubKey.ECC.Types
 
 type Key32   = Word256 -- 32 byte key
 type Nonce8  = Word64  -- 8 bytes
@@ -88,7 +93,7 @@ data Message a = Message
     , msgNonce   :: Nonce24
     , msgPayload :: a
     }
- deriving (Show, Generic)
+ deriving (Show, Generic, Functor, Foldable, Traversable)
 
 isQuery :: Message a -> Bool
 isQuery (Message { msgType = SendNodes })                  = False
@@ -101,8 +106,6 @@ isResponse m = not (isQuery m)
 isError :: Message a -> Bool
 isError _ = False
 
-instance Serialize a => Serialize (Message a) where -- TODO TOX
-
 data PingPayload = PingPayload
     { isPong :: Bool
     , pingId :: Nonce8
@@ -194,3 +197,75 @@ instance Serialize NodeFormat where
 --   [Sendback data, length=8 bytes]
 --   ]
 
+data ToxCipherContext = ToxCipherContext -- TODO
+
+newtype Ciphered = Ciphered { cipheredBytes :: ByteString }
+
+getMessage :: Get (Message Ciphered)
+getMessage = do
+        typ <- get
+        nid <- get
+        tid <- get
+        cnt <- remaining
+        bs <- getBytes cnt
+        return Message { msgType = typ
+                       , msgClient = nid
+                       , msgNonce = tid
+                       , msgPayload = Ciphered bs }
+
+putMessage :: Message Ciphered -> Put
+putMessage (Message {..}) = do
+        put msgType
+        put msgClient
+        put msgNonce
+        let Ciphered bs = msgPayload
+        putByteString bs
+
+decipher :: ToxCipherContext -> Message Ciphered -> Either String (Message ByteString)
+decipher = error "TODO TOX: decipher"
+
+encipher :: ToxCipherContext -> Message ByteString -> Message Ciphered
+encipher = error "TODO TOX: encipher"
+
+-- see rfc7748
+curve25519 :: Curve
+curve25519 = CurveFP (CurvePrime prime curvecommon)
+ where
+    prime = 2^255 - 19 -- (≅ 1 modulo 4)
+
+    -- 1 * v^2 = u^3 + 486662*u^2 + u
+
+    curvecommon = CurveCommon
+        { ecc_a = 486662
+        , ecc_b = 1
+        , ecc_g = Point 9 14781619447589544791020593568409986887264606134616475288964881837755586237401 -- base point
+        , ecc_n = 2^252 + 0x14def9dea2f79cd65812631a5cf5d3ed -- order
+        , ecc_h = 8 -- cofactor
+        }
+
+
+
+instance Envelope Message where
+    type TransactionID Message = Nonce24
+    type NodeId Message = NodeId
+
+    envelopePayload = msgPayload
+
+    envelopeTransaction = msgNonce
+
+    envelopeClass Message { msgType = Ping      } = Query
+    envelopeClass Message { msgType = Pong      } = Response
+    envelopeClass Message { msgType = GetNodes  } = Query
+    envelopeClass Message { msgType = SendNodes } = Response
+
+    buildReply self addr qry payload = (fmap (const payload) qry) { msgClient = self }
+
+instance WireFormat ByteString Message where
+    type SerializableTo ByteString = Serialize
+    type CipherContext ByteString Message = ToxCipherContext
+
+    decodePayload = mapM decode
+    encodePayload = fmap encode
+
+    decodeHeaders ctx bs = runGet getMessage bs >>= decipher ctx
+    encodeHeaders ctx msg = runPut $ putMessage $ encipher ctx msg
diff --git a/src/Network/BitTorrent/DHT/Query.hs b/src/Network/BitTorrent/DHT/Query.hs
index e1104cb9..820db8ba 100644
--- a/src/Network/BitTorrent/DHT/Query.hs
+++ b/src/Network/BitTorrent/DHT/Query.hs
@@ -112,7 +112,7 @@ nodeHandler :: ( Address ip
 #endif
            => (NodeAddr ip -> a -> DHT ip b) -> NodeHandler ip
 #ifdef VERSION_bencoding
-nodeHandler action = handler mainline $ \ sockAddr qry -> do
+nodeHandler action = handler $ \ sockAddr qry -> do
   let remoteId  = queringNodeId qry
       read_only = queryIsReadOnly qry
       q         = queryParams qry
diff --git a/src/Network/DHT/Mainline.hs b/src/Network/DHT/Mainline.hs
index 7cd33c0d..540b74f9 100644
--- a/src/Network/DHT/Mainline.hs
+++ b/src/Network/DHT/Mainline.hs
@@ -1,22 +1,40 @@
 {-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE TypeFamilies #-}
 module Network.DHT.Mainline where
 
+import Network.Socket
 import Network.RPC
-import Network.KRPC.Message
+import Network.KRPC.Message as KRPC
 import Data.BEncode as BE
 import qualified Data.ByteString.Lazy as L
+import Network.BitTorrent.Address as BT (NodeId)
 
-mainline :: Messaging KMessageOf TransactionId BValue
-mainline = Messaging
-    { messageClass = \case Q _ -> Query
-                           R _ -> Response
-                           E _ -> Error
-    , messageTransaction = \case Q q -> queryId q
-                                 R r -> respId r
-                                 E e -> errorId e
-    , messagePayload = \case Q q -> queryArgs q
-                             R r -> respVals r
-                             E e -> error "TODO: messagePayload for KError"
-    , encodePayload = fmap (L.toStrict . BE.encode)
-    , decodePayload = sequence . fmap BE.decode
-    }
+instance Envelope KMessageOf where
+    type TransactionID KMessageOf = KRPC.TransactionId
+    type NodeId KMessageOf = BT.NodeId
+
+    envelopePayload (Q q) = queryArgs q
+    envelopePayload (R r) = respVals r
+    envelopePayload (E _) = error "TODO: messagePayload for KError"
+
+    envelopeTransaction (Q q) = queryId q
+    envelopeTransaction (R r) = respId r
+    envelopeTransaction (E e) = errorId e
+
+    envelopeClass (Q _) = Query
+    envelopeClass (R _) = Response
+    envelopeClass (E _) = Error
+
+    buildReply self addr qry response =
+        (R (KResponse response (envelopeTransaction qry) (Just $ ReflectedIP addr)))
+
+instance WireFormat BValue KMessageOf where
+    type SerializableTo BValue = BEncode
+    type CipherContext BValue KMessageOf = ()
+
+    decodeHeaders _ bs = BE.decode bs >>= BE.fromBEncode
+    decodePayload kmsg = mapM BE.fromBEncode kmsg
+
+    encodeHeaders _ kmsg = L.toStrict $ BE.encode kmsg
+    encodePayload msg = fmap BE.toBEncode msg
diff --git a/src/Network/KRPC/Manager.hs b/src/Network/KRPC/Manager.hs
index 58ac7674..f31a3cd6 100644
--- a/src/Network/KRPC/Manager.hs
+++ b/src/Network/KRPC/Manager.hs
@@ -78,11 +78,13 @@ import Data.Tuple
 import Data.Typeable
 import Network.RPC
 import Network.KRPC.Message
-import Network.KRPC.Method
+import Network.KRPC.Method hiding (Envelope)
+import qualified Network.KRPC.Method as KRPC (Envelope)
 import Network.Socket hiding (listen)
 import Network.Socket.ByteString as BS
 import System.IO.Error
 import System.Timeout
+import Network.DHT.Mainline
 
 
 {-----------------------------------------------------------------------
@@ -130,14 +132,14 @@ validateOptions Options {..}
 --  Options
 -----------------------------------------------------------------------}
 
-type KResult = Either KError KResponse
+type KResult = Either KError KMessage -- Response
 
 type TransactionCounter = IORef Int
 type CallId             = (TransactionId, SockAddr)
 type CallRes            = MVar (KQueryArgs, KResult) -- (raw response, decoded response)
 type PendingCalls       = IORef (Map CallId CallRes)
 
-type HandlerBody h msg v = SockAddr -> msg v -> h (Either String v)
+type HandlerBody h msg v = SockAddr -> msg v -> h (Either String (msg v))
 
 -- | Handler is a function which will be invoked then some /remote/
 -- node querying /this/ node.
@@ -362,7 +364,7 @@ queryK addr params kont = do
       case res of
 #ifdef VERSION_bencoding
         Left  (KError   c m _) -> throwIO $ QueryFailed c (T.decodeUtf8 m)
-        Right (KResponse {..}) ->
+        Right (R (KResponse {..})) ->
           case fromBEncode respVals of
             Right r -> pure $ kont raw r respIP
 #else
@@ -421,15 +423,16 @@ prettyQF e = T.encodeUtf8 $ "handler fail while performing query: "
 --   If the handler make some 'query' normally it /should/ handle
 --   corresponding 'QueryFailure's.
 --
-handler :: forall h a b msg. (KRPC a b, Applicative h, Functor msg)
-        => Messaging msg TransactionId (Envelope a b) -> (SockAddr -> a -> h b) -> Handler h msg (Envelope a b)
-handler msging body = (name, wrapper)
+handler :: forall h a b msg raw. (KRPC a b, Applicative h, Functor msg, WireFormat raw msg, SerializableTo raw a, SerializableTo raw b)
+        => (SockAddr -> a -> h b) -> Handler h msg raw
+handler body = (name, wrapper)
   where
     Method name = method :: Method a b
+    wrapper :: SockAddr -> msg raw -> h (Either String (msg raw))
     wrapper addr args =
-      case unseal $ messagePayload msging args of
+      case decodePayload args of
         Left  e -> pure $ Left e
-        Right a -> Right . seal <$> body addr a
+        Right a -> Right . encodePayload . buildReply (error "self node-id") addr args <$> body addr (envelopePayload a)
 
 runHandler :: MonadKRPC h m
 #ifdef VERSION_bencoding
@@ -461,7 +464,7 @@ runHandler h addr m = Lifted.catches wrapper failbacks
         Right a -> do -- KQueryArgs
           $(logDebugS) "handler.success" signature
 #ifdef VERSION_bencoding
-          return $ Right $ KResponse a (queryId m) (Just $ ReflectedIP addr)
+          return $ Right a
 #else
           let cli = error "TODO TOX client node id"
               messageid = error "TODO TOX message response id"
@@ -542,7 +545,7 @@ handleResponse raw result addr = do
   Manager {..} <- getManager
   liftIO $ do
 #ifdef VERSION_bencoding
-    let resultId = either errorId respId  result
+    let resultId = either errorId envelopeTransaction result
 #else
     let resultId = either Tox.msgNonce Tox.msgNonce result
 #endif
@@ -554,7 +557,7 @@ handleResponse raw result addr = do
 #ifdef VERSION_bencoding
 handleMessage :: MonadKRPC h m => KQueryArgs -> KMessage -> SockAddr -> m ()
 handleMessage raw (Q q) = handleQuery    raw q
-handleMessage raw (R r) = handleResponse raw (Right r)
+handleMessage raw (R r) = handleResponse raw (Right (R r))
 handleMessage raw (E e) = handleResponse raw (Left  e)
 #else
 handleMessage :: MonadKRPC h m => KQueryArgs -> Tox.Message BC.ByteString -> SockAddr -> m ()
diff --git a/src/Network/RPC.hs b/src/Network/RPC.hs
index 2e9356e8..727422fd 100644
--- a/src/Network/RPC.hs
+++ b/src/Network/RPC.hs
@@ -1,15 +1,47 @@
-{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ConstraintKinds        #-}
+{-# LANGUAGE FunctionalDependencies #-}
+{-# LANGUAGE MultiParamTypeClasses  #-}
+{-# LANGUAGE RankNTypes             #-}
+{-# LANGUAGE ScopedTypeVariables    #-}
+{-# LANGUAGE TypeFamilies           #-}
+{-# LANGUAGE DeriveDataTypeable     #-}
 module Network.RPC where
 
 import Data.ByteString (ByteString)
+import Data.Kind       (Constraint)
+import Data.Data
+import Network.Socket
 
 data MessageClass = Error | Query | Response
- deriving (Eq,Ord,Enum,Bounded,Show,Read)
-
-data Messaging msg tid payload = Messaging
-    { messageClass       :: forall a. msg a -> MessageClass
-    , messageTransaction :: forall a. msg a -> tid
-    , messagePayload     :: forall a. msg a -> a
-    , encodePayload      :: msg payload -> msg ByteString
-    , decodePayload      :: msg ByteString -> Either String (msg payload)
-    }
+ deriving (Eq,Ord,Enum,Bounded,Data,Show,Read)
+
+class Envelope envelope where
+    type TransactionID envelope
+    type NodeId envelope
+
+    envelopePayload     :: envelope a -> a
+    envelopeTransaction :: envelope a -> TransactionID envelope
+    envelopeClass       :: envelope a -> MessageClass
+
+    -- | > buildReply self addr qry response
+    --
+    --    [ self ]     this node's id.
+    --
+    --    [ addr ]     SockAddr of query origin.
+    --
+    --    [ qry ]      received query message.
+    --
+    --    [ response ] response payload.
+    --
+    -- Returns: response message envelope
+    buildReply :: NodeId envelope -> SockAddr -> envelope a -> b -> envelope b
+
+class Envelope envelope => WireFormat raw envelope where
+    type SerializableTo raw :: * -> Constraint
+    type CipherContext raw envelope
+
+    decodeHeaders :: CipherContext raw envelope -> ByteString -> Either String (envelope raw)
+    decodePayload :: SerializableTo raw a => envelope raw -> Either String (envelope a)
+
+    encodeHeaders :: CipherContext raw envelope -> envelope raw -> ByteString
+    encodePayload :: SerializableTo raw a => envelope a -> envelope raw