module Data.MessagePack.RPC (
MessageId
, MethodName
, Message(..)
) where
import Data.MessagePack (MessagePack (..), Object (..))
import Data.List (intercalate)
import qualified Data.Text as T
import Data.Word (Word64)
type MessageId = Word64
type MethodName = T.Text
data Message =
RequestMessage MessageId MethodName [Object]
| ResponseMessage MessageId (Either Object Object)
| NotificationMessage MethodName [Object]
deriving Eq
instance MessagePack Message where
toObject (RequestMessage mid methodName args) =
ObjectArray
[ ObjectWord 0
, ObjectWord mid
, ObjectStr methodName
, ObjectArray args
]
toObject (ResponseMessage mid (Right result)) =
ObjectArray
[ ObjectWord 1
, ObjectWord mid
, ObjectNil
, result
]
toObject (ResponseMessage mid (Left err)) =
ObjectArray
[ ObjectWord 1
, ObjectWord mid
, err
, ObjectNil
]
toObject (NotificationMessage methodName params) =
ObjectArray
[ ObjectWord 2
, ObjectStr methodName
, ObjectArray params
]
fromObject
( ObjectArray
[ ObjectWord 0
, ObjectWord mid
, ObjectStr methodName
, ObjectArray args
]
) =
return $ RequestMessage mid methodName args
fromObject
( ObjectArray
[ ObjectWord 1
, ObjectWord mid
, ObjectNil
, result
]
) =
return $ ResponseMessage mid (Right result)
fromObject
( ObjectArray
[ ObjectWord 1
, ObjectWord mid
, err
, ObjectNil
]
) =
return $ ResponseMessage mid (Left err)
fromObject
( ObjectArray
[ ObjectWord 2
, ObjectStr methodName
, ObjectArray params
]
) =
return $ NotificationMessage methodName params
fromObject other =
fail $ "Unexpected object:" ++ show other
instance Show Message where
show (RequestMessage mid method objs) =
"request(" ++ show mid ++ ") " ++ T.unpack method ++ " " ++ showObjs objs
show (ResponseMessage mid (Left obj)) =
"response error(" ++ show mid ++ ") " ++ showObj obj
show (ResponseMessage mid (Right obj)) =
"response(" ++ show mid ++ ") " ++ showObj obj
show (NotificationMessage method objs) =
"notification " ++ T.unpack method ++ " " ++ showObjs objs
showObjs :: [Object] -> String
showObjs objs = "[" ++ intercalate "," (map showObj objs) ++ "]"
showObj :: Object -> String
showObj (ObjectWord w) = "+" ++ show w
showObj (ObjectInt n) = show n
showObj ObjectNil = "nil"
showObj (ObjectBool b) = show b
showObj (ObjectStr s) = "\"" ++ T.unpack s ++ "\""
showObj (ObjectArray v) = "[" ++ intercalate "," (map showObj v) ++ "]"
showObj (ObjectMap m) = "{" ++ intercalate "," (map showPair m) ++ "}"
where showPair (x, y) = "(" ++ showObj x ++ "," ++ showObj y ++ ")"
showObj (ObjectBin _ ) = error "ObjectBin"
showObj (ObjectExt _ _ ) = error "ObjectExt"
showObj (ObjectFloat _) = error "ObjectFloat"
showObj (ObjectDouble _) = error "ObjectDouble"