diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,19 @@ +Copyright (c) 2013 Sam T. + +Permission is hereby granted, free of charge, to any person obtaining a copy of +this software and associated documentation files (the "Software"), to deal in +the Software without restriction, including without limitation the rights to +use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies +of the Software, and to permit persons to whom the Software is furnished to do +so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in all +copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +SOFTWARE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/bench/Main.hs b/bench/Main.hs new file mode 100644 --- /dev/null +++ b/bench/Main.hs @@ -0,0 +1,32 @@ +{-# LANGUAGE OverloadedStrings #-} +module Main (main) where + +import Control.Monad +import Data.ByteString (ByteString) +import qualified Data.ByteString as B +import Criterion.Main +import Remote.KRPC + + +addr :: RemoteAddr +addr = (0, 6000) + +echo :: Method ByteString ByteString +echo = method "echo" ["x"] ["x"] + +main :: IO () +main = withRemote $ \remote -> do { + ; let sizes = [10, 100, 1000, 10000, 16 * 1024] + ; let repetitions = [1, 10, 100, 1000] + ; let params = [(r, s) | r <- repetitions, s <- sizes] + ; let benchmarks = map (uncurry (mkbench_ remote)) params + ; defaultMain benchmarks + } + where + mkbench_ re r n = bench (show r ++ "/" ++ show n) $ nfIO $ + replicateM r $ call_ re addr echo (B.replicate n 0) + +{- + forM_ [1..] $ const $ do + async addr myconcat (replicate 100 [1..10]) +-} diff --git a/bench/Server.hs b/bench/Server.hs new file mode 100644 --- /dev/null +++ b/bench/Server.hs @@ -0,0 +1,12 @@ +{-# LANGUAGE OverloadedStrings #-} +module Main (main) where + +import Data.ByteString (ByteString) +import Remote.KRPC + + +echo :: Method ByteString ByteString +echo = method "echo" ["x"] ["x"] + +main :: IO () +main = server 6000 [ echo ==> return ] diff --git a/krpc.cabal b/krpc.cabal new file mode 100644 --- /dev/null +++ b/krpc.cabal @@ -0,0 +1,93 @@ +name: krpc +version: 0.1.0.0 +license: MIT +license-file: LICENSE +author: Sam T. +maintainer: Sam T. +copyright: (c) 2013, Sam T. +category: Network +build-type: Simple +cabal-version: >=1.8 +homepage: https://github.com/pxqr/krpc +bug-reports: https://github.com/pxqr/krpc/issues +synopsis: KRPC remote procedure call protocol implementation. +description: + + KRPC remote procedure call protocol implementation. + . + [/Release Notes/] + . + * /0.1.0.0:/ Initial version. + + +source-repository head + type: git + location: git://github.com/pxqr/krpc.git + + + +library + exposed-modules: Remote.KRPC + , Remote.KRPC.Protocol + , Remote.KRPC.Scheme + + build-depends: base == 4.* + + , lifted-base >= 0.1.1 + , transformers >= 0.2 + , monad-control >= 0.3 + + , bytestring >= 0.10 + , containers >= 0.4 + , bencoding >= 0.1 + + , network >= 2.3 + + + hs-source-dirs: src + extensions: PatternGuards + ghc-options: -Wall + + + +test-suite test-client + type: exitcode-stdio-1.0 + main-is: Client.hs + other-modules: Shared + build-depends: base == 4.* + , bytestring + , process + , filepath + + , krpc + + , HUnit + , test-framework + , test-framework-hunit + + hs-source-dirs: tests + +executable test-server + main-is: Server.hs + other-modules: Shared + build-depends: base == 4.* + , bytestring + , krpc + + hs-source-dirs: tests + + + + +executable bench-server + main-is: Server.hs + build-depends: base == 4.*, krpc, bytestring + hs-source-dirs: bench + ghc-options: -fforce-recomp + +benchmark bench-client + type: exitcode-stdio-1.0 + main-is: Main.hs + hs-source-dirs: bench + build-depends: base == 4.5.*, krpc, criterion, bytestring + ghc-options: -O2 -fforce-recomp diff --git a/src/Remote/KRPC.hs b/src/Remote/KRPC.hs new file mode 100644 --- /dev/null +++ b/src/Remote/KRPC.hs @@ -0,0 +1,340 @@ +-- | +-- Copyright : (c) Sam T. 2013 +-- License : MIT +-- 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 more examples see @exsamples@ or @tests@ directories. +-- +-- For protocol details see 'Remote.KRPC.Protocol' module. +-- +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleContexts, DeriveDataTypeable #-} +{-# LANGUAGE ExplicitForAll, KindSignatures #-} +{-# LANGUAGE ViewPatterns #-} +module Remote.KRPC + ( -- * Method + Method(..) + , method, idM + + -- * Client + , RemoteAddr + , RPCException(..) + , call, Async, async, await + + -- * 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.Typeable +import Network + +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. +-- +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] + } + +-- TODO ppMethod + +-- | 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 #-} + + +extractArgs :: BEncodable arg + => [ParamName] -> Map ParamName BEncode -> Result arg +extractArgs as d = fromBEncode =<< + case as of + [] -> Right (BList []) + [x] -> f x + xs -> BList <$> mapM f xs + where + f x = maybe (Left ("not found key " ++ BC.unpack x)) Right + (M.lookup x d) +{-# INLINE extractArgs #-} + +injectVals :: BEncodable arg => [ParamName] -> arg -> [(ParamName, BEncode)] +injectVals [] (toBEncode -> BList []) = [] +injectVals [p] (toBEncode -> arg) = [(p, arg)] +injectVals ps (toBEncode -> BList as) = L.zip ps as +injectVals _ _ = error "KRPC.injectVals: impossible" +{-# INLINE injectVals #-} + +-- | 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) 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 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 + + +-- | Asynchonous result typically get from 'async' call. Used to defer +-- return values transfer. +newtype Async result = Async { waitResult :: IO result } + + +-- | Query procedure call but not wait for its results. This function +-- returns 'Async' value which is handle to procedure result. Actual +-- result might be obtained with 'await'. Unable to throw +-- 'RPCException', this might happen in 'await' if at all. +-- +-- Note that sending multiple queries at the same time to the one +-- remote is not recommended. For exsample in the following scenario: +-- +-- > aa <- async theRemote .... +-- > ab <- async theRemote .... +-- > a <- await ab +-- > b <- await ab +-- +-- it's likely that the /a/ and /b/ values will be mixed up. So in +-- order to get correct results you need to make 'await' before the +-- next 'async'. +-- +async :: MonadIO host + => (BEncodable param, BEncodable result) + => RemoteAddr -- ^ Address of callee. + -> Method param result -- ^ Procedure to call. + -> param -- ^ Arguments passed by callee to procedure. + -> host (Async result) -- ^ Handle to result. +async addr m arg = do + liftIO $ withRemote $ \sock -> + queryCall sock addr m arg + return $ Async $ withRemote $ \sock -> + getResult sock m + +-- | Will wait until the callee finished processing of procedure call +-- and return its results. Throws 'RPCException' on any error +-- occurred. +await :: MonadIO host + => Async result -- ^ Obtained from the corresponding 'async'. + -> host result -- ^ Result values of the procedure call quered + -- with 'async'. +await = liftIO . waitResult +{-# INLINE await #-} + + +type HandlerBody remote = 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 = (methodName m, newbody) + where + {-# INLINE newbody #-} + newbody q = + case extractArgs (methodParams m) (queryArgs q) of + Left e -> return (Left (ProtocolError (BC.pack e))) + Right a -> do + r <- body a + return (Right (kresponse (injectVals (methodVals m) 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 $ \_ q -> do + case dispatch (queryMethod q) of + Nothing -> return $ Left $ MethodUnknown (queryMethod q) + Just m -> invoke m q + where + handlerMap = M.fromList handlers + dispatch s = M.lookup s handlerMap + invoke m q = m q diff --git a/src/Remote/KRPC/Protocol.hs b/src/Remote/KRPC/Protocol.hs new file mode 100644 --- /dev/null +++ b/src/Remote/KRPC/Protocol.hs @@ -0,0 +1,253 @@ +-- | +-- Copyright : (c) Sam T. 2013 +-- License : MIT +-- 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, TypeSynonymInstances #-} +{-# LANGUAGE MultiParamTypeClasses, 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 Prelude hiding (catch) +import Control.Applicative +import Control.Exception.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 #-} +{-# SPECIALIZE sendMessage :: BEncode -> KRemoteAddr -> KRemote -> IO () #-} + +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 bind) (liftIO . sClose) loop + where + bind = 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) + `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 new file mode 100644 --- /dev/null +++ b/src/Remote/KRPC/Scheme.hs @@ -0,0 +1,79 @@ +-- | +-- Copyright : (c) Sam T. 2013 +-- License : MIT +-- 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, 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 new file mode 100644 --- /dev/null +++ b/tests/Client.hs @@ -0,0 +1,68 @@ +{-# LANGUAGE OverloadedStrings #-} +module Main (main) where + +import Control.Concurrent +import Control.Exception +import qualified Data.ByteString as B +import System.Environment +import System.Process +import System.FilePath + +import Test.HUnit hiding (Test) +import Test.Framework +import Test.Framework.Providers.HUnit + +import Remote.KRPC +import Shared + + +addr :: RemoteAddr +addr = (0, 6000) + +withServ :: FilePath -> IO () -> IO () +withServ serv_path = bracket up terminateProcess . const + where + up = do + (_, _, _, h) <- createProcess (proc serv_path []) + threadDelay 1000000 + return h + +main :: IO () +main = do + let serv_path = "dist" "build" "test-server" "test-server" + withServ serv_path $ + defaultMain tests + + +(==?) :: (Eq a, Show a) => a -> IO a -> Assertion +expected ==? action = do + actual <- action + expected @=? actual + +tests :: [Test] +tests = + [ testCase "unit" $ + () ==? call addr unitM () + + , testCase "echo int" $ + 1234 ==? call addr echoM 1234 + + , testCase "reverse 1..100" $ + reverse [1..100] ==? call addr reverseM [1..100] + + , testCase "reverse empty list" $ + reverse [] ==? call addr reverseM [] + + , testCase "reverse singleton list" $ + reverse [1] ==? call addr reverseM [1] + + , testCase "swap pair" $ + (1, 0) ==? call addr swapM (0, 1) + + , testCase "shift triple" $ + ([2..10], (), 1) ==? call addr shiftR ((), 1, [2..10]) + + , testCase "echo bytestring" $ + let bs = B.replicate 400 0 in + bs ==? call addr echoBytes bs + ] diff --git a/tests/Server.hs b/tests/Server.hs new file mode 100644 --- /dev/null +++ b/tests/Server.hs @@ -0,0 +1,16 @@ +{-# LANGUAGE IncoherentInstances #-} +module Main (main) where + +import Remote.KRPC +import Shared + + +main :: IO () +main = server 6000 + [ unitM ==> return + , echoM ==> return + , echoBytes ==> return + , swapM ==> \(a, b) -> return (b, a) + , reverseM ==> return . reverse + , shiftR ==> \(a, b, c) -> return (c, a, b) + ] diff --git a/tests/Shared.hs b/tests/Shared.hs new file mode 100644 --- /dev/null +++ b/tests/Shared.hs @@ -0,0 +1,25 @@ +{-# LANGUAGE OverloadedStrings #-} +module Shared + (echoM, echoBytes, unitM, swapM, reverseM, shiftR + ) where + +import Data.ByteString (ByteString) +import Remote.KRPC + +unitM :: Method () () +unitM = method "unit" [] [] + +echoM :: Method Int Int +echoM = method "echo" ["x"] ["x"] + +echoBytes :: Method ByteString ByteString +echoBytes = method "echoBytes" ["x"] ["x"] + +reverseM :: Method [Int] [Int] +reverseM = method "reverse" ["xs"] ["ys"] + +swapM :: Method (Int, Int) (Int, Int) +swapM = method "swap" ["x", "y"] ["b", "a"] + +shiftR :: Method ((), Int, [Int]) ([Int], (), Int) +shiftR = method "shiftR" ["x", "y", "z"] ["a", "b", "c"]