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