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