-- | Namecoin utility library
module Namecoin where
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
-- | Alias for types with an error message
type Error = Either String
-- * Namecoin config parser
-- | Parse a comment (line beggining with a "#")
comment :: Parser ()
comment = do
char '#' >> takeTill isEndOfLine
endOfLine
return ()
-- | Parse an option of form
--
-- > key=value
setting :: Parser (Text, Text)
setting = do
name <- takeTill (== '=')
char '='
value <- takeTill isEndOfLine
endOfLine
return (name, value)
-- | Parse a line (either a comment or an option)
line :: Parser (Text, Text)
line = (comment >> line) <|> setting
-- | Parse the namecoin config format
config :: 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
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
}
-- | 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
}
-- | Namecoin API error record
data RPCError = RPCError
{ code :: Int -- ^ a number indicating the kind of error
, message :: String -- ^ a detailed explanation of the error
}
-- | 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)
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 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 (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
-- * Name operations
-- | 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
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 1