src/Configuration.hs

   1 module Configuration (
   2   Cfg(..),
   3   get_cfg,
   4   use_account
   5   )
   6 where
   7
   8 import Control.Monad (mplus)
   9 import Data.ConfigFile
  10 import Data.Maybe (isJust)
  11 import Data.Monoid (Monoid(..))
  12 import System.Directory (
  13   getAppUserDataDirectory
  14   )
  15 import System.Exit (ExitCode(..), exitWith)
  16 import System.FilePath.Posix (joinPath)
  17 import System.IO (hPutStrLn, stderr)
  18
  19 import qualified CommandLine as Cmd (
  20   Args(..),
  21   apply_args,
  22   program_name
  23   )
  24 import ExitCodes
  25
  26 -- | Contains all of our configurable options.
  27 data Cfg = Cfg {
  28   article  :: String,
  29   output :: FilePath,
  30   password :: Maybe String,
  31   username :: Maybe String }
  32
  33
  34 instance Monoid Cfg where
  35   mempty = Cfg { article  = "",
  36                  output   = "",
  37                  password = Nothing,
  38                  username = Nothing }
  39
  40   mappend c1 c2 =
  41     let article'  = (if null article1 then article2 else article1)
  42         output'   = (if null output1 then output2 else output1)
  43         password' = password1 `mplus` password2
  44         username' = username1 `mplus` username2
  45     in
  46         Cfg { article  = article',
  47               output   = output',
  48               password = password',
  49               username = username' }
  50     where
  51       article1  = article c1
  52       article2  = article c2
  53       output1   = output c1
  54       output2   = output c2
  55       password1 = password c1
  56       password2 = password c2
  57       username1 = username c1
  58       username2 = username c2
  59
  60
  61 use_account :: Cfg -> Bool
  62 use_account cfg =
  63   (isJust $ username cfg) && (isJust $ password cfg)
  64
  65 format_cpe :: CPError -> String
  66 format_cpe (ParseError desc, _) = "Parse error: " ++ desc
  67 format_cpe (SectionAlreadyExists desc, _) = "Section already exists: " ++ desc
  68 format_cpe (NoSection desc, _) = "Missing section: " ++ desc
  69 format_cpe (NoOption desc, _) = "Missing required option: " ++ desc
  70 format_cpe (OtherProblem desc, _) = "Error: " ++ desc
  71 format_cpe (InterpolationError desc, _) = "Interpolation error: " ++ desc
  72
  73
  74 -- | The config parsing functions return either the result or a
  75 --   'CPError'. If there was an error, we represent it as 'Nothing'
  76 --   (at least if we're forcing the value into a 'Maybe'
  77 --   wrapper. Otherwise, we return 'Just' the result.
  78 either_to_maybe :: Either CPError a -> Maybe a
  79 either_to_maybe (Left  _) = Nothing
  80 either_to_maybe (Right x) = Just x
  81
  82
  83 config_filename :: String
  84 config_filename = Cmd.program_name ++ ".conf"
  85
  86 config_path :: IO FilePath
  87 config_path = do
  88   cfg_dir <- getAppUserDataDirectory Cmd.program_name
  89   return $ joinPath [cfg_dir, config_filename]
  90
  91 parse_config :: IO (Either String Cfg)
  92 parse_config = do
  93   cfg_file <- config_path
  94   parse_result <- readfile emptyCP cfg_file
  95
  96   return $
  97     case parse_result of
  98       Left err -> Left (format_cpe err)
  99       Right cp ->
 100           let cp_username = get cp "DEFAULT" "username"
 101               cp_password = get cp "DEFAULT" "password"
 102
 103               cfg_username = either_to_maybe cp_username
 104               cfg_password = either_to_maybe cp_password
 105           in
 106               Right $ mempty { username = cfg_username,
 107                                password = cfg_password }
 108
 109
 110
 111 get_cfg :: IO Cfg
 112 get_cfg = do
 113   cmd_article <- Cmd.apply_args
 114   let arg_cfg = mempty { article = Cmd.article cmd_article,
 115                          output  = Cmd.output cmd_article }
 116
 117   either_file_cfg <- parse_config
 118   case either_file_cfg of
 119     Left err -> do
 120       hPutStrLn stderr err
 121       exitWith $ ExitFailure exit_config_parse_failed
 122     Right file_cfg ->
 123       -- The left operand takes precedence when both are non-empty!
 124       return $ arg_cfg `mappend` file_cfg