diff --git a/ChangeLog b/ChangeLog new file mode 100644 --- /dev/null +++ b/ChangeLog @@ -0,0 +1,48 @@ +2013-12-25 Sam Truzjan + + 0.5.0.0: Major API changes. + + * Added transaction handling; + * Use the same socket for server and client; + * New query function will infer query method from request/response + datatypes. + * Added MonadKRPC and KRPC classes. + +2013-11-26 Sam Truzjan + + * 0.4.1.1: Fixed build failure on GHC == 7.4.* + +2013-10-17 Sam Truzjan + + * 0.4.1.0: Use bencoding-0.4.* + +2013-10-03 Sam Truzjan + + * 0.4.0.1: Minor documentation fixes. + +2013-10-03 Sam Truzjan + + * 0.4.0.0: IPv6 support. + +2013-09-28 Sam Truzjan + + * 0.3.0.0: Use bencoding-0.3.* + * Rename Remote.* to Network.* modules. + +2013-09-28 Sam Truzjan + + * 0.2.2.0: Use bencoding-0.2.2.* + +2013-08-27 Sam Truzjan + + * 0.2.0.0: Async API have been removed, use /async/ package + instead. + * Expose caller address in handlers. + +2013-07-09 Sam Truzjan + + * 0.1.1.0: Allow passing raw argument\/result dictionaries. + +2013-07-09 Sam Truzjan + + * 0.1.0.0: Initial version. diff --git a/bench/Main.hs b/bench/Main.hs --- a/bench/Main.hs +++ b/bench/Main.hs @@ -1,33 +1,32 @@ -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} module Main (main) where - import Control.Monad -import Data.ByteString (ByteString) -import qualified Data.ByteString as B +import Control.Monad.Reader import Criterion.Main +import Data.ByteString as BS import Network.KRPC -import Network.Socket +instance KRPC ByteString ByteString where + method = "echo" -addr :: RemoteAddr -addr = SockAddrInet 6000 0 +echo :: Handler IO +echo = handler $ \ _ bs -> return (bs :: ByteString) -echo :: Method ByteString ByteString -echo = method "echo" ["x"] ["x"] +addr :: SockAddr +addr = SockAddrInet 6000 (256 * 256 * 256 + 127) 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 - } +main = withManager addr [echo] $ \ m -> (`runReaderT` m) $ do + listen + liftIO $ defaultMain (benchmarks m) 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]) --} + sizes = [10, 100, 1000, 10000, 16 * 1024] + repetitions = [1, 10, 100, 1000] + benchmarks m = [mkbench m r s | r <- repetitions, s <- sizes] + where + mkbench m r n = + bench (show r ++ "times" ++ "/" ++ show n ++ "bytes") $ nfIO $ + replicateM r $ + runReaderT (query addr (BS.replicate n 0)) m diff --git a/bench/Server.hs b/bench/Server.hs deleted file mode 100644 --- a/bench/Server.hs +++ /dev/null @@ -1,13 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -module Main (main) where - -import Data.ByteString (ByteString) -import Network.KRPC -import Network.Socket - - -echo :: Method ByteString ByteString -echo = method "echo" ["x"] ["x"] - -main :: IO () -main = server (SockAddrInet 6000 0) [ echo ==> return ] diff --git a/changelog b/changelog deleted file mode 100644 --- a/changelog +++ /dev/null @@ -1,11 +0,0 @@ -* 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. -* 0.4.0.0: IPv6 support. -* 0.4.0.1: Minor documentation fixes. -* 0.4.1.0: Use bencoding-0.4.* -* 0.4.1.1: Fixed build failure on GHC == 7.4.* diff --git a/krpc.cabal b/krpc.cabal --- a/krpc.cabal +++ b/krpc.cabal @@ -1,5 +1,5 @@ name: krpc -version: 0.4.1.1 +version: 0.5.0.0 license: BSD3 license-file: LICENSE author: Sam Truzjan @@ -12,13 +12,16 @@ , GHC == 7.6.3 homepage: https://github.com/cobit/krpc bug-reports: https://github.com/cobit/krpc/issues -synopsis: KRPC remote procedure call protocol implementation. +synopsis: KRPC protocol implementation description: - KRPC remote procedure call protocol implementation. + The KRPC protocol is a simple RPC mechanism consisting of bencoded + dictionaries sent over UDP. + . + extra-source-files: README.md - , changelog + , ChangeLog source-repository head type: git @@ -29,7 +32,7 @@ type: git location: git://github.com/cobit/krpc.git branch: master - tag: v0.4.1.1 + tag: v0.5.0.0 library default-language: Haskell2010 @@ -37,74 +40,48 @@ , RecordWildCards hs-source-dirs: src exposed-modules: Network.KRPC - , Network.KRPC.Protocol - , Network.KRPC.Scheme + Network.KRPC.Message + Network.KRPC.Method + Network.KRPC.Manager build-depends: base == 4.* , bytestring >= 0.10 - , lifted-base >= 0.1.1 , transformers >= 0.2 + , mtl , monad-control >= 0.3 - - , bencoding == 0.4.* - + , bencoding >= 0.4.3 , network >= 2.3 - + , containers if impl(ghc < 7.6) build-depends: ghc-prim - ghc-options: -Wall - -test-suite test-client +test-suite spec type: exitcode-stdio-1.0 default-language: Haskell2010 hs-source-dirs: tests - main-is: Client.hs - other-modules: Shared + main-is: Spec.hs + other-modules: Network.KRPCSpec + Network.KRPC.MethodSpec + Network.KRPC.MessageSpec build-depends: base == 4.* , bytestring - , process - , filepath - - , bencoding - , krpc , network - - , HUnit - , test-framework - , test-framework-hunit - - -executable test-server - default-language: Haskell2010 - hs-source-dirs: tests - main-is: Server.hs - other-modules: Shared - build-depends: base == 4.* - , bytestring + , mtl + , hspec + , QuickCheck + , quickcheck-instances , bencoding , krpc - , network -executable bench-server - default-language: Haskell2010 - hs-source-dirs: bench - main-is: Server.hs - build-depends: base == 4.* - , bytestring - , krpc - , network - ghc-options: -fforce-recomp - -benchmark bench-client +benchmark bench type: exitcode-stdio-1.0 default-language: Haskell2010 hs-source-dirs: bench main-is: Main.hs build-depends: base == 4.* , bytestring + , mtl , criterion , krpc - , network ghc-options: -O2 -fforce-recomp diff --git a/src/Network/KRPC.hs b/src/Network/KRPC.hs --- a/src/Network/KRPC.hs +++ b/src/Network/KRPC.hs @@ -6,8 +6,8 @@ -- 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. +-- point is exceptions and errors, so to 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: -- @@ -41,323 +41,42 @@ -- * 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. +-- If every other error occurred then caller get the +-- 'GenericError'. All errors returned by callee are throwed as +-- ordinary haskell exceptions at caller side. Also note that both +-- caller and callee use plain UDP, so KRPC is unreliable. -- --- For more examples see @exsamples@ or @tests@ directories. +-- For async 'query' use @async@ package. -- --- For protocol details see 'Remote.KRPC.Protocol' module. +-- For protocol details see "Network.KRPC.Message" 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 as BE -import Data.BEncode.BDict as BE -import Data.BEncode.Types as BE -import Data.ByteString.Char8 as BC -import Data.List as L -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 . BE.lookup x - -extractArgs :: [ParamName] -> BDict -> Result BValue -extractArgs [] d = Right $ if BE.null d then BList [] else BDict d -extractArgs [x] d = lookupKey x d -extractArgs xs d = BList <$> mapM (`lookupKey` d) xs -{-# INLINE extractArgs #-} - -zipBDict :: [BKey] -> [BValue] -> BDict -zipBDict (k : ks) (v : vs) = Cons k v (zipBDict ks vs) -zipBDict _ _ = Nil - -injectVals :: [ParamName] -> BValue -> BDict -injectVals [] (BList []) = BE.empty -injectVals [] (BDict d ) = d -injectVals [] be = invalidParamList [] be -injectVals [p] arg = BE.singleton p arg -injectVals ps (BList as) = zipBDict 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) + ( -- * Methods + Method + , KRPC (..) --- | Procedure signature and implementation binded up. -type MethodHandler remote = (MethodName, HandlerBody remote) + -- * RPC + , Handler + , handler + , query --- 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 ==> + -- * Manager + , MonadKRPC (..) + , Manager + , newManager + , closeManager + , withManager + , listen --- | 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)))) + -- * Exceptions + , KError (..) + , ErrorCode (..) -infix 1 ==>@ + -- * Re-export + , SockAddr (..) + ) where --- | 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) - => KRemoteAddr -- ^ Port used to accept incoming connections. - -> [MethodHandler remote] -- ^ Method table. - -> remote () -server servAddr handlers = do - remoteServer servAddr $ \addr q -> do - case L.lookup (queryMethod q) handlers of - Nothing -> return $ Left $ MethodUnknown (queryMethod q) - Just m -> m addr q +import Network.KRPC.Message +import Network.KRPC.Method +import Network.KRPC.Manager +import Network.Socket (SockAddr (..)) diff --git a/src/Network/KRPC/Manager.hs b/src/Network/KRPC/Manager.hs new file mode 100644 --- /dev/null +++ b/src/Network/KRPC/Manager.hs @@ -0,0 +1,265 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE FlexibleInstances #-} +module Network.KRPC.Manager + ( MonadKRPC (..) + , Manager + , newManager + , closeManager + , withManager + + , query + + , Handler + , handler + , listener + , listen + ) where + +import Control.Applicative +import Control.Arrow +import Control.Concurrent +import Control.Concurrent.Lifted (fork) +import Control.Exception hiding (Handler) +import Control.Exception.Lifted as Lifted (catch) +import Control.Monad +import Control.Monad.Reader +import Control.Monad.Trans.Control +import Data.BEncode as BE +import Data.ByteString.Char8 as BC +import Data.ByteString.Lazy as BL +import Data.IORef +import Data.List as L +import Data.Map as M +import Data.Tuple +import Network.KRPC.Message +import Network.KRPC.Method +import Network.Socket hiding (listen) +import Network.Socket.ByteString as BS +import System.Timeout + + +type KResult = Either KError KResponse + +type TransactionCounter = IORef Int +type CallId = (TransactionId, SockAddr) +type CallRes = MVar KResult +type PendingCalls = IORef (Map CallId CallRes) + +type HandlerBody h = SockAddr -> BValue -> h (BE.Result BValue) + +-- | Handler is a function which will be invoked then some /remote/ +-- node querying /this/ node. +type Handler h = (MethodName, HandlerBody h) + +-- | Keep track pending queries made by /this/ node and handle queries +-- made by /remote/ nodes. +data Manager h = Manager + { sock :: !Socket + , queryTimeout :: !Int -- ^ in seconds + , listenerThread :: !(MVar ThreadId) + , transactionCounter :: {-# UNPACK #-} !TransactionCounter + , pendingCalls :: {-# UNPACK #-} !PendingCalls + , handlers :: [Handler h] + } + +-- | A monad which can perform or handle queries. +class (MonadBaseControl IO m, MonadIO m) => MonadKRPC h m | m -> h where + -- | Ask for manager. + getManager :: m (Manager h) + + default getManager :: MonadReader (Manager h) m => m (Manager h) + getManager = ask + + -- | Can be used to add logging for instance. + liftHandler :: h a -> m a + + default liftHandler :: m a -> m a + liftHandler = id + +instance (MonadBaseControl IO h, MonadIO h) + => MonadKRPC h (ReaderT (Manager h) h) where + liftHandler = lift + +sockAddrFamily :: SockAddr -> Family +sockAddrFamily (SockAddrInet _ _ ) = AF_INET +sockAddrFamily (SockAddrInet6 _ _ _ _) = AF_INET6 +sockAddrFamily (SockAddrUnix _ ) = AF_UNIX + +seedTransaction :: Int +seedTransaction = 0 + +defaultQueryTimeout :: Int +defaultQueryTimeout = 120 + +-- | Bind socket to the specified address. To enable query handling +-- run 'listen'. +newManager :: SockAddr -- ^ address to listen on; + -> [Handler h] -- ^ handlers to run on incoming queries. + -> IO (Manager h) -- ^ new manager. +newManager servAddr handlers = do + sock <- bindServ + tref <- newEmptyMVar + tran <- newIORef seedTransaction + calls <- newIORef M.empty + return $ Manager sock defaultQueryTimeout tref tran calls handlers + where + bindServ = do + let family = sockAddrFamily servAddr + sock <- socket family Datagram defaultProtocol + when (family == AF_INET6) $ do + setSocketOption sock IPv6Only 0 + bindSocket sock servAddr + return sock + +-- | Unblock all pending calls and close socket. +closeManager :: Manager m -> IO () +closeManager Manager {..} = do + maybe (return ()) killThread =<< tryTakeMVar listenerThread + -- TODO unblock calls + close sock + +-- | Normally you should use Control.Monad.Trans.Resource.allocate +-- function. +withManager :: SockAddr -> [Handler h] -> (Manager h -> IO a) -> IO a +withManager addr hs = bracket (newManager addr hs) closeManager + +{----------------------------------------------------------------------- +-- Client +-----------------------------------------------------------------------} + +sendMessage :: MonadIO m => BEncode a => Socket -> SockAddr -> a -> m () +sendMessage sock addr a = do + liftIO $ sendManyTo sock (BL.toChunks (BE.encode a)) addr + +genTransactionId :: TransactionCounter -> IO TransactionId +genTransactionId ref = do + cur <- atomicModifyIORef' ref $ \ cur -> (succ cur, cur) + return $ BC.pack (show cur) + +registerQuery :: CallId -> PendingCalls -> IO CallRes +registerQuery cid ref = do + ares <- newEmptyMVar + atomicModifyIORef' ref $ \ m -> (M.insert cid ares m, ()) + return ares + +-- simultaneous M.lookup and M.delete guarantees that we never get two +-- or more responses to the same query +unregisterQuery :: CallId -> PendingCalls -> IO (Maybe CallRes) +unregisterQuery cid ref = do + atomicModifyIORef' ref $ swap . + M.updateLookupWithKey (const (const Nothing)) cid + +queryResponse :: BEncode a => CallRes -> IO a +queryResponse ares = do + res <- readMVar ares + KResponse {..} <- either throwIO pure res + case fromBEncode respVals of + Right r -> pure r + Left e -> throwIO $ decodeError e respId + +-- | Enqueue query to the given node. +-- +-- This function will throw exception if quered node respond with +-- @error@ message or timeout expires. +-- +query :: forall h m a b. (MonadKRPC h m, KRPC a b) => SockAddr -> a -> m b +query addr params = do + Manager {..} <- getManager + liftIO $ do + tid <- genTransactionId transactionCounter + let Method name = method :: Method a b + let q = KQuery (toBEncode params) name tid + + ares <- registerQuery (tid, addr) pendingCalls + sendMessage sock addr q + `onException` unregisterQuery (tid, addr) pendingCalls + + mres <- timeout (queryTimeout * 10 ^ (6 :: Int)) $ do + queryResponse ares + + case mres of + Just res -> return res + Nothing -> do + _ <- unregisterQuery (tid, addr) pendingCalls + throwIO $ timeoutExpired tid + +{----------------------------------------------------------------------- +-- Handlers +-----------------------------------------------------------------------} + +-- | Make handler from handler function. Any thrown exception will be +-- supressed and send over the wire back to the querying node. +handler :: forall h a b. (KRPC a b, Monad h) + => (SockAddr -> a -> h b) -> Handler h +handler body = (name, wrapper) + where + Method name = method :: Method a b + wrapper addr args = + case fromBEncode args of + Left e -> return $ Left e + Right a -> do + r <- body addr a + return $ Right $ toBEncode r + +runHandler :: MonadKRPC h m => HandlerBody h -> SockAddr -> KQuery -> m KResult +runHandler h addr KQuery {..} = wrapper `Lifted.catch` failback + where + wrapper = ((`decodeError` queryId) +++ (`KResponse` queryId)) + <$> liftHandler (h addr queryArgs) + failback e = return $ Left $ serverError e queryId + +dispatchHandler :: MonadKRPC h m => KQuery -> SockAddr -> m KResult +dispatchHandler q @ KQuery {..} addr = do + Manager {..} <- getManager + case L.lookup queryMethod handlers of + Nothing -> return $ Left $ unknownMethod queryMethod queryId + Just h -> runHandler h addr q + +{----------------------------------------------------------------------- +-- Listener +-----------------------------------------------------------------------} + +handleQuery :: MonadKRPC h m => KQuery -> SockAddr -> m () +handleQuery q addr = void $ fork $ do + Manager {..} <- getManager + res <- dispatchHandler q addr + sendMessage sock addr $ either toBEncode toBEncode res + +handleResponse :: MonadKRPC h m => KResult -> SockAddr -> m () +handleResponse result addr = do + Manager {..} <- getManager + liftIO $ do + let resultId = either errorId respId result + mcall <- unregisterQuery (resultId, addr) pendingCalls + case mcall of + Nothing -> return () + Just ares -> putMVar ares result + +handleMessage :: MonadKRPC h m => KMessage -> SockAddr -> m () +handleMessage (Q q) = handleQuery q +handleMessage (R r) = handleResponse (Right r) +handleMessage (E e) = handleResponse (Left e) + +maxMsgSize :: Int +maxMsgSize = 64 * 1024 + +listener :: MonadKRPC h m => m () +listener = do + Manager {..} <- getManager + forever $ do + (bs, addr) <- liftIO $ BS.recvFrom sock maxMsgSize + case BE.decode bs of + Left e -> liftIO $ sendMessage sock addr $ unknownMessage e + Right m -> handleMessage m addr + +-- | Should be run before any 'query', otherwise they will never +-- succeed. +listen :: MonadKRPC h m => m () +listen = do + Manager {..} <- getManager + tid <- fork $ listener + liftIO $ putMVar listenerThread tid diff --git a/src/Network/KRPC/Message.hs b/src/Network/KRPC/Message.hs new file mode 100644 --- /dev/null +++ b/src/Network/KRPC/Message.hs @@ -0,0 +1,269 @@ +-- | +-- Copyright : (c) Sam Truzjan 2013 +-- License : BSD3 +-- Maintainer : pxqr.sta@gmail.com +-- Stability : experimental +-- Portability : portable +-- +-- KRPC messages types used in communication. All messages are +-- encoded as bencode dictionary. +-- +-- Normally, you don't need to import this module. +-- +-- See +-- +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE DeriveDataTypeable #-} +module Network.KRPC.Message + ( -- * Transaction + TransactionId + + -- * Error + , ErrorCode (..) + , KError(..) + , serverError + , decodeError + , unknownMethod + , unknownMessage + , timeoutExpired + + -- * Query + , KQuery(..) + , MethodName + + -- * Response + , KResponse(..) + + -- * Message + , KMessage (..) + ) where + +import Control.Applicative +import Control.Exception.Lifted as Lifted +import Data.BEncode as BE +import Data.ByteString as B +import Data.ByteString.Char8 as BC +import Data.Typeable + + +-- | This transaction ID is generated by the querying node and is +-- echoed in the response, so responses may be correlated with +-- multiple queries to the same node. The transaction ID should be +-- encoded as a short string of binary numbers, typically 2 characters +-- are enough as they cover 2^16 outstanding queries. +type TransactionId = ByteString + +unknownTransaction :: TransactionId +unknownTransaction = "" + +{----------------------------------------------------------------------- +-- Error messages +-----------------------------------------------------------------------} + +-- | Types of RPC errors. +data ErrorCode + -- | Some error doesn't fit in any other category. + = GenericError + + -- | Occur when server fail to process procedure call. + | ServerError + + -- | Malformed packet, invalid arguments or bad token. + | ProtocolError + + -- | Occur when client trying to call method server don't know. + | MethodUnknown + deriving (Show, Read, Eq, Ord, Bounded, Typeable) + +-- | According to the table: +-- +instance Enum ErrorCode where + fromEnum GenericError = 201 + fromEnum ServerError = 202 + fromEnum ProtocolError = 203 + fromEnum MethodUnknown = 204 + {-# INLINE fromEnum #-} + + toEnum 201 = GenericError + toEnum 202 = ServerError + toEnum 203 = ProtocolError + toEnum 204 = MethodUnknown + toEnum _ = GenericError + {-# INLINE toEnum #-} + +instance BEncode ErrorCode where + toBEncode = toBEncode . fromEnum + {-# INLINE toBEncode #-} + + fromBEncode b = toEnum <$> fromBEncode b + {-# INLINE fromBEncode #-} + +-- | Errors are sent when a query cannot be fulfilled. Error message +-- can be send only from server to client but not in the opposite +-- direction. +-- +data KError = KError + { errorCode :: !ErrorCode -- ^ the type of error; + , errorMessage :: !ByteString -- ^ human-readable text message; + , errorId :: !TransactionId -- ^ match to the corresponding 'queryId'. + } deriving (Show, Read, Eq, Ord, Typeable) + +-- | Errors, or KRPC message dictionaries with a \"y\" value of \"e\", +-- contain one additional key \"e\". The value of \"e\" is a +-- list. The first element is an integer representing the error +-- code. The second element is a string containing the error +-- message. +-- +-- Example Error Packet: +-- +-- > { "t": "aa", "y":"e", "e":[201, "A Generic Error Ocurred"]} +-- +-- or bencoded: +-- +-- > d1:eli201e23:A Generic Error Ocurrede1:t2:aa1:y1:ee +-- +instance BEncode KError where + toBEncode KError {..} = toDict $ + "e" .=! (errorCode, errorMessage) + .: "t" .=! errorId + .: "y" .=! ("e" :: ByteString) + .: endDict + {-# INLINE toBEncode #-} + + fromBEncode = fromDict $ do + lookAhead $ match "y" (BString "e") + (code, msg) <- field (req "e") + KError code msg <$>! "t" + {-# INLINE fromBEncode #-} + +instance Exception KError + +-- | Happen when some query handler fail. +serverError :: SomeException -> TransactionId -> KError +serverError e = KError ServerError (BC.pack (show e)) + +-- | Received 'queryArgs' or 'respVals' can not be decoded. +decodeError :: String -> TransactionId -> KError +decodeError msg = KError ProtocolError (BC.pack msg) + +-- | If /remote/ node send query /this/ node doesn't know about then +-- this error message should be sent in response. +unknownMethod :: MethodName -> TransactionId -> KError +unknownMethod = KError MethodUnknown + +-- | A remote node has send some 'KMessage' this node is unable to +-- decode. +unknownMessage :: String -> KError +unknownMessage msg = KError ProtocolError (BC.pack msg) unknownTransaction + +-- | A /remote/ node is not responding to the /our/ request the for +-- specified period of time. +timeoutExpired :: TransactionId -> KError +timeoutExpired = KError GenericError "timeout expired" + +{----------------------------------------------------------------------- +-- Query messages +-----------------------------------------------------------------------} + +type MethodName = 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. +-- +data KQuery = KQuery + { queryArgs :: !BValue -- ^ values to be passed to method; + , queryMethod :: !MethodName -- ^ method to call; + , queryId :: !TransactionId -- ^ one-time query token. + } deriving (Show, Read, Eq, Ord, Typeable) + +-- | Queries, or KRPC message dictionaries with a \"y\" value of +-- \"q\", contain two additional keys; \"q\" and \"a\". Key \"q\" has +-- a string value containing the method name of the query. Key \"a\" +-- has a dictionary value containing named arguments to the query. +-- +-- Example Query packet: +-- +-- > { "t" : "aa", "y" : "q", "q" : "ping", "a" : { "msg" : "hi!" } } +-- +instance BEncode KQuery where + toBEncode KQuery {..} = toDict $ + "a" .=! queryArgs + .: "q" .=! queryMethod + .: "t" .=! queryId + .: "y" .=! ("q" :: ByteString) + .: endDict + {-# INLINE toBEncode #-} + + fromBEncode = fromDict $ do + lookAhead $ match "y" (BString "q") + KQuery <$>! "a" <*>! "q" <*>! "t" + {-# INLINE fromBEncode #-} + +{----------------------------------------------------------------------- +-- Response messages +-----------------------------------------------------------------------} + +-- | Response messages are sent upon successful completion of a +-- query: +-- +-- * 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, +-- 'KError' should be sent instead. +-- +-- * KResponse can be only sent from server to client. +-- +data KResponse = KResponse + { respVals :: BValue -- ^ 'BDict' containing return values; + , respId :: TransactionId -- ^ match to the corresponding 'queryId'. + } deriving (Show, Read, Eq, Ord, Typeable) + +-- | Responses, or KRPC message dictionaries with a \"y\" value of +-- \"r\", contain one additional key \"r\". The value of \"r\" is a +-- dictionary containing named return values. +-- +-- Example Response packet: +-- +-- > { "t" : "aa", "y" : "r", "r" : { "msg" : "you've sent: hi!" } } +-- +instance BEncode KResponse where + toBEncode KResponse {..} = toDict $ + "r" .=! respVals + .: "t" .=! respId + .: "y" .=! ("r" :: ByteString) + .: endDict + {-# INLINE toBEncode #-} + + fromBEncode = fromDict $ do + lookAhead $ match "y" (BString "r") + KResponse <$>! "r" <*>! "t" + {-# INLINE fromBEncode #-} + +{----------------------------------------------------------------------- +-- Summed messages +-----------------------------------------------------------------------} + +-- | Generic KRPC message. +data KMessage + = Q KQuery + | R KResponse + | E KError + deriving (Show, Eq) + +instance BEncode KMessage where + toBEncode (Q q) = toBEncode q + toBEncode (R r) = toBEncode r + toBEncode (E e) = toBEncode e + + fromBEncode b = + Q <$> fromBEncode b + <|> R <$> fromBEncode b + <|> E <$> fromBEncode b + <|> decodingError "KMessage: unknown message or message tag" diff --git a/src/Network/KRPC/Method.hs b/src/Network/KRPC/Method.hs new file mode 100644 --- /dev/null +++ b/src/Network/KRPC/Method.hs @@ -0,0 +1,87 @@ +-- | +-- Copyright : (c) Sam Truzjan 2013 +-- License : BSD3 +-- Maintainer : pxqr.sta@gmail.com +-- Stability : experimental +-- Portability : portable +-- +-- Normally, you don't need to import this module. +-- +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE DefaultSignatures #-} +module Network.KRPC.Method + ( Method (..) + , KRPC (..) + ) where + +import Data.BEncode (BEncode) +import Data.ByteString.Char8 as BC +import Data.Char +import Data.Monoid +import Data.List as L +import Data.String +import Data.Typeable +import Network.KRPC.Message + + +-- | Method datatype used to describe method 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. +-- +-- * result: Type of return value of the method. +-- +newtype Method param result = Method MethodName + deriving (Eq, Ord, IsString, BEncode) + +-- | Example: +-- +-- @show (Method \"concat\" :: [Int] Int) == \"concat :: [Int] -> Int\"@ +-- +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 name) = + showString (BC.unpack name) <> + showString " :: " <> + shows paramsTy <> + showString " -> " <> + shows valuesTy + where + impossible = error "KRPC.showsMethod: impossible" + paramsTy = typeOf (impossible :: a) + valuesTy = typeOf (impossible :: b) + +-- | In order to perform or handle KRPC query you need to provide +-- corresponding 'KRPC' class. +-- +-- Example: +-- +-- @ +-- data Ping = Ping Text deriving BEncode +-- data Pong = Pong Text deriving BEncode +-- +-- instance 'KRPC' Ping Pong where +-- method = \"ping\" +-- @ +-- +class (BEncode req, BEncode resp) => KRPC req resp | req -> resp where + -- | Method name. Default implementation uses lowercased @req@ + -- datatype name. + -- + method :: Method req resp + + -- TODO add underscores + default method :: Typeable req => Method req resp + method = Method $ fromString $ L.map toLower $ show $ typeOf hole + where + hole = error "krpc.method: impossible" :: req diff --git a/src/Network/KRPC/Protocol.hs b/src/Network/KRPC/Protocol.hs deleted file mode 100644 --- a/src/Network/KRPC/Protocol.hs +++ /dev/null @@ -1,252 +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 --- -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE DefaultSignatures #-} -{-# LANGUAGE DeriveDataTypeable #-} -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 - ) 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 as BE -import Data.BEncode.BDict as BE -import Data.BEncode.Types as BE -import Data.ByteString as B -import Data.ByteString.Char8 as BC -import qualified Data.ByteString.Lazy as LB -import Data.Typeable - -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, Typeable) - -instance BEncode KError where - {-# SPECIALIZE instance BEncode KError #-} - {-# INLINE toBEncode #-} - toBEncode e = toDict $ - "e" .=! (errorCode e, errorMessage e) - .: "y" .=! ("e" :: ByteString) - .: endDict - - {-# INLINE fromBEncode #-} - fromBEncode be @ (BDict d) - | BE.lookup "y" d == Just (BString "e") - = (`fromDict` be) $ do - uncurry mkKError <$>! "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 - - -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 :: BDict - } deriving (Show, Read, Eq, Ord, Typeable) - -instance BEncode KQuery where - {-# SPECIALIZE instance BEncode KQuery #-} - {-# INLINE toBEncode #-} - toBEncode (KQuery m args) = toDict $ - "a" .=! BDict args - .: "q" .=! m - .: "y" .=! ("q" :: ByteString) - .: endDict - - {-# INLINE fromBEncode #-} - fromBEncode bv @ (BDict d) - | BE.lookup "y" d == Just (BString "q") = (`fromDict` bv) $ do - a <- field (req "a") - q <- field (req "q") - return $! KQuery q a - - fromBEncode _ = decodingError "KQuery" - -kquery :: MethodName -> BDict -> KQuery -kquery = KQuery -{-# 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, Typeable) - -instance BEncode KResponse where - {-# INLINE toBEncode #-} - toBEncode (KResponse vals) = toDict $ - "r" .=! vals - .: "y" .=! ("r" :: ByteString) - .: endDict - - {-# INLINE fromBEncode #-} - fromBEncode bv @ (BDict d) - | BE.lookup "y" d == Just (BString "r") = (`fromDict` bv) $ do - KResponse <$>! "r" - - fromBEncode _ = decodingError "KDict" - -kresponse :: BDict -> KResponse -kresponse = KResponse -{-# INLINE kresponse #-} - -type KRemoteAddr = SockAddr -type KRemote = Socket - -sockAddrFamily :: SockAddr -> Family -sockAddrFamily (SockAddrInet _ _ ) = AF_INET -sockAddrFamily (SockAddrInet6 _ _ _ _) = AF_INET6 -sockAddrFamily (SockAddrUnix _ ) = AF_UNIX - -withRemote :: (MonadBaseControl IO m, MonadIO m) => (KRemote -> m a) -> m a -withRemote = bracket (liftIO (socket AF_INET6 Datagram defaultProtocol)) - (liftIO . sClose) -{-# SPECIALIZE withRemote :: (KRemote -> IO a) -> IO a #-} - -maxMsgSize :: Int ---maxMsgSize = 512 -- release: size of payload of one udp packet -maxMsgSize = 64 * 1024 -- bench: max UDP MTU -{-# INLINE maxMsgSize #-} - -sendMessage :: BEncode msg => msg -> KRemoteAddr -> KRemote -> IO () -sendMessage msg addr sock = sendManyTo sock (LB.toChunks (encode msg)) addr -{-# INLINE sendMessage #-} - -recvResponse :: KRemote -> IO (Either KError KResponse) -recvResponse sock = do - (raw, _) <- recvFrom sock maxMsgSize - return $ case decode raw of - Right resp -> Right resp - Left decE -> Left $ case decode 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) - => KRemoteAddr -- ^ Port number to listen. - -> (KRemoteAddr -> KQuery -> remote (Either KError KResponse)) - -- ^ Handler. - -> remote () -remoteServer servAddr action = bracket (liftIO bindServ) (liftIO . sClose) loop - where - bindServ = do - let family = sockAddrFamily servAddr - sock <- socket family Datagram defaultProtocol - when (family == AF_INET6) $ do - setSocketOption sock IPv6Only 0 - bindSocket sock servAddr - return sock - - loop sock = forever $ do - (bs, addr) <- liftIO $ recvFrom sock maxMsgSize - reply <- handleMsg bs addr - liftIO $ sendMessage reply addr sock - where - handleMsg bs addr = case decode 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 deleted file mode 100644 --- a/src/Network/KRPC/Scheme.hs +++ /dev/null @@ -1,82 +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 Network.KRPC.Scheme - ( KMessage(..) - , KQueryScheme(..), methodQueryScheme - , KResponseScheme(..), methodRespScheme - ) where - -import Control.Applicative -import Data.BEncode.BDict as BS -import Data.BEncode.Types as BS - -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 - scheme = errorCode - {-# INLINE scheme #-} - -data KQueryScheme = KQueryScheme { - qscMethod :: MethodName - , qscParams :: [ParamName] - } deriving (Show, Read, Eq, Ord) - -bdictKeys :: BDict -> [BKey] -bdictKeys (Cons k _ xs) = k : bdictKeys xs -bdictKeys Nil = [] - -instance KMessage KQuery KQueryScheme where - scheme q = KQueryScheme - { qscMethod = queryMethod q - , qscParams = bdictKeys $ queryArgs q - } - {-# INLINE scheme #-} - -methodQueryScheme :: Method a b -> KQueryScheme -methodQueryScheme = KQueryScheme <$> methodName <*> methodParams -{-# INLINE methodQueryScheme #-} - -newtype KResponseScheme = KResponseScheme - { rscVals :: [ValName] - } deriving (Show, Read, Eq, Ord) - -instance KMessage KResponse KResponseScheme where - {-# SPECIALIZE instance KMessage KResponse KResponseScheme #-} - scheme = KResponseScheme . bdictKeys . respVals - {-# INLINE scheme #-} - -methodRespScheme :: Method a b -> KResponseScheme -methodRespScheme = KResponseScheme . methodVals -{-# INLINE methodRespScheme #-} diff --git a/tests/Client.hs b/tests/Client.hs deleted file mode 100644 --- a/tests/Client.hs +++ /dev/null @@ -1,80 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -module Main (main) where - -import Control.Concurrent -import Control.Exception -import qualified Data.ByteString as B -import Data.BEncode as BE -import Data.BEncode.BDict as BE -import System.Process -import System.FilePath - -import Test.HUnit hiding (Test) -import Test.Framework -import Test.Framework.Providers.HUnit - -import Network.KRPC -import Network.Socket -import Shared - - -addr :: RemoteAddr -addr = SockAddrInet 6000 0 - -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 - - , testCase "raw method" $ - BInteger 10 ==? call addr rawM (BInteger 10) - - , testCase "raw dict" $ - let dict = BDict $ BE.fromAscList - [ ("some_int", BInteger 100) - , ("some_list", BList [BInteger 10]) - ] - in dict ==? call addr rawDictM dict - ] diff --git a/tests/Network/KRPC/MessageSpec.hs b/tests/Network/KRPC/MessageSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Network/KRPC/MessageSpec.hs @@ -0,0 +1,71 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +module Network.KRPC.MessageSpec (spec) where +import Control.Applicative +import Data.ByteString.Lazy as BL +import Test.Hspec +import Test.QuickCheck +import Test.QuickCheck.Instances () + +import Data.BEncode as BE +import Network.KRPC.Message + +instance Arbitrary ErrorCode where + arbitrary = arbitraryBoundedEnum + +instance Arbitrary KError where + arbitrary = KError <$> arbitrary <*> arbitrary <*> arbitrary + +instance Arbitrary KQuery where + arbitrary = KQuery <$> pure (BInteger 0) <*> arbitrary <*> arbitrary + +instance Arbitrary KResponse where + arbitrary = KResponse <$> pure (BList []) <*> arbitrary + +instance Arbitrary KMessage where + arbitrary = frequency + [ (1, Q <$> arbitrary) + , (1, R <$> arbitrary) + , (1, E <$> arbitrary) + ] + +spec :: Spec +spec = do + describe "error message" $ do + it "properly bencoded (iso)" $ property $ \ ke -> + BE.decode (BL.toStrict (BE.encode ke)) `shouldBe` Right (ke :: KError) + + it "properly bencoded" $ do + BE.decode "d1:eli201e23:A Generic Error Ocurrede1:t2:aa1:y1:ee" + `shouldBe` Right (KError GenericError "A Generic Error Ocurred" "aa") + + BE.decode "d1:eli202e22:A Server Error Ocurrede1:t2:bb1:y1:ee" + `shouldBe` Right (KError ServerError "A Server Error Ocurred" "bb") + + BE.decode "d1:eli203e24:A Protocol Error Ocurrede1:t2:cc1:y1:ee" + `shouldBe` Right (KError ProtocolError "A Protocol Error Ocurred" "cc") + + BE.decode "d1:eli204e30:Attempt to call unknown methode1:t2:dd1:y1:ee" + `shouldBe` Right + (KError MethodUnknown "Attempt to call unknown method" "dd") + + describe "query message" $ do + it "properly bencoded (iso)" $ property $ \ kq -> + BE.decode (BL.toStrict (BE.encode kq)) `shouldBe` Right (kq :: KQuery) + + it "properly bencoded" $ do + BE.decode "d1:ale1:q4:ping1:t2:aa1:y1:qe" `shouldBe` + Right (KQuery (BList []) "ping" "aa") + + + describe "response message" $ do + it "properly bencoded (iso)" $ property $ \ kr -> + BE.decode (BL.toStrict (BE.encode kr)) `shouldBe` Right (kr :: KResponse) + + it "properly bencoded" $ do + BE.decode "d1:rle1:t2:aa1:y1:re" `shouldBe` + Right (KResponse (BList []) "aa") + + describe "generic message" $ do + it "properly bencoded (iso)" $ property $ \ km -> + BE.decode (BL.toStrict (BE.encode km)) `shouldBe` Right (km :: KMessage) diff --git a/tests/Network/KRPC/MethodSpec.hs b/tests/Network/KRPC/MethodSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Network/KRPC/MethodSpec.hs @@ -0,0 +1,52 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +module Network.KRPC.MethodSpec where +import Control.Applicative +import Data.BEncode +import Data.ByteString as BS +import Data.Typeable +import Network.KRPC +import Test.Hspec + + +data Ping = Ping + deriving (Show, Eq, Typeable) + +instance BEncode Ping where + toBEncode Ping = toBEncode () + fromBEncode b = Ping <$ (fromBEncode b :: Result ()) + +instance KRPC Ping Ping + +ping :: Monad h => Handler h +ping = handler $ \ _ Ping -> return Ping + +newtype Echo a = Echo a + deriving (Show, Eq, BEncode, Typeable) + +echo :: Monad h => Handler h +echo = handler $ \ _ (Echo a) -> return (Echo (a :: ByteString)) + +instance (Typeable a, BEncode a) => KRPC (Echo a) (Echo a) + +spec :: Spec +spec = do + describe "ping method" $ do + it "name is ping" $ do + (method :: Method Ping Ping) `shouldBe` "ping" + + it "has pretty Show instance" $ do + show (method :: Method Ping Ping) `shouldBe` "ping :: Ping -> Ping" + + describe "echo method" $ do + it "is overloadable" $ do + (method :: Method (Echo Int ) (Echo Int )) `shouldBe` "echo int" + (method :: Method (Echo Bool) (Echo Bool)) `shouldBe` "echo bool" + + it "has pretty Show instance" $ do + show (method :: Method (Echo Int) (Echo Int)) + `shouldBe` "echo int :: Echo Int -> Echo Int" diff --git a/tests/Network/KRPCSpec.hs b/tests/Network/KRPCSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Network/KRPCSpec.hs @@ -0,0 +1,33 @@ +{-# LANGUAGE OverloadedStrings #-} +module Network.KRPCSpec (spec) where +import Control.Monad.Reader +import Network.Socket (SockAddr (..)) +import Network.KRPC +import Network.KRPC.MethodSpec hiding (spec) +import Test.Hspec + +servAddr :: SockAddr +servAddr = SockAddrInet 6000 (256 * 256 * 256 + 127) + +handlers :: [Handler IO] +handlers = + [ handler $ \ _ Ping -> return Ping + , handler $ \ _ (Echo a) -> return (Echo (a :: Bool)) + , handler $ \ _ (Echo a) -> return (Echo (a :: Int)) + ] + +spec :: Spec +spec = do + describe "query" $ do + it "run handlers" $ do + let int = 0xabcd :: Int + (withManager servAddr handlers $ runReaderT $ do + listen + query servAddr (Echo int)) + `shouldReturn` Echo int + + it "throw timeout exception" $ do + (withManager servAddr handlers $ runReaderT $ do + query servAddr (Echo (0xabcd :: Int)) + ) + `shouldThrow` (== KError GenericError "timeout expired" "0") diff --git a/tests/Server.hs b/tests/Server.hs deleted file mode 100644 --- a/tests/Server.hs +++ /dev/null @@ -1,20 +0,0 @@ -{-# LANGUAGE IncoherentInstances #-} -module Main (main) where - -import Data.BEncode -import Network.KRPC -import Network.Socket -import Shared - - -main :: IO () -main = server (SockAddrInet 6000 0) - [ unitM ==> return - , echoM ==> return - , echoBytes ==> return - , swapM ==> \(a, b) -> return (b, a) - , reverseM ==> return . reverse - , shiftR ==> \(a, b, c) -> return (c, a, b) - , rawM ==> return - , rawDictM ==> return - ] diff --git a/tests/Shared.hs b/tests/Shared.hs deleted file mode 100644 --- a/tests/Shared.hs +++ /dev/null @@ -1,39 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -module Shared - ( echoM - , echoBytes - , unitM - , swapM - , reverseM - , shiftR - , rawM - , rawDictM - ) where - -import Data.ByteString (ByteString) -import Data.BEncode -import Network.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"] - -rawM :: Method BValue BValue -rawM = method "rawM" [""] [""] - -rawDictM :: Method BValue BValue -rawDictM = method "m" [] [] diff --git a/tests/Spec.hs b/tests/Spec.hs new file mode 100644 --- /dev/null +++ b/tests/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-}