module Network.MessagePackRpc.Client (
Connection,
connect,
disconnect,
RpcError(..),
RpcMethod,
call,
method,
) where
import Control.Concurrent.MVar
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 :: MVar Handle }
connect :: String
-> Int
-> IO Connection
connect addr port = withSocketsDo $ do
h <- connectTo addr (PortNumber $ fromIntegral port)
mh <- newMVar h
return $ Connection
{ connHandle = mh
}
disconnect :: Connection -> IO ()
disconnect Connection { connHandle = mh } =
hClose =<< takeMVar mh
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 = mh } m args = withMVar mh $ \h -> 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