X-Git-Url: http://gitweb.michael.orlitzky.com/?p=dead%2Fhalcyon.git;a=blobdiff_plain;f=src%2FOptionalConfiguration.hs;h=17c7191dead04be9265ec82e91604a730034ebb0;hp=53635439ac354c76bc1f9d96d074fac6ee89254c;hb=c9a905e0ab69317448f261377ab9031fb83443b4;hpb=26718edaad5cd7921d957a1f0972fd9f5cd5b645 diff --git a/src/OptionalConfiguration.hs b/src/OptionalConfiguration.hs index 5363543..17c7191 100644 --- a/src/OptionalConfiguration.hs +++ b/src/OptionalConfiguration.hs @@ -1,32 +1,60 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} --- | The program will parse ~/.twatrc for any available configuration +-- | The program will parse ~/.halcyonrc for any available configuration -- directives, resulting in an OptionalCfg. The command-line -- arguments will be used to create another OptionalCfg, and the two -- will be merged. Finally, a default_config will be updated from -- the merged OptionalCfgs. -- -module OptionalConfiguration +module OptionalConfiguration ( + OptionalCfg(..), + from_rc ) where -import Data.Monoid (Monoid(..)) -import qualified Data.Configurator as DC +import qualified Data.Configurator as DC ( + Worth (Optional), + load, + lookup ) --- The same as Cfg, except everything is optional. It's easy to merge --- two of these by simply dropping the Nothings in favor of the Justs. +import Data.Data ( Data ) +import Data.Maybe ( fromMaybe ) +import Data.Monoid ( Monoid(..) ) +import Data.Typeable ( Typeable ) +import Paths_halcyon ( getSysconfDir ) +import System.Directory ( getHomeDirectory ) +import System.FilePath ( () ) +import System.IO ( hPutStrLn, stderr ) +import System.IO.Error ( catchIOError ) + +import Usernames ( Usernames(..) ) + + +-- | The same as Cfg, except everything is optional. It's easy to +-- merge two of these by simply dropping the Nothings in favor of +-- the Justs. The 'usernames' are left un-maybed so that cmdargs +-- can parse more than one of them. +-- data OptionalCfg = - OptionalCfg { consumer_key :: Maybe String, - consumer_secret :: Maybe String, + OptionalCfg { access_secret :: Maybe String, access_token :: Maybe String, - access_secret :: Maybe String, + consumer_key :: Maybe String, + consumer_secret :: Maybe String, + daemonize :: Maybe Bool, + from_address :: Maybe String, heartbeat :: Maybe Int, ignore_replies :: Maybe Bool, ignore_retweets :: Maybe Bool, + pidfile :: Maybe FilePath, + run_as_group :: Maybe String, + run_as_user :: Maybe String, sendmail_path :: Maybe String, - from_address :: Maybe String, to_address :: Maybe String, + usernames :: Usernames, verbose :: Maybe Bool } + deriving (Show, Data, Typeable) instance Monoid OptionalCfg where mempty = OptionalCfg @@ -41,19 +69,29 @@ instance Monoid OptionalCfg where Nothing Nothing Nothing + Nothing + Nothing + Nothing + mempty + Nothing cfg1 `mappend` cfg2 = OptionalCfg + (merge (access_secret cfg1) (access_secret cfg2)) + (merge (access_token cfg1) (access_token cfg2)) (merge (consumer_key cfg1) (consumer_key cfg2)) (merge (consumer_secret cfg1) (consumer_secret cfg2)) - (merge (access_token cfg1) (access_token cfg2)) - (merge (access_secret cfg1) (access_secret cfg2)) + (merge (daemonize cfg1) (daemonize cfg2)) + (merge (from_address cfg1) (from_address cfg2)) (merge (heartbeat cfg1) (heartbeat cfg2)) (merge (ignore_replies cfg1) (ignore_replies cfg2)) (merge (ignore_retweets cfg1) (ignore_retweets cfg2)) + (merge (pidfile cfg1) (pidfile cfg2)) + (merge (run_as_group cfg1) (run_as_group cfg2)) + (merge (run_as_user cfg1) (run_as_user cfg2)) (merge (sendmail_path cfg1) (sendmail_path cfg2)) - (merge (from_address cfg1) (from_address cfg2)) (merge (to_address cfg1) (to_address cfg2)) + ((usernames cfg1) `mappend` (usernames cfg2)) (merge (verbose cfg1) (verbose cfg2)) where merge :: (Maybe a) -> (Maybe a) -> (Maybe a) @@ -62,30 +100,62 @@ instance Monoid OptionalCfg where merge Nothing (Just x) = Just x merge (Just _) (Just y) = Just y + + +-- | Obtain an 'OptionalCfg' from halcyonrc in either the global +-- configuration directory or the user's home directory. The one in +-- $HOME is prefixed by a dot so that it is hidden. +-- +-- We make an attempt at cross-platform compatibility; we will try +-- to find the correct directory even on Windows. But if the calls +-- to getHomeDirectory/getSysconfDir fail for whatever reason, we +-- fall back to using the Unix-specific /etc and $HOME. +-- from_rc :: IO OptionalCfg from_rc = do - cfg <- DC.load [ DC.Optional "$(HOME)/.twatrc" ] + etc <- catchIOError + getSysconfDir (\e -> do hPutStrLn stderr ("ERROR: " ++ (show e)) + return "/etc") + home <- catchIOError + getHomeDirectory (\e -> do hPutStrLn stderr ("ERROR: " ++ (show e)) + return "$(HOME)") + + let global_config_path = etc "halcyonrc" + let user_config_path = home ".halcyonrc" + cfg <- DC.load [ DC.Optional global_config_path, + DC.Optional user_config_path ] + + cfg_access_secret <- DC.lookup cfg "access-secret" + cfg_access_token <- DC.lookup cfg "access-token" cfg_consumer_key <- DC.lookup cfg "consumer-key" cfg_consumer_secret <- DC.lookup cfg "consumer-secret" - cfg_access_token <- DC.lookup cfg "access-token" - cfg_access_secret <- DC.lookup cfg "access-secret" + cfg_daemonize <- DC.lookup cfg "daemonize" + cfg_from_address <- DC.lookup cfg "from" cfg_heartbeat <- DC.lookup cfg "heartbeat" cfg_ignore_replies <- DC.lookup cfg "ignore-replies" cfg_ignore_retweets <- DC.lookup cfg "ignore-retweets" + cfg_pidfile <- DC.lookup cfg "pidfile" + cfg_run_as_group <- DC.lookup cfg "run_as_group" + cfg_run_as_user <- DC.lookup cfg "run_as_user" cfg_sendmail_path <- DC.lookup cfg "sendmail-path" - cfg_from_address <- DC.lookup cfg "from" cfg_to_address <- DC.lookup cfg "to" + cfg_usernames <- DC.lookup cfg "usernames" cfg_verbose <- DC.lookup cfg "verbose" + return $ OptionalCfg + cfg_access_secret + cfg_access_token cfg_consumer_key cfg_consumer_secret - cfg_access_token - cfg_access_secret + cfg_daemonize + cfg_from_address cfg_heartbeat cfg_ignore_replies cfg_ignore_retweets + cfg_pidfile + cfg_run_as_group + cfg_run_as_user cfg_sendmail_path - cfg_from_address cfg_to_address + (fromMaybe mempty cfg_usernames) cfg_verbose -