nested values, tests, and aeson

5 files changed, 243 insertions, 56 deletions

diff --git a/src/Conftrack.hs b/src/Conftrack.hs
index 3003115..0f40048 100644
--- a/src/Conftrack.hs
+++ b/src/Conftrack.hs
@@ -7,18 +7,28 @@
 {-# LANGUAGE AllowAmbiguousTypes #-}
 {-# LANGUAGE LambdaCase #-}
 
-module Conftrack  where
-
-import Conftrack.Value (ConfigError(..), ConfigValue(..), Key, Origin(..))
+module Conftrack
+  ( Config(..)
+  , Warning(..)
+  , runFetchConfig
+  , readValue
+  , readNested
+  , SomeSource
+  , ConfigError(..)
+  , Key(..)
+  , Value(..)
+  ) where
+
+import Conftrack.Value (ConfigError(..), ConfigValue(..), Key (..), Origin(..), Value(..), KeyPart, prefixedWith)
 import Conftrack.Source (SomeSource (..), ConfigSource (..))
 
 import Prelude hiding (unzip)
-import Control.Monad.State (get, StateT (..), MonadState (..), gets)
+import Control.Monad.State (get, StateT (..), MonadState (..), modify)
 import Data.Functor ((<&>))
 import Control.Monad.Reader (MonadIO (liftIO))
 import Data.List.NonEmpty (NonEmpty, unzip)
 import qualified Data.List.NonEmpty as NonEmpty
-import Control.Monad (forM)
+import Control.Monad (forM, foldM)
 import Data.Either (isRight)
 import Control.Monad.Trans.Except (ExceptT(..), runExceptT, throwE)
 import Control.Monad.Trans (lift)
@@ -30,31 +40,29 @@ import Data.Maybe (isJust)
 class Config a where
   readConfig :: FetchMonad a
 
-type FetchMonad = StateT (NonEmpty SomeSource, [Origin], [Warning]) (ExceptT [ConfigError] IO)
+type FetchMonad = StateT (NonEmpty SomeSource, [KeyPart], [Origin], [Warning]) (ExceptT [ConfigError] IO)
 
 newtype Warning = Warning Text
  deriving Show
 
 runFetchConfig :: Config a => NonEmpty SomeSource -> IO (Either [ConfigError] (a, [Origin], [Warning]))
 runFetchConfig sources = do
-  results <- runExceptT $ runStateT readConfig (sources, [], [])
-
+  results <- runExceptT $ runStateT readConfig (sources, [], [], [])
   case results of
     Left a -> pure $ Left a
-    Right (result, (sources, origins, warnings)) -> do
+    Right (result, (sources, _prefix, origins, warnings)) -> do
       unusedWarnings <- collectUnused sources
       pure $ Right (result, origins, unusedWarnings <> warnings)
 
 readValue :: ConfigValue a => Key -> FetchMonad a
-readValue key = do
-  (sources, origins, warnings) <- get
+readValue bareKey = do
+  (sources, prefix, origins, warnings) <- get
+
+  let key = bareKey `prefixedWith` prefix
 
-  -- TODO: this should short-curcuit here (so we have correct unused key sets)
-  stuff <- liftIO $ forM sources $ \(SomeSource (source, sourceState)) -> do
-    (eitherValue, newState) <- runStateT (fetchValue key source) sourceState
-    pure (eitherValue, SomeSource (source, newState))
+  stuff <- liftIO $ firstMatchInSources key (NonEmpty.toList sources) <&> NonEmpty.fromList
 
-  let (maybeValues, states) = Data.List.NonEmpty.unzip stuff
+  let (maybeValues, states) = unzip stuff
 
   let values = maybeValues <&> \case
         Right (val, text) -> fromConfig val <&> (\val -> (val, Origin key text))
@@ -64,13 +72,35 @@ readValue key = do
     [] -> lift $ throwE [NotPresent]
     val:_ -> pure val
 
-  put (states, snd val : origins, warnings)
-
+  put (states, prefix, snd val : origins, warnings)
   pure (fst val)
 
+
+firstMatchInSources :: Key -> [SomeSource] -> IO [(Either ConfigError (Value, Text), SomeSource)]
+firstMatchInSources _ [] = pure []
+firstMatchInSources key (SomeSource (source, sourceState):sources) = do
+  (eitherValue, newState) <- runStateT (fetchValue key source) sourceState
+
+  case eitherValue of
+    Left _ -> do
+      firstMatchInSources key sources
+        <&> (\a -> (eitherValue, SomeSource (source, newState)) : a)
+    Right _ ->
+      pure $ (eitherValue, SomeSource (source, newState)) : fmap (Left Shadowed ,) sources
+
+
+readNested :: forall a. Config a => Key -> FetchMonad a
+readNested (Key prefix') = do
+  prefix <- state (\(sources, prefix, origins, warnings) ->
+                     (prefix, (sources, prefix <> NonEmpty.toList prefix', origins, warnings)))
+  config <- readConfig
+  modify (\(sources, _, origins, warnings) -> (sources, prefix, origins, warnings))
+  pure config
+
 collectUnused :: NonEmpty SomeSource -> IO [Warning]
 collectUnused sources = do
   forM sources (\(SomeSource (source, sourceState)) ->
     runStateT (leftovers source) sourceState <&> fst)
     <&> fmap (\(Just a) -> Warning $ "Unused Keys " <> T.pack (show a))
+        . filter (\(Just a) -> not (null a))
         . NonEmpty.filter isJust
diff --git a/src/Conftrack/Source.hs b/src/Conftrack/Source.hs
index df6f82c..ecfa20d 100644
--- a/src/Conftrack/Source.hs
+++ b/src/Conftrack/Source.hs
@@ -3,44 +3,21 @@
 {-# LANGUAGE ImpredicativeTypes #-}
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE AllowAmbiguousTypes #-}
-{-# LANGUAGE OverloadedStrings #-}
 
-module Conftrack.Source (ConfigSource(..), SomeSource(..), Trivial(..)) where
+module Conftrack.Source (ConfigSource(..), SomeSource(..)) where
 
-import Conftrack.Value (Key, Value(..), ConfigError(..), Origin)
+import Conftrack.Value (Key, Value(..), ConfigError(..))
 
-import Control.Monad.State (get, modify, StateT (..), MonadState (..))
-import Data.Map.Strict (Map)
-import qualified Data.Map.Strict as M
-import Data.Function ((&))
+import Control.Monad.State (StateT (..))
 import Data.Text (Text)
-import qualified Data.Text as T
 
 
 class ConfigSource s where
-  type ConfigState s
-  fetchValue :: Key ->  s -> StateT (ConfigState s) IO (Either ConfigError (Value, Text))
-  leftovers ::  s -> StateT (ConfigState s) IO (Maybe [Key])
+  type SourceState s
+  fetchValue :: Key -> s -> StateT (SourceState s) IO (Either ConfigError (Value, Text))
+  leftovers :: s -> StateT (SourceState s) IO (Maybe [Key])
 
 data SomeSource = forall source. ConfigSource source
-   => SomeSource (source, ConfigState source)
+   => SomeSource (source, SourceState source)
 
 
-newtype Trivial = Trivial (Map Key Value)
-
-instance ConfigSource Trivial where
-  type ConfigState Trivial = [Key]
-  fetchValue key (Trivial tree) = do
-    case M.lookup key tree of
-      Nothing -> pure $ Left NotPresent
-      Just val -> do
-        modify (key :)
-        pure $ Right (val, "Trivial source with keys "<> T.pack (show (M.keys tree)))
-
-  leftovers (Trivial tree) = do
-    used <- get
-
-    M.keys tree
-     & filter (`notElem` used)
-     & Just
-     & pure
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
diff --git a/src/Conftrack/Source/Trivial.hs b/src/Conftrack/Source/Trivial.hs
new file mode 100644
index 0000000..bb06e77
--- /dev/null
+++ b/src/Conftrack/Source/Trivial.hs
@@ -0,0 +1,41 @@
+{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE QuantifiedConstraints #-}
+{-# LANGUAGE ImpredicativeTypes #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE AllowAmbiguousTypes #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module Conftrack.Source.Trivial where
+
+import Conftrack.Value (Key, Value(..), ConfigError(..), Origin)
+import Conftrack.Source (SomeSource(..), ConfigSource (..))
+
+import Control.Monad.State (get, modify, StateT (..), MonadState (..))
+import Data.Map.Strict (Map)
+import qualified Data.Map.Strict as M
+import Data.Function ((&))
+import qualified Data.Text as T
+
+
+newtype Trivial = Trivial (Map Key Value)
+
+mkTrivialSource :: [(Key, Value)] -> SomeSource
+mkTrivialSource pairs = SomeSource (source, [])
+  where source = Trivial (M.fromList pairs)
+
+instance ConfigSource Trivial where
+  type SourceState Trivial = [Key]
+  fetchValue key (Trivial tree) = do
+    case M.lookup key tree of
+      Nothing -> pure $ Left NotPresent
+      Just val -> do
+        modify (key :)
+        pure $ Right (val, "Trivial source with keys "<> T.pack (show (M.keys tree)))
+
+  leftovers (Trivial tree) = do
+    used <- get
+
+    M.keys tree
+     & filter (`notElem` used)
+     & Just
+     & pure
diff --git a/src/Conftrack/Value.hs b/src/Conftrack/Value.hs
index c5768cc..f934d51 100644
--- a/src/Conftrack/Value.hs
+++ b/src/Conftrack/Value.hs
@@ -3,24 +3,40 @@
 {-# LANGUAGE ImpredicativeTypes #-}
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE AllowAmbiguousTypes #-}
+{-# LANGUAGE StrictData #-}
+{-# LANGUAGE OverloadedStrings #-}
 
-module Conftrack.Value (Value(..), ConfigError(..), Key(..), ConfigValue(..), Origin(..)) where
+module Conftrack.Value (Value(..), ConfigError(..), Key(..), ConfigValue(..), Origin(..), KeyPart, prefixedWith) where
 
 import Data.Text(Text)
-import Data.List.NonEmpty (NonEmpty)
+import qualified Data.Text as T
+import qualified Data.ByteString as BS
+import qualified Data.ByteString.Lazy as LB
+import Data.List.NonEmpty (NonEmpty, prependList)
+import System.OsPath (OsPath, encodeUtf)
+import qualified Data.Text.Encoding as BS
 
 data Value =
-  ConfigText Text
+  ConfigString BS.ByteString
   | ConfigInteger Integer
   | ConfigOther Text Text
+  | ConfigBool Bool
+  | ConfigNull
   deriving Show
 
-newtype Key = Key (NonEmpty Text)
+type KeyPart = Text
+
+newtype Key = Key (NonEmpty KeyPart)
   deriving newtype (Eq, Ord, Show)
 
+prefixedWith :: Key -> [KeyPart] -> Key
+prefixedWith (Key key) prefix = Key (prependList prefix key)
+
 data ConfigError =
-  ParseError
+  ParseError Text
+  | TypeMismatch Text Value
   | NotPresent
+  | Shadowed
   deriving Show
 
 class ConfigValue a where
@@ -30,9 +46,31 @@ data Origin = Origin Key Text
   deriving Show
 
 instance ConfigValue Text where
-  fromConfig (ConfigText a) = Right a
-  fromConfig _ = Left ParseError
+  fromConfig (ConfigString a) = Right (BS.decodeUtf8 a)
+  fromConfig val = Left (TypeMismatch "text" val)
 
 instance ConfigValue Integer where
   fromConfig (ConfigInteger a) = Right a
-  fromConfig _ = Left ParseError
+  fromConfig val = Left (TypeMismatch "integer" val)
+
+instance ConfigValue Bool where
+  fromConfig (ConfigBool b) = Right b
+  fromConfig val = Left (TypeMismatch "bool" val)
+
+instance ConfigValue a => ConfigValue (Maybe a) where
+  fromConfig ConfigNull = Right Nothing
+  fromConfig just = fmap Just (fromConfig just)
+
+instance ConfigValue OsPath where
+  fromConfig (ConfigString text) = case encodeUtf (T.unpack (BS.decodeUtf8 text)) of
+    Right path -> Right path
+    Left err -> Left (ParseError (T.pack $ show err))
+  fromConfig val = Left (TypeMismatch "path" val)
+
+instance ConfigValue LB.ByteString where
+  fromConfig (ConfigString strict) = Right (LB.fromStrict strict)
+  fromConfig val = Left (TypeMismatch "string" val)
+
+instance ConfigValue BS.ByteString where
+  fromConfig (ConfigString string) = Right string
+  fromConfig val = Left (TypeMismatch "string" val)