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