{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE QuantifiedConstraints #-}
{-# LANGUAGE ImpredicativeTypes #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE LambdaCase #-}

-- | Functions for producing sources reading from json strings or files, using the aeson library.
module Conftrack.Source.Aeson (mkJsonSource, mkJsonSourceWith, mkJsonFileSource, JsonSource(..)) where

import Conftrack.Value (Key (..), ConfigError(..), Value (..), KeyPart)
import Conftrack.Source (SomeSource(..), ConfigSource (..))

import Prelude hiding (readFile)
import qualified Data.Aeson as A
import Control.Monad.State (get, modify, MonadState (..))
import Data.Function ((&))
import Data.Text (Text)
import qualified Data.Aeson.Text as A
import qualified Data.Text as T
import qualified Data.Text.Lazy as LT
import qualified Data.Aeson.Types as A
import qualified Data.Aeson.Key as A
import Data.Aeson.Types (unexpected)
import qualified Data.List.NonEmpty as NonEmpty
import Control.Monad ((>=>))
import Data.Functor ((<&>))
import System.OsPath (OsPath)
import qualified System.OsPath as OS
import System.File.OsPath (readFile)
import qualified Data.Aeson.KeyMap as A
import qualified Data.Text.Encoding as BS

data JsonSource = JsonSource
  { JsonSource -> Value
jsonSourceValue :: A.Value
  , JsonSource -> Text
jsonSourceDescription :: Text
  } deriving (Int -> JsonSource -> ShowS
[JsonSource] -> ShowS
JsonSource -> String
(Int -> JsonSource -> ShowS)
-> (JsonSource -> String)
-> ([JsonSource] -> ShowS)
-> Show JsonSource
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> JsonSource -> ShowS
showsPrec :: Int -> JsonSource -> ShowS
$cshow :: JsonSource -> String
show :: JsonSource -> String
$cshowList :: [JsonSource] -> ShowS
showList :: [JsonSource] -> ShowS
Show)

-- | Make a source from an aeson value
mkJsonSource :: A.Value -> SomeSource
mkJsonSource :: Value -> SomeSource
mkJsonSource Value
value = Text -> Value -> SomeSource
mkJsonSourceWith (Text
"JSON string " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
LT.toStrict (Value -> Text
forall a. ToJSON a => a -> Text
A.encodeToLazyText Value
value)) Value
value

-- | same as 'mkJsonSource', but with an additional description to be shown
-- in output of 'Conftrack.Pretty.printConfigOrigins'.
mkJsonSourceWith :: Text -> A.Value -> SomeSource
mkJsonSourceWith :: Text -> Value -> SomeSource
mkJsonSourceWith Text
description Value
value = (JsonSource, SourceState JsonSource) -> SomeSource
forall source.
ConfigSource source =>
(source, SourceState source) -> SomeSource
SomeSource (JsonSource
source, [])
  where source :: JsonSource
source = Value -> Text -> JsonSource
JsonSource Value
value Text
description

-- | Make a source from a json file.
mkJsonFileSource :: OsPath -> IO (Maybe SomeSource)
mkJsonFileSource :: OsPath -> IO (Maybe SomeSource)
mkJsonFileSource OsPath
path = do
  ByteString
bytes <- OsPath -> IO ByteString
readFile OsPath
path
  Text
pathAsText <- OsPath -> IO String
forall (m :: * -> *). MonadThrow m => OsPath -> m String
OS.decodeUtf OsPath
path IO String -> (String -> Text) -> IO Text
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> Text -> Text
LT.toStrict (Text -> Text) -> (String -> Text) -> String -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
LT.pack
  Maybe SomeSource -> IO (Maybe SomeSource)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe SomeSource -> IO (Maybe SomeSource))
-> Maybe SomeSource -> IO (Maybe SomeSource)
forall a b. (a -> b) -> a -> b
$ ByteString -> Maybe Value
forall a. FromJSON a => ByteString -> Maybe a
A.decode ByteString
bytes
    Maybe Value -> (Value -> SomeSource) -> Maybe SomeSource
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> Text -> Value -> SomeSource
mkJsonSourceWith (Text
"JSON file " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
pathAsText)

instance ConfigSource JsonSource where
  type SourceState JsonSource = [Key]

  fetchValue :: Key
-> JsonSource
-> StateT
     (SourceState JsonSource) IO (Either ConfigError (Value, Text))
fetchValue key :: Key
key@(Key NonEmpty Text
parts) JsonSource{Value
Text
jsonSourceValue :: JsonSource -> Value
jsonSourceDescription :: JsonSource -> Text
jsonSourceValue :: Value
jsonSourceDescription :: Text
..} = do
    case (Value -> Parser Value) -> Value -> Either String Value
forall a b. (a -> Parser b) -> a -> Either String b
A.parseEither ([Text] -> Value -> Parser Value
lookupJsonPath (NonEmpty Text -> [Text]
forall a. NonEmpty a -> [a]
NonEmpty.toList NonEmpty Text
parts) (Value -> Parser Value)
-> (Value -> Parser Value) -> Value -> Parser Value
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Value -> Parser Value
parseJsonValue) Value
jsonSourceValue of
      Left String
a -> Either ConfigError (Value, Text)
-> StateT
     (SourceState JsonSource) IO (Either ConfigError (Value, Text))
forall a. a -> StateT (SourceState JsonSource) IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either ConfigError (Value, Text)
 -> StateT
      (SourceState JsonSource) IO (Either ConfigError (Value, Text)))
-> Either ConfigError (Value, Text)
-> StateT
     (SourceState JsonSource) IO (Either ConfigError (Value, Text))
forall a b. (a -> b) -> a -> b
$ ConfigError -> Either ConfigError (Value, Text)
forall a b. a -> Either a b
Left (Text -> ConfigError
ParseError (String -> Text
T.pack String
a))
      Right Value
val -> do
        ([Key] -> [Key]) -> StateT [Key] IO ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (Key
key :)
        Either ConfigError (Value, Text)
-> StateT [Key] IO (Either ConfigError (Value, Text))
forall a. a -> StateT [Key] IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either ConfigError (Value, Text)
 -> StateT [Key] IO (Either ConfigError (Value, Text)))
-> Either ConfigError (Value, Text)
-> StateT [Key] IO (Either ConfigError (Value, Text))
forall a b. (a -> b) -> a -> b
$ (Value, Text) -> Either ConfigError (Value, Text)
forall a b. b -> Either a b
Right (Value
val, Text
jsonSourceDescription)

  leftovers :: JsonSource -> StateT (SourceState JsonSource) IO (Maybe [Key])
leftovers JsonSource{Value
Text
jsonSourceValue :: JsonSource -> Value
jsonSourceDescription :: JsonSource -> Text
jsonSourceValue :: Value
jsonSourceDescription :: Text
..} = do
    [Key]
used <- StateT [Key] IO [Key]
forall s (m :: * -> *). MonadState s m => m s
get

    Value -> [Key]
allJsonPaths Value
jsonSourceValue
     [Key] -> ([Key] -> [Key]) -> [Key]
forall a b. a -> (a -> b) -> b
& (Key -> Bool) -> [Key] -> [Key]
forall a. (a -> Bool) -> [a] -> [a]
filter (Key -> [Key] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Key]
used)
     [Key] -> ([Key] -> Maybe [Key]) -> Maybe [Key]
forall a b. a -> (a -> b) -> b
& [Key] -> Maybe [Key]
forall a. a -> Maybe a
Just
     Maybe [Key]
-> (Maybe [Key] -> StateT [Key] IO (Maybe [Key]))
-> StateT [Key] IO (Maybe [Key])
forall a b. a -> (a -> b) -> b
& Maybe [Key] -> StateT [Key] IO (Maybe [Key])
forall a. a -> StateT [Key] IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure

-- | this is essentially a FromJSON instance for Value, but not written as one
-- so as to not introduce an orphan
parseJsonValue :: A.Value -> A.Parser Value
parseJsonValue :: Value -> Parser Value
parseJsonValue = \case
  (A.String Text
bytes) -> Value -> Parser Value
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value -> Parser Value) -> Value -> Parser Value
forall a b. (a -> b) -> a -> b
$ ByteString -> Value
ConfigString (Text -> ByteString
BS.encodeUtf8 Text
bytes)
  (A.Number Scientific
num) ->
    Value -> Parser Integer
forall a. FromJSON a => Value -> Parser a
A.parseJSON (Scientific -> Value
A.Number Scientific
num) Parser Integer -> (Integer -> Value) -> Parser Value
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> Integer -> Value
ConfigInteger
  (A.Bool Bool
b) -> Value -> Parser Value
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value -> Parser Value) -> Value -> Parser Value
forall a b. (a -> b) -> a -> b
$ Bool -> Value
ConfigBool Bool
b
  Value
A.Null -> Value -> Parser Value
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Value
ConfigNull
  (A.Object Object
_) -> Value -> Parser Value
forall a. Value -> Parser a
unexpected Value
"unexpected json object"
  (A.Array Array
_) -> Value -> Parser Value
forall a. Value -> Parser a
unexpected Value
"unexpected json array"

lookupJsonPath ::  [KeyPart] -> A.Value -> A.Parser A.Value
lookupJsonPath :: [Text] -> Value -> Parser Value
lookupJsonPath [] Value
value = Value -> Parser Value
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Value
value
lookupJsonPath (Text
part:[Text]
parts) Value
value = do
  String -> (Object -> Parser Value) -> Value -> Parser Value
forall a. String -> (Object -> Parser a) -> Value -> Parser a
A.withObject String
"blub" (\Object
obj -> Object
obj Object -> Key -> Parser Value
forall a. FromJSON a => Object -> Key -> Parser a
A..: Text -> Key
A.fromText Text
part) Value
value
  Parser Value -> (Value -> Parser Value) -> Parser Value
forall a b. Parser a -> (a -> Parser b) -> Parser b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [Text] -> Value -> Parser Value
lookupJsonPath [Text]
parts

allJsonPaths :: A.Value -> [Key]
allJsonPaths :: Value -> [Key]
allJsonPaths = (NonEmpty Key -> Key) -> [NonEmpty Key] -> [Key]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap NonEmpty Key -> Key
keyToKey ([NonEmpty Key] -> [Key])
-> (Value -> [NonEmpty Key]) -> Value -> [Key]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Key] -> Value -> [NonEmpty Key]
subKeys []
  where
    keyToKey :: NonEmpty Key -> Key
keyToKey NonEmpty Key
keys = NonEmpty Text -> Key
Key ((Key -> Text) -> NonEmpty Key -> NonEmpty Text
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Key -> Text
forall {a}. FromJSON a => Key -> a
aesonKeyToText NonEmpty Key
keys)
    aesonKeyToText :: Key -> a
aesonKeyToText (Key
key :: A.Key) = case (Value -> Parser a) -> Value -> Maybe a
forall a b. (a -> Parser b) -> a -> Maybe b
A.parseMaybe Value -> Parser a
forall a. FromJSON a => Value -> Parser a
A.parseJSON (Key -> Value
forall a. ToJSON a => a -> Value
A.toJSON Key
key) of
      Maybe a
Nothing -> String -> a
forall a. HasCallStack => String -> a
error String
"key not representable as text; this is a bug in conftrack-aeson."
      Just a
a -> a
a
    subKeys :: [Key] -> Value -> [NonEmpty Key]
subKeys [Key]
prefix (A.Object Object
keymap) =
      (Key -> Value -> [NonEmpty Key]) -> Object -> [NonEmpty Key]
forall m a. Monoid m => (Key -> a -> m) -> KeyMap a -> m
A.foldMapWithKey (\Key
key Value
v -> [Key] -> Value -> [NonEmpty Key]
subKeys ([Key]
prefix [Key] -> [Key] -> [Key]
forall a. Semigroup a => a -> a -> a
<> [Key
key]) Value
v) Object
keymap
    subKeys [Key]
prefix Value
_ = case [Key] -> Maybe (NonEmpty Key)
forall a. [a] -> Maybe (NonEmpty a)
NonEmpty.nonEmpty [Key]
prefix of
      Just NonEmpty Key
key -> [NonEmpty Key
key]
      Maybe (NonEmpty Key)
_ -> [NonEmpty Key]
forall a. HasCallStack => a
undefined