module Data.Configurator.Load
( load
) where
import Protolude
import Control.Exception (throw)
import Text.Megaparsec (parse, errorBundlePretty)
import qualified Data.Map.Strict as M
import Data.Scientific (toBoundedInteger,
toRealFloat)
import qualified Data.Text as T
import qualified Data.Text.Lazy as TL
import Data.Text.Lazy.Builder (fromString,
fromText,
toLazyText)
import Data.Text.Lazy.Builder.Int (decimal)
import Data.Text.Lazy.Builder.RealFloat (realFloat)
import qualified System.Environment
import Data.Configurator.Syntax
import Data.Configurator.Types
load :: FilePath -> IO Config
load :: [Char] -> IO Config
load [Char]
path = Text -> Text -> Config -> Directive -> IO Config
applyDirective Text
"" Text
"" forall k a. Map k a
M.empty (Text -> Directive
Import forall a b. (a -> b) -> a -> b
$ [Char] -> Text
T.pack [Char]
path)
loadOne :: Path -> IO [Directive]
loadOne :: Text -> IO [Directive]
loadOne Text
path = do
Text
s <- [Char] -> IO Text
readFile (Text -> [Char]
T.unpack Text
path)
case forall e s a.
Parsec e s a -> [Char] -> s -> Either (ParseErrorBundle s e) a
parse Parser [Directive]
topLevel (Text -> [Char]
T.unpack Text
path) Text
s of
Left ParseErrorBundle Text Void
err -> forall a e. Exception e => e -> a
throw forall a b. (a -> b) -> a -> b
$ Text -> ParseError
ParseError forall a b. (a -> b) -> a -> b
$ [Char] -> Text
T.pack forall a b. (a -> b) -> a -> b
$ forall s e.
(VisualStream s, TraversableStream s, ShowErrorComponent e) =>
ParseErrorBundle s e -> [Char]
errorBundlePretty ParseErrorBundle Text Void
err
Right [Directive]
directives -> forall (m :: * -> *) a. Monad m => a -> m a
return [Directive]
directives
applyDirective :: Key -> Path -> Config -> Directive -> IO Config
applyDirective :: Text -> Text -> Config -> Directive -> IO Config
applyDirective Text
prefix Text
path Config
config Directive
directive = case Directive
directive of
Bind Text
key (String Text
str) -> do
Text
v <- Text -> Text -> Text -> Config -> IO Text
interpolate Text
prefix (Text
prefix forall a. Semigroup a => a -> a -> a
<> Text
key) Text
str Config
config
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert (Text
prefix forall a. Semigroup a => a -> a -> a
<> Text
key) (Text -> Value
String Text
v) Config
config
Bind Text
key Value
value ->
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert (Text
prefix forall a. Semigroup a => a -> a -> a
<> Text
key) Value
value Config
config
Group Text
key [Directive]
directives -> forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (Text -> Text -> Config -> Directive -> IO Config
applyDirective Text
prefix' Text
path) Config
config [Directive]
directives
where prefix' :: Text
prefix' = Text
prefix forall a. Semigroup a => a -> a -> a
<> Text
key forall a. Semigroup a => a -> a -> a
<> Text
"."
Import Text
relpath ->
let path' :: Text
path' = Text -> Text -> Text
relativize Text
path Text
relpath
in do
[Directive]
directives <- Text -> IO [Directive]
loadOne Text
path'
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (Text -> Text -> Config -> Directive -> IO Config
applyDirective Text
prefix Text
path') Config
config [Directive]
directives
DirectiveComment Directive
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return Config
config
interpolate :: Key -> Key -> Text -> Config -> IO Text
interpolate :: Text -> Text -> Text -> Config -> IO Text
interpolate Text
prefix Text
key Text
s Config
config
| Text
"$" Text -> Text -> Bool
`T.isInfixOf` Text
s =
case forall e s a.
Parsec e s a -> [Char] -> s -> Either (ParseErrorBundle s e) a
parse Parser [Interpolate]
interp ([Char]
"<" forall a. [a] -> [a] -> [a]
++ Text -> [Char]
T.unpack Text
key forall a. [a] -> [a] -> [a]
++ [Char]
">") Text
s of
Left ParseErrorBundle Text Void
err -> forall a e. Exception e => e -> a
throw forall a b. (a -> b) -> a -> b
$ Text -> ParseError
ParseError forall a b. (a -> b) -> a -> b
$ [Char] -> Text
T.pack forall a b. (a -> b) -> a -> b
$ forall s e.
(VisualStream s, TraversableStream s, ShowErrorComponent e) =>
ParseErrorBundle s e -> [Char]
errorBundlePretty ParseErrorBundle Text Void
err
Right [Interpolate]
xs -> Text -> Text
TL.toStrict forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> Text
toLazyText forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Monoid a => [a] -> a
mconcat forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Interpolate -> IO Builder
interpret [Interpolate]
xs
| Bool
otherwise = forall (m :: * -> *) a. Monad m => a -> m a
return Text
s
where
lookupEnv :: Text -> Maybe Value
lookupEnv Text
name = forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, MonadPlus m) =>
t (m a) -> m a
msum forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Config
config) [Text]
fullnames
where fullnames :: [Text]
fullnames = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map (Text -> [Text] -> Text
T.intercalate Text
".")
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map (forall a. [a] -> [a]
reverse forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text
nameforall a. a -> [a] -> [a]
:))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> [[a]]
tails
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> [a]
reverse
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Bool
T.null)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> Text -> [Text]
T.split (forall a. Eq a => a -> a -> Bool
==Char
'.')
forall a b. (a -> b) -> a -> b
$ Text
prefix
interpret :: Interpolate -> IO Builder
interpret (Literal Text
x) = forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> Builder
fromText Text
x)
interpret (Interpolate Text
name) =
case Text -> Maybe Value
lookupEnv Text
name of
Just (String Text
x) -> forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> Builder
fromText Text
x)
Just (Number Scientific
r) ->
case forall i. (Integral i, Bounded i) => Scientific -> Maybe i
toBoundedInteger Scientific
r :: Maybe Int64 of
Just Int64
n -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. Integral a => a -> Builder
decimal Int64
n)
Maybe Int64
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. RealFloat a => a -> Builder
realFloat (forall a. RealFloat a => Scientific -> a
toRealFloat Scientific
r :: Double))
Just Value
_ -> forall a e. Exception e => e -> a
throw forall a b. (a -> b) -> a -> b
$ Text -> ParseError
formatErr forall a b. (a -> b) -> a -> b
$ Text
"variable '" forall a. Semigroup a => a -> a -> a
<> Text
name forall a. Semigroup a => a -> a -> a
<> Text
"' is not a string or number"
Maybe Value
Nothing -> do
Maybe [Char]
var <- [Char] -> IO (Maybe [Char])
System.Environment.lookupEnv (Text -> [Char]
T.unpack Text
name)
case Maybe [Char]
var of
Maybe [Char]
Nothing -> forall a e. Exception e => e -> a
throw forall a b. (a -> b) -> a -> b
$ Text -> ParseError
formatErr forall a b. (a -> b) -> a -> b
$ Text
"no such variable: '" forall a. Semigroup a => a -> a -> a
<> Text
name forall a. Semigroup a => a -> a -> a
<> Text
"'"
Just [Char]
x -> forall (m :: * -> *) a. Monad m => a -> m a
return ([Char] -> Builder
fromString [Char]
x)
formatErr :: Text -> ParseError
formatErr Text
err = Text -> ParseError
ParseError forall a b. (a -> b) -> a -> b
$ Text
"<" forall a. Semigroup a => a -> a -> a
<> Text
key forall a. Semigroup a => a -> a -> a
<> Text
">:\n" forall a. Semigroup a => a -> a -> a
<> Text
err forall a. Semigroup a => a -> a -> a
<> Text
"\n"
relativize :: Path -> Path -> Path
relativize :: Text -> Text -> Text
relativize Text
parent Text
child
| Text -> Char
T.head Text
child forall a. Eq a => a -> a -> Bool
== Char
'/' = Text
child
| Bool
otherwise = forall a b. (a, b) -> a
fst (Text -> Text -> (Text, Text)
T.breakOnEnd Text
"/" Text
parent) Text -> Text -> Text
`T.append` Text
child