summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/Network/KRPC.hs25
-rw-r--r--src/Network/KRPC/Message.hs118
2 files changed, 87 insertions, 56 deletions
diff --git a/src/Network/KRPC.hs b/src/Network/KRPC.hs
index 2c3a1b48..a96d8da9 100644
--- a/src/Network/KRPC.hs
+++ b/src/Network/KRPC.hs
@@ -190,7 +190,7 @@ recvResponse sock = do
190 Right resp -> Right resp 190 Right resp -> Right resp
191 Left decE -> Left $ case decode raw of 191 Left decE -> Left $ case decode raw of
192 Right kerror -> kerror 192 Right kerror -> kerror
193 _ -> ProtocolError (BC.pack decE) 193 _ -> KError ProtocolError (BC.pack decE) undefined
194 194
195withRemote :: (MonadBaseControl IO m, MonadIO m) => (Socket -> m a) -> m a 195withRemote :: (MonadBaseControl IO m, MonadIO m) => (Socket -> m a) -> m a
196withRemote = bracket (liftIO (socket AF_INET6 Datagram defaultProtocol)) 196withRemote = bracket (liftIO (socket AF_INET6 Datagram defaultProtocol))
@@ -199,8 +199,10 @@ withRemote = bracket (liftIO (socket AF_INET6 Datagram defaultProtocol))
199 199
200getResult :: BEncode result => Socket -> IO result 200getResult :: BEncode result => Socket -> IO result
201getResult sock = do 201getResult sock = do
202 resp <- either throw (return . respVals) =<< recvResponse sock 202 KResponse {..} <- either throw return =<< recvResponse sock
203 either (throw . ProtocolError . BC.pack) return $ fromBEncode resp 203 case fromBEncode respVals of
204 Left msg -> throw $ KError ProtocolError (BC.pack msg) respId
205 Right r -> return r
204 206
205-- | Makes remote procedure call. Throws RPCException on any error 207-- | Makes remote procedure call. Throws RPCException on any error
206-- occurred. 208-- occurred.
@@ -233,10 +235,10 @@ handler body = (name, newbody)
233 {-# INLINE newbody #-} 235 {-# INLINE newbody #-}
234 newbody addr KQuery {..} = 236 newbody addr KQuery {..} =
235 case fromBEncode queryArgs of 237 case fromBEncode queryArgs of
236 Left e -> return (Left (ProtocolError (BC.pack e))) 238 Left e -> return $ Left $ KError ProtocolError (BC.pack e) queryId
237 Right a -> do 239 Right a -> do
238 r <- body addr a 240 r <- body addr a
239 return (Right (KResponse (toBEncode r) queryId)) 241 return $ Right $ KResponse (toBEncode r) queryId
240 242
241sockAddrFamily :: SockAddr -> Family 243sockAddrFamily :: SockAddr -> Family
242sockAddrFamily (SockAddrInet _ _ ) = AF_INET 244sockAddrFamily (SockAddrInet _ _ ) = AF_INET
@@ -265,8 +267,9 @@ remoteServer servAddr action = bracket (liftIO bindServ) (liftIO . sClose) loop
265 where 267 where
266 handleMsg bs addr = case decode bs of 268 handleMsg bs addr = case decode bs of
267 Right query -> (either toBEncode toBEncode <$> action addr query) 269 Right query -> (either toBEncode toBEncode <$> action addr query)
268 `Lifted.catch` (return . toBEncode . serverError) 270 `Lifted.catch` (return . toBEncode . (`serverError` undefined ))
269 Left decodeE -> return $ toBEncode (ProtocolError (BC.pack decodeE)) 271 Left decodeE -> return $ toBEncode $
272 KError ProtocolError (BC.pack decodeE) undefined
270 273
271-- | Run RPC server on specified port by using list of handlers. 274-- | Run RPC server on specified port by using list of handlers.
272-- Server will dispatch procedure specified by callee, but note that 275-- Server will dispatch procedure specified by callee, but note that
@@ -277,7 +280,7 @@ server :: (MonadBaseControl IO remote, MonadIO remote)
277 -> [MethodHandler remote] -- ^ Method table. 280 -> [MethodHandler remote] -- ^ Method table.
278 -> remote () 281 -> remote ()
279server servAddr handlers = do 282server servAddr handlers = do
280 remoteServer servAddr $ \addr q -> do 283 remoteServer servAddr $ \addr q @ KQuery {..} -> do
281 case L.lookup (queryMethod q) handlers of 284 case L.lookup queryMethod handlers of
282 Nothing -> return $ Left $ MethodUnknown (queryMethod q) 285 Nothing -> return $ Left $ KError MethodUnknown queryMethod queryId
283 Just m -> m addr q 286 Just m -> m addr q
diff --git a/src/Network/KRPC/Message.hs b/src/Network/KRPC/Message.hs
index 1a004c64..a70c2ea9 100644
--- a/src/Network/KRPC/Message.hs
+++ b/src/Network/KRPC/Message.hs
@@ -20,7 +20,8 @@
20{-# LANGUAGE DeriveDataTypeable #-} 20{-# LANGUAGE DeriveDataTypeable #-}
21module Network.KRPC.Message 21module Network.KRPC.Message
22 ( -- * Error 22 ( -- * Error
23 KError(..) 23 ErrorCode (..)
24 , KError(..)
24 , serverError 25 , serverError
25 26
26 -- * Query 27 -- * Query
@@ -31,13 +32,60 @@ module Network.KRPC.Message
31 , KResponse(..) 32 , KResponse(..)
32 ) where 33 ) where
33 34
35import Control.Applicative
34import Control.Exception.Lifted as Lifted 36import Control.Exception.Lifted as Lifted
35import Data.BEncode as BE 37import Data.BEncode as BE
36import Data.BEncode.BDict as BE
37import Data.ByteString as B 38import Data.ByteString as B
38import Data.ByteString.Char8 as BC 39import Data.ByteString.Char8 as BC
39import Data.Typeable 40import Data.Typeable
40 41
42
43-- | This transaction ID is generated by the querying node and is
44-- echoed in the response, so responses may be correlated with
45-- multiple queries to the same node. The transaction ID should be
46-- encoded as a short string of binary numbers, typically 2 characters
47-- are enough as they cover 2^16 outstanding queries.
48type TransactionId = ByteString
49
50{-----------------------------------------------------------------------
51-- Error messages
52-----------------------------------------------------------------------}
53
54data ErrorCode
55 -- | Some error doesn't fit in any other category.
56 = GenericError
57
58 -- | Occur when server fail to process procedure call.
59 | ServerError
60
61 -- | Malformed packet, invalid arguments or bad token.
62 | ProtocolError
63
64 -- | Occur when client trying to call method server don't know.
65 | MethodUnknown
66 deriving (Show, Read, Eq, Ord, Bounded, Typeable)
67
68instance Enum ErrorCode where
69 fromEnum GenericError = 201
70 fromEnum ServerError = 202
71 fromEnum ProtocolError = 203
72 fromEnum MethodUnknown = 204
73 {-# INLINE fromEnum #-}
74
75 toEnum 201 = GenericError
76 toEnum 202 = ServerError
77 toEnum 203 = ProtocolError
78 toEnum 204 = MethodUnknown
79 toEnum _ = GenericError
80 {-# INLINE toEnum #-}
81
82instance BEncode ErrorCode where
83 toBEncode = toBEncode . fromEnum
84 {-# INLINE toBEncode #-}
85
86 fromBEncode b = toEnum <$> fromBEncode b
87 {-# INLINE fromBEncode #-}
88
41-- | Errors used to signal that some error occurred while processing a 89-- | Errors used to signal that some error occurred while processing a
42-- procedure call. Error may be send only from server to client but 90-- procedure call. Error may be send only from server to client but
43-- not in the opposite direction. 91-- not in the opposite direction.
@@ -46,62 +94,38 @@ import Data.Typeable
46-- 94--
47-- > { "y" : "e", "e" : [<error_code>, <human_readable_error_reason>] } 95-- > { "y" : "e", "e" : [<error_code>, <human_readable_error_reason>] }
48-- 96--
49data KError 97data KError = KError
50 -- | Some error doesn't fit in any other category. 98 { errorCode :: !ErrorCode
51 = GenericError { errorMessage :: !ByteString } 99 , errorMessage :: !ByteString
52 100 , errorId :: !TransactionId
53 -- | Occur when server fail to process procedure call. 101 } deriving (Show, Read, Eq, Ord, Typeable)
54 | ServerError { errorMessage :: !ByteString }
55
56 -- | Malformed packet, invalid arguments or bad token.
57 | ProtocolError { errorMessage :: !ByteString }
58
59 -- | Occur when client trying to call method server don't know.
60 | MethodUnknown { errorMessage :: !ByteString }
61 deriving (Show, Read, Eq, Ord, Typeable)
62 102
63instance BEncode KError where 103instance BEncode KError where
64 {-# SPECIALIZE instance BEncode KError #-} 104
65 {-# INLINE toBEncode #-} 105 toBEncode KError {..} = toDict $
66 toBEncode e = toDict $ 106 "e" .=! (errorCode, errorMessage)
67 "e" .=! (errorCode e, errorMessage e) 107 .: "t" .=! errorId
68 .: "y" .=! ("e" :: ByteString) 108 .: "y" .=! ("e" :: ByteString)
69 .: endDict 109 .: endDict
110 {-# INLINE toBEncode #-}
70 111
112 fromBEncode = fromDict $ do
113 lookAhead $ match "y" (BString "e")
114 (code, msg) <- field (req "e")
115 KError code msg <$>! "t"
71 {-# INLINE fromBEncode #-} 116 {-# INLINE fromBEncode #-}
72 fromBEncode be @ (BDict d)
73 | BE.lookup "y" d == Just (BString "e")
74 = (`fromDict` be) $ do
75 uncurry mkKError <$>! "e"
76
77 fromBEncode _ = decodingError "KError"
78 117
79instance Exception KError 118instance Exception KError
80 119
81type ErrorCode = Int 120serverError :: SomeException -> TransactionId -> KError
82 121serverError e = KError ServerError (BC.pack (show e))
83errorCode :: KError -> ErrorCode
84errorCode (GenericError _) = 201
85errorCode (ServerError _) = 202
86errorCode (ProtocolError _) = 203
87errorCode (MethodUnknown _) = 204
88{-# INLINE errorCode #-}
89 122
90mkKError :: ErrorCode -> ByteString -> KError 123{-----------------------------------------------------------------------
91mkKError 201 = GenericError 124-- Query messages
92mkKError 202 = ServerError 125-----------------------------------------------------------------------}
93mkKError 203 = ProtocolError
94mkKError 204 = MethodUnknown
95mkKError _ = GenericError
96{-# INLINE mkKError #-}
97
98serverError :: SomeException -> KError
99serverError = ServerError . BC.pack . show
100 126
101type MethodName = ByteString 127type MethodName = ByteString
102 128
103type TransactionId = ByteString
104
105-- | Query used to signal that caller want to make procedure call to 129-- | Query used to signal that caller want to make procedure call to
106-- callee and pass arguments in. Therefore query may be only sent from 130-- callee and pass arguments in. Therefore query may be only sent from
107-- client to server but not in the opposite direction. 131-- client to server but not in the opposite direction.
@@ -130,6 +154,10 @@ instance BEncode KQuery where
130 KQuery <$>! "a" <*>! "q" <*>! "t" 154 KQuery <$>! "a" <*>! "q" <*>! "t"
131 {-# INLINE fromBEncode #-} 155 {-# INLINE fromBEncode #-}
132 156
157{-----------------------------------------------------------------------
158-- Response messages
159-----------------------------------------------------------------------}
160
133-- | KResponse used to signal that callee successufully process a 161-- | KResponse used to signal that callee successufully process a
134-- procedure call and to return values from procedure. KResponse should 162-- procedure call and to return values from procedure. KResponse should
135-- not be sent if error occurred during RPC. Thus KResponse may be only 163-- not be sent if error occurred during RPC. Thus KResponse may be only