diff --git a/changelog b/changelog --- a/changelog +++ b/changelog @@ -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.* diff --git a/krpc.cabal b/krpc.cabal --- a/krpc.cabal +++ b/krpc.cabal @@ -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 diff --git a/src/Network/KRPC.hs b/src/Network/KRPC.hs --- a/src/Network/KRPC.hs +++ b/src/Network/KRPC.hs @@ -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 diff --git a/src/Network/KRPC/Protocol.hs b/src/Network/KRPC/Protocol.hs --- a/src/Network/KRPC/Protocol.hs +++ b/src/Network/KRPC/Protocol.hs @@ -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" : "", "a" : [, , ...] } -- 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" : [, , ...] } -- 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)) diff --git a/src/Network/KRPC/Scheme.hs b/src/Network/KRPC/Scheme.hs --- a/src/Network/KRPC/Scheme.hs +++ b/src/Network/KRPC/Scheme.hs @@ -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 #-} diff --git a/tests/Client.hs b/tests/Client.hs --- a/tests/Client.hs +++ b/tests/Client.hs @@ -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]) ]