summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--examples/Server.hs2
-rw-r--r--examples/Shared.hs7
-rw-r--r--src/Remote/KRPC.hs39
-rw-r--r--src/Remote/KRPC/Method.hs47
4 files changed, 48 insertions, 47 deletions
diff --git a/examples/Server.hs b/examples/Server.hs
index 027e0453..550bc344 100644
--- a/examples/Server.hs
+++ b/examples/Server.hs
@@ -6,4 +6,4 @@ import Shared
6 6
7 7
8main :: IO () 8main :: IO ()
9main = server 6000 [handler echoInt] 9main = server 6000 [undefined]
diff --git a/examples/Shared.hs b/examples/Shared.hs
index 77986125..efe345ac 100644
--- a/examples/Shared.hs
+++ b/examples/Shared.hs
@@ -1,9 +1,6 @@
1module Shared (echoInt, myconcat) where 1module Shared (echoInt) where
2 2
3import Remote.KRPC 3import Remote.KRPC
4 4
5echoInt :: Method IO Int Int 5echoInt :: Method Int Int
6echoInt = idM 6echoInt = idM
7
8myconcat :: Method IO [[Int]] [Int]
9myconcat = concatM \ No newline at end of file
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
23import Control.Exception 23import Control.Exception
@@ -46,14 +46,14 @@ type RemoteAddr = KRemoteAddr
46 46
47queryCall :: BEncodable param 47queryCall :: BEncodable param
48 => KRemote -> KRemoteAddr 48 => KRemote -> KRemoteAddr
49 -> Method remote param result -> param -> IO () 49 -> Method param result -> param -> IO ()
50queryCall sock addr m arg = sendMessage q addr sock 50queryCall 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
54getResult :: BEncodable result 54getResult :: BEncodable result
55 => KRemote -> KRemoteAddr 55 => KRemote -> KRemoteAddr
56 -> Method remote param result -> IO result 56 -> Method param result -> IO result
57getResult sock addr m = do 57getResult 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
76call :: (MonadBaseControl IO host, MonadIO host) 76call :: (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
82call addr m arg = liftIO $ withRemote $ \sock -> do 82call addr m arg = liftIO $ withRemote $ \sock -> do
@@ -86,10 +86,11 @@ call addr m arg = liftIO $ withRemote $ \sock -> do
86 86
87newtype Async result = Async { waitResult :: IO result } 87newtype Async result = Async { waitResult :: IO result }
88 88
89-- TODO document errorneous usage
89async :: MonadIO host 90async :: 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)
95async addr m arg = do 96async addr m arg = do
@@ -102,31 +103,37 @@ await :: MonadIO host => Async result -> host result
102await = liftIO . waitResult 103await = liftIO . waitResult
103 104
104-- TODO better name 105-- TODO better name
105type MHandler remote = Method remote BEncode (Result BEncode) 106type MHandler remote = ( Method BEncode (Result BEncode)
107 , BEncode -> remote (Result BEncode)
108 )
106 109
107handler :: 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)
112handler m = m { methodBody = \x -> do 116 -> MHandler remote
113 case fromBEncode x of 117m ==> 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
119server :: (MonadBaseControl IO remote, MonadIO remote) 126server :: (MonadBaseControl IO remote, MonadIO remote)
120 => PortNumber 127 => PortNumber
121 -> [MHandler remote] 128 -> [MHandler remote]
122 -> remote () 129 -> remote ()
123server servport ms = remoteServer servport $ \_ q -> do 130server 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 #-}
2module Remote.KRPC.Method 2module 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
12import Prelude hiding ((.), id) 12import Prelude hiding ((.), id)
@@ -15,6 +15,8 @@ import Control.Monad
15 15
16import Remote.KRPC.Protocol 16import 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--
26data Method remote param result = Method { 28data 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
40instance Monad remote => Category (Method remote) where 39instance 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--
48idM :: Monad m => Method m a a 54idM :: Method a a
49idM = method "id" ["x"] ["y"] return 55idM = 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--
57composeM :: Monad m => Method m b c -> Method m a b -> Method m a c 64composeM :: Method b c -> Method a b -> Method a c
58composeM g h = Method (methodName g ++ methodName h) 65composeM 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--
67concatM :: Monad m => Method m [[a]] [a]
68concatM = method "concat" ["xxs"] ["xs"] $ return . Prelude.concat
69 69
70 70
71method :: MethodName 71method :: MethodName -> [ParamName] -> [ValName] -> Method param result
72 -> [ParamName]
73 -> [ValName]
74 -> (param -> remote result)
75 -> Method remote param result
76method name = Method [name] 72method name = Method [name]
73{-# INLINE method #-} \ No newline at end of file