From 64e2f33e7185fe16305cd8852173747281a8c77a Mon Sep 17 00:00:00 2001
From: tv <tv@shackspace.de>
Date: Thu, 6 Nov 2014 14:41:35 +0100
Subject: (Optionally) get configuration from environment.
---
src/Main.hs | 3 ++-
src/Main/Config.hs | 35 ++++++++++++++++++++++++++++++-----
2 files changed, 32 insertions(+), 6 deletions(-)
diff --git a/src/Main.hs b/src/Main.hs
index 3a41de4..a2755e0 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -69,7 +69,8 @@ data Resource
-- | Run the application with the default configuration.
-- This calls 'start' with 'defaultConfig'.
main :: IO ()
-main = start defaultConfig
+main =
+ start =<< defaultConfig
-- | Run the application with the given configuration.
diff --git a/src/Main/Config.hs b/src/Main/Config.hs
index 47c12ba..45fa50f 100644
--- a/src/Main/Config.hs
+++ b/src/Main/Config.hs
@@ -8,7 +8,14 @@
module Main.Config (Config(..), defaultConfig) where
+import Control.Applicative
+import Control.Exception (tryJust)
+import Control.Monad (guard)
+import Data.Monoid
import Network.Wai.Handler.Warp (Port)
+import System.Environment (getEnv)
+import System.IO.Error (isDoesNotExistError)
+import Text.Read (readEither)
data Config = Config
@@ -18,12 +25,30 @@ data Config = Config
-- |
+-- The default configuration gets read from the environment variables
+-- @cgroupRoot@ and @httpPort@.
+--
+-- If either doesn't exist, then their respective default value gets used:
--
-- > cgroupRoot = "/sys/fs/cgroup"
-- > httpPort = 8001
--
-defaultConfig :: Config
-defaultConfig = Config
- { cgroupRoot = "/sys/fs/cgroup"
- , httpPort = 8001
- }
+defaultConfig :: IO Config
+defaultConfig =
+ Config
+ <$> getEnv' Right "/sys/fs/cgroup" "cgroupRoot"
+ <*> getEnv' readEither 8001 "httpPort"
+
+
+-- | Takes a parse function, a default value, and a variable name.
+getEnv' :: (String -> Either String a) -> a -> String -> IO a
+getEnv' pf def name =
+ either (const def) parse <$>
+ tryJust (guard . isDoesNotExistError) (getEnv name)
+ where
+ parse rawValue =
+ case pf rawValue of
+ Left err ->
+ error $ "Main.Config.getEnv' " <> show name <> ": " <> err
+ Right value ->
+ value
--
cgit v1.2.3