src/Configuration.hs

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