namecoin-update/Main.hs

{-# Language TemplateHaskell, RecordWildCards #-}

import System.Process
import System.Exit
import System.Environment (getArgs)
import Data.Maybe         (listToMaybe, fromMaybe)
import Data.Aeson
import Data.Aeson.TH
import Data.ByteString.Lazy.Char8 (pack)
import Control.Exception (try)

data Name = Name
  { name       :: String
  , value      :: String
  , expires_in :: Int
  }

deriveJSON defaultOptions ''Name


defaultPath :: FilePath
defaultPath = "$XDG_CONFIG_HOME/namecoin"


namecoin :: FilePath -> [String] -> CreateProcess
namecoin path args = shell ("namecoind -conf=" ++ path ++ " " ++ unwords args)


readCommand   conf     = readCreateProcess (namecoin conf ["name_list"]) ""
updateCommand conf n v = readCreateProcessWithExitCode (namecoin conf ["name_update", n, v]) ""


updateName :: FilePath -> Name -> IO Int
updateName conf Name{..}
  | expires_in < 100 = do
    (code, out, err) <- updateCommand conf name value
    if code == ExitSuccess
      then putStrLn (name ++ " updated: "       ++ out) >> return 0
      else putStrLn (name ++ " update failed: " ++ err) >> return 1
  | otherwise = putStrLn ("No need to update " ++ name) >> return 0


main :: IO ()
main = do
  conf <- (fromMaybe defaultPath . listToMaybe) <$> getArgs
  out  <- pack <$> readCommand conf
  case eitherDecode out of
    Right names -> do
      errs <- sum <$> mapM (updateName conf) (names :: [Name])
      if errs > 0
        then putStrLn (show errs ++ " updates failed")
        else putStrLn "All ok"
    Left err -> putStrLn ("Error communicating with namecoin: " ++ err)