module Network.Haskoin.Stratum.Message
(
Method
, ErrorValue
, RequestValue
, ResponseValue
, MessageValue
, ResultValue
, Id(..)
, Result
, Error(..)
, Request(..)
, Response(..)
, Message(..)
, errParse
, errReq
, errMeth
, errParams
, errInternal
, errStr
, leftStr
, numericId
) where
import Control.Applicative ((<|>))
import Control.Monad (mzero)
import Data.Aeson.Types hiding (Result)
import Data.Text (Text, unpack)
import Text.Read (readEither)
type Method = Text
type Result r e v = Either (Error e v) r
type ErrorValue = Error Value String
type RequestValue = Request Value
type ResponseValue = Response Value Value String
type MessageValue = Message Value Value Value String
type ResultValue = Result Value Value String
data Id = IntId { intId :: Int }
| TxtId { txtId :: Text }
deriving (Eq, Show)
data Error e v
= ErrObj
{ errCode :: Int
, errMsg :: String
, errData :: Maybe e
}
| ErrVal
{ errVal :: v
}
deriving (Eq, Show)
data Request j = Request
{ reqMethod :: Method
, reqParams :: Maybe j
, reqId :: Maybe Id
} deriving (Eq, Show)
data Response r e v = Response
{ resResult :: Result r e v
, resId :: Maybe Id
} deriving (Eq, Show)
data Message j r e v
= MsgRequest (Request j)
| MsgResponse (Response r e v)
deriving (Eq, Show)
instance FromJSON Id where
parseJSON (String s) = return (TxtId s)
parseJSON (Number n) = do
let (i, d) = properFraction n
if d == 0.0 then return (IntId i) else mzero
parseJSON _ = mzero
instance ToJSON Id where
toJSON (TxtId s) = toJSON s
toJSON (IntId i) = toJSON i
instance (FromJSON e, FromJSON v) => FromJSON (Error e v) where
parseJSON v@(Object o) = do
mc <- o .:? "code"
mm <- o .:? "message"
md <- o .:? "data"
case (mc, mm) of
(Just c, Just m) -> return (ErrObj c m md)
_ -> parseJSON v >>= return . ErrVal
parseJSON v = parseJSON v >>= return . ErrVal
instance (ToJSON e, ToJSON v) => ToJSON (Error e v) where
toJSON (ErrObj c m d) = object
[ "code" .= c
, "message" .= m
, "data" .= d ]
toJSON (ErrVal v) = toJSON v
instance FromJSON j => FromJSON (Request j) where
parseJSON (Object o) = do
m <- o .: "method"
p <- o .:? "params"
i <- o .:? "id"
return (Request m p i)
parseJSON _ = mzero
instance ToJSON j => ToJSON (Request j) where
toJSON (Request m p i) = object $ filter f
[ "jsonrpc" .= ("2.0" :: String)
, "method" .= m
, "params" .= p
, "id" .= i ]
where
f (_, Null) = False
f _ = True
instance (FromJSON r, FromJSON e, FromJSON v)
=> FromJSON (Response r e v)
where
parseJSON (Object o) = do
mi <- o .: "id"
me <- o .:? "error" .!= Nothing
mr <- o .:? "result" .!= Nothing
case (me, mr) of
(Just e, _) -> return (Response (Left e) mi)
(_, Just r) -> return (Response (Right r) mi)
_ -> mzero
parseJSON _ = mzero
instance (ToJSON r, ToJSON e, ToJSON v)
=> ToJSON (Response r e v)
where
toJSON (Response (Right r) i) = object
[ "jsonrpc" .= ("2.0" :: String)
, "id" .= i
, "result" .= r
]
toJSON (Response (Left e) i) = object
[ "jsonrpc" .= ("2.0" :: String)
, "id" .= i
, "error" .= e
]
instance (FromJSON j, FromJSON r, FromJSON e, FromJSON v)
=> FromJSON (Message j r e v)
where
parseJSON o@(Object _) = q <|> s
where
q = parseJSON o >>= return . MsgRequest
s = parseJSON o >>= return . MsgResponse
parseJSON _ = mzero
instance (ToJSON j, ToJSON r, ToJSON e, ToJSON v)
=> ToJSON (Message j r e v)
where
toJSON (MsgRequest r) = toJSON r
toJSON (MsgResponse r) = toJSON r
errParse :: ToJSON e => Maybe e -> Error e v
errParse = ErrObj (32700) "Parse error"
errReq :: ToJSON e => Maybe e -> Error e v
errReq = ErrObj (32600) "Invalid request"
errMeth :: ToJSON e => Maybe e -> Error e v
errMeth = ErrObj (32601) "Method not found"
errParams :: ToJSON e => Maybe e -> Error e v
errParams = ErrObj (32602) "Invalid params"
errInternal :: ToJSON e => Maybe e -> Error e v
errInternal = ErrObj (32606) "Internal error"
errStr :: Error e Value -> String
errStr (ErrObj _ m _) = m
errStr (ErrVal v) = either id id . flip parseEither v $
withText "error string" (return . unpack)
leftStr :: Either (Error e Value) r -> Either String r
leftStr (Left e) = Left (errStr e)
leftStr (Right r) = Right r
numericId :: Id -> Either String Int
numericId (IntId i) = Right i
numericId (TxtId t) = readEither $ unpack t