-- |
-- Copyright: (c) 2019 Lucas David Traverso
-- License: MPL-2.0
-- Maintainer: Lucas David Traverso <lucas6246@gmail.com>
-- Stability: stable
-- Portability: portable
--
-- Source for json config files using Aeson
{-# LANGUAGE CPP #-}
{-# LANGUAGE RecordWildCards #-}
module Conferer.Source.Aeson where

#if MIN_VERSION_aeson(2,0,0)
import Data.Aeson hiding (Key)
import qualified Data.Aeson.KeyMap as KeyMap
import qualified Data.Aeson.Key as Key
#else
import Data.Aeson
import qualified Data.HashMap.Strict as KeyMap
#endif
import Control.Applicative
import Data.Text (Text)
import qualified Data.Text as Text
import qualified Data.Text.Encoding as Text
import Data.Vector ((!?))
import qualified Data.Vector as Vector
import Text.Read (readMaybe)
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as L
import Data.List (intersperse, sort)
import System.Directory (doesFileExist)
import Control.Exception
import Control.Monad (guard)

import Conferer.Source.Files
import qualified Conferer.Source.Null as Null
import Conferer.Source

-- | 'Source' that read a config file as json and uses that value in a way that
-- makes sense for Conferer but doesn't respect json perfectly.
data JsonSource = JsonSource
  { JsonSource -> Value
value :: Value
  } 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
showList :: [JsonSource] -> ShowS
$cshowList :: [JsonSource] -> ShowS
show :: JsonSource -> String
$cshow :: JsonSource -> String
showsPrec :: Int -> JsonSource -> ShowS
$cshowsPrec :: Int -> JsonSource -> ShowS
Show, JsonSource -> JsonSource -> Bool
(JsonSource -> JsonSource -> Bool)
-> (JsonSource -> JsonSource -> Bool) -> Eq JsonSource
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: JsonSource -> JsonSource -> Bool
$c/= :: JsonSource -> JsonSource -> Bool
== :: JsonSource -> JsonSource -> Bool
$c== :: JsonSource -> JsonSource -> Bool
Eq)

instance IsSource JsonSource where
  getKeyInSource :: JsonSource -> Key -> IO (Maybe Text)
getKeyInSource JsonSource {Value
value :: Value
value :: JsonSource -> Value
..} Key
key = do
    Maybe Text -> IO (Maybe Text)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Text -> IO (Maybe Text)) -> Maybe Text -> IO (Maybe Text)
forall a b. (a -> b) -> a -> b
$ Value -> Maybe Text
valueToText (Value -> Maybe Text) -> Maybe Value -> Maybe Text
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Key -> Value -> Maybe Value
traverseJSON Key
key Value
value
  getSubkeysInSource :: JsonSource -> Key -> IO [Key]
getSubkeysInSource JsonSource {Value
value :: Value
value :: JsonSource -> Value
..} Key
key = do
    [Key] -> IO [Key]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Key] -> IO [Key]) -> [Key] -> IO [Key]
forall a b. (a -> b) -> a -> b
$ (Key -> Key) -> [Key] -> [Key]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Key
key Key -> Key -> Key
/.) ([Key] -> [Key]) -> [Key] -> [Key]
forall a b. (a -> b) -> a -> b
$ [Key] -> (Value -> [Key]) -> Maybe Value -> [Key]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] Value -> [Key]
listKeysInJSON (Maybe Value -> [Key]) -> Maybe Value -> [Key]
forall a b. (a -> b) -> a -> b
$ Key -> Value -> Maybe Value
traverseJSON Key
key Value
value

-- | Create a 'SourceCreator' which uses files with @config/{env}.json@
-- template and then uses 'fromFilePath'
fromConfig :: Key -> SourceCreator
fromConfig :: Key -> SourceCreator
fromConfig Key
key Config
config = do
  String
fileToParse <- Key -> String -> Config -> IO String
getFilePathFromEnv Key
key String
"json" Config
config
  String -> IO Source
fromFilePath' String
fileToParse

-- | Create a 'SourceCreator' from a filepath
--
-- If the file is not present it will behave as if it had no keys.
--
-- If the file doesn't have valid json it will throw an error.
fromFilePath :: FilePath -> SourceCreator
fromFilePath :: String -> SourceCreator
fromFilePath String
fileToParse Config
_config =
  String -> IO Source
fromFilePath' String
fileToParse

-- | Create a 'Source' from a filepath
--
-- If the file is not present it will behave as if it had no keys.
--
-- If the file doesn't have valid json it will throw an error.
fromFilePath' :: FilePath -> IO Source
fromFilePath' :: String -> IO Source
fromFilePath' String
fileToParse = do
  Bool
fileExists <- String -> IO Bool
doesFileExist String
fileToParse
  if Bool
fileExists
    then do
      Maybe Value
value <- ByteString -> Maybe Value
forall a. FromJSON a => ByteString -> Maybe a
decodeStrict' (ByteString -> Maybe Value) -> IO ByteString -> IO (Maybe Value)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO ByteString
B.readFile String
fileToParse
      case Maybe Value
value of
        Maybe Value
Nothing ->
          String -> IO Source
forall a. HasCallStack => String -> a
error (String -> IO Source) -> String -> IO Source
forall a b. (a -> b) -> a -> b
$ String
"Failed to decode json file '" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
fileToParse String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"'"
        Just Value
v -> do
          case Value -> [RawKey]
invalidJsonKeys Value
v of
            [] ->
              Source -> IO Source
forall (m :: * -> *) a. Monad m => a -> m a
return (Source -> IO Source) -> Source -> IO Source
forall a b. (a -> b) -> a -> b
$ Value -> Source
fromValue Value
v
            [RawKey]
errors ->
              JsonHasInvalidKeysError -> IO Source
forall e a. Exception e => e -> IO a
throwIO (JsonHasInvalidKeysError -> IO Source)
-> JsonHasInvalidKeysError -> IO Source
forall a b. (a -> b) -> a -> b
$ String -> [RawKey] -> JsonHasInvalidKeysError
JsonHasInvalidKeysError String
fileToParse [RawKey]
errors
    else do
      Source -> IO Source
forall (m :: * -> *) a. Monad m => a -> m a
return (Source -> IO Source) -> Source -> IO Source
forall a b. (a -> b) -> a -> b
$ Source
Null.empty

-- | Exception thrown from 'fromFilePath' when the json in the
-- parsed file has incorrect keys
data JsonHasInvalidKeysError =
  JsonHasInvalidKeysError FilePath [RawKey] deriving (JsonHasInvalidKeysError -> JsonHasInvalidKeysError -> Bool
(JsonHasInvalidKeysError -> JsonHasInvalidKeysError -> Bool)
-> (JsonHasInvalidKeysError -> JsonHasInvalidKeysError -> Bool)
-> Eq JsonHasInvalidKeysError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: JsonHasInvalidKeysError -> JsonHasInvalidKeysError -> Bool
$c/= :: JsonHasInvalidKeysError -> JsonHasInvalidKeysError -> Bool
== :: JsonHasInvalidKeysError -> JsonHasInvalidKeysError -> Bool
$c== :: JsonHasInvalidKeysError -> JsonHasInvalidKeysError -> Bool
Eq, Int -> JsonHasInvalidKeysError -> ShowS
[JsonHasInvalidKeysError] -> ShowS
JsonHasInvalidKeysError -> String
(Int -> JsonHasInvalidKeysError -> ShowS)
-> (JsonHasInvalidKeysError -> String)
-> ([JsonHasInvalidKeysError] -> ShowS)
-> Show JsonHasInvalidKeysError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [JsonHasInvalidKeysError] -> ShowS
$cshowList :: [JsonHasInvalidKeysError] -> ShowS
show :: JsonHasInvalidKeysError -> String
$cshow :: JsonHasInvalidKeysError -> String
showsPrec :: Int -> JsonHasInvalidKeysError -> ShowS
$cshowsPrec :: Int -> JsonHasInvalidKeysError -> ShowS
Show)

instance Exception JsonHasInvalidKeysError

-- | Create a 'Source' from a json value, never fails.
fromValue :: Value -> Source
fromValue :: Value -> Source
fromValue Value
value =
  JsonSource -> Source
forall s. (IsSource s, Show s) => s -> Source
Source JsonSource :: Value -> JsonSource
JsonSource {Value
value :: Value
value :: Value
..}

-- | Traverse a 'Value' using a 'Key' to get a 'Value'.
--
-- This function can nest objects and arrays when keys are nested
--
-- @
-- 'traverseJSON' "a.b" {a: {b: 12}} == Just "12"
-- 'traverseJSON' "a.b" {a: {b: false}} == Just "false"
-- 'traverseJSON' "a" {a: {b: false}} == Nothing
-- 'traverseJSON' "1" [false, true] == Just "true"
-- 'traverseJSON' "0.a" [{a: "hi"}] == Just "hi"
-- 'traverseJSON' "0" [] == Nothing
-- @
traverseJSON :: Key -> Value -> Maybe Value
traverseJSON :: Key -> Value -> Maybe Value
traverseJSON Key
key Value
value =
 case (Key -> Maybe (Text, Key)
unconsKey Key
key, Value
value) of
   (Maybe (Text, Key)
Nothing, Value
v) ->
     Value -> Maybe Value
forall a. a -> Maybe a
Just Value
v
   (Just (Text
"keys", Key
""), Object Object
o) ->
      Key -> Object -> Maybe Value
forall v. Key -> KeyMap v -> Maybe v
KeyMap.lookup Key
"keys" Object
o
        Maybe Value -> Maybe Value -> Maybe Value
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Value -> Maybe Value
forall (f :: * -> *) a. Applicative f => a -> f a
pure (
              Text -> Value
String (Text -> Value) -> Text -> Value
forall a b. (a -> b) -> a -> b
$
#if MIN_VERSION_aeson(2,0,0)
              Key -> Text
Key.toText (Key -> Text) -> Key -> Text
forall a b. (a -> b) -> a -> b
$
#endif
              [Key] -> Key
forall a. Monoid a => [a] -> a
mconcat ([Key] -> Key) -> [Key] -> Key
forall a b. (a -> b) -> a -> b
$
              Key -> [Key] -> [Key]
forall a. a -> [a] -> [a]
intersperse Key
"," ([Key] -> [Key]) -> [Key] -> [Key]
forall a b. (a -> b) -> a -> b
$
              [Key] -> [Key]
forall a. Ord a => [a] -> [a]
sort ([Key] -> [Key]) -> [Key] -> [Key]
forall a b. (a -> b) -> a -> b
$
              Object -> [Key]
forall v. KeyMap v -> [Key]
KeyMap.keys Object
o)
   (Just (Text
c, Key
ks), Object Object
o) ->
     Key -> Object -> Maybe Value
forall v. Key -> KeyMap v -> Maybe v
KeyMap.lookup
#if MIN_VERSION_aeson(2,0,0)
      (Text -> Key
Key.fromText Text
c)
#else
      c
#endif
      Object
o Maybe Value -> (Value -> Maybe Value) -> Maybe Value
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Key -> Value -> Maybe Value
traverseJSON Key
ks
   (Just (Text
"keys", Key
""), Array Array
vs) ->
      Value -> Maybe Value
forall a. a -> Maybe a
Just (Value -> Maybe Value) -> Value -> Maybe Value
forall a b. (a -> b) -> a -> b
$
        Text -> Value
String (Text -> Value) -> Text -> Value
forall a b. (a -> b) -> a -> b
$
        RawKey -> Text
forall a. Monoid a => [a] -> a
mconcat (RawKey -> Text) -> RawKey -> Text
forall a b. (a -> b) -> a -> b
$
        Text -> RawKey -> RawKey
forall a. a -> [a] -> [a]
intersperse Text
"," (RawKey -> RawKey) -> RawKey -> RawKey
forall a b. (a -> b) -> a -> b
$
        (Int -> Text) -> [Int] -> RawKey
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (String -> Text
Text.pack (String -> Text) -> (Int -> String) -> Int -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> String
forall a. Show a => a -> String
show)
        [Int
0..Array -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Array
vs Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1]
   (Just (Text
c, Key
ks), Array Array
vs) -> do
     Int
n :: Int <- String -> Maybe Int
forall a. Read a => String -> Maybe a
readMaybe (String -> Maybe Int) -> String -> Maybe Int
forall a b. (a -> b) -> a -> b
$ Text -> String
Text.unpack Text
c
     Value
v <- Array
vs Array -> Int -> Maybe Value
forall a. Vector a -> Int -> Maybe a
!? Int
n
     Key -> Value -> Maybe Value
traverseJSON Key
ks Value
v
   (Just (Text, Key)
_, Value
_) ->
     Maybe Value
forall a. Maybe a
Nothing

-- | Get the list of available keys inside a json value
listKeysInJSON :: Value -> [Key]
listKeysInJSON :: Value -> [Key]
listKeysInJSON = Key -> Value -> [Key]
go Key
""
  where
  go :: Key -> Value -> [Key]
  go :: Key -> Value -> [Key]
go Key
key Value
value =
    case (Key -> Maybe (Text, Key)
unconsKey Key
key, Value
value) of
      (Maybe (Text, Key)
_, Object Object
o) ->
        let
          self :: [Key]
self =
            case Value -> Maybe Text
valueToText (Value -> Maybe Text) -> Maybe Value -> Maybe (Maybe Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Key -> Object -> Maybe Value
forall v. Key -> KeyMap v -> Maybe v
KeyMap.lookup Key
"_self" Object
o of
              Just Maybe Text
_ -> [Key
key]
              Maybe (Maybe Text)
Nothing -> []
        in [Key]
self [Key] -> [Key] -> [Key]
forall a. [a] -> [a] -> [a]
++ do
          (Key
k, Value
v) <- Object -> [(Key, Value)]
forall v. KeyMap v -> [(Key, v)]
KeyMap.toList Object
o
          let textK :: Text
textK =
#if MIN_VERSION_aeson(2,0,0)
                Key -> Text
Key.toText Key
k
#else
                k
#endif
          Bool -> [()]
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> [()]) -> Bool -> [()]
forall a b. (a -> b) -> a -> b
$ Text -> Bool
isValidKeyFragment Text
textK
          Key -> Value -> [Key]
go (Key
key Key -> Key -> Key
/. Text -> Key
fromText Text
textK) Value
v
      (Maybe (Text, Key)
_, Array Array
as) -> do
        (Integer
index :: Integer, Value
v) <- [Integer] -> [Value] -> [(Integer, Value)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Integer
0..] ([Value] -> [(Integer, Value)]) -> [Value] -> [(Integer, Value)]
forall a b. (a -> b) -> a -> b
$ Array -> [Value]
forall a. Vector a -> [a]
Vector.toList Array
as
        Key -> Value -> [Key]
go (Key
key Key -> Key -> Key
/. String -> Key
mkKey (Integer -> String
forall a. Show a => a -> String
show Integer
index)) Value
v
      (Maybe (Text, Key)
Nothing, Value
_) -> []
      (Maybe (Text, Key)
_, Value
_) -> [Key
key]

-- | Turn json 'Value' into 'Text' to return that key
valueToText :: Value -> Maybe Text
valueToText :: Value -> Maybe Text
valueToText (String Text
t) = Text -> Maybe Text
forall a. a -> Maybe a
Just Text
t
valueToText (Object Object
o) = do
  Value
selfValue <- Key -> Object -> Maybe Value
forall v. Key -> KeyMap v -> Maybe v
KeyMap.lookup Key
"_self" Object
o
  Value -> Maybe Text
valueToText Value
selfValue
valueToText (Array Array
_as) = Maybe Text
forall a. Maybe a
Nothing
valueToText (Number Scientific
n) = Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$ ByteString -> Text
Text.decodeUtf8 (ByteString -> Text) -> ByteString -> Text
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
L.toStrict (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Value -> ByteString
forall a. ToJSON a => a -> ByteString
encode (Value -> ByteString) -> Value -> ByteString
forall a b. (a -> b) -> a -> b
$ Scientific -> Value
Number Scientific
n
valueToText (Bool Bool
b) = Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$ Bool -> Text
boolToString Bool
b
valueToText (Value
Null) = Maybe Text
forall a. Maybe a
Nothing

-- | Turn a 'GHC.Types.Bool' into a 'Text'
boolToString :: Bool -> Text
boolToString :: Bool -> Text
boolToString Bool
True = Text
"true"
boolToString Bool
False = Text
"false"

-- | Because we use an old version of aeson
resultToMaybe :: Result a -> Maybe a
resultToMaybe :: Result a -> Maybe a
resultToMaybe (Error String
_) = Maybe a
forall a. Maybe a
Nothing
resultToMaybe (Success a
a) = a -> Maybe a
forall a. a -> Maybe a
Just a
a

type RawKey = [Text]

-- | Validates that a json has the correct format for keys,
-- since Conferer 'Key's are pretty restricted.
--
-- The Source will work with incorrect keys but they will
-- be ignored.
invalidJsonKeys :: Value -> [RawKey]
invalidJsonKeys :: Value -> [RawKey]
invalidJsonKeys = (RawKey -> Bool) -> [RawKey] -> [RawKey]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (RawKey -> Bool) -> RawKey -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RawKey -> Bool
validKey) ([RawKey] -> [RawKey]) -> (Value -> [RawKey]) -> Value -> [RawKey]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> [RawKey]
allKeys
  where
    validFragmentForJSON :: Text -> Bool
    validFragmentForJSON :: Text -> Bool
validFragmentForJSON Text
fragment = Text -> Bool
isValidKeyFragment Text
fragment Bool -> Bool -> Bool
|| Text
fragment Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"_self"
    validKey :: RawKey -> Bool
    validKey :: RawKey -> Bool
validKey RawKey
fragments = (Text -> Bool) -> RawKey -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Text -> Bool
validFragmentForJSON RawKey
fragments

-- | Returns all keys in a json object
allKeys :: Value -> [RawKey]
allKeys :: Value -> [RawKey]
allKeys = RawKey -> Value -> [RawKey]
go RawKey
forall a. Monoid a => a
mempty
  where
    go :: RawKey -> Value -> [RawKey]
    go :: RawKey -> Value -> [RawKey]
go RawKey
rawkey Value
value =
      case Value
value of
        Object Object
o ->
          let
            keys :: [RawKey]
keys =
              (Text -> RawKey) -> RawKey -> [RawKey]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Text
t -> RawKey
rawkey RawKey -> RawKey -> RawKey
forall a. [a] -> [a] -> [a]
++ [Text
t])
#if MIN_VERSION_aeson(2,0,0)
              (RawKey -> [RawKey]) -> (Object -> RawKey) -> Object -> [RawKey]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Key -> Text) -> [Key] -> RawKey
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Key -> Text
Key.toText
#endif
              ([Key] -> RawKey) -> (Object -> [Key]) -> Object -> RawKey
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Object -> [Key]
forall v. KeyMap v -> [Key]
KeyMap.keys
              (Object -> [RawKey]) -> Object -> [RawKey]
forall a b. (a -> b) -> a -> b
$ Object
o
          in [RawKey]
keys [RawKey] -> [RawKey] -> [RawKey]
forall a. [a] -> [a] -> [a]
++ do
          (Key
k, Value
v) <- Object -> [(Key, Value)]
forall v. KeyMap v -> [(Key, v)]
KeyMap.toList Object
o
          let textK :: Text
textK =
#if MIN_VERSION_aeson(2,0,0)
                Key -> Text
Key.toText Key
k
#else
                k
#endif
          let subkey :: RawKey
subkey = RawKey
rawkey RawKey -> RawKey -> RawKey
forall a. [a] -> [a] -> [a]
++ [Text
textK]
          RawKey -> Value -> [RawKey]
go RawKey
subkey Value
v
        Array Array
as -> do
          (Integer
index :: Integer, Value
v) <- [Integer] -> [Value] -> [(Integer, Value)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Integer
0..] ([Value] -> [(Integer, Value)]) -> [Value] -> [(Integer, Value)]
forall a b. (a -> b) -> a -> b
$ Array -> [Value]
forall a. Vector a -> [a]
Vector.toList Array
as
          let subkey :: RawKey
subkey = RawKey
rawkey RawKey -> RawKey -> RawKey
forall a. [a] -> [a] -> [a]
++ [String -> Text
Text.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Integer -> String
forall a. Show a => a -> String
show Integer
index]
          RawKey -> Value -> [RawKey]
go RawKey
subkey Value
v
        Value
_ -> []