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 :: 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
".") -- ["a.b.c.x","a.b.x","a.x","x"]
                    ([[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]
:)) -- [["a","b","c","x"],["a","b","x"],["a","x"],["x"]]
                    ([[Key]] -> [[Key]]) -> (Key -> [[Key]]) -> Key -> [[Key]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Key] -> [[Key]]
forall a. [a] -> [[a]]
tails                   -- [["c","b","a"],["b","a"],["a"],[]]
                    ([Key] -> [[Key]]) -> (Key -> [Key]) -> Key -> [[Key]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Key] -> [Key]
forall a. [a] -> [a]
reverse                 -- ["c","b","a"]
                    ([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)   -- ["a","b","c"]
                    ([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
'.')         -- ["a","b","c",""]
                    (Key -> [Key]) -> Key -> [Key]
forall a b. (a -> b) -> a -> b
$ Key
prefix                  -- "a.b.c."

  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