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
|
-- | JSON-RPC 1.0 response record
|
||||||
data RPCResponse = RPCResponse
|
data RPCResponse = RPCResponse
|
||||||
{ id :: String -- ^ the same identificative string
|
{ 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
|
, error :: Maybe RPCError -- ^ error in case the method call failed
|
||||||
}
|
}
|
||||||
|
|
||||||
-- | Namecoin API error record
|
-- | Namecoin API error record
|
||||||
data RPCError = RPCError
|
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
|
, message :: String -- ^ a detailed explanation of the error
|
||||||
}
|
}
|
||||||
|
|
||||||
@ -90,37 +90,34 @@ data Name = Name
|
|||||||
{ name :: String -- ^ the namecoin name
|
{ name :: String -- ^ the namecoin name
|
||||||
, value :: String -- ^ its value
|
, value :: String -- ^ its value
|
||||||
, expires_in :: Int -- ^ number of blocks before the name expires
|
, expires_in :: Int -- ^ number of blocks before the name expires
|
||||||
}
|
} deriving (Show)
|
||||||
|
|
||||||
-- | Namecoin API result type
|
|
||||||
type RPCResult = [Name]
|
|
||||||
|
|
||||||
deriveJSON defaultOptions ''RPCRequest
|
deriveJSON defaultOptions ''RPCRequest
|
||||||
deriveJSON defaultOptions ''RPCResponse
|
deriveJSON defaultOptions ''RPCResponse
|
||||||
deriveJSON defaultOptions ''RPCError
|
deriveJSON defaultOptions ''RPCError
|
||||||
deriveJSON defaultOptions ''Name
|
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
|
-- | Execute an RPC method
|
||||||
rpcRequest
|
rpcRequest
|
||||||
:: String -- ^ the URI of the JSON-RPC endpoint
|
:: String -- ^ the URI of the JSON-RPC endpoint
|
||||||
-> String -- ^ the method name
|
-> String -- ^ the method name
|
||||||
-> [String] -- ^ the method parameters
|
-> [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
|
rpcRequest uri method params = do
|
||||||
req <- try (view responseBody <$> (asJSON =<< postWith options uri req))
|
req <- try (view responseBody <$> (asJSON =<< postWith options uri req))
|
||||||
return $ case req of
|
return $ case req of
|
||||||
Left err -> Left ("RPC error: "++show (err :: SomeException))
|
Left err -> Left ("RPC error: "++show (err :: SomeException))
|
||||||
Right res -> case (error res) of
|
Right res -> case (error res) of
|
||||||
Nothing -> Right (fromJust $ result res)
|
Nothing -> Right (result res)
|
||||||
Just err -> Left ("API error "++code err++": "++message err)
|
Just err -> Left ("API error "++show (code err)++": "++message err)
|
||||||
where
|
where
|
||||||
req = toJSON (RPCRequest "namecoin-update" method params)
|
req = toJSON (RPCRequest "namecoin-update" method params)
|
||||||
options = set checkResponse (Just $ \_ _ -> return ()) defaults
|
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
|
-- * Expiration checking
|
||||||
|
|
||||||
@ -128,6 +125,10 @@ nameList uri = rpcRequest uri "name_list" []
|
|||||||
isExpiring :: Name -> Bool
|
isExpiring :: Name -> Bool
|
||||||
isExpiring name = expires_in name < 100
|
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)
|
-- | Issue an udpate for a name (confirming its current value)
|
||||||
nameUpdate :: String -> Name -> IO Int
|
nameUpdate :: String -> Name -> IO Int
|
||||||
nameUpdate uri (Name {..}) = do
|
nameUpdate uri (Name {..}) = do
|
||||||
|
Loading…
Reference in New Issue
Block a user