module Network.MessagePackRpc.Client (
Connection,
connect,
disconnect,
RpcError(..),
RpcMethod,
call,
method,
) where
import Control.Exception
import Control.Monad
import Data.Attoparsec.Enumerator
import qualified Data.ByteString.Lazy as BL
import Data.Enumerator
import Data.Enumerator.Binary
import Data.Functor
import Data.MessagePack
import Data.Typeable
import Network
import System.IO
import System.Random
bufferSize :: Integer
bufferSize = 4096
data Connection
= Connection
{ connHandle :: Handle }
connect :: String
-> Int
-> IO Connection
connect addr port = withSocketsDo $ do
h <- connectTo addr (PortNumber $ fromIntegral port)
return $ Connection
{ connHandle = h
}
disconnect :: Connection -> IO ()
disconnect Connection { connHandle = h } =
hClose h
data RpcError
= ServerError Object
| ResultTypeError String
| ProtocolError String
deriving (Eq, Ord, Typeable)
instance Exception RpcError
instance Show RpcError where
show (ServerError err) =
"server error: " ++ show err
show (ResultTypeError err) =
"result type error: " ++ err
show (ProtocolError err) =
"protocol error: " ++ err
class RpcType r where
rpcc :: Connection -> String -> [Object] -> r
fromObject' :: OBJECT o => Object -> o
fromObject' o =
case tryFromObject o of
Left err -> throw $ ResultTypeError err
Right r -> r
instance OBJECT o => RpcType (IO o) where
rpcc c m args = return . fromObject' =<< rpcCall c m (reverse args)
instance (OBJECT o, RpcType r) => RpcType (o -> r) where
rpcc c m args arg = rpcc c m (toObject arg:args)
rpcCall :: Connection -> String -> [Object] -> IO Object
rpcCall Connection{ connHandle = h } m args = do
msgid <- (`mod`2^(30::Int)) <$> randomIO :: IO Int
BL.hPutStr h $ pack (0 ::Int, msgid, m, args)
hFlush h
run_ $ enumHandle bufferSize h $$ do
(rtype, rmsgid, rerror, rresult) <- iterParser get
when (rtype /= (1 :: Int)) $
throw $ ProtocolError $ "response type is not 1 (got " ++ show rtype ++ ")"
when (rmsgid /= msgid) $
throw $ ProtocolError $ "message id mismatch: expect " ++ show msgid ++ ", but got " ++ show rmsgid
case tryFromObject rerror of
Left _ ->
throw $ ServerError rerror
Right () ->
return rresult
call :: RpcType a =>
Connection
-> String
-> a
call c m = rpcc c m []
method :: RpcType a => String -> RpcMethod a
method c m = call m c
type RpcMethod a = Connection -> a