diff options
-rw-r--r-- | krpc.cabal | 2 | ||||
-rw-r--r-- | src/Remote/KRPC.hs | 22 | ||||
-rw-r--r-- | src/Remote/KRPC/Protocol.hs | 24 | ||||
-rw-r--r-- | tests/Shared.hs | 4 |
4 files changed, 25 insertions, 27 deletions
@@ -49,7 +49,7 @@ library | |||
49 | 49 | ||
50 | , bytestring >= 0.10 | 50 | , bytestring >= 0.10 |
51 | , containers >= 0.4 | 51 | , containers >= 0.4 |
52 | , bencoding == 0.2.2.* | 52 | , bencoding == 0.3.* |
53 | 53 | ||
54 | , network >= 2.3 | 54 | , network >= 2.3 |
55 | ghc-options: -Wall | 55 | ghc-options: -Wall |
diff --git a/src/Remote/KRPC.hs b/src/Remote/KRPC.hs index 3659ec66..5c913daa 100644 --- a/src/Remote/KRPC.hs +++ b/src/Remote/KRPC.hs | |||
@@ -164,7 +164,7 @@ data Method param result = Method { | |||
164 | , methodVals :: [ValName] | 164 | , methodVals :: [ValName] |
165 | } deriving (Eq, Ord, Generic) | 165 | } deriving (Eq, Ord, Generic) |
166 | 166 | ||
167 | instance BEncodable (Method a b) | 167 | instance BEncode (Method a b) |
168 | 168 | ||
169 | instance (Typeable a, Typeable b) => Show (Method a b) where | 169 | instance (Typeable a, Typeable b) => Show (Method a b) where |
170 | showsPrec _ = showsMethod | 170 | showsPrec _ = showsMethod |
@@ -224,16 +224,16 @@ method :: MethodName -> [ParamName] -> [ValName] -> Method param result | |||
224 | method = Method | 224 | method = Method |
225 | {-# INLINE method #-} | 225 | {-# INLINE method #-} |
226 | 226 | ||
227 | lookupKey :: ParamName -> Map ByteString BEncode -> Result BEncode | 227 | lookupKey :: ParamName -> BDict -> Result BValue |
228 | lookupKey x = maybe (Left ("not found key " ++ BC.unpack x)) Right . M.lookup x | 228 | lookupKey x = maybe (Left ("not found key " ++ BC.unpack x)) Right . M.lookup x |
229 | 229 | ||
230 | extractArgs :: [ParamName] -> Map ParamName BEncode -> Result BEncode | 230 | extractArgs :: [ParamName] -> BDict -> Result BValue |
231 | extractArgs [] d = Right $ if M.null d then BList [] else BDict d | 231 | extractArgs [] d = Right $ if M.null d then BList [] else BDict d |
232 | extractArgs [x] d = lookupKey x d | 232 | extractArgs [x] d = lookupKey x d |
233 | extractArgs xs d = BList <$> mapM (`lookupKey` d) xs | 233 | extractArgs xs d = BList <$> mapM (`lookupKey` d) xs |
234 | {-# INLINE extractArgs #-} | 234 | {-# INLINE extractArgs #-} |
235 | 235 | ||
236 | injectVals :: [ParamName] -> BEncode -> [(ParamName, BEncode)] | 236 | injectVals :: [ParamName] -> BValue -> [(ParamName, BValue)] |
237 | injectVals [] (BList []) = [] | 237 | injectVals [] (BList []) = [] |
238 | injectVals [] (BDict d ) = M.toList d | 238 | injectVals [] (BDict d ) = M.toList d |
239 | injectVals [] be = invalidParamList [] be | 239 | injectVals [] be = invalidParamList [] be |
@@ -242,7 +242,7 @@ injectVals ps (BList as) = L.zip ps as | |||
242 | injectVals ps be = invalidParamList ps be | 242 | injectVals ps be = invalidParamList ps be |
243 | {-# INLINE injectVals #-} | 243 | {-# INLINE injectVals #-} |
244 | 244 | ||
245 | invalidParamList :: [ParamName] -> BEncode -> a | 245 | invalidParamList :: [ParamName] -> BValue -> a |
246 | invalidParamList pl be | 246 | invalidParamList pl be |
247 | = error $ "KRPC invalid parameter list: " ++ show pl ++ "\n" ++ | 247 | = error $ "KRPC invalid parameter list: " ++ show pl ++ "\n" ++ |
248 | "while procedure args are: " ++ show be | 248 | "while procedure args are: " ++ show be |
@@ -262,14 +262,14 @@ instance Exception RPCException | |||
262 | -- | Address of remote can be called by client. | 262 | -- | Address of remote can be called by client. |
263 | type RemoteAddr = KRemoteAddr | 263 | type RemoteAddr = KRemoteAddr |
264 | 264 | ||
265 | queryCall :: BEncodable param | 265 | queryCall :: BEncode param |
266 | => KRemote -> KRemoteAddr | 266 | => KRemote -> KRemoteAddr |
267 | -> Method param result -> param -> IO () | 267 | -> Method param result -> param -> IO () |
268 | queryCall sock addr m arg = sendMessage q addr sock | 268 | queryCall sock addr m arg = sendMessage q addr sock |
269 | where | 269 | where |
270 | q = kquery (methodName m) (injectVals (methodParams m) (toBEncode arg)) | 270 | q = kquery (methodName m) (injectVals (methodParams m) (toBEncode arg)) |
271 | 271 | ||
272 | getResult :: BEncodable result | 272 | getResult :: BEncode result |
273 | => KRemote | 273 | => KRemote |
274 | -> Method param result -> IO result | 274 | -> Method param result -> IO result |
275 | getResult sock m = do | 275 | getResult sock m = do |
@@ -285,7 +285,7 @@ getResult sock m = do | |||
285 | -- | Makes remote procedure call. Throws RPCException on any error | 285 | -- | Makes remote procedure call. Throws RPCException on any error |
286 | -- occurred. | 286 | -- occurred. |
287 | call :: (MonadBaseControl IO host, MonadIO host) | 287 | call :: (MonadBaseControl IO host, MonadIO host) |
288 | => (BEncodable param, BEncodable result) | 288 | => (BEncode param, BEncode result) |
289 | => RemoteAddr -- ^ Address of callee. | 289 | => RemoteAddr -- ^ Address of callee. |
290 | -> Method param result -- ^ Procedure to call. | 290 | -> Method param result -- ^ Procedure to call. |
291 | -> param -- ^ Arguments passed by callee to procedure. | 291 | -> param -- ^ Arguments passed by callee to procedure. |
@@ -294,7 +294,7 @@ call addr m arg = liftIO $ withRemote $ \sock -> do call_ sock addr m arg | |||
294 | 294 | ||
295 | -- | The same as 'call' but use already opened socket. | 295 | -- | The same as 'call' but use already opened socket. |
296 | call_ :: (MonadBaseControl IO host, MonadIO host) | 296 | call_ :: (MonadBaseControl IO host, MonadIO host) |
297 | => (BEncodable param, BEncodable result) | 297 | => (BEncode param, BEncode result) |
298 | => Remote -- ^ Socket to use | 298 | => Remote -- ^ Socket to use |
299 | -> RemoteAddr -- ^ Address of callee. | 299 | -> RemoteAddr -- ^ Address of callee. |
300 | -> Method param result -- ^ Procedure to call. | 300 | -> Method param result -- ^ Procedure to call. |
@@ -313,7 +313,7 @@ type MethodHandler remote = (MethodName, HandlerBody remote) | |||
313 | -- we can safely erase types in (==>) | 313 | -- we can safely erase types in (==>) |
314 | -- | Assign method implementation to the method signature. | 314 | -- | Assign method implementation to the method signature. |
315 | (==>) :: forall (remote :: * -> *) (param :: *) (result :: *). | 315 | (==>) :: forall (remote :: * -> *) (param :: *) (result :: *). |
316 | (BEncodable param, BEncodable result) | 316 | (BEncode param, BEncode result) |
317 | => Monad remote | 317 | => Monad remote |
318 | => Method param result -- ^ Signature. | 318 | => Method param result -- ^ Signature. |
319 | -> (param -> remote result) -- ^ Implementation. | 319 | -> (param -> remote result) -- ^ Implementation. |
@@ -324,7 +324,7 @@ infix 1 ==> | |||
324 | 324 | ||
325 | -- | Similar to '==>@' but additionally pass caller address. | 325 | -- | Similar to '==>@' but additionally pass caller address. |
326 | (==>@) :: forall (remote :: * -> *) (param :: *) (result :: *). | 326 | (==>@) :: forall (remote :: * -> *) (param :: *) (result :: *). |
327 | (BEncodable param, BEncodable result) | 327 | (BEncode param, BEncode result) |
328 | => Monad remote | 328 | => Monad remote |
329 | => Method param result -- ^ Signature. | 329 | => Method param result -- ^ Signature. |
330 | -> (KRemoteAddr -> param -> remote result) -- ^ Implementation. | 330 | -> (KRemoteAddr -> param -> remote result) -- ^ Implementation. |
diff --git a/src/Remote/KRPC/Protocol.hs b/src/Remote/KRPC/Protocol.hs index 06e54f78..d28fdbeb 100644 --- a/src/Remote/KRPC/Protocol.hs +++ b/src/Remote/KRPC/Protocol.hs | |||
@@ -74,8 +74,8 @@ data KError | |||
74 | | MethodUnknown { errorMessage :: ByteString } | 74 | | MethodUnknown { errorMessage :: ByteString } |
75 | deriving (Show, Read, Eq, Ord) | 75 | deriving (Show, Read, Eq, Ord) |
76 | 76 | ||
77 | instance BEncodable KError where | 77 | instance BEncode KError where |
78 | {-# SPECIALIZE instance BEncodable KError #-} | 78 | {-# SPECIALIZE instance BEncode KError #-} |
79 | {-# INLINE toBEncode #-} | 79 | {-# INLINE toBEncode #-} |
80 | toBEncode e = fromAscAssocs -- WARN: keep keys sorted | 80 | toBEncode e = fromAscAssocs -- WARN: keep keys sorted |
81 | [ "e" --> (errorCode e, errorMessage e) | 81 | [ "e" --> (errorCode e, errorMessage e) |
@@ -125,11 +125,11 @@ type ParamName = ByteString | |||
125 | -- | 125 | -- |
126 | data KQuery = KQuery { | 126 | data KQuery = KQuery { |
127 | queryMethod :: MethodName | 127 | queryMethod :: MethodName |
128 | , queryArgs :: Map ParamName BEncode | 128 | , queryArgs :: Map ParamName BValue |
129 | } deriving (Show, Read, Eq, Ord) | 129 | } deriving (Show, Read, Eq, Ord) |
130 | 130 | ||
131 | instance BEncodable KQuery where | 131 | instance BEncode KQuery where |
132 | {-# SPECIALIZE instance BEncodable KQuery #-} | 132 | {-# SPECIALIZE instance BEncode KQuery #-} |
133 | {-# INLINE toBEncode #-} | 133 | {-# INLINE toBEncode #-} |
134 | toBEncode (KQuery m args) = fromAscAssocs -- WARN: keep keys sorted | 134 | toBEncode (KQuery m args) = fromAscAssocs -- WARN: keep keys sorted |
135 | [ "a" --> BDict args | 135 | [ "a" --> BDict args |
@@ -145,7 +145,7 @@ instance BEncodable KQuery where | |||
145 | 145 | ||
146 | fromBEncode _ = decodingError "KQuery" | 146 | fromBEncode _ = decodingError "KQuery" |
147 | 147 | ||
148 | kquery :: MethodName -> [(ParamName, BEncode)] -> KQuery | 148 | kquery :: MethodName -> [(ParamName, BValue)] -> KQuery |
149 | kquery name args = KQuery name (M.fromList args) | 149 | kquery name args = KQuery name (M.fromList args) |
150 | {-# INLINE kquery #-} | 150 | {-# INLINE kquery #-} |
151 | 151 | ||
@@ -163,12 +163,10 @@ type ValName = ByteString | |||
163 | -- | 163 | -- |
164 | -- > { "y" : "r", "r" : [<val1>, <val2>, ...] } | 164 | -- > { "y" : "r", "r" : [<val1>, <val2>, ...] } |
165 | -- | 165 | -- |
166 | newtype KResponse = KResponse { | 166 | newtype KResponse = KResponse { respVals :: BDict } |
167 | respVals :: Map ValName BEncode | 167 | deriving (Show, Read, Eq, Ord) |
168 | } deriving (Show, Read, Eq, Ord) | ||
169 | 168 | ||
170 | instance BEncodable KResponse where | 169 | instance BEncode KResponse where |
171 | {-# SPECIALIZE instance BEncodable KResponse #-} | ||
172 | {-# INLINE toBEncode #-} | 170 | {-# INLINE toBEncode #-} |
173 | toBEncode (KResponse vals) = fromAscAssocs -- WARN: keep keys sorted | 171 | toBEncode (KResponse vals) = fromAscAssocs -- WARN: keep keys sorted |
174 | [ "r" --> vals | 172 | [ "r" --> vals |
@@ -183,7 +181,7 @@ instance BEncodable KResponse where | |||
183 | fromBEncode _ = decodingError "KDict" | 181 | fromBEncode _ = decodingError "KDict" |
184 | 182 | ||
185 | 183 | ||
186 | kresponse :: [(ValName, BEncode)] -> KResponse | 184 | kresponse :: [(ValName, BValue)] -> KResponse |
187 | kresponse = KResponse . M.fromList | 185 | kresponse = KResponse . M.fromList |
188 | {-# INLINE kresponse #-} | 186 | {-# INLINE kresponse #-} |
189 | 187 | ||
@@ -208,7 +206,7 @@ maxMsgSize = 64 * 1024 -- max udp size | |||
208 | 206 | ||
209 | 207 | ||
210 | -- TODO eliminate toStrict | 208 | -- TODO eliminate toStrict |
211 | sendMessage :: BEncodable msg => msg -> KRemoteAddr -> KRemote -> IO () | 209 | sendMessage :: BEncode msg => msg -> KRemoteAddr -> KRemote -> IO () |
212 | sendMessage msg (host, port) sock = | 210 | sendMessage msg (host, port) sock = |
213 | sendAllTo sock (LB.toStrict (encoded msg)) (SockAddrInet port host) | 211 | sendAllTo sock (LB.toStrict (encoded msg)) (SockAddrInet port host) |
214 | {-# INLINE sendMessage #-} | 212 | {-# INLINE sendMessage #-} |
diff --git a/tests/Shared.hs b/tests/Shared.hs index f64112da..1060cfc8 100644 --- a/tests/Shared.hs +++ b/tests/Shared.hs | |||
@@ -32,8 +32,8 @@ swapM = method "swap" ["x", "y"] ["b", "a"] | |||
32 | shiftR :: Method ((), Int, [Int]) ([Int], (), Int) | 32 | shiftR :: Method ((), Int, [Int]) ([Int], (), Int) |
33 | shiftR = method "shiftR" ["x", "y", "z"] ["a", "b", "c"] | 33 | shiftR = method "shiftR" ["x", "y", "z"] ["a", "b", "c"] |
34 | 34 | ||
35 | rawM :: Method BEncode BEncode | 35 | rawM :: Method BValue BValue |
36 | rawM = method "rawM" [""] [""] | 36 | rawM = method "rawM" [""] [""] |
37 | 37 | ||
38 | rawDictM :: Method BEncode BEncode | 38 | rawDictM :: Method BValue BValue |
39 | rawDictM = method "m" [] [] \ No newline at end of file | 39 | rawDictM = method "m" [] [] \ No newline at end of file |