From 5ee611585e4eb6acb89b34e6679d89e25098e23b Mon Sep 17 00:00:00 2001 From: Sam T Date: Sun, 12 May 2013 06:46:58 +0400 Subject: - Remove Extractable class, fix multi param methods. --- src/Remote/KRPC.hs | 48 ++++++++++++++++++++++++----------------------- src/Remote/KRPC/Method.hs | 30 ----------------------------- 2 files changed, 25 insertions(+), 53 deletions(-) (limited to 'src') diff --git a/src/Remote/KRPC.hs b/src/Remote/KRPC.hs index a542f0b4..5c1aadd6 100644 --- a/src/Remote/KRPC.hs +++ b/src/Remote/KRPC.hs @@ -21,6 +21,7 @@ module Remote.KRPC , (==>), server ) where +import Control.Applicative import Control.Exception import Control.Monad.Trans.Control import Control.Monad.IO.Class @@ -39,31 +40,39 @@ data RPCException = RPCException KError deriving (Show, Eq, Typeable) instance Exception RPCException +type RemoteAddr = KRemoteAddr +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) +{-# INLINE extractArgs #-} -type RemoteAddr = KRemoteAddr +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" +{-# INLINE injectVals #-} queryCall :: BEncodable param - => Extractable param => KRemote -> KRemoteAddr -> Method param result -> param -> IO () queryCall sock addr m arg = sendMessage q addr sock where - q = kquery (methodName m) (mkVals (methodParams m) (injector arg)) - mkVals = L.zip + q = kquery (methodName m) (injectVals (methodParams m) arg) -extractArgs :: [ParamName] -> Map ParamName BEncode -> Result [BEncode] -extractArgs as d = mapM f as - where - f x | Just y <- M.lookup x d = return y - | otherwise = Left ("not found key " ++ BC.unpack x) -{-# INLINE extractArgs #-} -- TODO check scheme getResult :: BEncodable result - => Extractable result => KRemote -> KRemoteAddr -> Method param result -> IO result getResult sock addr m = do @@ -71,7 +80,7 @@ getResult sock addr m = do case resp of Left e -> throw (RPCException e) Right (respVals -> dict) -> do - case extractArgs (methodVals m) dict >>= extractor of + case extractArgs (methodVals m) dict of Right vals -> return vals Left e -> throw (RPCException (ProtocolError (BC.pack e))) @@ -81,7 +90,6 @@ getResult sock addr m = do -- call :: (MonadBaseControl IO host, MonadIO host) => (BEncodable param, BEncodable result) - => (Extractable param, Extractable result) => RemoteAddr -> Method param result -> param @@ -96,7 +104,6 @@ newtype Async result = Async { waitResult :: IO result } -- TODO document errorneous usage async :: MonadIO host => (BEncodable param, BEncodable result) - => (Extractable param, Extractable result) => RemoteAddr -> Method param result -> param @@ -119,8 +126,7 @@ type MethodHandler remote = (MethodName, HandlerBody remote) -- we can safely erase types in (==>) (==>) :: forall (remote :: * -> *) (param :: *) (result :: *). --- (BEncodable param, BEncodable result) - (Extractable param, Extractable result) + (BEncodable param, BEncodable result) => Monad remote => Method param result -> (param -> remote result) @@ -130,14 +136,13 @@ m ==> body = (methodName m, newbody) where {-# INLINE newbody #-} newbody q = - case extractArgs (methodParams m) (queryArgs q) >>= extractor of + case extractArgs (methodParams m) (queryArgs q) of Left e -> return (Left (ProtocolError (BC.pack e))) Right a -> do r <- body a - return (Right (kresponse (mkVals (methodVals m) (injector r)))) + return (Right (kresponse (injectVals (methodVals m) r))) - mkVals :: [ValName] -> [BEncode] -> [(ValName, BEncode)] - mkVals = L.zip +infix 1 ==> -- TODO: allow forkIO server :: (MonadBaseControl IO remote, MonadIO remote) @@ -153,6 +158,3 @@ server servport handlers = do handlerMap = M.fromList handlers dispatch s = M.lookup s handlerMap invoke m q = m q - - bimap f _ (Left x) = Left (f x) - bimap _ g (Right x) = Right (g x) \ No newline at end of file diff --git a/src/Remote/KRPC/Method.hs b/src/Remote/KRPC/Method.hs index d0c8e89a..4283256b 100644 --- a/src/Remote/KRPC/Method.hs +++ b/src/Remote/KRPC/Method.hs @@ -16,9 +16,6 @@ module Remote.KRPC.Method -- * Predefined methods , idM - - -- * Internal - , Extractable(..) ) where import Control.Applicative @@ -69,30 +66,3 @@ idM = method "id" ["x"] ["y"] method :: MethodName -> [ParamName] -> [ValName] -> Method param result method = Method {-# INLINE method #-} - - - -class Extractable a where - injector :: a -> [BEncode] - extractor :: [BEncode] -> Result a - -instance (BEncodable a, BEncodable b) => Extractable (a, b) where - {- SPECIALIZE instance (BEncodable a, BEncodable b) => Extractable (a, b) -} - injector (a, b) = [toBEncode a, toBEncode b] - {-# INLINE injector #-} - - extractor [a, b] = (,) <$> fromBEncode a <*> fromBEncode b - extractor _ = decodingError "unable to match pair" - {-# INLINE extractor #-} - -{- -instance BEncodable a => Extractable a where - {-# SPECIALIZE instance BEncodable a => Extractable a #-} - - injector x = [toBEncode x] - {-# INLINE injector #-} - - extractor [x] = fromBEncode x - extractor _ = decodingError "unable to match single value" - {-# INLINE extractor #-} --} \ No newline at end of file -- cgit v1.2.3