{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
-- | 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
type Error = Either String
-- * Namecoin config parser
-- | Parse a comment (line beggining with a "#")
comment :: P.Parser ()
comment = do
P.char '#' >> P.takeTill P.isEndOfLine
P.endOfLine
return ()
-- | Parse an option of form
--
-- > key=value
setting :: P.Parser (Text, Text)
setting = do
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 :: P.Parser (Text, Text)
line = (comment >> line) <|> setting
-- | Parse the namecoin config format
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 <- P.parseOnly config content
username <- get dict "rpcuser"
password <- get dict "rpcpassword"
address <- get dict "rpcbind"
port <- get dict "rpcport"
return ("http://"++username++":"++password++"@"++address++":"++port)
where
get dict key = maybe (missing key) (Right . unpack) (lookup key dict)
missing key = Left ("option '"++unpack key++"' is missing.")
-- * JSON-RPC client
-- | 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
} 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
, 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, Generic, FromJSON)
-- | Turn an Aeson AST object into a 'fromJSON' type
decodeValue :: FromJSON a => Value -> Error a
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
rpcRequest uri method params = do
req <- E.try (view W.responseBody <$> (W.asJSON =<< W.postWith options uri req))
return $ case req 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 = J.toJSON (RPCRequest "namecoin-update" method params)
options = set checkResponse (Just $ \_ _ -> return ()) defaults
-- * Name operations
-- | 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
putStr ("Updating name "++name++"... ")
req <- rpcRequest uri "name_update" [ name, value ]
case req of
Left err -> putStrLn "failed" >> putStrLn err >> return 1
Right _ -> putStrLn "ok" >> return 0