krpc 0.4.1.1 → 0.5.0.0
raw patch · 18 files changed
+905/−881 lines, 18 filesdep +QuickCheckdep +containersdep +hspecdep −HUnitdep −filepathdep −processdep ~bencodingdep ~bytestringdep ~network
Dependencies added: QuickCheck, containers, hspec, mtl, quickcheck-instances
Dependencies removed: HUnit, filepath, process, test-framework, test-framework-hunit
Dependency ranges changed: bencoding, bytestring, network
Files
- ChangeLog +48/−0
- bench/Main.hs +22/−23
- bench/Server.hs +0/−13
- changelog +0/−11
- krpc.cabal +25/−48
- src/Network/KRPC.hs +32/−313
- src/Network/KRPC/Manager.hs +265/−0
- src/Network/KRPC/Message.hs +269/−0
- src/Network/KRPC/Method.hs +87/−0
- src/Network/KRPC/Protocol.hs +0/−252
- src/Network/KRPC/Scheme.hs +0/−82
- tests/Client.hs +0/−80
- tests/Network/KRPC/MessageSpec.hs +71/−0
- tests/Network/KRPC/MethodSpec.hs +52/−0
- tests/Network/KRPCSpec.hs +33/−0
- tests/Server.hs +0/−20
- tests/Shared.hs +0/−39
- tests/Spec.hs +1/−0
+ ChangeLog view
@@ -0,0 +1,48 @@+2013-12-25 Sam Truzjan <pxqr.sta@gmail.com>++ 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 <pxqr.sta@gmail.com>++ * 0.4.1.1: Fixed build failure on GHC == 7.4.*++2013-10-17 Sam Truzjan <pxqr.sta@gmail.com>++ * 0.4.1.0: Use bencoding-0.4.*++2013-10-03 Sam Truzjan <pxqr.sta@gmail.com>++ * 0.4.0.1: Minor documentation fixes.++2013-10-03 Sam Truzjan <pxqr.sta@gmail.com>++ * 0.4.0.0: IPv6 support.++2013-09-28 Sam Truzjan <pxqr.sta@gmail.com>++ * 0.3.0.0: Use bencoding-0.3.*+ * Rename Remote.* to Network.* modules.++2013-09-28 Sam Truzjan <pxqr.sta@gmail.com>++ * 0.2.2.0: Use bencoding-0.2.2.*++2013-08-27 Sam Truzjan <pxqr.sta@gmail.com>++ * 0.2.0.0: Async API have been removed, use /async/ package+ instead.+ * Expose caller address in handlers.++2013-07-09 Sam Truzjan <pxqr.sta@gmail.com>++ * 0.1.1.0: Allow passing raw argument\/result dictionaries.++2013-07-09 Sam Truzjan <pxqr.sta@gmail.com>++ * 0.1.0.0: Initial version.
bench/Main.hs view
@@ -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
− bench/Server.hs
@@ -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 ]
− changelog
@@ -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.*
krpc.cabal view
@@ -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.+ .+ <http://bittorrent.org/beps/bep_0005.html#krpc-protocol> 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
src/Network/KRPC.hs view
@@ -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 (..))
+ src/Network/KRPC/Manager.hs view
@@ -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
+ src/Network/KRPC/Message.hs view
@@ -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 <http://www.bittorrent.org/beps/bep_0005.html#krpc-protocol>+--+{-# 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:+-- <http://bittorrent.org/beps/bep_0005.html#errors>+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"
+ src/Network/KRPC/Method.hs view
@@ -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
− src/Network/KRPC/Protocol.hs
@@ -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 <http://www.bittorrent.org/beps/bep_0005.html#krpc-protocol>----{-# 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" : [<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, 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" : "<method_name>", "a" : [<arg1>, <arg2>, ...] }----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" : [<val1>, <val2>, ...] }----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))
− src/Network/KRPC/Scheme.hs
@@ -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 #-}
− tests/Client.hs
@@ -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- ]
+ tests/Network/KRPC/MessageSpec.hs view
@@ -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)
+ tests/Network/KRPC/MethodSpec.hs view
@@ -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"
+ tests/Network/KRPCSpec.hs view
@@ -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")
− tests/Server.hs
@@ -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- ]
@@ -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" [] []
+ tests/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}