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