summaryrefslogtreecommitdiff
path: root/src/Remote
diff options
context:
space:
mode:
Diffstat (limited to 'src/Remote')
-rw-r--r--src/Remote/KRPC.hs22
-rw-r--r--src/Remote/KRPC/Protocol.hs24
2 files changed, 22 insertions, 24 deletions
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
167instance BEncodable (Method a b) 167instance BEncode (Method a b)
168 168
169instance (Typeable a, Typeable b) => Show (Method a b) where 169instance (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
224method = Method 224method = Method
225{-# INLINE method #-} 225{-# INLINE method #-}
226 226
227lookupKey :: ParamName -> Map ByteString BEncode -> Result BEncode 227lookupKey :: ParamName -> BDict -> Result BValue
228lookupKey x = maybe (Left ("not found key " ++ BC.unpack x)) Right . M.lookup x 228lookupKey x = maybe (Left ("not found key " ++ BC.unpack x)) Right . M.lookup x
229 229
230extractArgs :: [ParamName] -> Map ParamName BEncode -> Result BEncode 230extractArgs :: [ParamName] -> BDict -> Result BValue
231extractArgs [] d = Right $ if M.null d then BList [] else BDict d 231extractArgs [] d = Right $ if M.null d then BList [] else BDict d
232extractArgs [x] d = lookupKey x d 232extractArgs [x] d = lookupKey x d
233extractArgs xs d = BList <$> mapM (`lookupKey` d) xs 233extractArgs xs d = BList <$> mapM (`lookupKey` d) xs
234{-# INLINE extractArgs #-} 234{-# INLINE extractArgs #-}
235 235
236injectVals :: [ParamName] -> BEncode -> [(ParamName, BEncode)] 236injectVals :: [ParamName] -> BValue -> [(ParamName, BValue)]
237injectVals [] (BList []) = [] 237injectVals [] (BList []) = []
238injectVals [] (BDict d ) = M.toList d 238injectVals [] (BDict d ) = M.toList d
239injectVals [] be = invalidParamList [] be 239injectVals [] be = invalidParamList [] be
@@ -242,7 +242,7 @@ injectVals ps (BList as) = L.zip ps as
242injectVals ps be = invalidParamList ps be 242injectVals ps be = invalidParamList ps be
243{-# INLINE injectVals #-} 243{-# INLINE injectVals #-}
244 244
245invalidParamList :: [ParamName] -> BEncode -> a 245invalidParamList :: [ParamName] -> BValue -> a
246invalidParamList pl be 246invalidParamList 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.
263type RemoteAddr = KRemoteAddr 263type RemoteAddr = KRemoteAddr
264 264
265queryCall :: BEncodable param 265queryCall :: BEncode param
266 => KRemote -> KRemoteAddr 266 => KRemote -> KRemoteAddr
267 -> Method param result -> param -> IO () 267 -> Method param result -> param -> IO ()
268queryCall sock addr m arg = sendMessage q addr sock 268queryCall 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
272getResult :: BEncodable result 272getResult :: BEncode result
273 => KRemote 273 => KRemote
274 -> Method param result -> IO result 274 -> Method param result -> IO result
275getResult sock m = do 275getResult 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.
287call :: (MonadBaseControl IO host, MonadIO host) 287call :: (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.
296call_ :: (MonadBaseControl IO host, MonadIO host) 296call_ :: (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
77instance BEncodable KError where 77instance 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--
126data KQuery = KQuery { 126data 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
131instance BEncodable KQuery where 131instance 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
148kquery :: MethodName -> [(ParamName, BEncode)] -> KQuery 148kquery :: MethodName -> [(ParamName, BValue)] -> KQuery
149kquery name args = KQuery name (M.fromList args) 149kquery 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--
166newtype KResponse = KResponse { 166newtype KResponse = KResponse { respVals :: BDict }
167 respVals :: Map ValName BEncode 167 deriving (Show, Read, Eq, Ord)
168 } deriving (Show, Read, Eq, Ord)
169 168
170instance BEncodable KResponse where 169instance 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
186kresponse :: [(ValName, BEncode)] -> KResponse 184kresponse :: [(ValName, BValue)] -> KResponse
187kresponse = KResponse . M.fromList 185kresponse = 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
211sendMessage :: BEncodable msg => msg -> KRemoteAddr -> KRemote -> IO () 209sendMessage :: BEncode msg => msg -> KRemoteAddr -> KRemote -> IO ()
212sendMessage msg (host, port) sock = 210sendMessage 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 #-}