From 2f5450c06b70b5d9b319d651af5934aa4e5f97c4 Mon Sep 17 00:00:00 2001 From: Sam Truzjan Date: Thu, 17 Oct 2013 09:49:42 +0400 Subject: Update library to use bencoding == 0.4.* --- krpc.cabal | 2 +- src/Network/KRPC.hs | 22 +++++++----- src/Network/KRPC/Protocol.hs | 81 ++++++++++++++++++++++---------------------- src/Network/KRPC/Scheme.hs | 22 +++++++----- 4 files changed, 69 insertions(+), 58 deletions(-) diff --git a/krpc.cabal b/krpc.cabal index 96098537..68025f43 100644 --- a/krpc.cabal +++ b/krpc.cabal @@ -47,7 +47,7 @@ library , bytestring >= 0.10 , containers >= 0.4 - , bencoding == 0.3.* + , bencoding == 0.4.* , network >= 2.3 ghc-options: -Wall diff --git a/src/Network/KRPC.hs b/src/Network/KRPC.hs index 0428669b..27363515 100644 --- a/src/Network/KRPC.hs +++ b/src/Network/KRPC.hs @@ -120,7 +120,9 @@ import Control.Applicative 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 @@ -226,20 +228,24 @@ method = Method {-# 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 #-} diff --git a/src/Network/KRPC/Protocol.hs b/src/Network/KRPC/Protocol.hs index 1e7bd7c3..67a4057d 100644 --- 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(..) @@ -46,9 +47,7 @@ module Network.KRPC.Protocol -- * Re-exports , encode - , encoded , decode - , decoded , toBEncode , fromBEncode ) where @@ -59,11 +58,14 @@ import Control.Monad 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 @@ -89,20 +91,21 @@ data KError -- | Occur when client trying to call method server don't know. | MethodUnknown { errorMessage :: ByteString } - deriving (Show, Read, Eq, Ord) + 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" @@ -140,33 +143,30 @@ type ParamName = ByteString -- data KQuery = KQuery { queryMethod :: MethodName - , queryArgs :: Map ParamName BValue - } deriving (Show, Read, Eq, Ord) + , 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 + 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 +179,24 @@ type ValName = ByteString -- > { "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 +218,15 @@ maxMsgSize = 64 * 1024 -- bench: max UDP MTU {-# 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 +251,7 @@ remoteServer servAddr action = bracket (liftIO bindServ) (liftIO . sClose) loop 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 index 15f0b677..59d2c627 100644 --- a/src/Network/KRPC/Scheme.hs +++ b/src/Network/KRPC/Scheme.hs @@ -21,6 +21,9 @@ module Network.KRPC.Scheme ) where import Control.Applicative +import Data.BEncode as BE +import Data.BEncode.BDict as BS +import Data.BEncode.Types as BS import Data.Map as M import Data.Set as S @@ -45,19 +48,23 @@ class KMessage message scheme | message -> scheme where instance KMessage KError ErrorCode where - {-# SPECIALIZE instance KMessage KError ErrorCode #-} scheme = errorCode {-# INLINE scheme #-} - data KQueryScheme = KQueryScheme { qscMethod :: MethodName , qscParams :: Set 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 = S.fromAscList $ bdictKeys $ queryArgs q + } {-# INLINE scheme #-} methodQueryScheme :: Method a b -> KQueryScheme @@ -65,14 +72,13 @@ methodQueryScheme = KQueryScheme <$> methodName <*> S.fromList . methodParams {-# INLINE methodQueryScheme #-} - -newtype KResponseScheme = KResponseScheme { - rscVals :: Set ValName +newtype KResponseScheme = KResponseScheme + { rscVals :: Set ValName } deriving (Show, Read, Eq, Ord) instance KMessage KResponse KResponseScheme where {-# SPECIALIZE instance KMessage KResponse KResponseScheme #-} - scheme = KResponseScheme . keysSet . respVals + scheme = KResponseScheme . S.fromAscList . bdictKeys . respVals {-# INLINE scheme #-} methodRespScheme :: Method a b -> KResponseScheme -- cgit v1.2.3