src/lib/Namecoin.hs: cleanup
- Replace TemplateHaskell with DeriveGenerics for Aeson instance - Limit exported functions - Use qualified module names
This commit is contained in:
parent
67fc016185
commit
14cf4a9781
GPG Key ID:
BFBAF4C975F76450
@ -1,16 +1,34 @@
|
||||
-- | Namecoin utility library
|
||||
module Namecoin where
|
||||
{-# LANGUAGE DeriveAnyClass #-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
|
||||
import Control.Applicative (many, (<|>))
|
||||
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.Text (Text, unpack)
|
||||
import Data.Aeson
|
||||
import Data.Aeson.TH
|
||||
import Network.Wreq
|
||||
-- | Namecoin utility library
|
||||
module Namecoin
|
||||
-- * JSON-RPC client
|
||||
( RPCRequest(..)
|
||||
, RPCResponse(..)
|
||||
, RPCError(..)
|
||||
, rpcRequest
|
||||
|
||||
-- * Name operations
|
||||
, Name(..)
|
||||
, nameList
|
||||
, nameUpdate
|
||||
|
||||
-- * Miscellanea
|
||||
, uri
|
||||
) where
|
||||
|
||||
import Control.Applicative (many, (<|>))
|
||||
import Control.Lens (set, view)
|
||||
import Data.Maybe (fromJust)
|
||||
import Data.Text (Text, unpack)
|
||||
import Data.Aeson (ToJSON, FromJSON, Value)
|
||||
import GHC.Generics (Generic)
|
||||
|
||||
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
|
||||
@ -20,36 +38,40 @@ type Error = Either String
|
||||
-- * Namecoin config parser
|
||||
|
||||
-- | Parse a comment (line beggining with a "#")
|
||||
comment :: Parser ()
|
||||
comment :: P.Parser ()
|
||||
comment = do
|
||||
char '#' >> takeTill isEndOfLine
|
||||
endOfLine
|
||||
P.char '#' >> P.takeTill P.isEndOfLine
|
||||
P.endOfLine
|
||||
return ()
|
||||
|
||||
|
||||
-- | Parse an option of form
|
||||
--
|
||||
-- > key=value
|
||||
setting :: Parser (Text, Text)
|
||||
setting :: P.Parser (Text, Text)
|
||||
setting = do
|
||||
name <- takeTill (== '=')
|
||||
char '='
|
||||
value <- takeTill isEndOfLine
|
||||
endOfLine
|
||||
name <- P.takeTill (== '=')
|
||||
P.char '='
|
||||
value <- P.takeTill P.isEndOfLine
|
||||
P.endOfLine
|
||||
return (name, value)
|
||||
|
||||
|
||||
-- | Parse a line (either a comment or an option)
|
||||
line :: Parser (Text, Text)
|
||||
line :: P.Parser (Text, Text)
|
||||
line = (comment >> line) <|> setting
|
||||
|
||||
|
||||
-- | Parse the namecoin config format
|
||||
config :: Parser [(Text, Text)]
|
||||
config :: P.Parser [(Text, Text)]
|
||||
config = many line
|
||||
|
||||
|
||||
-- | Takes the content of a namecoin config file
|
||||
-- and gives the URI to connect to the JSON-RPC server
|
||||
uri :: Text -> Error String
|
||||
uri content = do
|
||||
dict <- parseOnly config content
|
||||
dict <- P.parseOnly config content
|
||||
username <- get dict "rpcuser"
|
||||
password <- get dict "rpcpassword"
|
||||
address <- get dict "rpcbind"
|
||||
@ -64,64 +86,65 @@ uri content = do
|
||||
|
||||
-- | JSON-RPC 1.0 request record
|
||||
data RPCRequest = RPCRequest
|
||||
{ id :: String -- ^ a string identificating the client
|
||||
, method :: String -- ^ the name of the method
|
||||
, params :: [String] -- ^ a list of parameters for the method
|
||||
}
|
||||
{ id :: String -- ^ a string identificating the client
|
||||
, method :: String -- ^ the name of the method
|
||||
, params :: [String] -- ^ a list of parameters for the method
|
||||
} deriving (Generic, FromJSON, ToJSON)
|
||||
|
||||
|
||||
-- | JSON-RPC 1.0 response record
|
||||
data RPCResponse = RPCResponse
|
||||
{ id :: String -- ^ the same identificative string
|
||||
, result :: Value -- ^ result if the method call succeded
|
||||
, error :: Maybe RPCError -- ^ error in case the method call failed
|
||||
}
|
||||
{ id :: String -- ^ the same identificative string
|
||||
, result :: Value -- ^ result if the method call succeded
|
||||
, rpcError :: Maybe RPCError -- ^ error in case the method call failed
|
||||
} deriving (Generic, FromJSON, ToJSON)
|
||||
|
||||
|
||||
-- | Namecoin API error record
|
||||
data RPCError = RPCError
|
||||
{ code :: Int -- ^ a number indicating the kind of error
|
||||
, message :: String -- ^ a detailed explanation of the error
|
||||
}
|
||||
} deriving (Generic, FromJSON, ToJSON)
|
||||
|
||||
|
||||
-- | Namecoin API Value record
|
||||
data Name = Name
|
||||
{ name :: String -- ^ the namecoin name
|
||||
, value :: String -- ^ its value
|
||||
, expires_in :: Int -- ^ number of blocks before the name expires
|
||||
} deriving (Show)
|
||||
{ name :: String -- ^ the namecoin name
|
||||
, value :: String -- ^ its value
|
||||
, expires_in :: Int -- ^ number of blocks before the name expires
|
||||
} 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
|
||||
decodeValue :: FromJSON a => Value -> Error a
|
||||
decodeValue = eitherDecode . encode
|
||||
decodeValue = J.eitherDecode . J.encode
|
||||
|
||||
|
||||
-- | Execute an RPC method
|
||||
rpcRequest
|
||||
:: String -- ^ the URI of the JSON-RPC endpoint
|
||||
-> String -- ^ the method name
|
||||
-> [String] -- ^ the method parameters
|
||||
-> IO (Error Value) -- ^ and error or the wanted result
|
||||
:: String -- ^ the URI of the JSON-RPC endpoint
|
||||
-> String -- ^ the method name
|
||||
-> [String] -- ^ the method parameters
|
||||
-> IO (Error Value) -- ^ and error or the wanted result
|
||||
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
|
||||
Left err -> Left ("RPC error: "++show (err :: SomeException))
|
||||
Right res -> case (error res) of
|
||||
Left err -> Left ("RPC error: "++show (err :: E.SomeException))
|
||||
Right res -> case (rpcError res) of
|
||||
Nothing -> Right (result res)
|
||||
Just err -> Left ("API error "++show (code err)++": "++message err)
|
||||
where
|
||||
req = toJSON (RPCRequest "namecoin-update" method params)
|
||||
req = J.toJSON (RPCRequest "namecoin-update" method params)
|
||||
options = set checkResponse (Just $ \_ _ -> return ()) defaults
|
||||
|
||||
|
||||
-- * Name operations
|
||||
|
||||
-- | Return the list of currently registered names
|
||||
-- | Returns 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
|
||||
@ -130,4 +153,3 @@ nameUpdate uri (Name {..}) = do
|
||||
case req of
|
||||
Left err -> putStrLn "failed" >> putStrLn err >> return 1
|
||||
Right _ -> putStrLn "ok" >> return 1
|
||||
|
||||
|
||||
Loading…
Reference in New Issue
Block a user