fix JSON error handling

This commit is contained in:
rnhmjoj 2017-05-14 05:53:04 +02:00
parent 84dba30b71
commit 3e147c0c92
No known key found for this signature in database
GPG Key ID: 362BB82B7E496B7C

27
Main.hs
View File

@ -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