From 4321bb0b5b90c0f92217ccd07a67f17fce44b388 Mon Sep 17 00:00:00 2001 From: stuebinm Date: Thu, 6 Jun 2024 18:26:42 +0200 Subject: nested values, tests, and aeson --- src/Conftrack.hs | 66 +++++++++++++++++++------- src/Conftrack/Source.hs | 37 +++------------ src/Conftrack/Source/Aeson.hs | 101 ++++++++++++++++++++++++++++++++++++++++ src/Conftrack/Source/Trivial.hs | 41 ++++++++++++++++ src/Conftrack/Value.hs | 54 +++++++++++++++++---- 5 files changed, 243 insertions(+), 56 deletions(-) create mode 100644 src/Conftrack/Source/Aeson.hs create mode 100644 src/Conftrack/Source/Trivial.hs (limited to 'src') 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) -- cgit v1.2.3