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

4 files changed, 91 insertions, 38 deletions

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