-- |
-- 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 RecordWildCards #-}
module Conferer.Source.Aeson where

import Data.Aeson
import Control.Applicative
import qualified Data.HashMap.Strict as HashMap
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)
import System.Directory (doesFileExist)

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 '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
          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
    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

-- | 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) ->
      Text -> Object -> Maybe Value
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HashMap.lookup Text
"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
$
              [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$
              Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
intersperse Text
"," ([Text] -> [Text]) -> [Text] -> [Text]
forall a b. (a -> b) -> a -> b
$
              Object -> [Text]
forall k v. HashMap k v -> [k]
HashMap.keys Object
o)
   (Just (Text
c, Key
ks), Object Object
o) ->
     Text -> Object -> Maybe Value
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HashMap.lookup Text
c 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
$
        [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$
        Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
intersperse Text
"," ([Text] -> [Text]) -> [Text] -> [Text]
forall a b. (a -> b) -> a -> b
$
        (Int -> Text) -> [Int] -> [Text]
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) -> do
        (Text
k, Value
v) <- Object -> [(Text, Value)]
forall k v. HashMap k v -> [(k, v)]
HashMap.toList Object
o
        Key -> Value -> [Key]
go (Key
key Key -> Key -> Key
/. Text -> Key
fromText Text
k) 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) = Maybe Text
forall a. Maybe a
Nothing
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