{-# 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 :: Parser ()
comment = do
  Char -> Parser Char
P.char Char
'#' Parser Char -> Parser Text Text -> Parser Text Text
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (Char -> Bool) -> Parser Text Text
P.takeTill Char -> Bool
P.isEndOfLine
  Parser ()
P.endOfLine
  () -> Parser ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()


-- | Parse an option of form
--
-- > key=value
setting :: P.Parser (Text, Text)
setting :: Parser (Text, Text)
setting = do
  Text
name <- (Char -> Bool) -> Parser Text Text
P.takeTill (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'=')
  Char -> Parser Char
P.char Char
'='
  Text
value <- (Char -> Bool) -> Parser Text Text
P.takeTill Char -> Bool
P.isEndOfLine
  Parser ()
P.endOfLine
  (Text, Text) -> Parser (Text, Text)
forall (m :: * -> *) a. Monad m => a -> m a
return (Text
name, Text
value)


-- | Parse a line (either a comment or an option)
line :: P.Parser (Text, Text)
line :: Parser (Text, Text)
line = (Parser ()
comment Parser () -> Parser (Text, Text) -> Parser (Text, Text)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Parser (Text, Text)
line) Parser (Text, Text) -> Parser (Text, Text) -> Parser (Text, Text)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser (Text, Text)
setting


-- | Parse the namecoin config format
config :: P.Parser [(Text, Text)]
config :: Parser [(Text, Text)]
config = Parser (Text, Text) -> Parser [(Text, Text)]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many Parser (Text, Text)
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 :: Text -> Error String
uri Text
content = do
  [(Text, Text)]
dict     <- Parser [(Text, Text)] -> Text -> Either String [(Text, Text)]
forall a. Parser a -> Text -> Either String a
P.parseOnly Parser [(Text, Text)]
config Text
content
  String
username <- [(Text, Text)] -> Text -> Error String
get [(Text, Text)]
dict Text
"rpcuser"
  String
password <- [(Text, Text)] -> Text -> Error String
get [(Text, Text)]
dict Text
"rpcpassword"
  String
address  <- [(Text, Text)] -> Text -> Error String
get [(Text, Text)]
dict Text
"rpcbind"
  String
port     <- [(Text, Text)] -> Text -> Error String
get [(Text, Text)]
dict Text
"rpcport"
  String -> Error String
forall (m :: * -> *) a. Monad m => a -> m a
return (String
"http://"String -> String -> String
forall a. [a] -> [a] -> [a]
++String
usernameString -> String -> String
forall a. [a] -> [a] -> [a]
++String
":"String -> String -> String
forall a. [a] -> [a] -> [a]
++String
passwordString -> String -> String
forall a. [a] -> [a] -> [a]
++String
"@"String -> String -> String
forall a. [a] -> [a] -> [a]
++String
addressString -> String -> String
forall a. [a] -> [a] -> [a]
++String
":"String -> String -> String
forall a. [a] -> [a] -> [a]
++String
port)
  where
    get :: [(Text, Text)] -> Text -> Error String
get [(Text, Text)]
dict Text
key = Error String
-> (Text -> Error String) -> Maybe Text -> Error String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Text -> Error String
forall {b}. Text -> Either String b
missing Text
key) (String -> Error String
forall a b. b -> Either a b
Right (String -> Error String)
-> (Text -> String) -> Text -> Error String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
unpack) (Text -> [(Text, Text)] -> Maybe Text
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Text
key [(Text, Text)]
dict)
    missing :: Text -> Either String b
missing Text
key  = String -> Either String b
forall a b. a -> Either a b
Left (String
"option '"String -> String -> String
forall a. [a] -> [a] -> [a]
++Text -> String
unpack Text
keyString -> String -> String
forall a. [a] -> [a] -> [a]
++String
"' is missing.")


-- * JSON-RPC client

-- | JSON-RPC 1.0 request record
data RPCRequest = RPCRequest
  { RPCRequest -> String
id      :: String    -- ^ a string identificating the client
  , RPCRequest -> String
method  :: String    -- ^ the name of the method
  , RPCRequest -> [String]
params  :: [String]  -- ^ a list of parameters for the method
  } deriving ((forall x. RPCRequest -> Rep RPCRequest x)
-> (forall x. Rep RPCRequest x -> RPCRequest) -> Generic RPCRequest
forall x. Rep RPCRequest x -> RPCRequest
forall x. RPCRequest -> Rep RPCRequest x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep RPCRequest x -> RPCRequest
$cfrom :: forall x. RPCRequest -> Rep RPCRequest x
Generic, Value -> Parser [RPCRequest]
Value -> Parser RPCRequest
(Value -> Parser RPCRequest)
-> (Value -> Parser [RPCRequest]) -> FromJSON RPCRequest
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [RPCRequest]
$cparseJSONList :: Value -> Parser [RPCRequest]
parseJSON :: Value -> Parser RPCRequest
$cparseJSON :: Value -> Parser RPCRequest
FromJSON, [RPCRequest] -> Encoding
[RPCRequest] -> Value
RPCRequest -> Encoding
RPCRequest -> Value
(RPCRequest -> Value)
-> (RPCRequest -> Encoding)
-> ([RPCRequest] -> Value)
-> ([RPCRequest] -> Encoding)
-> ToJSON RPCRequest
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [RPCRequest] -> Encoding
$ctoEncodingList :: [RPCRequest] -> Encoding
toJSONList :: [RPCRequest] -> Value
$ctoJSONList :: [RPCRequest] -> Value
toEncoding :: RPCRequest -> Encoding
$ctoEncoding :: RPCRequest -> Encoding
toJSON :: RPCRequest -> Value
$ctoJSON :: RPCRequest -> Value
ToJSON)


-- | JSON-RPC 1.0 response record
data RPCResponse = RPCResponse
  { RPCResponse -> String
id       :: String          -- ^ the same identificative string 
  , RPCResponse -> Value
result   :: Value           -- ^ result if the method call succeded
  , RPCResponse -> Maybe RPCError
rpcError :: Maybe RPCError  -- ^ error in case the method call failed
  } deriving ((forall x. RPCResponse -> Rep RPCResponse x)
-> (forall x. Rep RPCResponse x -> RPCResponse)
-> Generic RPCResponse
forall x. Rep RPCResponse x -> RPCResponse
forall x. RPCResponse -> Rep RPCResponse x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep RPCResponse x -> RPCResponse
$cfrom :: forall x. RPCResponse -> Rep RPCResponse x
Generic, Value -> Parser [RPCResponse]
Value -> Parser RPCResponse
(Value -> Parser RPCResponse)
-> (Value -> Parser [RPCResponse]) -> FromJSON RPCResponse
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [RPCResponse]
$cparseJSONList :: Value -> Parser [RPCResponse]
parseJSON :: Value -> Parser RPCResponse
$cparseJSON :: Value -> Parser RPCResponse
FromJSON, [RPCResponse] -> Encoding
[RPCResponse] -> Value
RPCResponse -> Encoding
RPCResponse -> Value
(RPCResponse -> Value)
-> (RPCResponse -> Encoding)
-> ([RPCResponse] -> Value)
-> ([RPCResponse] -> Encoding)
-> ToJSON RPCResponse
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [RPCResponse] -> Encoding
$ctoEncodingList :: [RPCResponse] -> Encoding
toJSONList :: [RPCResponse] -> Value
$ctoJSONList :: [RPCResponse] -> Value
toEncoding :: RPCResponse -> Encoding
$ctoEncoding :: RPCResponse -> Encoding
toJSON :: RPCResponse -> Value
$ctoJSON :: RPCResponse -> Value
ToJSON)


-- | Namecoin API error record
data RPCError = RPCError
  { RPCError -> Int
code    :: Int     -- ^ a number indicating the kind of error
  , RPCError -> String
message :: String  -- ^ a detailed explanation of the error
  } deriving ((forall x. RPCError -> Rep RPCError x)
-> (forall x. Rep RPCError x -> RPCError) -> Generic RPCError
forall x. Rep RPCError x -> RPCError
forall x. RPCError -> Rep RPCError x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep RPCError x -> RPCError
$cfrom :: forall x. RPCError -> Rep RPCError x
Generic, Value -> Parser [RPCError]
Value -> Parser RPCError
(Value -> Parser RPCError)
-> (Value -> Parser [RPCError]) -> FromJSON RPCError
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [RPCError]
$cparseJSONList :: Value -> Parser [RPCError]
parseJSON :: Value -> Parser RPCError
$cparseJSON :: Value -> Parser RPCError
FromJSON, [RPCError] -> Encoding
[RPCError] -> Value
RPCError -> Encoding
RPCError -> Value
(RPCError -> Value)
-> (RPCError -> Encoding)
-> ([RPCError] -> Value)
-> ([RPCError] -> Encoding)
-> ToJSON RPCError
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [RPCError] -> Encoding
$ctoEncodingList :: [RPCError] -> Encoding
toJSONList :: [RPCError] -> Value
$ctoJSONList :: [RPCError] -> Value
toEncoding :: RPCError -> Encoding
$ctoEncoding :: RPCError -> Encoding
toJSON :: RPCError -> Value
$ctoJSON :: RPCError -> Value
ToJSON)


-- | Namecoin API Value record
data Name = Name
  { Name -> String
name       :: String  -- ^ the namecoin name
  , Name -> String
value      :: String  -- ^ its value
  , Name -> Int
expires_in :: Int     -- ^ number of blocks before the name expires
  } deriving (Int -> Name -> String -> String
[Name] -> String -> String
Name -> String
(Int -> Name -> String -> String)
-> (Name -> String) -> ([Name] -> String -> String) -> Show Name
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [Name] -> String -> String
$cshowList :: [Name] -> String -> String
show :: Name -> String
$cshow :: Name -> String
showsPrec :: Int -> Name -> String -> String
$cshowsPrec :: Int -> Name -> String -> String
Show, (forall x. Name -> Rep Name x)
-> (forall x. Rep Name x -> Name) -> Generic Name
forall x. Rep Name x -> Name
forall x. Name -> Rep Name x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Name x -> Name
$cfrom :: forall x. Name -> Rep Name x
Generic, Value -> Parser [Name]
Value -> Parser Name
(Value -> Parser Name) -> (Value -> Parser [Name]) -> FromJSON Name
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [Name]
$cparseJSONList :: Value -> Parser [Name]
parseJSON :: Value -> Parser Name
$cparseJSON :: Value -> Parser Name
FromJSON)


-- | Turn an Aeson AST object into a 'fromJSON' type
decodeValue :: FromJSON a => Value -> Error a
decodeValue :: forall a. FromJSON a => Value -> Error a
decodeValue = ByteString -> Either String a
forall a. FromJSON a => ByteString -> Either String a
J.eitherDecode (ByteString -> Either String a)
-> (Value -> ByteString) -> Value -> Either String a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> ByteString
forall a. ToJSON a => a -> ByteString
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 :: String -> String -> [String] -> IO (Error Value)
rpcRequest String
uri String
method [String]
params = do
  Either SomeException RPCResponse
req <- IO RPCResponse -> IO (Either SomeException RPCResponse)
forall e a. Exception e => IO a -> IO (Either e a)
E.try (Getting RPCResponse (Response RPCResponse) RPCResponse
-> Response RPCResponse -> RPCResponse
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting RPCResponse (Response RPCResponse) RPCResponse
forall body0 body1.
Lens (Response body0) (Response body1) body0 body1
W.responseBody (Response RPCResponse -> RPCResponse)
-> IO (Response RPCResponse) -> IO RPCResponse
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Response ByteString -> IO (Response RPCResponse)
forall (m :: * -> *) a.
(MonadThrow m, FromJSON a) =>
Response ByteString -> m (Response a)
W.asJSON (Response ByteString -> IO (Response RPCResponse))
-> IO (Response ByteString) -> IO (Response RPCResponse)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Options -> String -> Value -> IO (Response ByteString)
forall a.
Postable a =>
Options -> String -> a -> IO (Response ByteString)
W.postWith Options
options String
uri Value
req))
  Error Value -> IO (Error Value)
forall (m :: * -> *) a. Monad m => a -> m a
return (Error Value -> IO (Error Value))
-> Error Value -> IO (Error Value)
forall a b. (a -> b) -> a -> b
$ case Either SomeException RPCResponse
req of
    Left  SomeException
err -> String -> Error Value
forall a b. a -> Either a b
Left (String
"RPC error: "String -> String -> String
forall a. [a] -> [a] -> [a]
++SomeException -> String
forall a. Show a => a -> String
show (SomeException
err :: E.SomeException))
    Right RPCResponse
res -> case (RPCResponse -> Maybe RPCError
rpcError RPCResponse
res) of
      Maybe RPCError
Nothing  -> Value -> Error Value
forall a b. b -> Either a b
Right (RPCResponse -> Value
result RPCResponse
res)
      Just RPCError
err -> String -> Error Value
forall a b. a -> Either a b
Left  (String
"API error "String -> String -> String
forall a. [a] -> [a] -> [a]
++Int -> String
forall a. Show a => a -> String
show (RPCError -> Int
code RPCError
err)String -> String -> String
forall a. [a] -> [a] -> [a]
++String
": "String -> String -> String
forall a. [a] -> [a] -> [a]
++RPCError -> String
message RPCError
err)
  where
    req :: Value
req = RPCRequest -> Value
forall a. ToJSON a => a -> Value
J.toJSON (String -> String -> [String] -> RPCRequest
RPCRequest String
"namecoin-update" String
method [String]
params)
    options :: Options
options = ASetter
  Options Options (Maybe ResponseChecker) (Maybe ResponseChecker)
-> Maybe ResponseChecker -> Options -> Options
forall s t a b. ASetter s t a b -> b -> s -> t
set ASetter
  Options Options (Maybe ResponseChecker) (Maybe ResponseChecker)
Lens' Options (Maybe ResponseChecker)
checkResponse (ResponseChecker -> Maybe ResponseChecker
forall a. a -> Maybe a
Just (ResponseChecker -> Maybe ResponseChecker)
-> ResponseChecker -> Maybe ResponseChecker
forall a b. (a -> b) -> a -> b
$ \Request
_ Response BodyReader
_ -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()) Options
defaults


-- * Name operations

-- | Returns the list of currently registered names
nameList :: String -> IO (Error [Name])
nameList :: String -> IO (Error [Name])
nameList String
uri = (Error Value -> Error [Name])
-> IO (Error Value) -> IO (Error [Name])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Value -> Error [Name]
forall a. FromJSON a => Value -> Error a
decodeValue (Value -> Error [Name]) -> Error Value -> Error [Name]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<) (String -> String -> [String] -> IO (Error Value)
rpcRequest String
uri String
"name_list" [])


-- | Issue an udpate for a name (confirming its current value)
nameUpdate :: String -> Name -> IO Int
nameUpdate :: String -> Name -> IO Int
nameUpdate String
uri (Name {Int
String
expires_in :: Int
value :: String
name :: String
$sel:expires_in:Name :: Name -> Int
$sel:value:Name :: Name -> String
$sel:name:Name :: Name -> String
..}) = do
  String -> IO ()
putStr (String
"Updating name "String -> String -> String
forall a. [a] -> [a] -> [a]
++String
nameString -> String -> String
forall a. [a] -> [a] -> [a]
++String
"... ")
  Error Value
req <- String -> String -> [String] -> IO (Error Value)
rpcRequest String
uri String
"name_update" [ String
name, String
value ]
  case Error Value
req of
    Left  String
err -> String -> IO ()
putStrLn String
"failed" IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> String -> IO ()
putStrLn String
err IO () -> IO Int -> IO Int
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Int -> IO Int
forall (m :: * -> *) a. Monad m => a -> m a
return Int
1
    Right Value
_   -> String -> IO ()
putStrLn String
"ok" IO () -> IO Int -> IO Int
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Int -> IO Int
forall (m :: * -> *) a. Monad m => a -> m a
return Int
0