1 files changed, 101 insertions, 0 deletions
diff --git a/src/Conftrack/Source/Aeson.hs b/src/Conftrack/Source/Aeson.hs
new file mode 100644
index 0000000..97353d0
--- /dev/null
+++ b/src/Conftrack/Source/Aeson.hs
@@ -0,0 +1,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