src/Configuration.hs

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