@@ -0,0 +1,136 @@
2+{-# LANGUAGE OverloadedStrings #-}
3+-- | Some next-gen helper functions for the scaffolding's configuration system.
4+module Data.Yaml.Config
18+#if __GLASGOW_HASKELL__ < 710
19+import Control.Applicative ((<$>))
23+import Data.List.NonEmpty (nonEmpty)
25+import qualified Data.HashMap.Strict as H
26+import Data.Text (Text, pack)
27+import System.Environment (getEnvironment)
28+import Control.Arrow ((***))
29+import Control.Monad (forM)
30+import Control.Exception (throwIO)
31+import Data.Text.Encoding (encodeUtf8)
32+import qualified Data.Yaml as Y
33+import Data.Maybe (fromMaybe)
34+import qualified Data.Text as T
36+newtype MergedValue = MergedValue { getMergedValue :: Value }
38+instance Semigroup MergedValue where
39+ MergedValue x <> MergedValue y = MergedValue $ mergeValues x y
42+mergeValues :: Value -> Value -> Value
43+mergeValues (Object x) (Object y) = Object $ H.unionWith mergeValues x y
46+applyEnvValue :: Bool -- ^ require an environment variable to be present?
47+ -> H.HashMap Text Text -> Value -> Value
48+applyEnvValue requireEnv' env =
51+ goV (Object o) = Object $ goV <$> o
52+ goV (Array a) = Array (goV <$> a)
53+ goV (String t1) = fromMaybe (String t1) $ do
54+ t2 <- T.stripPrefix "_env:" t1
55+ let (name, t3) = T.break (== ':') t2
56+ mdef = fmap parseValue $ T.stripPrefix ":" t3
57+ Just $ case H.lookup name env of
59+ -- If the default value parses as a String, we treat the
60+ -- environment variable as a raw value and do not parse it.
61+ -- This means that things like numeric passwords just work.
62+ -- However, for originally numerical or boolean values (e.g.,
63+ -- port numbers), we still perform a normal YAML parse.
66+ -- https://github.com/yesodweb/yesod/issues/1061
68+ Just (String _) -> String val
72+ Just val | not requireEnv' -> val
76+ parseValue val = fromMaybe (String val) $ Y.decode $ encodeUtf8 val
78+getCurrentEnv :: IO (H.HashMap Text Text)
79+getCurrentEnv = fmap (H.fromList . map (pack *** pack)) getEnvironment
81+applyCurrentEnv :: Bool -- ^ require an environment variable to be present?
83+applyCurrentEnv requireEnv' orig = flip (applyEnvValue requireEnv') orig <$> getCurrentEnv
85+data EnvUsage = IgnoreEnv
88+ | UseCustomEnv (H.HashMap Text Text)
89+ | RequireCustomEnv (H.HashMap Text Text)
91+ignoreEnv, useEnv, requireEnv :: EnvUsage
94+requireEnv = RequireEnv
96+useCustomEnv, requireCustomEnv :: H.HashMap Text Text -> EnvUsage
97+useCustomEnv = UseCustomEnv
98+requireCustomEnv = RequireCustomEnv
100+-- | Load the settings from the following three sources:
102+-- * Run time config files
104+-- * Run time environment variables
106+-- * The default compile time config file
108+ :: FromJSON settings
109+ => [FilePath] -- ^ run time config files to use, earlier files have precedence
110+ -> [Value] -- ^ any other values to use, usually from compile time config. overridden by files
113+loadYamlSettings runTimeFiles compileValues envUsage = do
114+ runValues <- forM runTimeFiles $ \fp -> do
115+ eres <- Y.decodeFileEither fp
118+ putStrLn $ "loadYamlSettings: Could not parse file as YAML: " ++ fp
120+ Right value -> return value
123+ case nonEmpty $ map MergedValue $ runValues ++ compileValues of
124+ Nothing -> error "loadYamlSettings: No configuration provided"
125+ Just ne -> return $ getMergedValue $ sconcat ne
128+ IgnoreEnv -> return $ applyEnvValue False mempty value'
129+ UseEnv -> applyCurrentEnv False value'
130+ RequireEnv -> applyCurrentEnv True value'
131+ UseCustomEnv env -> return $ applyEnvValue False env value'
132+ RequireCustomEnv env -> return $ applyEnvValue True env value'
134+ case fromJSON value of
135+ Error s -> error $ "Could not convert to AppSettings: " ++ s
136+ Success settings -> return settings