From 3806b3513f04dd360badf438fa103334dd32933c Mon Sep 17 00:00:00 2001 From: Sam T Date: Sat, 11 May 2013 21:31:05 +0400 Subject: ~ Separate method implementation. This will break everything for now. --- src/Remote/KRPC.hs | 39 +++++++++++++++++++++++---------------- src/Remote/KRPC/Method.hs | 47 ++++++++++++++++++++++------------------------- 2 files changed, 45 insertions(+), 41 deletions(-) (limited to 'src') diff --git a/src/Remote/KRPC.hs b/src/Remote/KRPC.hs index a6318ccd..8f2027f2 100644 --- a/src/Remote/KRPC.hs +++ b/src/Remote/KRPC.hs @@ -17,7 +17,7 @@ module Remote.KRPC , call, async, await -- * Server - , handler, server + , server ) where import Control.Exception @@ -46,14 +46,14 @@ type RemoteAddr = KRemoteAddr queryCall :: BEncodable param => KRemote -> KRemoteAddr - -> Method remote param result -> param -> IO () + -> Method param result -> param -> IO () queryCall sock addr m arg = sendMessage q addr sock where q = kquery (L.head (methodName m)) [(L.head (methodParams m), toBEncode arg)] getResult :: BEncodable result => KRemote -> KRemoteAddr - -> Method remote param result -> IO result + -> Method param result -> IO result getResult sock addr m = do resp <- recvResponse addr sock case resp of @@ -76,7 +76,7 @@ getResult sock addr m = do call :: (MonadBaseControl IO host, MonadIO host) => (BEncodable param, BEncodable result) => RemoteAddr - -> Method remote param result + -> Method param result -> param -> host result call addr m arg = liftIO $ withRemote $ \sock -> do @@ -86,10 +86,11 @@ call addr m arg = liftIO $ withRemote $ \sock -> do newtype Async result = Async { waitResult :: IO result } +-- TODO document errorneous usage async :: MonadIO host => (BEncodable param, BEncodable result) => RemoteAddr - -> Method remote param result + -> Method param result -> param -> host (Async result) async addr m arg = do @@ -102,31 +103,37 @@ await :: MonadIO host => Async result -> host result await = liftIO . waitResult -- TODO better name -type MHandler remote = Method remote BEncode (Result BEncode) +type MHandler remote = ( Method BEncode (Result BEncode) + , BEncode -> remote (Result BEncode) + ) -handler :: forall (remote :: * -> *) (param :: *) (result :: *). +-- we can safely erase types in (==>) +(==>) :: forall (remote :: * -> *) (param :: *) (result :: *). (BEncodable param, BEncodable result) => Monad remote - => Method remote param result - -> Method remote BEncode (Result BEncode) -handler m = m { methodBody = \x -> do - case fromBEncode x of - Right a -> liftM (Right . toBEncode) (methodBody m a) + => Method param result + -> (param -> remote result) + -> MHandler remote +m ==> body = undefined + where + newbody x = case fromBEncode x of + Right a -> liftM (Right . toBEncode) (body a) Left e -> return (Left e) - } + -- TODO: allow forkIO +-- TODO: allow overloading server :: (MonadBaseControl IO remote, MonadIO remote) => PortNumber -> [MHandler remote] -> remote () server servport ms = remoteServer servport $ \_ q -> do let name = queryMethod q - let args = queryArgs q + let args = undefined -- queryArgs q let m = L.head ms - res <- methodBody m (snd (L.head (M.toList args))) + res <- undefined -- methodBody m (snd (L.head (M.toList args))) case res of Left r -> return (Left (ProtocolError (T.pack r))) Right r -> do - let retName = L.head (methodVals m) + let retName = undefined -- L.head (methodVals m) return (Right (kresponse [(retName, r)])) diff --git a/src/Remote/KRPC/Method.hs b/src/Remote/KRPC/Method.hs index f4b0bb9a..3c757d07 100644 --- a/src/Remote/KRPC/Method.hs +++ b/src/Remote/KRPC/Method.hs @@ -1,12 +1,12 @@ {-# LANGUAGE OverloadedStrings #-} module Remote.KRPC.Method - ( Method(methodName, methodParams, methodVals, methodBody) + ( Method(methodName, methodParams, methodVals) -- * Construction , method -- * Predefined methods - , idM, composeM, concatM + , idM, composeM ) where import Prelude hiding ((.), id) @@ -15,6 +15,8 @@ import Control.Monad import Remote.KRPC.Protocol + + -- | The -- -- * argument: type of method parameter @@ -23,30 +25,35 @@ import Remote.KRPC.Protocol -- -- * result: type of return value of the method. -- -data Method remote param result = Method { +data Method param result = Method { -- | Name used in query and methodName :: [MethodName] - -- | Description of each method parameter in right to left order. + -- | Description of each parameter in /right to left/ order. , methodParams :: [ParamName] - -- | Description of each method return value in right to left order. + -- | Description of each return value in /right to left/ order. , methodVals :: [ValName] - - -- | Description of method body. - , methodBody :: param -> remote result } -instance Monad remote => Category (Method remote) where +instance Category Method where + {-# SPECIALIZE instance Category Method #-} id = idM + {-# INLINE id #-} + (.) = composeM + {-# INLINE (.) #-} + + +-- TODO ppMethod -- | Remote identity function. Could be used for echo servers for example. -- -- idM = method "id" ["x"] ["y"] return -- -idM :: Monad m => Method m a a -idM = method "id" ["x"] ["y"] return +idM :: Method a a +idM = method "id" ["x"] ["y"] +{-# INLINE idM #-} -- | Pipelining of two or more methods. -- @@ -54,23 +61,13 @@ idM = method "id" ["x"] ["y"] return -- KRPC, so both server and client should use this implementation, -- otherwise you more likely get the 'ProtocolError'. -- -composeM :: Monad m => Method m b c -> Method m a b -> Method m a c +composeM :: Method b c -> Method a b -> Method a c composeM g h = Method (methodName g ++ methodName h) (methodParams h) (methodVals g) - (methodBody h >=> methodBody g) - --- | Concat list of list. Could be used for performance tests. --- --- concatM = method "concat" ["xxs"] ["xs"] $ return . Prelude.concat --- -concatM :: Monad m => Method m [[a]] [a] -concatM = method "concat" ["xxs"] ["xs"] $ return . Prelude.concat +{-# INLINE composeM #-} -method :: MethodName - -> [ParamName] - -> [ValName] - -> (param -> remote result) - -> Method remote param result +method :: MethodName -> [ParamName] -> [ValName] -> Method param result method name = Method [name] +{-# INLINE method #-} \ No newline at end of file -- cgit v1.2.3