summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--.gitignore1
-rw-r--r--conftrack.cabal16
-rw-r--r--src/Conftrack.hs66
-rw-r--r--src/Conftrack/Source.hs37
-rw-r--r--src/Conftrack/Source/Aeson.hs101
-rw-r--r--src/Conftrack/Source/Trivial.hs41
-rw-r--r--src/Conftrack/Value.hs54
-rw-r--r--test/Main.hs94
8 files changed, 331 insertions, 79 deletions
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
generated by cgit v1.2.3 (git 2.25.1) at 2024-11-22 01:44:23 +0000