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