diff options
author | Sam T <pxqr.sta@gmail.com> | 2013-05-12 04:54:04 +0400 |
---|---|---|
committer | Sam T <pxqr.sta@gmail.com> | 2013-05-12 04:54:04 +0400 |
commit | 250db0db86afe9462de1624a11e6b124c191d467 (patch) | |
tree | e784b568b9bd8271be0c89164cb4b31bbf06fd31 /src/Remote | |
parent | e188c26f9e6b548b5170fb86f1bd4beee1f84708 (diff) |
- Remove text dependency.
Diffstat (limited to 'src/Remote')
-rw-r--r-- | src/Remote/KRPC.hs | 8 | ||||
-rw-r--r-- | src/Remote/KRPC/Protocol.hs | 23 |
2 files changed, 12 insertions, 19 deletions
diff --git a/src/Remote/KRPC.hs b/src/Remote/KRPC.hs index 719b9a25..fcfdf6bf 100644 --- a/src/Remote/KRPC.hs +++ b/src/Remote/KRPC.hs | |||
@@ -30,8 +30,6 @@ import Data.ByteString.Char8 as BC | |||
30 | import Data.List as L | 30 | import Data.List as L |
31 | import Data.Map as M | 31 | import Data.Map as M |
32 | import Data.Set as S | 32 | import Data.Set as S |
33 | import Data.Text as T | ||
34 | import Data.Text.Encoding as T | ||
35 | import Data.Typeable | 33 | import Data.Typeable |
36 | import Network | 34 | import Network |
37 | 35 | ||
@@ -77,7 +75,7 @@ getResult sock addr m = do | |||
77 | Right (respVals -> dict) -> do | 75 | Right (respVals -> dict) -> do |
78 | case extractArgs (methodVals m) dict >>= extractor of | 76 | case extractArgs (methodVals m) dict >>= extractor of |
79 | Right vals -> return vals | 77 | Right vals -> return vals |
80 | Left e -> throw (RPCException (ProtocolError (T.pack e))) | 78 | Left e -> throw (RPCException (ProtocolError (BC.pack e))) |
81 | 79 | ||
82 | -- TODO async call | 80 | -- TODO async call |
83 | -- | Makes remote procedure call. Throws RPCException if server | 81 | -- | Makes remote procedure call. Throws RPCException if server |
@@ -135,7 +133,7 @@ m ==> body = (methodName m, newbody) | |||
135 | {-# INLINE newbody #-} | 133 | {-# INLINE newbody #-} |
136 | newbody q = | 134 | newbody q = |
137 | case extractArgs (methodParams m) (queryArgs q) >>= extractor of | 135 | case extractArgs (methodParams m) (queryArgs q) >>= extractor of |
138 | Left e -> return (Left (ProtocolError (T.pack e))) | 136 | Left e -> return (Left (ProtocolError (BC.pack e))) |
139 | Right a -> do | 137 | Right a -> do |
140 | r <- body a | 138 | r <- body a |
141 | return (Right (kresponse (mkVals (methodVals m) (injector r)))) | 139 | return (Right (kresponse (mkVals (methodVals m) (injector r)))) |
@@ -151,7 +149,7 @@ server :: (MonadBaseControl IO remote, MonadIO remote) | |||
151 | server servport handlers = do | 149 | server servport handlers = do |
152 | remoteServer servport $ \_ q -> do | 150 | remoteServer servport $ \_ q -> do |
153 | case dispatch (queryMethod q) of | 151 | case dispatch (queryMethod q) of |
154 | Nothing -> return $ Left $ MethodUnknown (decodeUtf8 (queryMethod q)) | 152 | Nothing -> return $ Left $ MethodUnknown (queryMethod q) |
155 | Just m -> invoke m q | 153 | Just m -> invoke m q |
156 | where | 154 | where |
157 | handlerMap = M.fromList handlers | 155 | handlerMap = M.fromList handlers |
diff --git a/src/Remote/KRPC/Protocol.hs b/src/Remote/KRPC/Protocol.hs index 98674c51..918bc735 100644 --- a/src/Remote/KRPC/Protocol.hs +++ b/src/Remote/KRPC/Protocol.hs | |||
@@ -49,10 +49,10 @@ import Control.Monad.Trans.Control | |||
49 | 49 | ||
50 | import Data.BEncode | 50 | import Data.BEncode |
51 | import Data.ByteString as B | 51 | import Data.ByteString as B |
52 | import Data.ByteString.Char8 as BC | ||
52 | import qualified Data.ByteString.Lazy as LB | 53 | import qualified Data.ByteString.Lazy as LB |
53 | import Data.Map as M | 54 | import Data.Map as M |
54 | import Data.Set as S | 55 | import Data.Set as S |
55 | import Data.Text as T | ||
56 | 56 | ||
57 | import Network.Socket hiding (recvFrom) | 57 | import Network.Socket hiding (recvFrom) |
58 | import Network.Socket.ByteString | 58 | import Network.Socket.ByteString |
@@ -78,16 +78,16 @@ class KMessage message scheme | message -> scheme where | |||
78 | -- TODO document that it is and how transferred | 78 | -- TODO document that it is and how transferred |
79 | data KError | 79 | data KError |
80 | -- | Some error doesn't fit in any other category. | 80 | -- | Some error doesn't fit in any other category. |
81 | = GenericError { errorMessage :: Text } | 81 | = GenericError { errorMessage :: ByteString } |
82 | 82 | ||
83 | -- | Occur when server fail to process procedure call. | 83 | -- | Occur when server fail to process procedure call. |
84 | | ServerError { errorMessage :: Text } | 84 | | ServerError { errorMessage :: ByteString } |
85 | 85 | ||
86 | -- | Malformed packet, invalid arguments or bad token. | 86 | -- | Malformed packet, invalid arguments or bad token. |
87 | | ProtocolError { errorMessage :: Text } | 87 | | ProtocolError { errorMessage :: ByteString } |
88 | 88 | ||
89 | -- | Occur when client trying to call method server don't know. | 89 | -- | Occur when client trying to call method server don't know. |
90 | | MethodUnknown { errorMessage :: Text } | 90 | | MethodUnknown { errorMessage :: ByteString } |
91 | deriving (Show, Read, Eq, Ord) | 91 | deriving (Show, Read, Eq, Ord) |
92 | 92 | ||
93 | instance BEncodable KError where | 93 | instance BEncodable KError where |
@@ -116,7 +116,7 @@ errorCode (ProtocolError _) = 203 | |||
116 | errorCode (MethodUnknown _) = 204 | 116 | errorCode (MethodUnknown _) = 204 |
117 | {-# INLINE errorCode #-} | 117 | {-# INLINE errorCode #-} |
118 | 118 | ||
119 | mkKError :: ErrorCode -> Text -> KError | 119 | mkKError :: ErrorCode -> ByteString -> KError |
120 | mkKError 201 = GenericError | 120 | mkKError 201 = GenericError |
121 | mkKError 202 = ServerError | 121 | mkKError 202 = ServerError |
122 | mkKError 203 = ProtocolError | 122 | mkKError 203 = ProtocolError |
@@ -125,7 +125,7 @@ mkKError _ = GenericError | |||
125 | {-# INLINE mkKError #-} | 125 | {-# INLINE mkKError #-} |
126 | 126 | ||
127 | serverError :: SomeException -> KError | 127 | serverError :: SomeException -> KError |
128 | serverError = ServerError . T.pack . show | 128 | serverError = ServerError . BC.pack . show |
129 | 129 | ||
130 | -- TODO Asc everywhere | 130 | -- TODO Asc everywhere |
131 | 131 | ||
@@ -238,7 +238,7 @@ recvResponse addr sock = do | |||
238 | Right resp -> Right resp | 238 | Right resp -> Right resp |
239 | Left decE -> Left $ case decoded raw of | 239 | Left decE -> Left $ case decoded raw of |
240 | Right kerror -> kerror | 240 | Right kerror -> kerror |
241 | _ -> ProtocolError (T.pack decE) | 241 | _ -> ProtocolError (BC.pack decE) |
242 | 242 | ||
243 | 243 | ||
244 | remoteServer :: (MonadBaseControl IO remote, MonadIO remote) | 244 | remoteServer :: (MonadBaseControl IO remote, MonadIO remote) |
@@ -265,12 +265,7 @@ remoteServer servport action = bracket (liftIO bind) (liftIO . sClose) loop | |||
265 | handleMsg bs addr = case decoded bs of | 265 | handleMsg bs addr = case decoded bs of |
266 | Right query -> (either toBEncode toBEncode <$> action addr query) | 266 | Right query -> (either toBEncode toBEncode <$> action addr query) |
267 | `catch` (return . toBEncode . serverError) | 267 | `catch` (return . toBEncode . serverError) |
268 | Left decodeE -> return $ toBEncode rpcE | 268 | Left decodeE -> return $ toBEncode (ProtocolError (BC.pack decodeE)) |
269 | where | ||
270 | rpcE = ProtocolError $ T.concat | ||
271 | ["Unable to decode query: ", T.pack (show bs), "\n" | ||
272 | ,"Specifically: ", T.pack decodeE | ||
273 | ] | ||
274 | 269 | ||
275 | 270 | ||
276 | -- TODO to bencodable | 271 | -- TODO to bencodable |