From: Michael Orlitzky Date: Sat, 28 Dec 2013 17:35:01 +0000 (-0500) Subject: Add (Optional)Configuration modules. X-Git-Tag: 0.0.1~155 X-Git-Url: http://gitweb.michael.orlitzky.com/?a=commitdiff_plain;h=08fce472b305acb2cfbffbe877798378c4079cc4;p=dead%2Fhtsn-import.git Add (Optional)Configuration modules. --- diff --git a/src/Configuration.hs b/src/Configuration.hs new file mode 100644 index 0000000..feefe92 --- /dev/null +++ b/src/Configuration.hs @@ -0,0 +1,56 @@ +-- | This module defines the 'Configuration' type, which is just a +-- wrapper around all of the configuration options we accept on the +-- command line. +-- +module Configuration ( + Configuration(..), + merge_optional ) +where + +import System.Console.CmdArgs.Default ( Default(..) ) +import System.Log ( Priority( INFO ) ) + +import qualified OptionalConfiguration as OC ( + OptionalConfiguration(..), + merge_maybes ) + + +-- | The main configuration data type. This will be passed to most of +-- the important functions once it has been created. +data Configuration = + Configuration { + connection_string :: String, + log_file :: Maybe FilePath, + log_level :: Priority, + syslog :: Bool } + deriving (Show) + +-- | A Configuration with all of its fields set to their default +-- values. +instance Default Configuration where + def = Configuration { + connection_string = def, + log_file = def, + log_level = INFO, + syslog = def } + + +-- | Merge a Configuration with an OptionalConfiguration. This is more +-- or less the Monoid instance for OptionalConfiguration, but since +-- the two types are different, we have to repeat ourselves. +merge_optional :: Configuration + -> OC.OptionalConfiguration + -> Configuration +merge_optional cfg opt_cfg = + Configuration + (merge (connection_string cfg) (OC.connection_string opt_cfg)) + (OC.merge_maybes (log_file cfg) (OC.log_file opt_cfg)) + (merge (log_level cfg) (OC.log_level opt_cfg)) + (merge (syslog cfg) (OC.syslog opt_cfg)) + where + -- | If the thing on the right is Just something, return that + -- something, otherwise return the thing on the left. + merge :: a -> Maybe a -> a + merge x Nothing = x + merge _ (Just y) = y + diff --git a/src/OptionalConfiguration.hs b/src/OptionalConfiguration.hs new file mode 100644 index 0000000..f44f77a --- /dev/null +++ b/src/OptionalConfiguration.hs @@ -0,0 +1,134 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE StandaloneDeriving #-} + +-- | An OptionalConfiguration is just like a 'Configuration', except +-- all of its fields are optional. The user can set options in two +-- places: the command-line, and a configuration file. Obviously if +-- a parameter is set in one place, it doesn't need to be set in the +-- other. Thus, the latter needs to be optional. +-- +module OptionalConfiguration ( + OptionalConfiguration(..), + from_rc, + merge_maybes ) +where + +import qualified Data.Configurator as DC ( + Worth(Optional), + load, + lookup ) +import qualified Data.Configurator.Types as DCT ( + Configured, + Value( String ), + convert ) +import Data.Data ( Data ) +import Data.Monoid ( Monoid(..) ) +import Data.Typeable ( Typeable ) +import Paths_htsn_import ( getSysconfDir ) +import System.Directory ( getHomeDirectory ) +import System.FilePath ( () ) +import System.IO.Error ( catchIOError ) +import System.Log ( Priority(..) ) + +import Logging ( log_error ) -- Can't import report_error from Main +import Terminal ( display_error ) -- 'cause of circular imports. + + +-- Derive standalone instances of Data and Typeable for Priority. This +-- is necessary for OptionalConfiguration (which contains a Maybe +-- Priority) to derive Data and Typeable. +deriving instance Data Priority +deriving instance Typeable Priority + +-- | The same as Configuration, except everything is optional. It's easy to +-- merge two of these by simply dropping the Nothings in favor of +-- the Justs. The 'feed_hosts' are left un-maybed so that cmdargs +-- can parse more than one of them. +-- +data OptionalConfiguration = + OptionalConfiguration { + connection_string :: Maybe String, + log_file :: Maybe FilePath, + log_level :: Maybe Priority, + syslog :: Maybe Bool } + deriving (Show, Data, Typeable) + + +-- | Combine two Maybes into one, essentially mashing them +-- together. We give precedence to the second argument when both are +-- Justs. +merge_maybes :: (Maybe a) -> (Maybe a) -> (Maybe a) +merge_maybes Nothing Nothing = Nothing +merge_maybes (Just x) Nothing = Just x +merge_maybes Nothing (Just x) = Just x +merge_maybes (Just _) (Just y) = Just y + + +-- | The Monoid instance for these lets us "combine" two +-- OptionalConfigurations. The "combine" operation that we'd like to +-- perform is, essentially, to mash them together. So if we have two +-- OptionalConfigurations, each half full, we could combine them +-- into one big one. +-- +-- This is used to merge command-line and config-file settings. +-- +instance Monoid OptionalConfiguration where + -- | An empty OptionalConfiguration. + mempty = OptionalConfiguration Nothing Nothing Nothing Nothing + + + -- | Combine @cfg1@ and @cfg2@, giving precedence to @cfg2@. + cfg1 `mappend` cfg2 = + OptionalConfiguration + (merge_maybes (connection_string cfg1) (connection_string cfg2)) + (merge_maybes (log_file cfg1) (log_file cfg2)) + (merge_maybes (log_level cfg1) (log_level cfg2)) + (merge_maybes (syslog cfg1) (syslog cfg2)) + + +instance DCT.Configured Priority where + -- | This allows us to read a Priority level out of a Configurator + -- config file. By default Configurator wouldn't know what to do, + -- so we have to tell it that we expect one of the valid Priority + -- constructors. + convert (DCT.String "INFO") = Just INFO + convert (DCT.String "WARNING") = Just WARNING + convert (DCT.String "ERROR") = Just ERROR + convert _ = Nothing + + +-- | Obtain an OptionalConfiguration from htsn-importrc 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 OptionalConfiguration +from_rc = do + etc <- catchIOError getSysconfDir (\e -> do + display_error (show e) + log_error (show e) + return "/etc") + home <- catchIOError getHomeDirectory (\e -> do + display_error (show e) + log_error (show e) + return "$(HOME)") + let global_config_path = etc "htsn-importrc" + let user_config_path = home ".htsn-importrc" + cfg <- DC.load [ DC.Optional global_config_path, + DC.Optional user_config_path ] + cfg_connection_string <- DC.lookup cfg "connection_string" + cfg_log_file <- DC.lookup cfg "log_file" + cfg_log_level <- DC.lookup cfg "log_level" + cfg_syslog <- DC.lookup cfg "syslog" + + return $ OptionalConfiguration + cfg_connection_string + cfg_log_file + cfg_log_level + cfg_syslog