packages feed

krpc (empty) → 0.1.0.0

raw patch · 11 files changed

+939/−0 lines, 11 filesdep +HUnitdep +basedep +bencodingsetup-changed

Dependencies added: HUnit, base, bencoding, bytestring, containers, criterion, filepath, krpc, lifted-base, monad-control, network, process, test-framework, test-framework-hunit, transformers

Files

+ LICENSE view
@@ -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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ bench/Main.hs view
@@ -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])+-}
+ bench/Server.hs view
@@ -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 ]
+ krpc.cabal view
@@ -0,0 +1,93 @@+name:                  krpc+version:               0.1.0.0+license:               MIT+license-file:          LICENSE+author:                Sam T.+maintainer:            Sam T. <pxqr.sta@gmail.com>+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
+ src/Remote/KRPC.hs view
@@ -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
+ src/Remote/KRPC/Protocol.hs view
@@ -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" : [<error_code>, <human_readable_error_reason>] }+--+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" : "<method_name>", "a" : [<arg1>, <arg2>, ...] }+--+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" : [<val1>, <val2>, ...] }+--+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))
+ src/Remote/KRPC/Scheme.hs view
@@ -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 #-}
+ tests/Client.hs view
@@ -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+  ]
+ tests/Server.hs view
@@ -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)+  ]
+ tests/Shared.hs view
@@ -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"]