diff --git a/NEWS.md b/NEWS.md new file mode 100644 --- /dev/null +++ b/NEWS.md @@ -0,0 +1,7 @@ +* 0.1.0.0: Initial version. +* 0.1.1.0: Allow passing raw argument\/result dictionaries. +* 0.2.0.0: Async API have been removed, use /async/ package instead. + Expose caller address in handlers. +* 0.2.2.0: Use bencoding-0.2.2.* +* 0.3.0.0: Use bencoding-0.3.* + Rename Remote.* to Network.* modules. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,39 @@ +### Synopsis + +KRPC is simple remote procedure call mechanism used by bittorrent DHT +but might be used anywhere else. + +### Description + +KRPC basically consisting of bencoded dictionaries sent over UDP. This +implementation provides extra safiety by separation of procedure +signature and implementation and baking procedure type in host +language, thus it's hard to shoot yourself in the foot accidently. + +See bittorrent DHT [specification][spec] for detailed protocol +description. + +#### Modules + +* Remote.KRPC — simple interface which reduce all RPC related stuff to + a few lines. Should be used in the first place. + +* Remote.KRPC.Protocol — raw protocol implementation. +* Remote.KRPC.Scheme — message validation. + +### Documentation + +For usage see examples in ```examples``` directory. +For documentation see haddock generated documentation. + +### Build Status [![Build Status][status-img]][status-link] + +### Maintainer + +Feel free to report bugs and suggestions via github +[issue tracker][issues] or the mail. + +[spec]: http://www.bittorrent.org/beps/bep_0005.html#krpc-protocol +[status-img]: https://travis-ci.org/cobit/krpc.png +[status-link]: https://travis-ci.org/cobit/krpc +[issues]: https://github.com/cobit/krpc/issues diff --git a/bench/Main.hs b/bench/Main.hs --- a/bench/Main.hs +++ b/bench/Main.hs @@ -5,7 +5,7 @@ import Data.ByteString (ByteString) import qualified Data.ByteString as B import Criterion.Main -import Remote.KRPC +import Network.KRPC addr :: RemoteAddr diff --git a/bench/Server.hs b/bench/Server.hs --- a/bench/Server.hs +++ b/bench/Server.hs @@ -2,7 +2,7 @@ module Main (main) where import Data.ByteString (ByteString) -import Remote.KRPC +import Network.KRPC echo :: Method ByteString ByteString diff --git a/krpc.cabal b/krpc.cabal --- a/krpc.cabal +++ b/krpc.cabal @@ -1,5 +1,5 @@ name: krpc -version: 0.2.2.0 +version: 0.3.0.0 license: BSD3 license-file: LICENSE author: Sam Truzjan @@ -17,15 +17,11 @@ KRPC remote procedure call protocol implementation. . - [/Release Notes/] - . - * /0.1.0.0:/ Initial version. - . - * /0.1.1.0:/ Allow passing raw argument\/result dictionaries. - . - * /0.2.0.0:/ Async API have been removed, use /async/ package instead. - Expose caller address in handlers. + See NEWS.md for release notes. +extra-source-files: README.md + , NEWS.md + source-repository head type: git location: git://github.com/cobit/krpc.git @@ -35,16 +31,16 @@ type: git location: git://github.com/cobit/krpc.git branch: master - tag: v0.2.2.0 + tag: v0.3.0.0 library default-language: Haskell2010 default-extensions: PatternGuards , RecordWildCards hs-source-dirs: src - exposed-modules: Remote.KRPC - , Remote.KRPC.Protocol - , Remote.KRPC.Scheme + exposed-modules: Network.KRPC + , Network.KRPC.Protocol + , Network.KRPC.Scheme build-depends: base == 4.* , lifted-base >= 0.1.1 @@ -53,7 +49,7 @@ , bytestring >= 0.10 , containers >= 0.4 - , bencoding == 0.2.2.* + , bencoding == 0.3.* , network >= 2.3 ghc-options: -Wall diff --git a/src/Network/KRPC.hs b/src/Network/KRPC.hs new file mode 100644 --- /dev/null +++ b/src/Network/KRPC.hs @@ -0,0 +1,362 @@ +-- | +-- Copyright : (c) Sam Truzjan 2013 +-- License : BSD3 +-- Maintainer : pxqr.sta@gmail.com +-- Stability : experimental +-- Portability : portable +-- +-- This module provides safe remote procedure call. One important +-- point is exceptions and errors, so be able handle them properly +-- we need to investigate a bit about how this all works. +-- Internally, in order to make method invokation KRPC makes the +-- following steps: +-- +-- * Caller serialize arguments to bencoded bytestrings; +-- +-- * Caller send bytestring data over UDP to the callee; +-- +-- * Callee receive and decode arguments to the method and method +-- name. If it can't decode then it send 'ProtocolError' back to the +-- caller; +-- +-- * Callee search for the @method name@ in the method table. +-- If it not present in the table then callee send 'MethodUnknown' +-- back to the caller; +-- +-- * Callee check if argument names match. If not it send +-- 'ProtocolError' back; +-- +-- * Callee make the actuall call to the plain old haskell +-- function. If the function throw exception then callee send +-- 'ServerError' back. +-- +-- * Callee serialize result of the function to bencoded bytestring. +-- +-- * Callee encode result to bencoded bytestring and send it back +-- to the caller. +-- +-- * Caller check if return values names match with the signature +-- it called in the first step. +-- +-- * Caller extracts results and finally return results of the +-- procedure call as ordinary haskell values. +-- +-- If every other error occurred caller get the 'GenericError'. All +-- errors returned by callee are throwed as ordinary haskell +-- exceptions at caller side. Make sure that both callee and caller +-- uses the same method signatures and everything should be ok: this +-- KRPC implementation provides some level of safety through +-- types. Also note that both caller and callee use plain UDP, so +-- KRPC is unreliable. +-- +-- Consider one tiny example. From now @caller = client@ and +-- @callee = server or remote@. +-- +-- Somewhere we have to define all procedure signatures. Imagine +-- that this is a library shared between client and server: +-- +-- > factorialMethod :: Method Int Int +-- > factorialMethod = method "factorial" ["x"] ["y"] +-- +-- Otherwise you can define this code in both client and server of +-- course. But in this case you might get into troubles: you can get +-- 'MethodUnknown' or 'ProtocolError' if name or type of method +-- will mismatch after not synced changes in client or server code. +-- +-- Now let's define our client-side: +-- +-- > main = withRemote $ \remote -> do +-- > result <- call remote (0, 6000) factorialMethod 4 +-- > assert (result == 24) $ print "Success!" +-- +-- It basically open socket with 'withRemote' and make all the other +-- steps in 'call' as describe above. And finally our server-side: +-- +-- > factorialImpl :: Int -> Int +-- > factorialImpl n = product [1..n] +-- > +-- > main = runServer [factorialMethod $ return . factorialImpl] +-- +-- Here we implement method signature from that shared lib and run +-- server with runServer by passing method table in. +-- +-- For async API use /async/ package, old API have been removed. +-- +-- For more examples see @exsamples@ or @tests@ directories. +-- +-- For protocol details see 'Remote.KRPC.Protocol' module. +-- +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE ExplicitForAll #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE DeriveGeneric #-} +module Network.KRPC + ( -- * Method + Method(..) + , method, idM + + -- * Client + , RemoteAddr + , RPCException(..) + , call + + -- * Server + , MethodHandler + , (==>) + , (==>@) + , server + + -- * Internal + , call_ + , withRemote + ) where + +import Control.Applicative +import Control.Exception +import Control.Monad.Trans.Control +import Control.Monad.IO.Class +import Data.BEncode +import Data.ByteString.Char8 as BC +import Data.List as L +import Data.Map as M +import Data.Monoid +import Data.Typeable +import Network +import GHC.Generics + +import Network.KRPC.Protocol + + +-- | Method datatype used to describe name, parameters and return +-- values of procedure. Client use a method to /invoke/, server +-- /implements/ the method to make the actual work. +-- +-- We use the following fantom types to ensure type-safiety: +-- +-- * param: Type of method parameters. Ordinary Tuple type used +-- to specify more than one parameter, so for example @Method +-- (Int, Int) result@ will take two arguments. +-- +-- * result: Type of return value of the method. Similarly, +-- tuple used to specify more than one return value, so for +-- exsample @Method (Foo, Bar) (Bar, Foo)@ will take two arguments +-- and return two values. +-- +-- To pass raw dictionaries you should specify empty param list: +-- +-- > method "my_method" [] [] :: Method BEncode BEncode +-- +-- In this case you should handle dictionary extraction by hand, both +-- in client and server. +-- +data Method param result = Method { + -- | Name used in query. + methodName :: MethodName + + -- | Name of each parameter in /right to left/ order. + , methodParams :: [ParamName] + + -- | Name of each return value in /right to left/ order. + , methodVals :: [ValName] + } deriving (Eq, Ord, Generic) + +instance BEncode (Method a b) + +instance (Typeable a, Typeable b) => Show (Method a b) where + showsPrec _ = showsMethod + +showsMethod + :: forall a. forall b. + Typeable a => Typeable b + => Method a b -> ShowS +showsMethod Method {..} = + showString (BC.unpack methodName) <> + showString " :: " <> + showsTuple methodParams paramsTy <> + showString " -> " <> + showsTuple methodVals valuesTy + where + paramsTy = typeOf (error "KRPC.showsMethod: impossible" :: a) + valuesTy = typeOf (error "KRPC.showsMethod: impossible" :: b) + + showsTuple ns ty + = showChar '(' + <> mconcat (L.intersperse (showString ", ") $ + L.zipWith showsTyArgName ns (detuple ty)) + <> showChar ')' + + showsTyArgName ns ty + = showString (BC.unpack ns) + <> showString " :: " + <> showString (show ty) + + detuple tyRep + | L.null args = [tyRep] + | otherwise = args + where + args = typeRepArgs tyRep + + +-- | Identity procedure signature. Could be used for echo +-- servers. Implemented as: +-- +-- > idM = method "id" ["x"] ["y"] +-- +idM :: Method a a +idM = method "id" ["x"] ["y"] +{-# INLINE idM #-} + +-- | Makes method signature. Note that order of parameters and return +-- values are not important as long as corresponding names and types +-- are match. For exsample this is the equal definitions: +-- +-- > methodA : Method (Foo, Bar) (Baz, Quux) +-- > methodA = method "mymethod" ["a", "b"] ["c", "d"] +-- +-- > methodA : Method (Bar, Foo) (Quux, Baz) +-- > methodB = method "mymethod" ["b", "a"] ["d", "c"] +-- +method :: MethodName -> [ParamName] -> [ValName] -> Method param result +method = Method +{-# INLINE method #-} + +lookupKey :: ParamName -> BDict -> Result BValue +lookupKey x = maybe (Left ("not found key " ++ BC.unpack x)) Right . M.lookup x + +extractArgs :: [ParamName] -> BDict -> Result BValue +extractArgs [] d = Right $ if M.null d then BList [] else BDict d +extractArgs [x] d = lookupKey x d +extractArgs xs d = BList <$> mapM (`lookupKey` d) xs +{-# INLINE extractArgs #-} + +injectVals :: [ParamName] -> BValue -> [(ParamName, BValue)] +injectVals [] (BList []) = [] +injectVals [] (BDict d ) = M.toList d +injectVals [] be = invalidParamList [] be +injectVals [p] arg = [(p, arg)] +injectVals ps (BList as) = L.zip ps as +injectVals ps be = invalidParamList ps be +{-# INLINE injectVals #-} + +invalidParamList :: [ParamName] -> BValue -> a +invalidParamList pl be + = error $ "KRPC invalid parameter list: " ++ show pl ++ "\n" ++ + "while procedure args are: " ++ show be + +-- | Alias to Socket, through might change in future. +type Remote = Socket + +-- | Represent any error mentioned by protocol specification that +-- 'call', 'await' might throw. +-- For more details see 'Remote.KRPC.Protocol'. +-- +data RPCException = RPCException KError + deriving (Show, Eq, Typeable) + +instance Exception RPCException + +-- | Address of remote can be called by client. +type RemoteAddr = KRemoteAddr + +queryCall :: BEncode param + => KRemote -> KRemoteAddr + -> Method param result -> param -> IO () +queryCall sock addr m arg = sendMessage q addr sock + where + q = kquery (methodName m) (injectVals (methodParams m) (toBEncode arg)) + +getResult :: BEncode result + => KRemote + -> Method param result -> IO result +getResult sock m = do + resp <- recvResponse sock + case resp of + Left e -> throw (RPCException e) + Right (respVals -> dict) -> do + case fromBEncode =<< extractArgs (methodVals m) dict of + Right vals -> return vals + Left e -> throw (RPCException (ProtocolError (BC.pack e))) + + +-- | Makes remote procedure call. Throws RPCException on any error +-- occurred. +call :: (MonadBaseControl IO host, MonadIO host) + => (BEncode param, BEncode result) + => RemoteAddr -- ^ Address of callee. + -> Method param result -- ^ Procedure to call. + -> param -- ^ Arguments passed by callee to procedure. + -> host result -- ^ Values returned by callee from the procedure. +call addr m arg = liftIO $ withRemote $ \sock -> do call_ sock addr m arg + +-- | The same as 'call' but use already opened socket. +call_ :: (MonadBaseControl IO host, MonadIO host) + => (BEncode param, BEncode result) + => Remote -- ^ Socket to use + -> RemoteAddr -- ^ Address of callee. + -> Method param result -- ^ Procedure to call. + -> param -- ^ Arguments passed by callee to procedure. + -> host result -- ^ Values returned by callee from the procedure. +call_ sock addr m arg = liftIO $ do + queryCall sock addr m arg + getResult sock m + + +type HandlerBody remote = KRemoteAddr -> KQuery -> remote (Either KError KResponse) + +-- | Procedure signature and implementation binded up. +type MethodHandler remote = (MethodName, HandlerBody remote) + +-- we can safely erase types in (==>) +-- | Assign method implementation to the method signature. +(==>) :: forall (remote :: * -> *) (param :: *) (result :: *). + (BEncode param, BEncode result) + => Monad remote + => Method param result -- ^ Signature. + -> (param -> remote result) -- ^ Implementation. + -> MethodHandler remote -- ^ Handler used by server. +{-# INLINE (==>) #-} +m ==> body = m ==>@ const body +infix 1 ==> + +-- | Similar to '==>@' but additionally pass caller address. +(==>@) :: forall (remote :: * -> *) (param :: *) (result :: *). + (BEncode param, BEncode result) + => Monad remote + => Method param result -- ^ Signature. + -> (KRemoteAddr -> param -> remote result) -- ^ Implementation. + -> MethodHandler remote -- ^ Handler used by server. +{-# INLINE (==>@) #-} +m ==>@ body = (methodName m, newbody) + where + {-# INLINE newbody #-} + newbody addr q = + case fromBEncode =<< extractArgs (methodParams m) (queryArgs q) of + Left e -> return (Left (ProtocolError (BC.pack e))) + Right a -> do + r <- body addr a + return (Right (kresponse (injectVals (methodVals m) (toBEncode r)))) + +infix 1 ==>@ + +-- TODO: allow forkIO + +-- | Run RPC server on specified port by using list of handlers. +-- Server will dispatch procedure specified by callee, but note that +-- it will not create new thread for each connection. +-- +server :: (MonadBaseControl IO remote, MonadIO remote) + => PortNumber -- ^ Port used to accept incoming connections. + -> [MethodHandler remote] -- ^ Method table. + -> remote () +server servport handlers = do + remoteServer servport $ \addr q -> do + case dispatch (queryMethod q) of + Nothing -> return $ Left $ MethodUnknown (queryMethod q) + Just m -> m addr q + where + handlerMap = M.fromList handlers + dispatch s = M.lookup s handlerMap diff --git a/src/Network/KRPC/Protocol.hs b/src/Network/KRPC/Protocol.hs new file mode 100644 --- /dev/null +++ b/src/Network/KRPC/Protocol.hs @@ -0,0 +1,266 @@ +-- | +-- Copyright : (c) Sam Truzjan 2013 +-- License : BSD3 +-- Maintainer : pxqr.sta@gmail.com +-- Stability : experimental +-- Portability : portable +-- +-- This module provides straightforward implementation of KRPC +-- protocol. In many situations 'Network.KRPC' should be prefered +-- since it gives more safe, convenient and high level api. +-- +-- See +-- +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE DefaultSignatures #-} +module Network.KRPC.Protocol + ( -- * Error + KError(..) + , ErrorCode + , errorCode + , mkKError + + -- * Query + , KQuery(queryMethod, queryArgs) + , MethodName + , ParamName + , kquery + + -- * Response + , KResponse(respVals) + , ValName + , kresponse + + , sendMessage + , recvResponse + + -- * Remote + , KRemote + , KRemoteAddr + , withRemote + , remoteServer + + -- * Re-exports + , encode + , encoded + , decode + , decoded + , toBEncode + , fromBEncode + ) where + +import Control.Applicative +import Control.Exception.Lifted as Lifted +import Control.Monad +import Control.Monad.IO.Class +import Control.Monad.Trans.Control + +import Data.BEncode +import Data.ByteString as B +import Data.ByteString.Char8 as BC +import qualified Data.ByteString.Lazy as LB +import Data.Map as M + +import Network.Socket hiding (recvFrom) +import Network.Socket.ByteString + + +-- | Errors used to signal that some error occurred while processing a +-- procedure call. Error may be send only from server to client but +-- not in the opposite direction. +-- +-- Errors are encoded as bencoded dictionary: +-- +-- > { "y" : "e", "e" : [, ] } +-- +data KError + -- | Some error doesn't fit in any other category. + = GenericError { errorMessage :: ByteString } + + -- | Occur when server fail to process procedure call. + | ServerError { errorMessage :: ByteString } + + -- | Malformed packet, invalid arguments or bad token. + | ProtocolError { errorMessage :: ByteString } + + -- | Occur when client trying to call method server don't know. + | MethodUnknown { errorMessage :: ByteString } + deriving (Show, Read, Eq, Ord) + +instance BEncode KError where + {-# SPECIALIZE instance BEncode KError #-} + {-# INLINE toBEncode #-} + toBEncode e = fromAscAssocs -- WARN: keep keys sorted + [ "e" --> (errorCode e, errorMessage e) + , "y" --> ("e" :: ByteString) + ] + + {-# INLINE fromBEncode #-} + fromBEncode (BDict d) + | M.lookup "y" d == Just (BString "e") + = uncurry mkKError <$> d >-- "e" + + fromBEncode _ = decodingError "KError" + +type ErrorCode = Int + +errorCode :: KError -> ErrorCode +errorCode (GenericError _) = 201 +errorCode (ServerError _) = 202 +errorCode (ProtocolError _) = 203 +errorCode (MethodUnknown _) = 204 +{-# INLINE errorCode #-} + +mkKError :: ErrorCode -> ByteString -> KError +mkKError 201 = GenericError +mkKError 202 = ServerError +mkKError 203 = ProtocolError +mkKError 204 = MethodUnknown +mkKError _ = GenericError +{-# INLINE mkKError #-} + +serverError :: SomeException -> KError +serverError = ServerError . BC.pack . show + +-- TODO Asc everywhere + + +type MethodName = ByteString +type ParamName = ByteString + +-- | Query used to signal that caller want to make procedure call to +-- callee and pass arguments in. Therefore query may be only sent from +-- client to server but not in the opposite direction. +-- +-- Queries are encoded as bencoded dictionary: +-- +-- > { "y" : "q", "q" : "", "a" : [, , ...] } +-- +data KQuery = KQuery { + queryMethod :: MethodName + , queryArgs :: Map ParamName BValue + } deriving (Show, Read, Eq, Ord) + +instance BEncode KQuery where + {-# SPECIALIZE instance BEncode KQuery #-} + {-# INLINE toBEncode #-} + toBEncode (KQuery m args) = fromAscAssocs -- WARN: keep keys sorted + [ "a" --> BDict args + , "q" --> m + , "y" --> ("q" :: ByteString) + ] + + {-# INLINE fromBEncode #-} + fromBEncode (BDict d) + | M.lookup "y" d == Just (BString "q") = + KQuery <$> d >-- "q" + <*> d >-- "a" + + fromBEncode _ = decodingError "KQuery" + +kquery :: MethodName -> [(ParamName, BValue)] -> KQuery +kquery name args = KQuery name (M.fromList args) +{-# INLINE kquery #-} + + + + +type ValName = ByteString + +-- | KResponse used to signal that callee successufully process a +-- procedure call and to return values from procedure. KResponse should +-- not be sent if error occurred during RPC. Thus KResponse may be only +-- sent from server to client. +-- +-- Responses are encoded as bencoded dictionary: +-- +-- > { "y" : "r", "r" : [, , ...] } +-- +newtype KResponse = KResponse { respVals :: BDict } + deriving (Show, Read, Eq, Ord) + +instance BEncode KResponse where + {-# INLINE toBEncode #-} + toBEncode (KResponse vals) = fromAscAssocs -- WARN: keep keys sorted + [ "r" --> vals + , "y" --> ("r" :: ByteString) + ] + + {-# INLINE fromBEncode #-} + fromBEncode (BDict d) + | M.lookup "y" d == Just (BString "r") = + KResponse <$> d >-- "r" + + fromBEncode _ = decodingError "KDict" + + +kresponse :: [(ValName, BValue)] -> KResponse +kresponse = KResponse . M.fromList +{-# INLINE kresponse #-} + + + +type KRemoteAddr = (HostAddress, PortNumber) + +type KRemote = Socket + +withRemote :: (MonadBaseControl IO m, MonadIO m) => (KRemote -> m a) -> m a +withRemote = bracket (liftIO (socket AF_INET Datagram defaultProtocol)) + (liftIO . sClose) +{-# SPECIALIZE withRemote :: (KRemote -> IO a) -> IO a #-} + + +maxMsgSize :: Int +{-# INLINE maxMsgSize #-} +-- release +--maxMsgSize = 512 -- size of payload of one udp packet +-- bench +maxMsgSize = 64 * 1024 -- max udp size + + +-- TODO eliminate toStrict +sendMessage :: BEncode msg => msg -> KRemoteAddr -> KRemote -> IO () +sendMessage msg (host, port) sock = + sendAllTo sock (LB.toStrict (encoded msg)) (SockAddrInet port host) +{-# INLINE sendMessage #-} + +recvResponse :: KRemote -> IO (Either KError KResponse) +recvResponse sock = do + (raw, _) <- recvFrom sock maxMsgSize + return $ case decoded raw of + Right resp -> Right resp + Left decE -> Left $ case decoded raw of + Right kerror -> kerror + _ -> ProtocolError (BC.pack decE) + +-- | Run server using a given port. Method invocation should be done manually. +remoteServer :: (MonadBaseControl IO remote, MonadIO remote) + => PortNumber -- ^ Port number to listen. + -> (KRemoteAddr -> KQuery -> remote (Either KError KResponse)) + -- ^ Handler. + -> remote () +remoteServer servport action = bracket (liftIO bindServ) (liftIO . sClose) loop + where + bindServ = do + sock <- socket AF_INET Datagram defaultProtocol + bindSocket sock (SockAddrInet servport iNADDR_ANY) + return sock + + loop sock = forever $ do + (bs, addr) <- liftIO $ recvFrom sock maxMsgSize + case addr of + SockAddrInet port host -> do + let kaddr = (host, port) + reply <- handleMsg bs kaddr + liftIO $ sendMessage reply kaddr sock + _ -> return () + + where + handleMsg bs addr = case decoded bs of + Right query -> (either toBEncode toBEncode <$> action addr query) + `Lifted.catch` (return . toBEncode . serverError) + Left decodeE -> return $ toBEncode (ProtocolError (BC.pack decodeE)) diff --git a/src/Network/KRPC/Scheme.hs b/src/Network/KRPC/Scheme.hs new file mode 100644 --- /dev/null +++ b/src/Network/KRPC/Scheme.hs @@ -0,0 +1,80 @@ +-- | +-- Copyright : (c) Sam Truzjan 2013 +-- License : BSD3 +-- Maintainer : pxqr.sta@gmail.com +-- Stability : experimental +-- Portability : portable +-- +-- This module provides message scheme validation for core protocol +-- messages from 'Remote.KRPC.Procotol'. This module should be used +-- with 'Remote.KRPC.Protocol', otherwise (if you are using 'Remote.KRPC') +-- this module seems to be useless. +-- +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FunctionalDependencies #-} +module Network.KRPC.Scheme + ( KMessage(..) + , KQueryScheme(..), methodQueryScheme + , KResponseScheme(..), methodRespScheme + ) where + +import Control.Applicative +import Data.Map as M +import Data.Set as S + +import Network.KRPC.Protocol +import Network.KRPC + + +-- | Used to validate any message by its scheme +-- +-- forall m. m `validate` scheme m +-- +class KMessage message scheme | message -> scheme where + -- | Get a message scheme. + scheme :: message -> scheme + + -- | Check a message with a scheme. + validate :: message -> scheme -> Bool + + default validate :: Eq scheme => message -> scheme -> Bool + validate = (==) . scheme + {-# INLINE validate #-} + + +instance KMessage KError ErrorCode where + {-# SPECIALIZE instance KMessage KError ErrorCode #-} + scheme = errorCode + {-# INLINE scheme #-} + + +data KQueryScheme = KQueryScheme { + qscMethod :: MethodName + , qscParams :: Set ParamName + } deriving (Show, Read, Eq, Ord) + +instance KMessage KQuery KQueryScheme where + {-# SPECIALIZE instance KMessage KQuery KQueryScheme #-} + scheme q = KQueryScheme (queryMethod q) (M.keysSet (queryArgs q)) + {-# INLINE scheme #-} + +methodQueryScheme :: Method a b -> KQueryScheme +methodQueryScheme = KQueryScheme <$> methodName + <*> S.fromList . methodParams +{-# INLINE methodQueryScheme #-} + + +newtype KResponseScheme = KResponseScheme { + rscVals :: Set ValName + } deriving (Show, Read, Eq, Ord) + +instance KMessage KResponse KResponseScheme where + {-# SPECIALIZE instance KMessage KResponse KResponseScheme #-} + scheme = KResponseScheme . keysSet . respVals + {-# INLINE scheme #-} + +methodRespScheme :: Method a b -> KResponseScheme +methodRespScheme = KResponseScheme . S.fromList . methodVals +{-# INLINE methodRespScheme #-} diff --git a/src/Remote/KRPC.hs b/src/Remote/KRPC.hs deleted file mode 100644 --- a/src/Remote/KRPC.hs +++ /dev/null @@ -1,362 +0,0 @@ --- | --- Copyright : (c) Sam Truzjan 2013 --- License : BSD3 --- Maintainer : pxqr.sta@gmail.com --- Stability : experimental --- Portability : portable --- --- This module provides safe remote procedure call. One important --- point is exceptions and errors, so be able handle them properly --- we need to investigate a bit about how this all works. --- Internally, in order to make method invokation KRPC makes the --- following steps: --- --- * Caller serialize arguments to bencoded bytestrings; --- --- * Caller send bytestring data over UDP to the callee; --- --- * Callee receive and decode arguments to the method and method --- name. If it can't decode then it send 'ProtocolError' back to the --- caller; --- --- * Callee search for the @method name@ in the method table. --- If it not present in the table then callee send 'MethodUnknown' --- back to the caller; --- --- * Callee check if argument names match. If not it send --- 'ProtocolError' back; --- --- * Callee make the actuall call to the plain old haskell --- function. If the function throw exception then callee send --- 'ServerError' back. --- --- * Callee serialize result of the function to bencoded bytestring. --- --- * Callee encode result to bencoded bytestring and send it back --- to the caller. --- --- * Caller check if return values names match with the signature --- it called in the first step. --- --- * Caller extracts results and finally return results of the --- procedure call as ordinary haskell values. --- --- If every other error occurred caller get the 'GenericError'. All --- errors returned by callee are throwed as ordinary haskell --- exceptions at caller side. Make sure that both callee and caller --- uses the same method signatures and everything should be ok: this --- KRPC implementation provides some level of safety through --- types. Also note that both caller and callee use plain UDP, so --- KRPC is unreliable. --- --- Consider one tiny example. From now @caller = client@ and --- @callee = server or remote@. --- --- Somewhere we have to define all procedure signatures. Imagine --- that this is a library shared between client and server: --- --- > factorialMethod :: Method Int Int --- > factorialMethod = method "factorial" ["x"] ["y"] --- --- Otherwise you can define this code in both client and server of --- course. But in this case you might get into troubles: you can get --- 'MethodUnknown' or 'ProtocolError' if name or type of method --- will mismatch after not synced changes in client or server code. --- --- Now let's define our client-side: --- --- > main = withRemote $ \remote -> do --- > result <- call remote (0, 6000) factorialMethod 4 --- > assert (result == 24) $ print "Success!" --- --- It basically open socket with 'withRemote' and make all the other --- steps in 'call' as describe above. And finally our server-side: --- --- > factorialImpl :: Int -> Int --- > factorialImpl n = product [1..n] --- > --- > main = runServer [factorialMethod $ return . factorialImpl] --- --- Here we implement method signature from that shared lib and run --- server with runServer by passing method table in. --- --- For async API use /async/ package, old API have been removed. --- --- For more examples see @exsamples@ or @tests@ directories. --- --- For protocol details see 'Remote.KRPC.Protocol' module. --- -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE ExplicitForAll #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE DeriveGeneric #-} -module Remote.KRPC - ( -- * Method - Method(..) - , method, idM - - -- * Client - , RemoteAddr - , RPCException(..) - , call - - -- * Server - , MethodHandler - , (==>) - , (==>@) - , server - - -- * Internal - , call_ - , withRemote - ) where - -import Control.Applicative -import Control.Exception -import Control.Monad.Trans.Control -import Control.Monad.IO.Class -import Data.BEncode -import Data.ByteString.Char8 as BC -import Data.List as L -import Data.Map as M -import Data.Monoid -import Data.Typeable -import Network -import GHC.Generics - -import Remote.KRPC.Protocol - - --- | Method datatype used to describe name, parameters and return --- values of procedure. Client use a method to /invoke/, server --- /implements/ the method to make the actual work. --- --- We use the following fantom types to ensure type-safiety: --- --- * param: Type of method parameters. Ordinary Tuple type used --- to specify more than one parameter, so for example @Method --- (Int, Int) result@ will take two arguments. --- --- * result: Type of return value of the method. Similarly, --- tuple used to specify more than one return value, so for --- exsample @Method (Foo, Bar) (Bar, Foo)@ will take two arguments --- and return two values. --- --- To pass raw dictionaries you should specify empty param list: --- --- > method "my_method" [] [] :: Method BEncode BEncode --- --- In this case you should handle dictionary extraction by hand, both --- in client and server. --- -data Method param result = Method { - -- | Name used in query. - methodName :: MethodName - - -- | Name of each parameter in /right to left/ order. - , methodParams :: [ParamName] - - -- | Name of each return value in /right to left/ order. - , methodVals :: [ValName] - } deriving (Eq, Ord, Generic) - -instance BEncodable (Method a b) - -instance (Typeable a, Typeable b) => Show (Method a b) where - showsPrec _ = showsMethod - -showsMethod - :: forall a. forall b. - Typeable a => Typeable b - => Method a b -> ShowS -showsMethod Method {..} = - showString (BC.unpack methodName) <> - showString " :: " <> - showsTuple methodParams paramsTy <> - showString " -> " <> - showsTuple methodVals valuesTy - where - paramsTy = typeOf (error "KRPC.showsMethod: impossible" :: a) - valuesTy = typeOf (error "KRPC.showsMethod: impossible" :: b) - - showsTuple ns ty - = showChar '(' - <> mconcat (L.intersperse (showString ", ") $ - L.zipWith showsTyArgName ns (detuple ty)) - <> showChar ')' - - showsTyArgName ns ty - = showString (BC.unpack ns) - <> showString " :: " - <> showString (show ty) - - detuple tyRep - | L.null args = [tyRep] - | otherwise = args - where - args = typeRepArgs tyRep - - --- | Identity procedure signature. Could be used for echo --- servers. Implemented as: --- --- > idM = method "id" ["x"] ["y"] --- -idM :: Method a a -idM = method "id" ["x"] ["y"] -{-# INLINE idM #-} - --- | Makes method signature. Note that order of parameters and return --- values are not important as long as corresponding names and types --- are match. For exsample this is the equal definitions: --- --- > methodA : Method (Foo, Bar) (Baz, Quux) --- > methodA = method "mymethod" ["a", "b"] ["c", "d"] --- --- > methodA : Method (Bar, Foo) (Quux, Baz) --- > methodB = method "mymethod" ["b", "a"] ["d", "c"] --- -method :: MethodName -> [ParamName] -> [ValName] -> Method param result -method = Method -{-# INLINE method #-} - -lookupKey :: ParamName -> Map ByteString BEncode -> Result BEncode -lookupKey x = maybe (Left ("not found key " ++ BC.unpack x)) Right . M.lookup x - -extractArgs :: [ParamName] -> Map ParamName BEncode -> Result BEncode -extractArgs [] d = Right $ if M.null d then BList [] else BDict d -extractArgs [x] d = lookupKey x d -extractArgs xs d = BList <$> mapM (`lookupKey` d) xs -{-# INLINE extractArgs #-} - -injectVals :: [ParamName] -> BEncode -> [(ParamName, BEncode)] -injectVals [] (BList []) = [] -injectVals [] (BDict d ) = M.toList d -injectVals [] be = invalidParamList [] be -injectVals [p] arg = [(p, arg)] -injectVals ps (BList as) = L.zip ps as -injectVals ps be = invalidParamList ps be -{-# INLINE injectVals #-} - -invalidParamList :: [ParamName] -> BEncode -> a -invalidParamList pl be - = error $ "KRPC invalid parameter list: " ++ show pl ++ "\n" ++ - "while procedure args are: " ++ show be - --- | Alias to Socket, through might change in future. -type Remote = Socket - --- | Represent any error mentioned by protocol specification that --- 'call', 'await' might throw. --- For more details see 'Remote.KRPC.Protocol'. --- -data RPCException = RPCException KError - deriving (Show, Eq, Typeable) - -instance Exception RPCException - --- | Address of remote can be called by client. -type RemoteAddr = KRemoteAddr - -queryCall :: BEncodable param - => KRemote -> KRemoteAddr - -> Method param result -> param -> IO () -queryCall sock addr m arg = sendMessage q addr sock - where - q = kquery (methodName m) (injectVals (methodParams m) (toBEncode arg)) - -getResult :: BEncodable result - => KRemote - -> Method param result -> IO result -getResult sock m = do - resp <- recvResponse sock - case resp of - Left e -> throw (RPCException e) - Right (respVals -> dict) -> do - case fromBEncode =<< extractArgs (methodVals m) dict of - Right vals -> return vals - Left e -> throw (RPCException (ProtocolError (BC.pack e))) - - --- | Makes remote procedure call. Throws RPCException on any error --- occurred. -call :: (MonadBaseControl IO host, MonadIO host) - => (BEncodable param, BEncodable result) - => RemoteAddr -- ^ Address of callee. - -> Method param result -- ^ Procedure to call. - -> param -- ^ Arguments passed by callee to procedure. - -> host result -- ^ Values returned by callee from the procedure. -call addr m arg = liftIO $ withRemote $ \sock -> do call_ sock addr m arg - --- | The same as 'call' but use already opened socket. -call_ :: (MonadBaseControl IO host, MonadIO host) - => (BEncodable param, BEncodable result) - => Remote -- ^ Socket to use - -> RemoteAddr -- ^ Address of callee. - -> Method param result -- ^ Procedure to call. - -> param -- ^ Arguments passed by callee to procedure. - -> host result -- ^ Values returned by callee from the procedure. -call_ sock addr m arg = liftIO $ do - queryCall sock addr m arg - getResult sock m - - -type HandlerBody remote = KRemoteAddr -> KQuery -> remote (Either KError KResponse) - --- | Procedure signature and implementation binded up. -type MethodHandler remote = (MethodName, HandlerBody remote) - --- we can safely erase types in (==>) --- | Assign method implementation to the method signature. -(==>) :: forall (remote :: * -> *) (param :: *) (result :: *). - (BEncodable param, BEncodable result) - => Monad remote - => Method param result -- ^ Signature. - -> (param -> remote result) -- ^ Implementation. - -> MethodHandler remote -- ^ Handler used by server. -{-# INLINE (==>) #-} -m ==> body = m ==>@ const body -infix 1 ==> - --- | Similar to '==>@' but additionally pass caller address. -(==>@) :: forall (remote :: * -> *) (param :: *) (result :: *). - (BEncodable param, BEncodable result) - => Monad remote - => Method param result -- ^ Signature. - -> (KRemoteAddr -> param -> remote result) -- ^ Implementation. - -> MethodHandler remote -- ^ Handler used by server. -{-# INLINE (==>@) #-} -m ==>@ body = (methodName m, newbody) - where - {-# INLINE newbody #-} - newbody addr q = - case fromBEncode =<< extractArgs (methodParams m) (queryArgs q) of - Left e -> return (Left (ProtocolError (BC.pack e))) - Right a -> do - r <- body addr a - return (Right (kresponse (injectVals (methodVals m) (toBEncode r)))) - -infix 1 ==>@ - --- TODO: allow forkIO - --- | Run RPC server on specified port by using list of handlers. --- Server will dispatch procedure specified by callee, but note that --- it will not create new thread for each connection. --- -server :: (MonadBaseControl IO remote, MonadIO remote) - => PortNumber -- ^ Port used to accept incoming connections. - -> [MethodHandler remote] -- ^ Method table. - -> remote () -server servport handlers = do - remoteServer servport $ \addr q -> do - case dispatch (queryMethod q) of - Nothing -> return $ Left $ MethodUnknown (queryMethod q) - Just m -> m addr q - where - handlerMap = M.fromList handlers - dispatch s = M.lookup s handlerMap diff --git a/src/Remote/KRPC/Protocol.hs b/src/Remote/KRPC/Protocol.hs deleted file mode 100644 --- a/src/Remote/KRPC/Protocol.hs +++ /dev/null @@ -1,251 +0,0 @@ --- | --- Copyright : (c) Sam Truzjan 2013 --- License : BSD3 --- Maintainer : pxqr.sta@gmail.com --- Stability : experimental --- Portability : portable --- --- This module provides straightforward implementation of KRPC --- protocol. In many situations 'Network.KRPC' should be prefered --- since it gives more safe, convenient and high level api. --- --- > See http://www.bittorrent.org/beps/bep_0005.html#krpc-protocol --- -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE DefaultSignatures #-} -module Remote.KRPC.Protocol - ( -- * Error - KError(..), ErrorCode, errorCode, mkKError - - -- * Query - , KQuery(queryMethod, queryArgs), MethodName, ParamName, kquery - - -- * Response - , KResponse(respVals), ValName, kresponse - - , sendMessage, recvResponse - - -- * Remote - , KRemote, KRemoteAddr, withRemote, remoteServer - - -- * Re-exports - , encode, encoded, decode, decoded, toBEncode, fromBEncode - ) where - -import Control.Applicative -import Control.Exception.Lifted as Lifted -import Control.Monad -import Control.Monad.IO.Class -import Control.Monad.Trans.Control - -import Data.BEncode -import Data.ByteString as B -import Data.ByteString.Char8 as BC -import qualified Data.ByteString.Lazy as LB -import Data.Map as M - -import Network.Socket hiding (recvFrom) -import Network.Socket.ByteString - - --- | Errors used to signal that some error occurred while processing a --- procedure call. Error may be send only from server to client but --- not in the opposite direction. --- --- Errors are encoded as bencoded dictionary: --- --- > { "y" : "e", "e" : [, ] } --- -data KError - -- | Some error doesn't fit in any other category. - = GenericError { errorMessage :: ByteString } - - -- | Occur when server fail to process procedure call. - | ServerError { errorMessage :: ByteString } - - -- | Malformed packet, invalid arguments or bad token. - | ProtocolError { errorMessage :: ByteString } - - -- | Occur when client trying to call method server don't know. - | MethodUnknown { errorMessage :: ByteString } - deriving (Show, Read, Eq, Ord) - -instance BEncodable KError where - {-# SPECIALIZE instance BEncodable KError #-} - {-# INLINE toBEncode #-} - toBEncode e = fromAscAssocs -- WARN: keep keys sorted - [ "e" --> (errorCode e, errorMessage e) - , "y" --> ("e" :: ByteString) - ] - - {-# INLINE fromBEncode #-} - fromBEncode (BDict d) - | M.lookup "y" d == Just (BString "e") - = uncurry mkKError <$> d >-- "e" - - fromBEncode _ = decodingError "KError" - -type ErrorCode = Int - -errorCode :: KError -> ErrorCode -errorCode (GenericError _) = 201 -errorCode (ServerError _) = 202 -errorCode (ProtocolError _) = 203 -errorCode (MethodUnknown _) = 204 -{-# INLINE errorCode #-} - -mkKError :: ErrorCode -> ByteString -> KError -mkKError 201 = GenericError -mkKError 202 = ServerError -mkKError 203 = ProtocolError -mkKError 204 = MethodUnknown -mkKError _ = GenericError -{-# INLINE mkKError #-} - -serverError :: SomeException -> KError -serverError = ServerError . BC.pack . show - --- TODO Asc everywhere - - -type MethodName = ByteString -type ParamName = ByteString - --- | Query used to signal that caller want to make procedure call to --- callee and pass arguments in. Therefore query may be only sent from --- client to server but not in the opposite direction. --- --- Queries are encoded as bencoded dictionary: --- --- > { "y" : "q", "q" : "", "a" : [, , ...] } --- -data KQuery = KQuery { - queryMethod :: MethodName - , queryArgs :: Map ParamName BEncode - } deriving (Show, Read, Eq, Ord) - -instance BEncodable KQuery where - {-# SPECIALIZE instance BEncodable KQuery #-} - {-# INLINE toBEncode #-} - toBEncode (KQuery m args) = fromAscAssocs -- WARN: keep keys sorted - [ "a" --> BDict args - , "q" --> m - , "y" --> ("q" :: ByteString) - ] - - {-# INLINE fromBEncode #-} - fromBEncode (BDict d) - | M.lookup "y" d == Just (BString "q") = - KQuery <$> d >-- "q" - <*> d >-- "a" - - fromBEncode _ = decodingError "KQuery" - -kquery :: MethodName -> [(ParamName, BEncode)] -> KQuery -kquery name args = KQuery name (M.fromList args) -{-# INLINE kquery #-} - - - - -type ValName = ByteString - --- | KResponse used to signal that callee successufully process a --- procedure call and to return values from procedure. KResponse should --- not be sent if error occurred during RPC. Thus KResponse may be only --- sent from server to client. --- --- Responses are encoded as bencoded dictionary: --- --- > { "y" : "r", "r" : [, , ...] } --- -newtype KResponse = KResponse { - respVals :: Map ValName BEncode - } deriving (Show, Read, Eq, Ord) - -instance BEncodable KResponse where - {-# SPECIALIZE instance BEncodable KResponse #-} - {-# INLINE toBEncode #-} - toBEncode (KResponse vals) = fromAscAssocs -- WARN: keep keys sorted - [ "r" --> vals - , "y" --> ("r" :: ByteString) - ] - - {-# INLINE fromBEncode #-} - fromBEncode (BDict d) - | M.lookup "y" d == Just (BString "r") = - KResponse <$> d >-- "r" - - fromBEncode _ = decodingError "KDict" - - -kresponse :: [(ValName, BEncode)] -> KResponse -kresponse = KResponse . M.fromList -{-# INLINE kresponse #-} - - - -type KRemoteAddr = (HostAddress, PortNumber) - -type KRemote = Socket - -withRemote :: (MonadBaseControl IO m, MonadIO m) => (KRemote -> m a) -> m a -withRemote = bracket (liftIO (socket AF_INET Datagram defaultProtocol)) - (liftIO . sClose) -{-# SPECIALIZE withRemote :: (KRemote -> IO a) -> IO a #-} - - -maxMsgSize :: Int -{-# INLINE maxMsgSize #-} --- release ---maxMsgSize = 512 -- size of payload of one udp packet --- bench -maxMsgSize = 64 * 1024 -- max udp size - - --- TODO eliminate toStrict -sendMessage :: BEncodable msg => msg -> KRemoteAddr -> KRemote -> IO () -sendMessage msg (host, port) sock = - sendAllTo sock (LB.toStrict (encoded msg)) (SockAddrInet port host) -{-# INLINE sendMessage #-} - -recvResponse :: KRemote -> IO (Either KError KResponse) -recvResponse sock = do - (raw, _) <- recvFrom sock maxMsgSize - return $ case decoded raw of - Right resp -> Right resp - Left decE -> Left $ case decoded raw of - Right kerror -> kerror - _ -> ProtocolError (BC.pack decE) - --- | Run server using a given port. Method invocation should be done manually. -remoteServer :: (MonadBaseControl IO remote, MonadIO remote) - => PortNumber -- ^ Port number to listen. - -> (KRemoteAddr -> KQuery -> remote (Either KError KResponse)) - -- ^ Handler. - -> remote () -remoteServer servport action = bracket (liftIO bindServ) (liftIO . sClose) loop - where - bindServ = do - sock <- socket AF_INET Datagram defaultProtocol - bindSocket sock (SockAddrInet servport iNADDR_ANY) - return sock - - loop sock = forever $ do - (bs, addr) <- liftIO $ recvFrom sock maxMsgSize - case addr of - SockAddrInet port host -> do - let kaddr = (host, port) - reply <- handleMsg bs kaddr - liftIO $ sendMessage reply kaddr sock - _ -> return () - - where - handleMsg bs addr = case decoded bs of - Right query -> (either toBEncode toBEncode <$> action addr query) - `Lifted.catch` (return . toBEncode . serverError) - Left decodeE -> return $ toBEncode (ProtocolError (BC.pack decodeE)) diff --git a/src/Remote/KRPC/Scheme.hs b/src/Remote/KRPC/Scheme.hs deleted file mode 100644 --- a/src/Remote/KRPC/Scheme.hs +++ /dev/null @@ -1,80 +0,0 @@ --- | --- Copyright : (c) Sam Truzjan 2013 --- License : BSD3 --- Maintainer : pxqr.sta@gmail.com --- Stability : experimental --- Portability : portable --- --- This module provides message scheme validation for core protocol --- messages from 'Remote.KRPC.Procotol'. This module should be used --- with 'Remote.KRPC.Protocol', otherwise (if you are using 'Remote.KRPC') --- this module seems to be useless. --- -{-# LANGUAGE DefaultSignatures #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FunctionalDependencies #-} -module Remote.KRPC.Scheme - ( KMessage(..) - , KQueryScheme(..), methodQueryScheme - , KResponseScheme(..), methodRespScheme - ) where - -import Control.Applicative -import Data.Map as M -import Data.Set as S - -import Remote.KRPC.Protocol -import Remote.KRPC - - --- | Used to validate any message by its scheme --- --- forall m. m `validate` scheme m --- -class KMessage message scheme | message -> scheme where - -- | Get a message scheme. - scheme :: message -> scheme - - -- | Check a message with a scheme. - validate :: message -> scheme -> Bool - - default validate :: Eq scheme => message -> scheme -> Bool - validate = (==) . scheme - {-# INLINE validate #-} - - -instance KMessage KError ErrorCode where - {-# SPECIALIZE instance KMessage KError ErrorCode #-} - scheme = errorCode - {-# INLINE scheme #-} - - -data KQueryScheme = KQueryScheme { - qscMethod :: MethodName - , qscParams :: Set ParamName - } deriving (Show, Read, Eq, Ord) - -instance KMessage KQuery KQueryScheme where - {-# SPECIALIZE instance KMessage KQuery KQueryScheme #-} - scheme q = KQueryScheme (queryMethod q) (M.keysSet (queryArgs q)) - {-# INLINE scheme #-} - -methodQueryScheme :: Method a b -> KQueryScheme -methodQueryScheme = KQueryScheme <$> methodName - <*> S.fromList . methodParams -{-# INLINE methodQueryScheme #-} - - -newtype KResponseScheme = KResponseScheme { - rscVals :: Set ValName - } deriving (Show, Read, Eq, Ord) - -instance KMessage KResponse KResponseScheme where - {-# SPECIALIZE instance KMessage KResponse KResponseScheme #-} - scheme = KResponseScheme . keysSet . respVals - {-# INLINE scheme #-} - -methodRespScheme :: Method a b -> KResponseScheme -methodRespScheme = KResponseScheme . S.fromList . methodVals -{-# INLINE methodRespScheme #-} diff --git a/tests/Client.hs b/tests/Client.hs --- a/tests/Client.hs +++ b/tests/Client.hs @@ -14,7 +14,7 @@ import Test.Framework import Test.Framework.Providers.HUnit -import Remote.KRPC +import Network.KRPC import Shared diff --git a/tests/Server.hs b/tests/Server.hs --- a/tests/Server.hs +++ b/tests/Server.hs @@ -2,7 +2,7 @@ module Main (main) where import Data.BEncode -import Remote.KRPC +import Network.KRPC import Shared diff --git a/tests/Shared.hs b/tests/Shared.hs --- a/tests/Shared.hs +++ b/tests/Shared.hs @@ -12,7 +12,7 @@ import Data.ByteString (ByteString) import Data.BEncode -import Remote.KRPC +import Network.KRPC unitM :: Method () () unitM = method "unit" [] [] @@ -32,8 +32,8 @@ shiftR :: Method ((), Int, [Int]) ([Int], (), Int) shiftR = method "shiftR" ["x", "y", "z"] ["a", "b", "c"] -rawM :: Method BEncode BEncode +rawM :: Method BValue BValue rawM = method "rawM" [""] [""] -rawDictM :: Method BEncode BEncode +rawDictM :: Method BValue BValue rawDictM = method "m" [] []