1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
|
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE QuantifiedConstraints #-}
{-# LANGUAGE ImpredicativeTypes #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE LambdaCase #-}
module Conftrack.Source.Aeson (JsonSource(..), mkJsonSource, mkJsonSourceWith, mkJsonFileSource) 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
{ jsonSourceValue :: A.Value
, jsonSourceDescription :: Text
} deriving (Show)
mkJsonSource :: A.Value -> SomeSource
mkJsonSource value = mkJsonSourceWith ("JSON string " <> LT.toStrict (A.encodeToLazyText value)) value
mkJsonSourceWith :: Text -> A.Value -> SomeSource
mkJsonSourceWith description value = SomeSource (source, [])
where source = JsonSource value description
mkJsonFileSource :: OsPath -> IO (Maybe SomeSource)
mkJsonFileSource path = do
bytes <- readFile path
pathAsText <- OS.decodeUtf path <&> LT.toStrict . LT.pack
pure $ A.decode bytes
<&> mkJsonSourceWith ("JSON file " <> pathAsText)
instance ConfigSource JsonSource where
type SourceState JsonSource = [Key]
fetchValue key@(Key parts) JsonSource{..} = do
case A.parseEither (lookupJsonPath (NonEmpty.toList parts) >=> parseJsonValue) jsonSourceValue of
Left a -> pure $ Left (ParseError (T.pack a))
Right val -> do
modify (key :)
pure $ Right (val, jsonSourceDescription)
leftovers JsonSource{..} = do
used <- get
allJsonPaths jsonSourceValue
& filter (`notElem` used)
& Just
& 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 = \case
(A.String bytes) -> pure $ ConfigString (BS.encodeUtf8 bytes)
(A.Number num) ->
A.parseJSON (A.Number num) <&> ConfigInteger
(A.Bool b) -> pure $ ConfigBool b
A.Null -> pure ConfigNull
(A.Object _) -> unexpected "unexpected json object"
(A.Array _) -> unexpected "unexpected json array"
lookupJsonPath :: [KeyPart] -> A.Value -> A.Parser A.Value
lookupJsonPath [] value = pure value
lookupJsonPath (part:parts) value = do
A.withObject "blub" (\obj -> obj A..: A.fromText part) value
>>= lookupJsonPath parts
allJsonPaths :: A.Value -> [Key]
allJsonPaths = fmap keyToKey . subKeys []
where
keyToKey keys = Key (fmap aesonKeyToText keys)
aesonKeyToText (key :: A.Key) = case A.parseMaybe A.parseJSON (A.toJSON key) of
Nothing -> error "key not representable as text; this is a bug in conftrack-aeson."
Just a -> a
subKeys prefix (A.Object keymap) =
A.foldMapWithKey (\key v -> subKeys (prefix <> [key]) v) keymap
subKeys prefix _ = case NonEmpty.nonEmpty prefix of
Just key -> [key]
_ -> undefined
|
