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

3 files changed, 59 insertions, 50 deletions

diff --git a/src/Network/KRPC/Manager.hs b/src/Network/KRPC/Manager.hs
index e7f0563b..b1e93101 100644
--- a/src/Network/KRPC/Manager.hs
+++ b/src/Network/KRPC/Manager.hs
@@ -76,6 +76,7 @@ import Data.Text as T
 import Data.Text.Encoding as T
 import Data.Tuple
 import Data.Typeable
+import Network.RPC
 import Network.KRPC.Message
 import Network.KRPC.Method
 import Network.Socket hiding (listen)
@@ -136,11 +137,11 @@ type CallId             = (TransactionId, SockAddr)
 type CallRes            = MVar (KQueryArgs, KResult) -- (raw response, decoded response)
 type PendingCalls       = IORef (Map CallId CallRes)
 
-type HandlerBody h = SockAddr -> KQueryArgs -> h (Either String KQueryArgs)
+type HandlerBody h msg v = SockAddr -> msg v -> h (Either String v)
 
 -- | Handler is a function which will be invoked then some /remote/
 -- node querying /this/ node.
-type Handler     h = (MethodName, HandlerBody h)
+type Handler     h msg v = (MethodName, HandlerBody h msg v)
 
 -- | Keep track pending queries made by /this/ node and handle queries
 -- made by /remote/ nodes.
@@ -150,7 +151,7 @@ data Manager h = Manager
   , listenerThread     :: !(MVar ThreadId)
   , transactionCounter :: {-# UNPACK #-} !TransactionCounter
   , pendingCalls       :: {-# UNPACK #-} !PendingCalls
-  , handlers           :: [Handler h]
+  , handlers           :: [Handler h KMessageOf BValue]
   }
 
 -- | A monad which can perform or handle queries.
@@ -182,10 +183,10 @@ sockAddrFamily (SockAddrCan _        ) = AF_CAN
 
 -- | Bind socket to the specified address. To enable query handling
 -- run 'listen'.
-newManager :: Options        -- ^ various protocol options;
-           -> SockAddr       -- ^ address to listen on;
-           -> [Handler h]    -- ^ handlers to run on incoming queries.
-           -> IO (Manager h) -- ^ new rpc manager.
+newManager :: Options                       -- ^ various protocol options;
+           -> SockAddr                      -- ^ address to listen on;
+           -> [Handler h KMessageOf BValue] -- ^ handlers to run on incoming queries.
+           -> IO (Manager h)                -- ^ new rpc manager.
 newManager opts @ Options {..} servAddr handlers = do
     validateOptions opts
     sock  <- bindServ
@@ -217,7 +218,7 @@ isActive Manager {..} = liftIO $ isBound sock
 
 -- | Normally you should use Control.Monad.Trans.Resource.allocate
 -- function.
-withManager :: Options -> SockAddr -> [Handler h]
+withManager :: Options -> SockAddr -> [Handler h KMessageOf BValue]
             -> (Manager h -> IO a) -> IO a
 withManager opts addr hs = bracket (newManager opts addr hs) closeManager
 
@@ -408,35 +409,25 @@ 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. (KRPC a b, Monad h)
-        => (SockAddr -> a -> h b) -> Handler h
-handler body = (name, wrapper)
+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)
   where
     Method name = method :: Method a b
     wrapper addr args =
-#ifdef VERSION_bencoding
-      case fromBEncode args of
-#else
-      case S.decode args of
-#endif
-        Left  e -> return $ Left e
-        Right a -> do
-          r <- body addr a
-#ifdef VERSION_bencoding
-          return $ Right $ toBEncode r
-#else
-          return $ Right $ S.encode r
-#endif
+      case unseal $ messagePayload msging args of
+        Left  e -> pure $ Left e
+        Right a -> Right . seal <$> body addr a
 
 runHandler :: MonadKRPC h m
-           => HandlerBody h -> SockAddr -> KQuery -> m KResult
+           => HandlerBody h KMessageOf BValue -> SockAddr -> KQuery -> m KResult
 runHandler h addr m = Lifted.catches wrapper failbacks
   where
     signature = querySignature (queryMethod m) (queryId m) addr
 
     wrapper = do
       $(logDebugS) "handler.quered" signature
-      result <- liftHandler (h addr (queryArgs m))
+      result <- liftHandler (h addr (Q m))
 
       case result of
         Left msg -> do
diff --git a/src/Network/KRPC/Message.hs b/src/Network/KRPC/Message.hs
index d48fa8ac..19f9fc9e 100644
--- a/src/Network/KRPC/Message.hs
+++ b/src/Network/KRPC/Message.hs
@@ -13,14 +13,16 @@
 --   See <http://www.bittorrent.org/beps/bep_0005.html#krpc-protocol>
 --
 {-# LANGUAGE CPP                    #-}
-{-# LANGUAGE OverloadedStrings      #-}
+{-# LANGUAGE DefaultSignatures      #-}
+{-# LANGUAGE DeriveDataTypeable     #-}
+{-# LANGUAGE DeriveFunctor          #-}
+{-# LANGUAGE DeriveTraversable      #-}
 {-# LANGUAGE FlexibleContexts       #-}
 {-# LANGUAGE FlexibleInstances      #-}
-{-# LANGUAGE TypeSynonymInstances   #-}
-{-# LANGUAGE MultiParamTypeClasses  #-}
 {-# LANGUAGE FunctionalDependencies #-}
-{-# LANGUAGE DefaultSignatures      #-}
-{-# LANGUAGE DeriveDataTypeable     #-}
+{-# LANGUAGE MultiParamTypeClasses  #-}
+{-# LANGUAGE OverloadedStrings      #-}
+{-# LANGUAGE TypeSynonymInstances   #-}
 module Network.KRPC.Message
        ( -- * Transaction
          TransactionId
@@ -32,7 +34,8 @@ module Network.KRPC.Message
        , unknownMessage
 
          -- * Query
-       , KQuery(..)
+       , KQueryOf(..)
+       , KQuery
 #ifndef VERSION_bencoding
        , queryArgs
        , queryMethod
@@ -41,11 +44,13 @@ module Network.KRPC.Message
        , MethodName
 
          -- * Response
-       , KResponse(..)
+       , KResponseOf(..)
+       , KResponse
        , ReflectedIP(..)
 
          -- * Message
-       , KMessage (..)
+       , KMessageOf (..)
+       , KMessage
        , KQueryArgs
 
        ) where
@@ -208,11 +213,13 @@ type KQueryArgs = ByteString      -- msgPayload
 -- callee and pass arguments in. Therefore query may be only sent from
 -- client to server but not in the opposite direction.
 --
-data KQuery = KQuery
-  { queryArgs   :: !KQueryArgs     -- ^ values to be passed to method;
+data KQueryOf a = KQuery
+  { queryArgs   :: !a              -- ^ values to be passed to method;
   , queryMethod :: !MethodName     -- ^ method to call;
   , queryId     :: !TransactionId  -- ^ one-time query token.
-  } deriving ( Show, Eq, Ord, Typeable, Read )
+  } deriving ( Show, Eq, Ord, Typeable, Read, Functor, Foldable, Traversable )
+
+type KQuery = KQueryOf KQueryArgs
 
 -- | Queries, or KRPC message dictionaries with a \"y\" value of
 -- \"q\", contain two additional keys; \"q\" and \"a\". Key \"q\" has
@@ -223,7 +230,7 @@ data KQuery = KQuery
 --
 --    > { "t" : "aa", "y" : "q", "q" : "ping", "a" : { "msg" : "hi!" } }
 --
-instance BEncode KQuery where
+instance (Typeable a, BEncode a) => BEncode (KQueryOf a) where
   toBEncode KQuery {..} = toDict $
        "a" .=! queryArgs
     .: "q" .=! queryMethod
@@ -288,11 +295,13 @@ encodeAddr _ = B.empty
 --   * KResponse can be only sent from server to client.
 --
 #ifdef VERSION_bencoding
-data KResponse = KResponse
-  { respVals :: KQueryArgs     -- ^ 'BDict' containing return values;
+data KResponseOf a = KResponse
+  { respVals :: a              -- ^ 'BDict' containing return values;
   , respId   :: TransactionId  -- ^ match to the corresponding 'queryId'.
   , respIP   :: Maybe ReflectedIP
-  } deriving (Show, Eq, Ord, Typeable)
+  } deriving (Show, Eq, Ord, Typeable, Functor, Foldable, Traversable)
+
+type KResponse = KResponseOf KQueryArgs
 
 -- | Responses, or KRPC message dictionaries with a \"y\" value of
 -- \"r\", contain one additional key \"r\". The value of \"r\" is a
@@ -302,7 +311,7 @@ data KResponse = KResponse
 --
 --   > { "t" : "aa", "y" : "r", "r" : { "msg" : "you've sent: hi!" } }
 --
-instance BEncode KResponse where
+instance (Typeable a, BEncode a) => BEncode (KResponseOf a) where
   toBEncode KResponse {..} = toDict $
        "ip" .=? respIP
     .: "r" .=! respVals
@@ -329,11 +338,13 @@ respIP         = Nothing :: Maybe ReflectedIP
 
 #ifdef VERSION_bencoding
 -- | Generic KRPC message.
-data KMessage
-  = Q KQuery
-  | R KResponse
+data KMessageOf a
+  = Q (KQueryOf a)
+  | R (KResponseOf a)
   | E KError
-    deriving (Show, Eq)
+    deriving (Show, Eq, Functor, Foldable, Traversable)
+
+type KMessage = KMessageOf KQueryArgs
 
 instance BEncode KMessage where
   toBEncode (Q q) = toBEncode q
diff --git a/src/Network/KRPC/Method.hs b/src/Network/KRPC/Method.hs
index 2a791924..ad93cb8b 100644
--- a/src/Network/KRPC/Method.hs
+++ b/src/Network/KRPC/Method.hs
@@ -8,11 +8,13 @@
 --   Normally, you don't need to import this module.
 --
 {-# LANGUAGE CPP                        #-}
-{-# LANGUAGE RankNTypes                 #-}
-{-# LANGUAGE MultiParamTypeClasses      #-}
+{-# LANGUAGE DefaultSignatures          #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE MultiParamTypeClasses      #-}
+{-# LANGUAGE RankNTypes                 #-}
 {-# LANGUAGE ScopedTypeVariables        #-}
-{-# LANGUAGE DefaultSignatures          #-}
+{-# LANGUAGE TypeFamilies               #-}
+{-# LANGUAGE FunctionalDependencies #-}
 module Network.KRPC.Method
        ( Method (..)
        , KRPC (..)
@@ -93,7 +95,9 @@ class ( Typeable req, Typeable resp
       , Serialize req, Serialize resp
 #endif
       )
-    => KRPC req resp where
+    => KRPC req resp | req -> resp, resp -> req where
+
+  type Envelope req resp
 
   -- | Method name. Default implementation uses lowercased @req@
   -- datatype name.
@@ -107,3 +111,6 @@ class ( Typeable req, Typeable resp
     where
       hole = error "krpc.method: impossible" :: req
 #endif
+
+  unseal :: Envelope req resp -> Either String req
+  seal :: resp -> Envelope req resp