@@ -0,0 +1,136 @@
1+{-# LANGUAGE CPP #-}
2+{-# LANGUAGE OverloadedStrings #-}
3+-- | Some next-gen helper functions for the scaffolding's configuration system.
4+module Data.Yaml.Config
5+ ( applyCurrentEnv
6+ , getCurrentEnv
7+ , applyEnvValue
8+ , loadYamlSettings
9+ , EnvUsage
10+ , ignoreEnv
11+ , useEnv
12+ , requireEnv
13+ , useCustomEnv
14+ , requireCustomEnv
15+ ) where
16+
17+
18+#if __GLASGOW_HASKELL__ < 710
19+import Control.Applicative ((<$>))
20+import Data.Monoid
21+#endif
22+import Data.Semigroup
23+import Data.List.NonEmpty (nonEmpty)
24+import Data.Aeson
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
35+
36+newtype MergedValue = MergedValue { getMergedValue :: Value }
37+
38+instance Semigroup MergedValue where
39+ MergedValue x <> MergedValue y = MergedValue $ mergeValues x y
40+
41+-- | Left biased
42+mergeValues :: Value -> Value -> Value
43+mergeValues (Object x) (Object y) = Object $ H.unionWith mergeValues x y
44+mergeValues x _ = x
45+
46+applyEnvValue :: Bool -- ^ require an environment variable to be present?
47+ -> H.HashMap Text Text -> Value -> Value
48+applyEnvValue requireEnv' env =
49+ goV
50+ where
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
58+ Just val ->
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.
64+ --
65+ -- For details, see:
66+ -- https://github.com/yesodweb/yesod/issues/1061
67+ case mdef of
68+ Just (String _) -> String val
69+ _ -> parseValue val
70+ Nothing ->
71+ case mdef of
72+ Just val | not requireEnv' -> val
73+ _ -> Null
74+ goV v = v
75+
76+ parseValue val = fromMaybe (String val) $ Y.decode $ encodeUtf8 val
77+
78+getCurrentEnv :: IO (H.HashMap Text Text)
79+getCurrentEnv = fmap (H.fromList . map (pack *** pack)) getEnvironment
80+
81+applyCurrentEnv :: Bool -- ^ require an environment variable to be present?
82+ -> Value -> IO Value
83+applyCurrentEnv requireEnv' orig = flip (applyEnvValue requireEnv') orig <$> getCurrentEnv
84+
85+data EnvUsage = IgnoreEnv
86+ | UseEnv
87+ | RequireEnv
88+ | UseCustomEnv (H.HashMap Text Text)
89+ | RequireCustomEnv (H.HashMap Text Text)
90+
91+ignoreEnv, useEnv, requireEnv :: EnvUsage
92+ignoreEnv = IgnoreEnv
93+useEnv = UseEnv
94+requireEnv = RequireEnv
95+
96+useCustomEnv, requireCustomEnv :: H.HashMap Text Text -> EnvUsage
97+useCustomEnv = UseCustomEnv
98+requireCustomEnv = RequireCustomEnv
99+
100+-- | Load the settings from the following three sources:
101+--
102+-- * Run time config files
103+--
104+-- * Run time environment variables
105+--
106+-- * The default compile time config file
107+loadYamlSettings
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
111+ -> EnvUsage
112+ -> IO settings
113+loadYamlSettings runTimeFiles compileValues envUsage = do
114+ runValues <- forM runTimeFiles $ \fp -> do
115+ eres <- Y.decodeFileEither fp
116+ case eres of
117+ Left e -> do
118+ putStrLn $ "loadYamlSettings: Could not parse file as YAML: " ++ fp
119+ throwIO e
120+ Right value -> return value
121+
122+ value' <-
123+ case nonEmpty $ map MergedValue $ runValues ++ compileValues of
124+ Nothing -> error "loadYamlSettings: No configuration provided"
125+ Just ne -> return $ getMergedValue $ sconcat ne
126+ value <-
127+ case envUsage of
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'
133+
134+ case fromJSON value of
135+ Error s -> error $ "Could not convert to AppSettings: " ++ s
136+ Success settings -> return settings