diff options
Diffstat (limited to '')
| -rw-r--r-- | CHANGELOG.md | 5 | ||||
| -rw-r--r-- | LICENSE | 30 | ||||
| -rw-r--r-- | conftrack.cabal | 46 | ||||
| -rw-r--r-- | src/Conftrack.hs | 76 | ||||
| -rw-r--r-- | src/Conftrack/Source.hs | 46 | ||||
| -rw-r--r-- | src/Conftrack/Value.hs | 38 | ||||
| -rw-r--r-- | test/Main.hs | 37 |
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. @@ -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 |