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
  39 instance Monoid Cfg where
  40   mempty = Cfg { article      = "",
  41                  cookie_jar   = Nothing,
  42                  full_stories = False,
  43                  output       = "",
  44                  password     = Nothing,
  45                  username     = Nothing }
  46
  47   mappend c1 c2 =
  48     let article'      = (if null article1 then article2 else article1)
  49         cookie_jar'   = cookie_jar1 `mplus` cookie_jar2
  50         full_stories' = full_stories1 || full_stories2
  51         output'       = (if null output1 then output2 else output1)
  52         password'     = password1 `mplus` password2
  53         username'     = username1 `mplus` username2
  54     in
  55         Cfg { article      = article',
  56               cookie_jar   = cookie_jar',
  57               full_stories = full_stories',
  58               output       = output',
  59               password     = password',
  60               username     = username' }
  61     where
  62       article1      = article c1
  63       article2      = article c2
  64       cookie_jar1   = cookie_jar c1
  65       cookie_jar2   = cookie_jar c2
  66       full_stories1 = full_stories c1
  67       full_stories2 = full_stories c2
  68       output1       = output c1
  69       output2       = output c2
  70       password1     = password c1
  71       password2     = password c2
  72       username1     = username c1
  73       username2     = username c2
  74
  75
  76 use_account :: Cfg -> Bool
  77 use_account cfg =
  78   (isJust $ username cfg) && (isJust $ password cfg)
  79
  80 format_cpe :: CPError -> String
  81 format_cpe (ParseError desc, _) = "Parse error: " ++ desc
  82 format_cpe (SectionAlreadyExists desc, _) = "Section already exists: " ++ desc
  83 format_cpe (NoSection desc, _) = "Missing section: " ++ desc
  84 format_cpe (NoOption desc, _) = "Missing required option: " ++ desc
  85 format_cpe (OtherProblem desc, _) = "Error: " ++ desc
  86 format_cpe (InterpolationError desc, _) = "Interpolation error: " ++ desc
  87
  88
  89 -- | The config parsing functions return either the result or a
  90 --   'CPError'. If there was an error, we represent it as 'Nothing'
  91 --   (at least if we're forcing the value into a 'Maybe'
  92 --   wrapper. Otherwise, we return 'Just' the result.
  93 either_to_maybe :: Either CPError a -> Maybe a
  94 either_to_maybe (Left  _) = Nothing
  95 either_to_maybe (Right x) = Just x
  96
  97
  98 config_filename :: String
  99 config_filename = Cmd.program_name ++ ".conf"
 100
 101 config_path :: IO FilePath
 102 config_path = do
 103   cfg_dir <- getAppUserDataDirectory Cmd.program_name
 104   let cfg_file = joinPath [cfg_dir, config_filename]
 105   return $ cfg_file
 106
 107 parse_config :: IO (Either String Cfg)
 108 parse_config = do
 109   cfg_file <- config_path
 110   it_exists <- doesFileExist cfg_file
 111   if not it_exists then do
 112     return $ Right mempty
 113   else do
 114     parse_result <- readfile emptyCP cfg_file
 115
 116     return $
 117       case parse_result of
 118         Left err -> Left (format_cpe err)
 119         Right cp ->
 120             let cp_full_stories = get cp "DEFAULT" "full_stories"
 121                 cp_password = get cp "DEFAULT" "password"
 122                 cp_username = get cp "DEFAULT" "username"
 123
 124                 cfg_password = either_to_maybe cp_password
 125                 cfg_full_stories = case cp_full_stories of
 126                                      Left _  -> False -- default
 127                                      Right f -> f
 128                 cfg_username = either_to_maybe cp_username
 129             in
 130                 Right $ mempty { full_stories = cfg_full_stories,
 131                                  password = cfg_password,
 132                                  username = cfg_username }
 133
 134
 135
 136 get_cfg :: IO Cfg
 137 get_cfg = do
 138   cmd_article <- Cmd.apply_args
 139   let arg_cfg = mempty { article = Cmd.article 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