src/Configuration.hs

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