krpc 0.4.0.1 → 0.4.1.0
raw patch · 6 files changed
+86/−90 lines, 6 filesdep −containersdep ~bencoding
Dependencies removed: containers
Dependency ranges changed: bencoding
Files
- changelog +1/−0
- krpc.cabal +4/−6
- src/Network/KRPC.hs +15/−13
- src/Network/KRPC/Protocol.hs +47/−53
- src/Network/KRPC/Scheme.hs +16/−14
- tests/Client.hs +3/−4
changelog view
@@ -7,3 +7,4 @@ 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.*
krpc.cabal view
@@ -1,5 +1,5 @@ name: krpc-version: 0.4.0.1+version: 0.4.1.0 license: BSD3 license-file: LICENSE author: Sam Truzjan@@ -29,7 +29,7 @@ type: git location: git://github.com/cobit/krpc.git branch: master- tag: v0.4.0.1+ tag: v0.4.1.0 library default-language: Haskell2010@@ -40,14 +40,13 @@ , Network.KRPC.Protocol , Network.KRPC.Scheme build-depends: base == 4.*+ , bytestring >= 0.10 , lifted-base >= 0.1.1 , transformers >= 0.2 , monad-control >= 0.3 - , bytestring >= 0.10- , containers >= 0.4- , bencoding == 0.3.*+ , bencoding == 0.4.* , network >= 2.3 ghc-options: -Wall@@ -61,7 +60,6 @@ other-modules: Shared build-depends: base == 4.* , bytestring- , containers , process , filepath
src/Network/KRPC.hs view
@@ -120,10 +120,11 @@ import Control.Exception import Control.Monad.Trans.Control import Control.Monad.IO.Class-import Data.BEncode+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.Map as M import Data.Monoid import Data.Typeable import Network@@ -226,20 +227,24 @@ {-# INLINE method #-} lookupKey :: ParamName -> BDict -> Result BValue-lookupKey x = maybe (Left ("not found key " ++ BC.unpack x)) Right . M.lookup x+lookupKey x = maybe (Left ("not found key " ++ BC.unpack x)) Right . BE.lookup x extractArgs :: [ParamName] -> BDict -> Result BValue-extractArgs [] d = Right $ if M.null d then BList [] else BDict d+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 #-} -injectVals :: [ParamName] -> BValue -> [(ParamName, BValue)]-injectVals [] (BList []) = []-injectVals [] (BDict d ) = M.toList d+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 = [(p, arg)]-injectVals ps (BList as) = L.zip ps as+injectVals [p] arg = BE.singleton p arg+injectVals ps (BList as) = zipBDict ps as injectVals ps be = invalidParamList ps be {-# INLINE injectVals #-} @@ -353,9 +358,6 @@ -> remote () server servAddr handlers = do remoteServer servAddr $ \addr q -> do- case dispatch (queryMethod q) of+ case L.lookup (queryMethod q) handlers of Nothing -> return $ Left $ MethodUnknown (queryMethod q) Just m -> m addr q- where- handlerMap = M.fromList handlers- dispatch s = M.lookup s handlerMap
src/Network/KRPC/Protocol.hs view
@@ -17,6 +17,7 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE DeriveDataTypeable #-} module Network.KRPC.Protocol ( -- * Error KError(..)@@ -43,14 +44,6 @@ , KRemoteAddr , withRemote , remoteServer-- -- * Re-exports- , encode- , encoded- , decode- , decoded- , toBEncode- , fromBEncode ) where import Control.Applicative@@ -59,11 +52,13 @@ import Control.Monad.IO.Class import Control.Monad.Trans.Control -import Data.BEncode+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.Map as M+import Data.Typeable import Network.Socket hiding (recvFrom) import Network.Socket.ByteString@@ -79,30 +74,31 @@ -- data KError -- | Some error doesn't fit in any other category.- = GenericError { errorMessage :: ByteString }+ = GenericError { errorMessage :: !ByteString } -- | Occur when server fail to process procedure call.- | ServerError { errorMessage :: ByteString }+ | ServerError { errorMessage :: !ByteString } -- | Malformed packet, invalid arguments or bad token.- | ProtocolError { errorMessage :: ByteString }+ | ProtocolError { errorMessage :: !ByteString } -- | Occur when client trying to call method server don't know.- | MethodUnknown { errorMessage :: ByteString }- deriving (Show, Read, Eq, Ord)+ | MethodUnknown { errorMessage :: !ByteString }+ deriving (Show, Read, Eq, Ord, Typeable) instance BEncode KError where {-# SPECIALIZE instance BEncode KError #-} {-# INLINE toBEncode #-}- toBEncode e = fromAscAssocs -- WARN: keep keys sorted- [ "e" --> (errorCode e, errorMessage e)- , "y" --> ("e" :: ByteString)- ]+ toBEncode e = toDict $+ "e" .=! (errorCode e, errorMessage e)+ .: "y" .=! ("e" :: ByteString)+ .: endDict {-# INLINE fromBEncode #-}- fromBEncode (BDict d)- | M.lookup "y" d == Just (BString "e")- = uncurry mkKError <$> d >-- "e"+ fromBEncode be @ (BDict d)+ | BE.lookup "y" d == Just (BString "e")+ = (`fromDict` be) $ do+ uncurry mkKError <$>! "e" fromBEncode _ = decodingError "KError" @@ -139,34 +135,33 @@ -- > { "y" : "q", "q" : "<method_name>", "a" : [<arg1>, <arg2>, ...] } -- data KQuery = KQuery {- queryMethod :: MethodName- , queryArgs :: Map ParamName BValue- } deriving (Show, Read, Eq, Ord)+ queryMethod :: !MethodName+ , queryArgs :: BDict+ } deriving (Show, Read, Eq, Ord, Typeable) instance BEncode KQuery where {-# SPECIALIZE instance BEncode KQuery #-} {-# INLINE toBEncode #-}- toBEncode (KQuery m args) = fromAscAssocs -- WARN: keep keys sorted- [ "a" --> BDict args- , "q" --> m- , "y" --> ("q" :: ByteString)- ]+ toBEncode (KQuery m args) = toDict $+ "a" .=! BDict args+ .: "q" .=! m+ .: "y" .=! ("q" :: ByteString)+ .: endDict {-# INLINE fromBEncode #-}- fromBEncode (BDict d)- | M.lookup "y" d == Just (BString "q") =- KQuery <$> d >-- "q"- <*> d >-- "a"+ 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 -> [(ParamName, BValue)] -> KQuery-kquery name args = KQuery name (M.fromList args)+kquery :: MethodName -> BDict -> KQuery+kquery = KQuery {-# INLINE kquery #-} -- type ValName = ByteString -- | KResponse used to signal that callee successufully process a@@ -179,25 +174,24 @@ -- > { "y" : "r", "r" : [<val1>, <val2>, ...] } -- newtype KResponse = KResponse { respVals :: BDict }- deriving (Show, Read, Eq, Ord)+ deriving (Show, Read, Eq, Ord, Typeable) instance BEncode KResponse where {-# INLINE toBEncode #-}- toBEncode (KResponse vals) = fromAscAssocs -- WARN: keep keys sorted- [ "r" --> vals- , "y" --> ("r" :: ByteString)- ]+ toBEncode (KResponse vals) = toDict $+ "r" .=! vals+ .: "y" .=! ("r" :: ByteString)+ .: endDict {-# INLINE fromBEncode #-}- fromBEncode (BDict d)- | M.lookup "y" d == Just (BString "r") =- KResponse <$> d >-- "r"+ fromBEncode bv @ (BDict d)+ | BE.lookup "y" d == Just (BString "r") = (`fromDict` bv) $ do+ KResponse <$>! "r" fromBEncode _ = decodingError "KDict" --kresponse :: [(ValName, BValue)] -> KResponse-kresponse = KResponse . M.fromList+kresponse :: BDict -> KResponse+kresponse = KResponse {-# INLINE kresponse #-} type KRemoteAddr = SockAddr@@ -219,15 +213,15 @@ {-# INLINE maxMsgSize #-} sendMessage :: BEncode msg => msg -> KRemoteAddr -> KRemote -> IO ()-sendMessage msg addr sock = sendManyTo sock (LB.toChunks (encoded msg)) addr+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 decoded raw of+ return $ case decode raw of Right resp -> Right resp- Left decE -> Left $ case decoded raw of+ Left decE -> Left $ case decode raw of Right kerror -> kerror _ -> ProtocolError (BC.pack decE) @@ -252,7 +246,7 @@ reply <- handleMsg bs addr liftIO $ sendMessage reply addr sock where- handleMsg bs addr = case decoded bs of+ 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 view
@@ -21,8 +21,8 @@ ) where import Control.Applicative-import Data.Map as M-import Data.Set as S+import Data.BEncode.BDict as BS+import Data.BEncode.Types as BS import Network.KRPC.Protocol import Network.KRPC@@ -45,36 +45,38 @@ instance KMessage KError ErrorCode where- {-# SPECIALIZE instance KMessage KError ErrorCode #-} scheme = errorCode {-# INLINE scheme #-} - data KQueryScheme = KQueryScheme { qscMethod :: MethodName- , qscParams :: Set ParamName+ , qscParams :: [ParamName] } deriving (Show, Read, Eq, Ord) +bdictKeys :: BDict -> [BKey]+bdictKeys (Cons k _ xs) = k : bdictKeys xs+bdictKeys Nil = []+ instance KMessage KQuery KQueryScheme where- {-# SPECIALIZE instance KMessage KQuery KQueryScheme #-}- scheme q = KQueryScheme (queryMethod q) (M.keysSet (queryArgs q))+ scheme q = KQueryScheme+ { qscMethod = queryMethod q+ , qscParams = bdictKeys $ queryArgs q+ } {-# INLINE scheme #-} methodQueryScheme :: Method a b -> KQueryScheme-methodQueryScheme = KQueryScheme <$> methodName- <*> S.fromList . methodParams+methodQueryScheme = KQueryScheme <$> methodName <*> methodParams {-# INLINE methodQueryScheme #-} --newtype KResponseScheme = KResponseScheme {- rscVals :: Set ValName+newtype KResponseScheme = KResponseScheme+ { rscVals :: [ValName] } deriving (Show, Read, Eq, Ord) instance KMessage KResponse KResponseScheme where {-# SPECIALIZE instance KMessage KResponse KResponseScheme #-}- scheme = KResponseScheme . keysSet . respVals+ scheme = KResponseScheme . bdictKeys . respVals {-# INLINE scheme #-} methodRespScheme :: Method a b -> KResponseScheme-methodRespScheme = KResponseScheme . S.fromList . methodVals+methodRespScheme = KResponseScheme . methodVals {-# INLINE methodRespScheme #-}
tests/Client.hs view
@@ -4,9 +4,8 @@ import Control.Concurrent import Control.Exception import qualified Data.ByteString as B-import Data.BEncode-import Data.Map-import System.Environment+import Data.BEncode as BE+import Data.BEncode.BDict as BE import System.Process import System.FilePath @@ -73,7 +72,7 @@ BInteger 10 ==? call addr rawM (BInteger 10) , testCase "raw dict" $- let dict = BDict $ fromList+ let dict = BDict $ BE.fromAscList [ ("some_int", BInteger 100) , ("some_list", BList [BInteger 10]) ]