diff --git a/krpc.cabal b/krpc.cabal --- a/krpc.cabal +++ b/krpc.cabal @@ -1,5 +1,5 @@ name: krpc -version: 0.1.0.0 +version: 0.2.0.0 license: MIT license-file: LICENSE author: Sam T. @@ -7,9 +7,11 @@ copyright: (c) 2013, Sam T. category: Network build-type: Simple -cabal-version: >=1.8 -homepage: https://github.com/pxqr/krpc -bug-reports: https://github.com/pxqr/krpc/issues +cabal-version: >= 1.10 +tested-with: GHC == 7.4.1 + , 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. description: @@ -18,19 +20,26 @@ [/Release Notes/] . * /0.1.0.0:/ Initial version. - + . + * /0.1.1.0:/ Allow passing raw argument\/result dictionaries. + . + * /0.2.0.0:/ Async API have been removed, use /async/ package instead. + Expose caller address in handlers. source-repository head type: git - location: git://github.com/pxqr/krpc.git + location: git://github.com/cobit/krpc.git library + default-language: Haskell2010 + default-extensions: PatternGuards + , RecordWildCards + hs-source-dirs: src exposed-modules: Remote.KRPC , Remote.KRPC.Protocol , Remote.KRPC.Scheme - build-depends: base == 4.* , lifted-base >= 0.1.1 @@ -39,55 +48,58 @@ , bytestring >= 0.10 , containers >= 0.4 - , bencoding >= 0.1 + , bencoding >= 0.2 , network >= 2.3 - - - hs-source-dirs: src - extensions: PatternGuards ghc-options: -Wall - test-suite test-client type: exitcode-stdio-1.0 + default-language: Haskell2010 + hs-source-dirs: tests main-is: Client.hs other-modules: Shared build-depends: base == 4.* , bytestring + , containers , process , filepath + , bencoding , krpc , HUnit , test-framework , test-framework-hunit - hs-source-dirs: tests executable test-server + default-language: Haskell2010 + hs-source-dirs: tests main-is: Server.hs other-modules: Shared build-depends: base == 4.* , bytestring + , bencoding , krpc - hs-source-dirs: tests - - - - executable bench-server - main-is: Server.hs - build-depends: base == 4.*, krpc, bytestring + default-language: Haskell2010 hs-source-dirs: bench + main-is: Server.hs + build-depends: base == 4.* + , bytestring + , krpc ghc-options: -fforce-recomp benchmark bench-client type: exitcode-stdio-1.0 - main-is: Main.hs + default-language: Haskell2010 hs-source-dirs: bench - build-depends: base == 4.5.*, krpc, criterion, bytestring + main-is: Main.hs + build-depends: base == 4.* + , bytestring + , criterion + , krpc ghc-options: -O2 -fforce-recomp diff --git a/src/Remote/KRPC.hs b/src/Remote/KRPC.hs --- a/src/Remote/KRPC.hs +++ b/src/Remote/KRPC.hs @@ -80,14 +80,20 @@ -- Here we implement method signature from that shared lib and run -- server with runServer by passing method table in. -- +-- For async API use /async/ package, old API have been removed. +-- -- For more examples see @exsamples@ or @tests@ directories. -- -- For protocol details see 'Remote.KRPC.Protocol' module. -- -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE FlexibleContexts, DeriveDataTypeable #-} -{-# LANGUAGE ExplicitForAll, KindSignatures #-} -{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE ExplicitForAll #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE DeriveGeneric #-} module Remote.KRPC ( -- * Method Method(..) @@ -96,10 +102,13 @@ -- * Client , RemoteAddr , RPCException(..) - , call, Async, async, await + , call -- * Server - , MethodHandler, (==>), server + , MethodHandler + , (==>) + , (==>@) + , server -- * Internal , call_ @@ -114,11 +123,14 @@ import Data.ByteString.Char8 as BC import Data.List as L import Data.Map as M +import Data.Monoid import Data.Typeable import Network +import GHC.Generics import Remote.KRPC.Protocol + -- | Method datatype used to describe name, parameters and return -- values of procedure. Client use a method to /invoke/, server -- /implements/ the method to make the actual work. @@ -134,6 +146,13 @@ -- 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 @@ -143,10 +162,45 @@ -- | Name of each return value in /right to left/ order. , methodVals :: [ValName] - } + } deriving (Eq, Ord, Generic) --- TODO ppMethod +instance BEncodable (Method a b) +instance (Typeable a, Typeable b) => Show (Method a b) where + showsPrec _ = showsMethod + +showsMethod + :: forall a. forall b. + Typeable a => Typeable b + => Method a b -> ShowS +showsMethod Method {..} = + showString (BC.unpack methodName) <> + showString " :: " <> + showsTuple methodParams paramsTy <> + showString " -> " <> + showsTuple methodVals valuesTy + where + paramsTy = typeOf (error "KRPC.showsMethod: impossible" :: a) + valuesTy = typeOf (error "KRPC.showsMethod: impossible" :: b) + + showsTuple ns ty + = showChar '(' + <> mconcat (L.intersperse (showString ", ") $ + L.zipWith showsTyArgName ns (detuple ty)) + <> showChar ')' + + showsTyArgName ns ty + = showString (BC.unpack ns) + <> showString " :: " + <> showString (show ty) + + detuple tyRep + | L.null args = [tyRep] + | otherwise = args + where + args = typeRepArgs tyRep + + -- | Identity procedure signature. Could be used for echo -- servers. Implemented as: -- @@ -170,26 +224,29 @@ method = Method {-# INLINE method #-} +lookupKey :: ParamName -> Map ByteString BEncode -> Result BEncode +lookupKey x = maybe (Left ("not found key " ++ BC.unpack x)) Right . M.lookup x -extractArgs :: BEncodable arg - => [ParamName] -> Map ParamName BEncode -> Result arg -extractArgs as d = fromBEncode =<< - case as of - [] -> Right (BList []) - [x] -> f x - xs -> BList <$> mapM f xs - where - f x = maybe (Left ("not found key " ++ BC.unpack x)) Right - (M.lookup x d) +extractArgs :: [ParamName] -> Map ParamName BEncode -> Result BEncode +extractArgs [] d = Right $ if M.null d then BList [] else BDict d +extractArgs [x] d = lookupKey x d +extractArgs xs d = BList <$> mapM (`lookupKey` d) xs {-# INLINE extractArgs #-} -injectVals :: BEncodable arg => [ParamName] -> arg -> [(ParamName, BEncode)] -injectVals [] (toBEncode -> BList []) = [] -injectVals [p] (toBEncode -> arg) = [(p, arg)] -injectVals ps (toBEncode -> BList as) = L.zip ps as -injectVals _ _ = error "KRPC.injectVals: impossible" +injectVals :: [ParamName] -> BEncode -> [(ParamName, BEncode)] +injectVals [] (BList []) = [] +injectVals [] (BDict d ) = M.toList d +injectVals [] be = invalidParamList [] be +injectVals [p] arg = [(p, arg)] +injectVals ps (BList as) = L.zip ps as +injectVals ps be = invalidParamList ps be {-# INLINE injectVals #-} +invalidParamList :: [ParamName] -> BEncode -> a +invalidParamList pl be + = error $ "KRPC invalid parameter list: " ++ show pl ++ "\n" ++ + "while procedure args are: " ++ show be + -- | Alias to Socket, through might change in future. type Remote = Socket @@ -210,7 +267,7 @@ -> Method param result -> param -> IO () queryCall sock addr m arg = sendMessage q addr sock where - q = kquery (methodName m) (injectVals (methodParams m) arg) + q = kquery (methodName m) (injectVals (methodParams m) (toBEncode arg)) getResult :: BEncodable result => KRemote @@ -220,7 +277,7 @@ case resp of Left e -> throw (RPCException e) Right (respVals -> dict) -> do - case extractArgs (methodVals m) dict of + case fromBEncode =<< extractArgs (methodVals m) dict of Right vals -> return vals Left e -> throw (RPCException (ProtocolError (BC.pack e))) @@ -248,52 +305,7 @@ getResult sock m --- | Asynchonous result typically get from 'async' call. Used to defer --- return values transfer. -newtype Async result = Async { waitResult :: IO result } - - --- | Query procedure call but not wait for its results. This function --- returns 'Async' value which is handle to procedure result. Actual --- result might be obtained with 'await'. Unable to throw --- 'RPCException', this might happen in 'await' if at all. --- --- Note that sending multiple queries at the same time to the one --- remote is not recommended. For exsample in the following scenario: --- --- > aa <- async theRemote .... --- > ab <- async theRemote .... --- > a <- await ab --- > b <- await ab --- --- it's likely that the /a/ and /b/ values will be mixed up. So in --- order to get correct results you need to make 'await' before the --- next 'async'. --- -async :: MonadIO host - => (BEncodable param, BEncodable result) - => RemoteAddr -- ^ Address of callee. - -> Method param result -- ^ Procedure to call. - -> param -- ^ Arguments passed by callee to procedure. - -> host (Async result) -- ^ Handle to result. -async addr m arg = do - liftIO $ withRemote $ \sock -> - queryCall sock addr m arg - return $ Async $ withRemote $ \sock -> - getResult sock m - --- | Will wait until the callee finished processing of procedure call --- and return its results. Throws 'RPCException' on any error --- occurred. -await :: MonadIO host - => Async result -- ^ Obtained from the corresponding 'async'. - -> host result -- ^ Result values of the procedure call quered - -- with 'async'. -await = liftIO . waitResult -{-# INLINE await #-} - - -type HandlerBody remote = KQuery -> remote (Either KError KResponse) +type HandlerBody remote = KRemoteAddr -> KQuery -> remote (Either KError KResponse) -- | Procedure signature and implementation binded up. type MethodHandler remote = (MethodName, HandlerBody remote) @@ -307,17 +319,28 @@ -> (param -> remote result) -- ^ Implementation. -> MethodHandler remote -- ^ Handler used by server. {-# INLINE (==>) #-} -m ==> body = (methodName m, newbody) +m ==> body = m ==>@ const body +infix 1 ==> + +-- | Similar to '==>@' but additionally pass caller address. +(==>@) :: forall (remote :: * -> *) (param :: *) (result :: *). + (BEncodable param, BEncodable result) + => Monad remote + => Method param result -- ^ Signature. + -> (KRemoteAddr -> param -> remote result) -- ^ Implementation. + -> MethodHandler remote -- ^ Handler used by server. +{-# INLINE (==>@) #-} +m ==>@ body = (methodName m, newbody) where {-# INLINE newbody #-} - newbody q = - case extractArgs (methodParams m) (queryArgs q) of + newbody addr q = + case fromBEncode =<< extractArgs (methodParams m) (queryArgs q) of Left e -> return (Left (ProtocolError (BC.pack e))) Right a -> do - r <- body a - return (Right (kresponse (injectVals (methodVals m) r))) + r <- body addr a + return (Right (kresponse (injectVals (methodVals m) (toBEncode r)))) -infix 1 ==> +infix 1 ==>@ -- TODO: allow forkIO @@ -330,11 +353,10 @@ -> [MethodHandler remote] -- ^ Method table. -> remote () server servport handlers = do - remoteServer servport $ \_ q -> do + remoteServer servport $ \addr q -> do case dispatch (queryMethod q) of Nothing -> return $ Left $ MethodUnknown (queryMethod q) - Just m -> invoke m q + Just m -> m addr q where handlerMap = M.fromList handlers dispatch s = M.lookup s handlerMap - invoke m q = m q diff --git a/src/Remote/KRPC/Protocol.hs b/src/Remote/KRPC/Protocol.hs --- a/src/Remote/KRPC/Protocol.hs +++ b/src/Remote/KRPC/Protocol.hs @@ -11,10 +11,12 @@ -- -- > See http://www.bittorrent.org/beps/bep_0005.html#krpc-protocol -- -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE FlexibleContexts, TypeSynonymInstances #-} -{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies #-} -{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE DefaultSignatures #-} module Remote.KRPC.Protocol ( @@ -36,9 +38,8 @@ , encode, encoded, decode, decoded, toBEncode, fromBEncode ) where -import Prelude hiding (catch) import Control.Applicative -import Control.Exception.Lifted +import Control.Exception.Lifted as Lifted import Control.Monad import Control.Monad.IO.Class import Control.Monad.Trans.Control @@ -59,7 +60,7 @@ -- -- Errors are encoded as bencoded dictionary: -- --- { "y" : "e", "e" : [, ] } +-- > { "y" : "e", "e" : [, ] } -- data KError -- | Some error doesn't fit in any other category. @@ -122,7 +123,7 @@ -- -- Queries are encoded as bencoded dictionary: -- --- { "y" : "q", "q" : "", "a" : [, , ...] } +-- > { "y" : "q", "q" : "", "a" : [, , ...] } -- data KQuery = KQuery { queryMethod :: MethodName @@ -162,7 +163,7 @@ -- -- Responses are encoded as bencoded dictionary: -- --- { "y" : "r", "r" : [, , ...] } +-- > { "y" : "r", "r" : [, , ...] } -- newtype KResponse = KResponse { respVals :: Map ValName BEncode @@ -213,7 +214,6 @@ sendMessage msg (host, port) sock = sendAllTo sock (LB.toStrict (encoded msg)) (SockAddrInet port host) {-# INLINE sendMessage #-} -{-# SPECIALIZE sendMessage :: BEncode -> KRemoteAddr -> KRemote -> IO () #-} recvResponse :: KRemote -> IO (Either KError KResponse) recvResponse sock = do @@ -230,9 +230,9 @@ -> (KRemoteAddr -> KQuery -> remote (Either KError KResponse)) -- ^ Handler. -> remote () -remoteServer servport action = bracket (liftIO bind) (liftIO . sClose) loop +remoteServer servport action = bracket (liftIO bindServ) (liftIO . sClose) loop where - bind = do + bindServ = do sock <- socket AF_INET Datagram defaultProtocol bindSocket sock (SockAddrInet servport iNADDR_ANY) return sock @@ -249,5 +249,5 @@ where handleMsg bs addr = case decoded bs of Right query -> (either toBEncode toBEncode <$> action addr query) - `catch` (return . toBEncode . serverError) + `Lifted.catch` (return . toBEncode . serverError) Left decodeE -> return $ toBEncode (ProtocolError (BC.pack decodeE)) diff --git a/src/Remote/KRPC/Scheme.hs b/src/Remote/KRPC/Scheme.hs --- a/src/Remote/KRPC/Scheme.hs +++ b/src/Remote/KRPC/Scheme.hs @@ -10,9 +10,10 @@ -- with 'Remote.KRPC.Protocol', otherwise (if you are using 'Remote.KRPC') -- this module seems to be useless. -- -{-# LANGUAGE DefaultSignatures #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FunctionalDependencies #-} module Remote.KRPC.Scheme ( KMessage(..) , KQueryScheme(..), methodQueryScheme diff --git a/tests/Client.hs b/tests/Client.hs --- a/tests/Client.hs +++ b/tests/Client.hs @@ -4,6 +4,8 @@ import Control.Concurrent import Control.Exception import qualified Data.ByteString as B +import Data.BEncode +import Data.Map import System.Environment import System.Process import System.FilePath @@ -65,4 +67,14 @@ , 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 $ fromList + [ ("some_int", BInteger 100) + , ("some_list", BList [BInteger 10]) + ] + in dict ==? call addr rawDictM dict ] diff --git a/tests/Server.hs b/tests/Server.hs --- a/tests/Server.hs +++ b/tests/Server.hs @@ -1,6 +1,7 @@ {-# LANGUAGE IncoherentInstances #-} module Main (main) where +import Data.BEncode import Remote.KRPC import Shared @@ -13,4 +14,6 @@ , 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 --- a/tests/Shared.hs +++ b/tests/Shared.hs @@ -1,9 +1,17 @@ {-# LANGUAGE OverloadedStrings #-} module Shared - (echoM, echoBytes, unitM, swapM, reverseM, shiftR + ( echoM + , echoBytes + , unitM + , swapM + , reverseM + , shiftR + , rawM + , rawDictM ) where import Data.ByteString (ByteString) +import Data.BEncode import Remote.KRPC unitM :: Method () () @@ -23,3 +31,9 @@ shiftR :: Method ((), Int, [Int]) ([Int], (), Int) shiftR = method "shiftR" ["x", "y", "z"] ["a", "b", "c"] + +rawM :: Method BEncode BEncode +rawM = method "rawM" [""] [""] + +rawDictM :: Method BEncode BEncode +rawDictM = method "m" [] []