{-# 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