namecoin-update/Main.hs

-- | Tool to keep namecoin names updated and well
module Main where

import Control.Applicative         (many, (<|>))
import Control.Monad               (when)
import Control.Lens                (set, view)
import Control.Exception           (try, SomeException)
import Prelude              hiding (error, readFile)
import Data.Attoparsec.Text hiding (try)
import Data.Maybe                  (fromJust)
import Data.Text                   (Text, unpack)
import Data.Text.IO                (readFile)
import Data.Aeson
import Data.Aeson.TH
import System.Environment          (getArgs)
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


-- * Expiration checking

-- | Check whether a name is going to expire soon (~2 day)
isExpiring :: Name -> Bool
isExpiring name = expires_in name < 100

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

-- | Check for names that will expire soon and update them
nameCheck :: String -> IO ()
nameCheck uri = do
  names <- nameList uri
  case names of
    Left  error -> putStrLn ("Name check failed. "++error)
    Right names -> do
      let expiring = filter isExpiring names
          total    = length expiring
      failed <- sum <$> mapM (nameUpdate uri) expiring
      if failed == 0
        then putStrLn "Names updated: all ok."
        else putStrLn (show failed ++ "/" ++ show total ++ " failed.")

-- | Main function
--
-- Reads the path of a namecoin config file
-- from the process arguments, connects to the
-- RPC server and updates the names found, if necessary.
main :: IO ()
main = do
  args <- getArgs
  when (null args) (fail "Must provide a namecoin config file.")
  conf <- readFile (head args)
  case uri conf of
    Left  err -> putStrLn ("Error reading config: " ++ err)
    Right uri -> nameCheck uri