]> gitweb.michael.orlitzky.com - dead/lwn-epub.git/blob - src/Configuration.hs
Switch from a FilePath to a CookieJar in the config.
[dead/lwn-epub.git] / 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