src/lib/Namecoin.hs: cleanup

- Replace TemplateHaskell with DeriveGenerics for Aeson instance
- Limit exported functions
- Use qualified module names
This commit is contained in:
Michele Guerini Rocco 2022-06-12 01:50:31 +02:00
parent 67fc016185
commit 14cf4a9781
Signed by: rnhmjoj
GPG Key ID: BFBAF4C975F76450

View File

@ -1,16 +1,34 @@
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
-- | Namecoin utility library -- | Namecoin utility library
module Namecoin where module Namecoin
-- * JSON-RPC client
( RPCRequest(..)
, RPCResponse(..)
, RPCError(..)
, rpcRequest
-- * Name operations
, Name(..)
, nameList
, nameUpdate
-- * Miscellanea
, uri
) where
import Control.Applicative (many, (<|>)) import Control.Applicative (many, (<|>))
import Control.Lens (set, view) import Control.Lens (set, view)
import Control.Exception (SomeException, try)
import Prelude hiding (error)
import Data.Attoparsec.Text hiding (try)
import Data.Maybe (fromJust) import Data.Maybe (fromJust)
import Data.Text (Text, unpack) import Data.Text (Text, unpack)
import Data.Aeson import Data.Aeson (ToJSON, FromJSON, Value)
import Data.Aeson.TH import GHC.Generics (Generic)
import Network.Wreq
import Network.Wreq as W
import qualified Data.Aeson as J
import qualified Data.Attoparsec.Text as P
import qualified Control.Exception as E
-- | Alias for types with an error message -- | Alias for types with an error message
@ -20,36 +38,40 @@ type Error = Either String
-- * Namecoin config parser -- * Namecoin config parser
-- | Parse a comment (line beggining with a "#") -- | Parse a comment (line beggining with a "#")
comment :: Parser () comment :: P.Parser ()
comment = do comment = do
char '#' >> takeTill isEndOfLine P.char '#' >> P.takeTill P.isEndOfLine
endOfLine P.endOfLine
return () return ()
-- | Parse an option of form -- | Parse an option of form
-- --
-- > key=value -- > key=value
setting :: Parser (Text, Text) setting :: P.Parser (Text, Text)
setting = do setting = do
name <- takeTill (== '=') name <- P.takeTill (== '=')
char '=' P.char '='
value <- takeTill isEndOfLine value <- P.takeTill P.isEndOfLine
endOfLine P.endOfLine
return (name, value) return (name, value)
-- | Parse a line (either a comment or an option) -- | Parse a line (either a comment or an option)
line :: Parser (Text, Text) line :: P.Parser (Text, Text)
line = (comment >> line) <|> setting line = (comment >> line) <|> setting
-- | Parse the namecoin config format -- | Parse the namecoin config format
config :: Parser [(Text, Text)] config :: P.Parser [(Text, Text)]
config = many line config = many line
-- | Takes the content of a namecoin config file -- | Takes the content of a namecoin config file
-- and gives the URI to connect to the JSON-RPC server -- and gives the URI to connect to the JSON-RPC server
uri :: Text -> Error String uri :: Text -> Error String
uri content = do uri content = do
dict <- parseOnly config content dict <- P.parseOnly config content
username <- get dict "rpcuser" username <- get dict "rpcuser"
password <- get dict "rpcpassword" password <- get dict "rpcpassword"
address <- get dict "rpcbind" address <- get dict "rpcbind"
@ -67,36 +89,36 @@ data RPCRequest = RPCRequest
{ id :: String -- ^ a string identificating the client { id :: String -- ^ a string identificating the client
, method :: String -- ^ the name of the method , method :: String -- ^ the name of the method
, params :: [String] -- ^ a list of parameters for the method , params :: [String] -- ^ a list of parameters for the method
} } deriving (Generic, FromJSON, ToJSON)
-- | 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 :: Value -- ^ result if the method call succeded , result :: Value -- ^ result if the method call succeded
, error :: Maybe RPCError -- ^ error in case the method call failed , rpcError :: Maybe RPCError -- ^ error in case the method call failed
} } deriving (Generic, FromJSON, ToJSON)
-- | Namecoin API error record -- | Namecoin API error record
data RPCError = RPCError data RPCError = RPCError
{ code :: Int -- ^ 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
} } deriving (Generic, FromJSON, ToJSON)
-- | Namecoin API Value record -- | Namecoin API Value record
data Name = Name 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) } deriving (Show, Generic, FromJSON)
deriveJSON defaultOptions ''RPCRequest
deriveJSON defaultOptions ''RPCResponse
deriveJSON defaultOptions ''RPCError
deriveJSON defaultOptions ''Name
-- | Turn an Aeson AST object into a 'fromJSON' type -- | Turn an Aeson AST object into a 'fromJSON' type
decodeValue :: FromJSON a => Value -> Error a decodeValue :: FromJSON a => Value -> Error a
decodeValue = eitherDecode . encode decodeValue = J.eitherDecode . J.encode
-- | Execute an RPC method -- | Execute an RPC method
rpcRequest rpcRequest
@ -105,23 +127,24 @@ rpcRequest
-> [String] -- ^ the method parameters -> [String] -- ^ the method parameters
-> IO (Error Value) -- ^ 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 <- E.try (view W.responseBody <$> (W.asJSON =<< W.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 :: E.SomeException))
Right res -> case (error res) of Right res -> case (rpcError res) of
Nothing -> Right (result res) Nothing -> Right (result res)
Just err -> Left ("API error "++show (code err)++": "++message err) Just err -> Left ("API error "++show (code err)++": "++message err)
where where
req = toJSON (RPCRequest "namecoin-update" method params) req = J.toJSON (RPCRequest "namecoin-update" method params)
options = set checkResponse (Just $ \_ _ -> return ()) defaults options = set checkResponse (Just $ \_ _ -> return ()) defaults
-- * Name operations -- * Name operations
-- | Return the list of currently registered names -- | Returns the list of currently registered names
nameList :: String -> IO (Error [Name]) nameList :: String -> IO (Error [Name])
nameList uri = fmap (decodeValue =<<) (rpcRequest uri "name_list" []) 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
@ -130,4 +153,3 @@ nameUpdate uri (Name {..}) = do
case req of case req of
Left err -> putStrLn "failed" >> putStrLn err >> return 1 Left err -> putStrLn "failed" >> putStrLn err >> return 1
Right _ -> putStrLn "ok" >> return 1 Right _ -> putStrLn "ok" >> return 1