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

-- | Read and parse a configuration file.
--
-- This may cause IO exceptions for reading this file or
-- imported files, and 'ParseError' if there is a problem
-- with parsing or evaluating the file.
load :: FilePath -> IO Config
load :: [Char] -> IO Config
load [Char]
path = Text -> Text -> Config -> Directive -> IO Config
applyDirective Text
"" Text
"" Config
forall k a. Map k a
M.empty (Text -> Directive
Import (Text -> Directive) -> Text -> Directive
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 Parsec Void Text [Directive]
-> [Char]
-> Text
-> Either (ParseErrorBundle Text Void) [Directive]
forall e s a.
Parsec e s a -> [Char] -> s -> Either (ParseErrorBundle s e) a
parse Parsec Void Text [Directive]
topLevel (Text -> [Char]
T.unpack Text
path) Text
s of
    Left ParseErrorBundle Text 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
$ Text -> ParseError
ParseError (Text -> ParseError) -> Text -> ParseError
forall a b. (a -> b) -> a -> b
$ [Char] -> Text
T.pack ([Char] -> Text) -> [Char] -> Text
forall a b. (a -> b) -> a -> b
$ ParseErrorBundle Text Void -> [Char]
forall s e.
(VisualStream s, TraversableStream s, ShowErrorComponent e) =>
ParseErrorBundle s e -> [Char]
errorBundlePretty ParseErrorBundle Text Void
err
    Right [Directive]
directives -> [Directive] -> IO [Directive]
forall a. a -> IO a
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 Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
key) Text
str Config
config
    Config -> IO Config
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Config -> IO Config) -> Config -> IO Config
forall a b. (a -> b) -> a -> b
$! Text -> Value -> Config -> Config
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert (Text
prefix Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
key) (Text -> Value
String Text
v) Config
config
  Bind Text
key Value
value ->
    Config -> IO Config
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Config -> IO Config) -> Config -> IO Config
forall a b. (a -> b) -> a -> b
$! Text -> Value -> Config -> Config
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert (Text
prefix Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
key) Value
value Config
config
  Group Text
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 (Text -> Text -> Config -> Directive -> IO Config
applyDirective Text
prefix' Text
path) Config
config [Directive]
directives
    where prefix' :: Text
prefix' = Text
prefix Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
key Text -> Text -> Text
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'
      (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 (Text -> Text -> Config -> Directive -> IO Config
applyDirective Text
prefix Text
path') Config
config [Directive]
directives
  DirectiveComment Directive
_ -> Config -> IO Config
forall a. a -> IO a
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 Parsec Void Text [Interpolate]
-> [Char]
-> Text
-> Either (ParseErrorBundle Text Void) [Interpolate]
forall e s a.
Parsec e s a -> [Char] -> s -> Either (ParseErrorBundle s e) a
parse Parsec Void Text [Interpolate]
interp ([Char]
"<" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Text -> [Char]
T.unpack Text
key [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
">") Text
s of
      Left ParseErrorBundle Text Void
err   -> ParseError -> IO Text
forall a e. Exception e => e -> a
throw (ParseError -> IO Text) -> ParseError -> IO Text
forall a b. (a -> b) -> a -> b
$ Text -> ParseError
ParseError (Text -> ParseError) -> Text -> ParseError
forall a b. (a -> b) -> a -> b
$ [Char] -> Text
T.pack ([Char] -> Text) -> [Char] -> Text
forall a b. (a -> b) -> a -> b
$ ParseErrorBundle Text Void -> [Char]
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 (Text -> Text) -> ([Builder] -> Text) -> [Builder] -> Text
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] -> Text) -> IO [Builder] -> IO Text
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)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Interpolate -> IO Builder
interpret [Interpolate]
xs
  | Bool
otherwise = Text -> IO Text
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Text
s

 where
  lookupEnv :: Text -> Maybe Value
lookupEnv Text
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
$ (Text -> Maybe Value) -> [Text] -> [Maybe Value]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map ((Text -> Config -> Maybe Value) -> Config -> Text -> Maybe Value
forall a b c. (a -> b -> c) -> b -> a -> c
flip Text -> Config -> Maybe Value
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Config
config) [Text]
fullnames
    where fullnames :: [Text]
fullnames = ([Text] -> Text) -> [[Text]] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map (Text -> [Text] -> Text
T.intercalate Text
".") -- ["a.b.c.x","a.b.x","a.x","x"]
                    ([[Text]] -> [Text]) -> (Text -> [[Text]]) -> Text -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Text] -> [Text]) -> [[Text]] -> [[Text]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map ([Text] -> [Text]
forall a. [a] -> [a]
reverse ([Text] -> [Text]) -> ([Text] -> [Text]) -> [Text] -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text
nameText -> [Text] -> [Text]
forall a. a -> [a] -> [a]
:)) -- [["a","b","c","x"],["a","b","x"],["a","x"],["x"]]
                    ([[Text]] -> [[Text]]) -> (Text -> [[Text]]) -> Text -> [[Text]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> [[Text]]
forall a. [a] -> [[a]]
tails                   -- [["c","b","a"],["b","a"],["a"],[]]
                    ([Text] -> [[Text]]) -> (Text -> [Text]) -> Text -> [[Text]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> [Text]
forall a. [a] -> [a]
reverse                 -- ["c","b","a"]
                    ([Text] -> [Text]) -> (Text -> [Text]) -> Text -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Bool) -> [Text] -> [Text]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (Text -> Bool) -> Text -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Bool
T.null)   -- ["a","b","c"]
                    ([Text] -> [Text]) -> (Text -> [Text]) -> Text -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> Text -> [Text]
T.split (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
'.')         -- ["a","b","c",""]
                    (Text -> [Text]) -> Text -> [Text]
forall a b. (a -> b) -> a -> b
$ Text
prefix                  -- "a.b.c."

  interpret :: Interpolate -> IO Builder
interpret (Literal Text
x)   = Builder -> IO Builder
forall a. a -> IO a
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) -> Builder -> IO Builder
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> Builder
fromText Text
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 a. a -> IO a
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 a. a -> IO a
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
$ Text -> ParseError
formatErr (Text -> ParseError) -> Text -> ParseError
forall a b. (a -> b) -> a -> b
$ Text
"variable '" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name Text -> Text -> Text
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 -> ParseError -> IO Builder
forall a e. Exception e => e -> a
throw (ParseError -> IO Builder) -> ParseError -> IO Builder
forall a b. (a -> b) -> a -> b
$ Text -> ParseError
formatErr (Text -> ParseError) -> Text -> ParseError
forall a b. (a -> b) -> a -> b
$ Text
"no such variable: '" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"'"
          Just [Char]
x  -> Builder -> IO Builder
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Char] -> Builder
fromString [Char]
x)
  formatErr :: Text -> ParseError
formatErr Text
err = Text -> ParseError
ParseError (Text -> ParseError) -> Text -> ParseError
forall a b. (a -> b) -> a -> b
$ Text
"<" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
key Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
">:\n" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
err Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\n"

relativize :: Path -> Path -> Path
relativize :: Text -> Text -> Text
relativize Text
parent Text
child
  | HasCallStack => Text -> Char
Text -> Char
T.head Text
child Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'/' = Text
child
  | Bool
otherwise           = (Text, Text) -> Text
forall a b. (a, b) -> a
fst (HasCallStack => Text -> Text -> (Text, Text)
Text -> Text -> (Text, Text)
T.breakOnEnd Text
"/" Text
parent) Text -> Text -> Text
`T.append` Text
child