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
"" 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
".") -- ["a.b.c.x","a.b.x","a.x","x"]
                    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]
:)) -- [["a","b","c","x"],["a","b","x"],["a","x"],["x"]]
                    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> [[a]]
tails                   -- [["c","b","a"],["b","a"],["a"],[]]
                    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> [a]
reverse                 -- ["c","b","a"]
                    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)   -- ["a","b","c"]
                    forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> Text -> [Text]
T.split (forall a. Eq a => a -> a -> Bool
==Char
'.')         -- ["a","b","c",""]
                    forall a b. (a -> b) -> a -> b
$ Text
prefix                  -- "a.b.c."

  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