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 --- .gitignore | 1 + conftrack.cabal | 16 +++++-- 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 +++++++++++++++++---- test/Main.hs | 94 +++++++++++++++++++++++++++++-------- 8 files changed, 331 insertions(+), 79 deletions(-) create mode 100644 .gitignore create mode 100644 src/Conftrack/Source/Aeson.hs create mode 100644 src/Conftrack/Source/Trivial.hs diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..c33954f --- /dev/null +++ b/.gitignore @@ -0,0 +1 @@ +dist-newstyle/ diff --git a/conftrack.cabal b/conftrack.cabal index 256fb7f..1a086e1 100644 --- a/conftrack.cabal +++ b/conftrack.cabal @@ -21,13 +21,20 @@ library exposed-modules: Conftrack , Conftrack.Value , Conftrack.Source + , Conftrack.Source.Trivial + , Conftrack.Source.Aeson -- other-modules: -- other-extensions: - build-depends: base ^>=4.17.2.1 + build-depends: base ^>=4.18 , text + , bytestring , containers , mtl , transformers + , aeson >= 2.0 + , scientific + , filepath >= 1.4.100 + , file-io hs-source-dirs: src default-language: GHC2021 @@ -40,7 +47,10 @@ test-suite conftrack-test hs-source-dirs: test main-is: Main.hs build-depends: - base ^>=4.17.2.1, + base ^>=4.18, conftrack, containers, - text + text, + aeson, + QuickCheck, + quickcheck-instances 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) diff --git a/test/Main.hs b/test/Main.hs index fa6a3fb..99b01d8 100644 --- a/test/Main.hs +++ b/test/Main.hs @@ -1,37 +1,91 @@ {-# LANGUAGE OverloadedLists #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE TemplateHaskell #-} module Main (main) where import Conftrack -import Conftrack.Value -import Conftrack.Source +import Conftrack.Source.Trivial (mkTrivialSource) +import Conftrack.Source.Aeson (mkJsonSource) -import qualified Data.Map.Strict as M import Data.Text (Text) -import Control.Exception (assert) +import qualified Data.Aeson as A +import Test.QuickCheck +import Test.QuickCheck.Monadic +import Test.QuickCheck.Instances () +import System.Exit (exitFailure, exitSuccess) +import qualified Data.Text.Encoding as BS -data TestType = TestType { testFoo :: Text, testBar :: Integer } + +data TestFlat = TestType { testFoo :: Text, testBar :: Integer } deriving (Show, Eq) -instance Config TestType where +instance Arbitrary TestFlat where + arbitrary = TestType <$> arbitrary <*> arbitrary + +data TestNested = TestNested { nestedFoo :: Text, nestedTest :: TestFlat } + deriving (Show, Eq) + +instance Arbitrary TestNested where + arbitrary = TestNested <$> arbitrary <*> arbitrary + +instance Config TestFlat where readConfig = TestType <$> readValue (Key ["foo"]) <*> readValue (Key ["bar"]) -main :: IO () -main = do - let trivial = Trivial (M.fromList [(Key ["foo"], ConfigText "foo"), (Key ["bar"], ConfigInteger 10)]) - Right (config :: TestType, _, _) <- runFetchConfig [SomeSource (trivial, [])] - () <- assert (config == TestType "foo" 10) (pure ()) +instance Config TestNested where + readConfig = TestNested + <$> readValue (Key ["foo"]) + <*> readNested (Key ["nested"]) + +testTypeToTrivial :: TestFlat -> SomeSource +testTypeToTrivial (TestType foo bar) = mkTrivialSource + [(Key ["foo"], ConfigString (BS.encodeUtf8 foo)), (Key ["bar"], ConfigInteger bar)] - let trivial = Trivial (M.fromList [(Key ["fo"], ConfigText "foo"), (Key ["bar"], ConfigInteger 10)]) - Left [NotPresent] <- runFetchConfig @TestType [SomeSource (trivial, [])] +testTypeToJson :: TestFlat -> SomeSource +testTypeToJson (TestType foo bar) = mkJsonSource $ + A.object ["foo" A..= foo, "bar" A..= bar] - let stack1 = Trivial (M.fromList [(Key ["foo"], ConfigText "foo")]) - let stack2 = Trivial (M.fromList [(Key ["bar"], ConfigInteger 10), (Key ["foo"], ConfigText "blub")]) - Right (config :: TestType, origins, warnings) <- runFetchConfig [SomeSource (stack1, []), SomeSource (stack2, [])] - () <- assert (config == TestType "foo" 11) (pure ()) - print origins - print warnings +nestedToTrivial :: TestNested -> SomeSource +nestedToTrivial (TestNested nfoo (TestType foo bar)) = + mkTrivialSource [ (Key ["foo"], ConfigString (BS.encodeUtf8 nfoo)) + , (Key ["nested", "foo"], ConfigString (BS.encodeUtf8 foo)) + , (Key ["nested", "bar"], ConfigInteger bar)] - print config +nestedToJson :: TestNested -> SomeSource +nestedToJson (TestNested nfoo (TestType foo bar)) = + mkJsonSource $ A.object + [ "foo" A..= nfoo + , "nested" A..= A.object + [ "foo" A..= foo + , "bar" A..=bar + ] + ] + +roundtripVia :: (Eq a, Config a) => (a -> SomeSource) -> a -> Property +roundtripVia f val = monadicIO $ do + let trivial = f val + Right (config :: a, _, _) <- run $ runFetchConfig [trivial] + assert (config == val) + +prop_flat :: TestFlat -> Property +prop_flat = roundtripVia testTypeToTrivial + +prop_nested :: TestNested -> Property +prop_nested = roundtripVia nestedToTrivial + +prop_aeson_flat :: TestFlat -> Property +prop_aeson_flat = roundtripVia testTypeToJson + +prop_aeson_nested :: TestNested -> Property +prop_aeson_nested = roundtripVia nestedToJson + +-- see quickcheck docs for why this return is here +return [] +runTests = $quickCheckAll + +main :: IO () +main = do + good <- runTests + if good then exitSuccess else exitFailure -- cgit v1.2.3