diff --git a/src/lib/Namecoin.hs b/src/lib/Namecoin.hs index 0808365..43c6eee 100644 --- a/src/lib/Namecoin.hs +++ b/src/lib/Namecoin.hs @@ -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 -