krpc 0.1.0.0 → 0.2.0.0

raw patch · 7 files changed

+184/−120 lines, 7 filesdep ~basedep ~bencodingdep ~containersPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: base, bencoding, containers

API changes (from Hackage documentation)

Files

• krpc.cabal +35/−23
• src/Remote/KRPC.hs +102/−80
• src/Remote/KRPC/Protocol.hs +13/−13
• src/Remote/KRPC/Scheme.hs +4/−3
• tests/Client.hs +12/−0
• tests/Server.hs +3/−0
• tests/Shared.hs +15/−1

@@ -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

@@ -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

@@ -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" : [<error_code>, <human_readable_error_reason>] }+--   > { "y" : "e", "e" : [<error_code>, <human_readable_error_reason>] } -- data KError     -- | Some error doesn't fit in any other category.@@ -122,7 +123,7 @@ -- --   Queries are encoded as bencoded dictionary: -----     { "y" : "q", "q" : "<method_name>", "a" : [<arg1>, <arg2>, ...] }+--    > { "y" : "q", "q" : "<method_name>", "a" : [<arg1>, <arg2>, ...] } -- data KQuery = KQuery {     queryMethod :: MethodName@@ -162,7 +163,7 @@ -- --   Responses are encoded as bencoded dictionary: -----     { "y" : "r", "r" : [<val1>, <val2>, ...] }+--   > { "y" : "r", "r" : [<val1>, <val2>, ...] } -- 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))

@@ -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

@@ -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   ]

@@ -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   ]

@@ -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" [] []