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