module Network.MessagePack ( Method
, runRPC ) where
import Control.Applicative
import Control.Monad
import Data.Int
import Data.MessagePack
import Data.Maybe
import Data.Serialize.Get
import Network.Simple.TCP
import qualified Data.ByteString as BS
import qualified Data.Map as M
import qualified Data.Serialize as S
import qualified Data.Text as T
type MsgId = Int64
type MsgType = Int64
reqMessage :: MsgType
reqMessage = 0
resMessage :: MsgType
resMessage = 1
errorMsgId :: Int64
errorMsgId = 0
type Method = Object -> IO (Either String Object)
runRPC :: M.Map T.Text Method -> HostPreference -> ServiceName -> IO ()
runRPC methods host service =
serve host service rpcServer
where
rpcServer (socket, _) =
do reqMsg <- getRequestMessage
respMsg <- either (return . errorResponse errorMsgId) (executeRPC methods) reqMsg
send socket $ S.encode respMsg
where
getRequestMessage =
do result <- go $ runGetPartial S.get
return $ case result of
Fail err _ -> Left err
Done r _ -> Right r
Partial _ -> Left "unexpected end of RPC message"
where
go partial = do bs <- fromMaybe BS.empty <$> recv socket 1024
case partial bs of
Partial partial' -> go partial'
x -> return x
executeRPC :: M.Map T.Text Method -> Object -> IO Object
executeRPC methods obj =
case getRPCData of
Left err -> return $ errorResponse errorMsgId err
Right (method, msgid, params) -> do result <- method params
return $ either (errorResponse msgid) (resultResponse msgid) result
where
getRPCData =
do let m .: k = maybe (Left $ "missing key: " ++ show k) Right $ M.lookup (ObjectString k) m
getMethod ms name = maybe (Left $ "unsupported method: " ++ show name) Right $ M.lookup name ms
case obj of
(ObjectMap m) -> do ObjectInt type_ <- m .: "type"
when (type_ /= reqMessage) $ Left $ "invalid RPC type: " ++ show type_
ObjectString methodName <- m .: "method"
method <- getMethod methods methodName
ObjectInt msgid <- m .: "msgid"
params <- m .: "params"
return (method, msgid, params)
_ -> Left "invalid msgpack RPC request"
errorResponse :: MsgId -> String -> Object
errorResponse msgid err = response msgid (ObjectString $ T.pack err) ObjectNil
resultResponse :: MsgId -> Object -> Object
resultResponse msgid = response msgid ObjectNil
response :: MsgId -> Object -> Object -> Object
response msgid errObj resObj =
ObjectMap $ M.fromList [ (ObjectString "type" , ObjectInt resMessage)
, (ObjectString "msgid" , ObjectInt msgid)
, (ObjectString "error" , errObj)
, (ObjectString "result", resObj) ]