fix JSON error handling
This commit is contained in:
parent
84dba30b71
commit
3e147c0c92
27
Main.hs
27
Main.hs
@ -75,13 +75,13 @@ data RPCRequest = RPCRequest
|
||||
-- | JSON-RPC 1.0 response record
|
||||
data RPCResponse = RPCResponse
|
||||
{ id :: String -- ^ the same identificative string
|
||||
, result :: Maybe RPCResult -- ^ result if the method call succeded
|
||||
, result :: Value -- ^ result if the method call succeded
|
||||
, error :: Maybe RPCError -- ^ error in case the method call failed
|
||||
}
|
||||
|
||||
-- | Namecoin API error record
|
||||
data RPCError = RPCError
|
||||
{ code :: String -- ^ a number indicating the kind of error
|
||||
{ code :: Int -- ^ a number indicating the kind of error
|
||||
, message :: String -- ^ a detailed explanation of the error
|
||||
}
|
||||
|
||||
@ -90,37 +90,34 @@ data Name = Name
|
||||
{ name :: String -- ^ the namecoin name
|
||||
, value :: String -- ^ its value
|
||||
, expires_in :: Int -- ^ number of blocks before the name expires
|
||||
}
|
||||
|
||||
-- | Namecoin API result type
|
||||
type RPCResult = [Name]
|
||||
} deriving (Show)
|
||||
|
||||
deriveJSON defaultOptions ''RPCRequest
|
||||
deriveJSON defaultOptions ''RPCResponse
|
||||
deriveJSON defaultOptions ''RPCError
|
||||
deriveJSON defaultOptions ''Name
|
||||
|
||||
-- | Turn an Aeson AST object into a 'fromJSON' type
|
||||
decodeValue :: FromJSON a => Value -> Error a
|
||||
decodeValue = eitherDecode . encode
|
||||
|
||||
-- | Execute an RPC method
|
||||
rpcRequest
|
||||
:: String -- ^ the URI of the JSON-RPC endpoint
|
||||
-> String -- ^ the method name
|
||||
-> [String] -- ^ the method parameters
|
||||
-> IO (Error RPCResult) -- ^ and error or the wanted result
|
||||
-> IO (Error Value) -- ^ and error or the wanted result
|
||||
rpcRequest uri method params = do
|
||||
req <- try (view responseBody <$> (asJSON =<< postWith options uri req))
|
||||
return $ case req of
|
||||
Left err -> Left ("RPC error: "++show (err :: SomeException))
|
||||
Right res -> case (error res) of
|
||||
Nothing -> Right (fromJust $ result res)
|
||||
Just err -> Left ("API error "++code err++": "++message err)
|
||||
Nothing -> Right (result res)
|
||||
Just err -> Left ("API error "++show (code err)++": "++message err)
|
||||
where
|
||||
req = toJSON (RPCRequest "namecoin-update" method params)
|
||||
options = set checkResponse (Just $ \_ _ -> return ()) defaults
|
||||
|
||||
-- | Return the list of currently registered names
|
||||
nameList :: String -> IO (Error [Name])
|
||||
nameList uri = rpcRequest uri "name_list" []
|
||||
|
||||
|
||||
-- * Expiration checking
|
||||
|
||||
@ -128,6 +125,10 @@ nameList uri = rpcRequest uri "name_list" []
|
||||
isExpiring :: Name -> Bool
|
||||
isExpiring name = expires_in name < 100
|
||||
|
||||
-- | Return the list of currently registered names
|
||||
nameList :: String -> IO (Error [Name])
|
||||
nameList uri = fmap (decodeValue =<<) (rpcRequest uri "name_list" [])
|
||||
|
||||
-- | Issue an udpate for a name (confirming its current value)
|
||||
nameUpdate :: String -> Name -> IO Int
|
||||
nameUpdate uri (Name {..}) = do
|
||||
|
Loading…
Reference in New Issue
Block a user