From 24df9a12a9240aaed8741d60e4b0b9cbf59a9fd9 Mon Sep 17 00:00:00 2001 From: joe Date: Mon, 5 Jun 2017 03:21:25 -0400 Subject: WIP: Adapting DHT to Tox network (part 2). --- src/Network/KRPC/Manager.hs | 43 +++++++++++++++----------------------- src/Network/KRPC/Message.hs | 51 +++++++++++++++++++++++++++------------------ src/Network/KRPC/Method.hs | 15 +++++++++---- 3 files changed, 59 insertions(+), 50 deletions(-) (limited to 'src/Network/KRPC') 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 -- {-# 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 -- cgit v1.2.3