src/OptionalConfiguration.hs

   1 {-# LANGUAGE DeriveDataTypeable #-}
   2 {-# LANGUAGE FlexibleInstances #-}
   3 {-# LANGUAGE OverloadedStrings #-}
   4
   5 -- | The program will parse ~/.halcyonrc for any available configuration
   6 --   directives, resulting in an OptionalCfg. The command-line
   7 --   arguments will be used to create another OptionalCfg, and the two
   8 --   will be merged. Finally, a default_config will be updated from
   9 --   the merged OptionalCfgs.
  10 --
  11
  12 module OptionalConfiguration (
  13   OptionalCfg(..),
  14   from_rc )
  15 where
  16
  17 import qualified Data.Configurator as DC (
  18   Worth (Optional),
  19   load,
  20   lookup )
  21
  22 import Data.Data ( Data )
  23 import Data.Maybe ( fromMaybe )
  24 import Data.Monoid ( Monoid(..) )
  25 import Data.Typeable ( Typeable )
  26 import Paths_halcyon ( getSysconfDir )
  27 import System.Directory ( getHomeDirectory )
  28 import System.FilePath ( (</>) )
  29 import System.IO ( hPutStrLn, stderr )
  30 import System.IO.Error ( catchIOError )
  31
  32 import Usernames ( Usernames(..) )
  33
  34
  35 -- | The same as Cfg, except everything is optional. It's easy to
  36 --   merge two of these by simply dropping the Nothings in favor of
  37 --   the Justs. The 'usernames' are left un-maybed so that cmdargs
  38 --   can parse more than one of them.
  39 --
  40 data OptionalCfg =
  41   OptionalCfg { access_secret :: Maybe String,
  42                 access_token :: Maybe String,
  43                 consumer_key :: Maybe String,
  44                 consumer_secret :: Maybe String,
  45                 daemonize :: Maybe Bool,
  46                 from_address :: Maybe String,
  47                 heartbeat :: Maybe Int,
  48                 ignore_replies :: Maybe Bool,
  49                 ignore_retweets :: Maybe Bool,
  50                 pidfile :: Maybe FilePath,
  51                 run_as_group :: Maybe String,
  52                 run_as_user :: Maybe String,
  53                 sendmail_path :: Maybe String,
  54                 to_address :: Maybe String,
  55                 usernames :: Usernames,
  56                 verbose :: Maybe Bool }
  57     deriving (Show, Data, Typeable)
  58
  59 instance Monoid OptionalCfg where
  60   mempty = OptionalCfg
  61              Nothing
  62              Nothing
  63              Nothing
  64              Nothing
  65              Nothing
  66              Nothing
  67              Nothing
  68              Nothing
  69              Nothing
  70              Nothing
  71              Nothing
  72              Nothing
  73              Nothing
  74              Nothing
  75              mempty
  76              Nothing
  77
  78   cfg1 `mappend` cfg2 =
  79     OptionalCfg
  80       (merge (access_secret cfg1) (access_secret cfg2))
  81       (merge (access_token cfg1) (access_token cfg2))
  82       (merge (consumer_key cfg1) (consumer_key cfg2))
  83       (merge (consumer_secret cfg1) (consumer_secret cfg2))
  84       (merge (daemonize cfg1) (daemonize cfg2))
  85       (merge (from_address cfg1) (from_address cfg2))
  86       (merge (heartbeat cfg1) (heartbeat cfg2))
  87       (merge (ignore_replies cfg1) (ignore_replies cfg2))
  88       (merge (ignore_retweets cfg1) (ignore_retweets cfg2))
  89       (merge (pidfile cfg1) (pidfile cfg2))
  90       (merge (run_as_group cfg1) (run_as_group cfg2))
  91       (merge (run_as_user cfg1) (run_as_user cfg2))
  92       (merge (sendmail_path cfg1) (sendmail_path cfg2))
  93       (merge (to_address cfg1) (to_address cfg2))
  94       ((usernames cfg1) `mappend` (usernames cfg2))
  95       (merge (verbose cfg1) (verbose cfg2))
  96     where
  97       merge :: (Maybe a) -> (Maybe a) -> (Maybe a)
  98       merge Nothing Nothing   = Nothing
  99       merge (Just x) Nothing  = Just x
 100       merge Nothing (Just x)  = Just x
 101       merge (Just _) (Just y) = Just y
 102
 103
 104
 105 -- | Obtain an 'OptionalCfg' from halcyonrc in either the global
 106 --   configuration directory or the user's home directory. The one in
 107 --   $HOME is prefixed by a dot so that it is hidden.
 108 --
 109 --   We make an attempt at cross-platform compatibility; we will try
 110 --   to find the correct directory even on Windows. But if the calls
 111 --   to getHomeDirectory/getSysconfDir fail for whatever reason, we
 112 --   fall back to using the Unix-specific /etc and $HOME.
 113 --
 114 from_rc :: IO OptionalCfg
 115 from_rc = do
 116   etc  <- catchIOError
 117             getSysconfDir (\e -> do hPutStrLn stderr ("ERROR: " ++ (show e))
 118                                     return "/etc")
 119   home <- catchIOError
 120             getHomeDirectory (\e -> do hPutStrLn stderr ("ERROR: " ++ (show e))
 121                                        return "$(HOME)")
 122
 123   let global_config_path = etc </> "halcyonrc"
 124   let user_config_path = home </> ".halcyonrc"
 125   cfg <- DC.load [ DC.Optional global_config_path,
 126                    DC.Optional user_config_path ]
 127
 128   cfg_access_secret <- DC.lookup cfg "access-secret"
 129   cfg_access_token <- DC.lookup cfg "access-token"
 130   cfg_consumer_key <- DC.lookup cfg "consumer-key"
 131   cfg_consumer_secret <- DC.lookup cfg "consumer-secret"
 132   cfg_daemonize <- DC.lookup cfg "daemonize"
 133   cfg_from_address <- DC.lookup cfg "from"
 134   cfg_heartbeat <- DC.lookup cfg "heartbeat"
 135   cfg_ignore_replies <- DC.lookup cfg "ignore-replies"
 136   cfg_ignore_retweets <- DC.lookup cfg "ignore-retweets"
 137   cfg_pidfile <- DC.lookup cfg "pidfile"
 138   cfg_run_as_group <- DC.lookup cfg "run_as_group"
 139   cfg_run_as_user <- DC.lookup cfg "run_as_user"
 140   cfg_sendmail_path <- DC.lookup cfg "sendmail-path"
 141   cfg_to_address <- DC.lookup cfg "to"
 142   cfg_usernames <- DC.lookup cfg "usernames"
 143   cfg_verbose <- DC.lookup cfg "verbose"
 144
 145   return $ OptionalCfg
 146              cfg_access_secret
 147              cfg_access_token
 148              cfg_consumer_key
 149              cfg_consumer_secret
 150              cfg_daemonize
 151              cfg_from_address
 152              cfg_heartbeat
 153              cfg_ignore_replies
 154              cfg_ignore_retweets
 155              cfg_pidfile
 156              cfg_run_as_group
 157              cfg_run_as_user
 158              cfg_sendmail_path
 159              cfg_to_address
 160              (fromMaybe mempty cfg_usernames)
 161              cfg_verbose