summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--CHANGELOG.md5
-rw-r--r--LICENSE30
-rw-r--r--conftrack.cabal46
-rw-r--r--src/Conftrack.hs76
-rw-r--r--src/Conftrack/Source.hs46
-rw-r--r--src/Conftrack/Value.hs38
-rw-r--r--test/Main.hs37
7 files changed, 278 insertions, 0 deletions
diff --git a/CHANGELOG.md b/CHANGELOG.md
new file mode 100644
index 0000000..ea3b9d1
--- /dev/null
+++ b/CHANGELOG.md
@@ -0,0 +1,5 @@
+# Revision history for conftrack
+
+## 0.0.1 -- YYYY-mm-dd
+
+* First version. Released on an unsuspecting world.
diff --git a/LICENSE b/LICENSE
new file mode 100644
index 0000000..5a7853f
--- /dev/null
+++ b/LICENSE
@@ -0,0 +1,30 @@
+Copyright (c) 2024, stuebinm
+
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+ * Redistributions of source code must retain the above copyright
+ notice, this list of conditions and the following disclaimer.
+
+ * Redistributions in binary form must reproduce the above
+ copyright notice, this list of conditions and the following
+ disclaimer in the documentation and/or other materials provided
+ with the distribution.
+
+ * Neither the name of stuebinm nor the names of other
+ contributors may be used to endorse or promote products derived
+ from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
diff --git a/conftrack.cabal b/conftrack.cabal
new file mode 100644
index 0000000..256fb7f
--- /dev/null
+++ b/conftrack.cabal
@@ -0,0 +1,46 @@
+cabal-version: 3.4
+name: conftrack
+version: 0.0.1
+-- synopsis:
+-- description:
+license: BSD-3-Clause
+license-file: LICENSE
+author: stuebinm
+maintainer: stuebinm@disroot.org
+-- copyright:
+category: Configuration
+build-type: Simple
+extra-doc-files: CHANGELOG.md
+-- extra-source-files:
+
+common warnings
+ ghc-options: -Wall
+
+library
+ import: warnings
+ exposed-modules: Conftrack
+ , Conftrack.Value
+ , Conftrack.Source
+ -- other-modules:
+ -- other-extensions:
+ build-depends: base ^>=4.17.2.1
+ , text
+ , containers
+ , mtl
+ , transformers
+ hs-source-dirs: src
+ default-language: GHC2021
+
+test-suite conftrack-test
+ import: warnings
+ default-language: GHC2021
+ -- other-modules:
+ -- other-extensions:
+ type: exitcode-stdio-1.0
+ hs-source-dirs: test
+ main-is: Main.hs
+ build-depends:
+ base ^>=4.17.2.1,
+ conftrack,
+ containers,
+ text
diff --git a/src/Conftrack.hs b/src/Conftrack.hs
new file mode 100644
index 0000000..3003115
--- /dev/null
+++ b/src/Conftrack.hs
@@ -0,0 +1,76 @@
+{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE QuantifiedConstraints #-}
+{-# LANGUAGE ImpredicativeTypes #-}
+{-# LANGUAGE OverloadedLists #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE AllowAmbiguousTypes #-}
+{-# LANGUAGE LambdaCase #-}
+
+module Conftrack where
+
+import Conftrack.Value (ConfigError(..), ConfigValue(..), Key, Origin(..))
+import Conftrack.Source (SomeSource (..), ConfigSource (..))
+
+import Prelude hiding (unzip)
+import Control.Monad.State (get, StateT (..), MonadState (..), gets)
+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 Data.Either (isRight)
+import Control.Monad.Trans.Except (ExceptT(..), runExceptT, throwE)
+import Control.Monad.Trans (lift)
+import Data.Text (Text)
+import qualified Data.Text as T
+import Data.Maybe (isJust)
+
+
+class Config a where
+ readConfig :: FetchMonad a
+
+type FetchMonad = StateT (NonEmpty SomeSource, [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, [], [])
+
+ case results of
+ Left a -> pure $ Left a
+ Right (result, (sources, 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
+
+ -- 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))
+
+ let (maybeValues, states) = Data.List.NonEmpty.unzip stuff
+
+ let values = maybeValues <&> \case
+ Right (val, text) -> fromConfig val <&> (\val -> (val, Origin key text))
+ Left e -> Left e
+
+ val <- case fmap (\(Right a) -> a) $ NonEmpty.filter isRight values of
+ [] -> lift $ throwE [NotPresent]
+ val:_ -> pure val
+
+ put (states, snd val : origins, warnings)
+
+ pure (fst val)
+
+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))
+ . NonEmpty.filter isJust
diff --git a/src/Conftrack/Source.hs b/src/Conftrack/Source.hs
new file mode 100644
index 0000000..df6f82c
--- /dev/null
+++ b/src/Conftrack/Source.hs
@@ -0,0 +1,46 @@
+{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE QuantifiedConstraints #-}
+{-# LANGUAGE ImpredicativeTypes #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE AllowAmbiguousTypes #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module Conftrack.Source (ConfigSource(..), SomeSource(..), Trivial(..)) where
+
+import Conftrack.Value (Key, Value(..), ConfigError(..), Origin)
+
+import Control.Monad.State (get, modify, StateT (..), MonadState (..))
+import Data.Map.Strict (Map)
+import qualified Data.Map.Strict as M
+import Data.Function ((&))
+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])
+
+data SomeSource = forall source. ConfigSource source
+ => SomeSource (source, ConfigState 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/Value.hs b/src/Conftrack/Value.hs
new file mode 100644
index 0000000..c5768cc
--- /dev/null
+++ b/src/Conftrack/Value.hs
@@ -0,0 +1,38 @@
+{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE QuantifiedConstraints #-}
+{-# LANGUAGE ImpredicativeTypes #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE AllowAmbiguousTypes #-}
+
+module Conftrack.Value (Value(..), ConfigError(..), Key(..), ConfigValue(..), Origin(..)) where
+
+import Data.Text(Text)
+import Data.List.NonEmpty (NonEmpty)
+
+data Value =
+ ConfigText Text
+ | ConfigInteger Integer
+ | ConfigOther Text Text
+ deriving Show
+
+newtype Key = Key (NonEmpty Text)
+ deriving newtype (Eq, Ord, Show)
+
+data ConfigError =
+ ParseError
+ | NotPresent
+ deriving Show
+
+class ConfigValue a where
+ fromConfig :: Value -> Either ConfigError a
+
+data Origin = Origin Key Text
+ deriving Show
+
+instance ConfigValue Text where
+ fromConfig (ConfigText a) = Right a
+ fromConfig _ = Left ParseError
+
+instance ConfigValue Integer where
+ fromConfig (ConfigInteger a) = Right a
+ fromConfig _ = Left ParseError
diff --git a/test/Main.hs b/test/Main.hs
new file mode 100644
index 0000000..fa6a3fb
--- /dev/null
+++ b/test/Main.hs
@@ -0,0 +1,37 @@
+{-# LANGUAGE OverloadedLists #-}
+{-# LANGUAGE OverloadedStrings #-}
+module Main (main) where
+
+import Conftrack
+import Conftrack.Value
+import Conftrack.Source
+
+import qualified Data.Map.Strict as M
+import Data.Text (Text)
+import Control.Exception (assert)
+
+data TestType = TestType { testFoo :: Text, testBar :: Integer }
+ deriving (Show, Eq)
+
+instance Config TestType 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 ())
+
+ let trivial = Trivial (M.fromList [(Key ["fo"], ConfigText "foo"), (Key ["bar"], ConfigInteger 10)])
+ Left [NotPresent] <- runFetchConfig @TestType [SomeSource (trivial, [])]
+
+ 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
+
+ print config
generated by cgit v1.2.3 (git 2.25.1) at 2024-11-22 04:17:59 +0000