diff options
Diffstat (limited to 'src')
-rw-r--r-- | src/Remote/KRPC.hs | 39 | ||||
-rw-r--r-- | src/Remote/KRPC/Method.hs | 47 |
2 files changed, 45 insertions, 41 deletions
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 | |||
17 | , call, async, await | 17 | , call, async, await |
18 | 18 | ||
19 | -- * Server | 19 | -- * Server |
20 | , handler, server | 20 | , server |
21 | ) where | 21 | ) where |
22 | 22 | ||
23 | import Control.Exception | 23 | import Control.Exception |
@@ -46,14 +46,14 @@ type RemoteAddr = KRemoteAddr | |||
46 | 46 | ||
47 | queryCall :: BEncodable param | 47 | queryCall :: BEncodable param |
48 | => KRemote -> KRemoteAddr | 48 | => KRemote -> KRemoteAddr |
49 | -> Method remote param result -> param -> IO () | 49 | -> Method param result -> param -> IO () |
50 | queryCall sock addr m arg = sendMessage q addr sock | 50 | queryCall sock addr m arg = sendMessage q addr sock |
51 | where | 51 | where |
52 | q = kquery (L.head (methodName m)) [(L.head (methodParams m), toBEncode arg)] | 52 | q = kquery (L.head (methodName m)) [(L.head (methodParams m), toBEncode arg)] |
53 | 53 | ||
54 | getResult :: BEncodable result | 54 | getResult :: BEncodable result |
55 | => KRemote -> KRemoteAddr | 55 | => KRemote -> KRemoteAddr |
56 | -> Method remote param result -> IO result | 56 | -> Method param result -> IO result |
57 | getResult sock addr m = do | 57 | getResult sock addr m = do |
58 | resp <- recvResponse addr sock | 58 | resp <- recvResponse addr sock |
59 | case resp of | 59 | case resp of |
@@ -76,7 +76,7 @@ getResult sock addr m = do | |||
76 | call :: (MonadBaseControl IO host, MonadIO host) | 76 | call :: (MonadBaseControl IO host, MonadIO host) |
77 | => (BEncodable param, BEncodable result) | 77 | => (BEncodable param, BEncodable result) |
78 | => RemoteAddr | 78 | => RemoteAddr |
79 | -> Method remote param result | 79 | -> Method param result |
80 | -> param | 80 | -> param |
81 | -> host result | 81 | -> host result |
82 | call addr m arg = liftIO $ withRemote $ \sock -> do | 82 | call addr m arg = liftIO $ withRemote $ \sock -> do |
@@ -86,10 +86,11 @@ call addr m arg = liftIO $ withRemote $ \sock -> do | |||
86 | 86 | ||
87 | newtype Async result = Async { waitResult :: IO result } | 87 | newtype Async result = Async { waitResult :: IO result } |
88 | 88 | ||
89 | -- TODO document errorneous usage | ||
89 | async :: MonadIO host | 90 | async :: MonadIO host |
90 | => (BEncodable param, BEncodable result) | 91 | => (BEncodable param, BEncodable result) |
91 | => RemoteAddr | 92 | => RemoteAddr |
92 | -> Method remote param result | 93 | -> Method param result |
93 | -> param | 94 | -> param |
94 | -> host (Async result) | 95 | -> host (Async result) |
95 | async addr m arg = do | 96 | async addr m arg = do |
@@ -102,31 +103,37 @@ await :: MonadIO host => Async result -> host result | |||
102 | await = liftIO . waitResult | 103 | await = liftIO . waitResult |
103 | 104 | ||
104 | -- TODO better name | 105 | -- TODO better name |
105 | type MHandler remote = Method remote BEncode (Result BEncode) | 106 | type MHandler remote = ( Method BEncode (Result BEncode) |
107 | , BEncode -> remote (Result BEncode) | ||
108 | ) | ||
106 | 109 | ||
107 | handler :: forall (remote :: * -> *) (param :: *) (result :: *). | 110 | -- we can safely erase types in (==>) |
111 | (==>) :: forall (remote :: * -> *) (param :: *) (result :: *). | ||
108 | (BEncodable param, BEncodable result) | 112 | (BEncodable param, BEncodable result) |
109 | => Monad remote | 113 | => Monad remote |
110 | => Method remote param result | 114 | => Method param result |
111 | -> Method remote BEncode (Result BEncode) | 115 | -> (param -> remote result) |
112 | handler m = m { methodBody = \x -> do | 116 | -> MHandler remote |
113 | case fromBEncode x of | 117 | m ==> body = undefined |
114 | Right a -> liftM (Right . toBEncode) (methodBody m a) | 118 | where |
119 | newbody x = case fromBEncode x of | ||
120 | Right a -> liftM (Right . toBEncode) (body a) | ||
115 | Left e -> return (Left e) | 121 | Left e -> return (Left e) |
116 | } | 122 | |
117 | 123 | ||
118 | -- TODO: allow forkIO | 124 | -- TODO: allow forkIO |
125 | -- TODO: allow overloading | ||
119 | server :: (MonadBaseControl IO remote, MonadIO remote) | 126 | server :: (MonadBaseControl IO remote, MonadIO remote) |
120 | => PortNumber | 127 | => PortNumber |
121 | -> [MHandler remote] | 128 | -> [MHandler remote] |
122 | -> remote () | 129 | -> remote () |
123 | server servport ms = remoteServer servport $ \_ q -> do | 130 | server servport ms = remoteServer servport $ \_ q -> do |
124 | let name = queryMethod q | 131 | let name = queryMethod q |
125 | let args = queryArgs q | 132 | let args = undefined -- queryArgs q |
126 | let m = L.head ms | 133 | let m = L.head ms |
127 | res <- methodBody m (snd (L.head (M.toList args))) | 134 | res <- undefined -- methodBody m (snd (L.head (M.toList args))) |
128 | case res of | 135 | case res of |
129 | Left r -> return (Left (ProtocolError (T.pack r))) | 136 | Left r -> return (Left (ProtocolError (T.pack r))) |
130 | Right r -> do | 137 | Right r -> do |
131 | let retName = L.head (methodVals m) | 138 | let retName = undefined -- L.head (methodVals m) |
132 | return (Right (kresponse [(retName, r)])) | 139 | 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 @@ | |||
1 | {-# LANGUAGE OverloadedStrings #-} | 1 | {-# LANGUAGE OverloadedStrings #-} |
2 | module Remote.KRPC.Method | 2 | module Remote.KRPC.Method |
3 | ( Method(methodName, methodParams, methodVals, methodBody) | 3 | ( Method(methodName, methodParams, methodVals) |
4 | 4 | ||
5 | -- * Construction | 5 | -- * Construction |
6 | , method | 6 | , method |
7 | 7 | ||
8 | -- * Predefined methods | 8 | -- * Predefined methods |
9 | , idM, composeM, concatM | 9 | , idM, composeM |
10 | ) where | 10 | ) where |
11 | 11 | ||
12 | import Prelude hiding ((.), id) | 12 | import Prelude hiding ((.), id) |
@@ -15,6 +15,8 @@ import Control.Monad | |||
15 | 15 | ||
16 | import Remote.KRPC.Protocol | 16 | import Remote.KRPC.Protocol |
17 | 17 | ||
18 | |||
19 | |||
18 | -- | The | 20 | -- | The |
19 | -- | 21 | -- |
20 | -- * argument: type of method parameter | 22 | -- * argument: type of method parameter |
@@ -23,30 +25,35 @@ import Remote.KRPC.Protocol | |||
23 | -- | 25 | -- |
24 | -- * result: type of return value of the method. | 26 | -- * result: type of return value of the method. |
25 | -- | 27 | -- |
26 | data Method remote param result = Method { | 28 | data Method param result = Method { |
27 | -- | Name used in query and | 29 | -- | Name used in query and |
28 | methodName :: [MethodName] | 30 | methodName :: [MethodName] |
29 | 31 | ||
30 | -- | Description of each method parameter in right to left order. | 32 | -- | Description of each parameter in /right to left/ order. |
31 | , methodParams :: [ParamName] | 33 | , methodParams :: [ParamName] |
32 | 34 | ||
33 | -- | Description of each method return value in right to left order. | 35 | -- | Description of each return value in /right to left/ order. |
34 | , methodVals :: [ValName] | 36 | , methodVals :: [ValName] |
35 | |||
36 | -- | Description of method body. | ||
37 | , methodBody :: param -> remote result | ||
38 | } | 37 | } |
39 | 38 | ||
40 | instance Monad remote => Category (Method remote) where | 39 | instance Category Method where |
40 | {-# SPECIALIZE instance Category Method #-} | ||
41 | id = idM | 41 | id = idM |
42 | {-# INLINE id #-} | ||
43 | |||
42 | (.) = composeM | 44 | (.) = composeM |
45 | {-# INLINE (.) #-} | ||
46 | |||
47 | |||
48 | -- TODO ppMethod | ||
43 | 49 | ||
44 | -- | Remote identity function. Could be used for echo servers for example. | 50 | -- | Remote identity function. Could be used for echo servers for example. |
45 | -- | 51 | -- |
46 | -- idM = method "id" ["x"] ["y"] return | 52 | -- idM = method "id" ["x"] ["y"] return |
47 | -- | 53 | -- |
48 | idM :: Monad m => Method m a a | 54 | idM :: Method a a |
49 | idM = method "id" ["x"] ["y"] return | 55 | idM = method "id" ["x"] ["y"] |
56 | {-# INLINE idM #-} | ||
50 | 57 | ||
51 | -- | Pipelining of two or more methods. | 58 | -- | Pipelining of two or more methods. |
52 | -- | 59 | -- |
@@ -54,23 +61,13 @@ idM = method "id" ["x"] ["y"] return | |||
54 | -- KRPC, so both server and client should use this implementation, | 61 | -- KRPC, so both server and client should use this implementation, |
55 | -- otherwise you more likely get the 'ProtocolError'. | 62 | -- otherwise you more likely get the 'ProtocolError'. |
56 | -- | 63 | -- |
57 | composeM :: Monad m => Method m b c -> Method m a b -> Method m a c | 64 | composeM :: Method b c -> Method a b -> Method a c |
58 | composeM g h = Method (methodName g ++ methodName h) | 65 | composeM g h = Method (methodName g ++ methodName h) |
59 | (methodParams h) | 66 | (methodParams h) |
60 | (methodVals g) | 67 | (methodVals g) |
61 | (methodBody h >=> methodBody g) | 68 | {-# INLINE composeM #-} |
62 | |||
63 | -- | Concat list of list. Could be used for performance tests. | ||
64 | -- | ||
65 | -- concatM = method "concat" ["xxs"] ["xs"] $ return . Prelude.concat | ||
66 | -- | ||
67 | concatM :: Monad m => Method m [[a]] [a] | ||
68 | concatM = method "concat" ["xxs"] ["xs"] $ return . Prelude.concat | ||
69 | 69 | ||
70 | 70 | ||
71 | method :: MethodName | 71 | method :: MethodName -> [ParamName] -> [ValName] -> Method param result |
72 | -> [ParamName] | ||
73 | -> [ValName] | ||
74 | -> (param -> remote result) | ||
75 | -> Method remote param result | ||
76 | method name = Method [name] | 72 | method name = Method [name] |
73 | {-# INLINE method #-} \ No newline at end of file | ||