diff options
| -rw-r--r-- | conftrack.cabal | 2 | ||||
| -rw-r--r-- | src/Conftrack.hs | 2 | ||||
| -rw-r--r-- | src/Conftrack/Source/Trivial.hs | 2 | ||||
| -rw-r--r-- | src/Conftrack/Source/Yaml.hs | 42 | ||||
| -rw-r--r-- | src/Conftrack/Value.hs | 6 |
5 files changed, 51 insertions, 3 deletions
diff --git a/conftrack.cabal b/conftrack.cabal index 1a086e1..bf564f8 100644 --- a/conftrack.cabal +++ b/conftrack.cabal @@ -23,6 +23,7 @@ library , Conftrack.Source , Conftrack.Source.Trivial , Conftrack.Source.Aeson + , Conftrack.Source.Yaml -- other-modules: -- other-extensions: build-depends: base ^>=4.18 @@ -32,6 +33,7 @@ library , mtl , transformers , aeson >= 2.0 + , yaml , scientific , filepath >= 1.4.100 , file-io diff --git a/src/Conftrack.hs b/src/Conftrack.hs index 0f40048..d6e68e2 100644 --- a/src/Conftrack.hs +++ b/src/Conftrack.hs @@ -69,7 +69,7 @@ readValue bareKey = do Left e -> Left e val <- case fmap (\(Right a) -> a) $ NonEmpty.filter isRight values of - [] -> lift $ throwE [NotPresent] + [] -> lift $ throwE [NotPresent key] val:_ -> pure val put (states, prefix, snd val : origins, warnings) diff --git a/src/Conftrack/Source/Trivial.hs b/src/Conftrack/Source/Trivial.hs index bb06e77..ff22ee9 100644 --- a/src/Conftrack/Source/Trivial.hs +++ b/src/Conftrack/Source/Trivial.hs @@ -27,7 +27,7 @@ instance ConfigSource Trivial where type SourceState Trivial = [Key] fetchValue key (Trivial tree) = do case M.lookup key tree of - Nothing -> pure $ Left NotPresent + Nothing -> pure $ Left (NotPresent key) Just val -> do modify (key :) pure $ Right (val, "Trivial source with keys "<> T.pack (show (M.keys tree))) diff --git a/src/Conftrack/Source/Yaml.hs b/src/Conftrack/Source/Yaml.hs new file mode 100644 index 0000000..6adc798 --- /dev/null +++ b/src/Conftrack/Source/Yaml.hs @@ -0,0 +1,42 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE QuantifiedConstraints #-} +{-# LANGUAGE ImpredicativeTypes #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE UndecidableInstances #-} + +module Conftrack.Source.Yaml (YamlSource(..), mkYamlSource, mkYamlSourceWith, mkYamlFileSource) where + +import Conftrack.Source (SomeSource(..), ConfigSource (..)) +import Conftrack.Source.Aeson + +import Prelude hiding (readFile) +import qualified Data.Aeson as A +import qualified Data.Yaml as Y +import Data.Text (Text) +import qualified Data.Aeson.Text as A +import qualified Data.Text.Lazy as LT +import Data.Functor ((<&>)) +import System.OsPath (OsPath) +import qualified System.OsPath as OS +import System.File.OsPath (readFile) +import qualified Data.ByteString as BS + +newtype YamlSource = YamlSource JsonSource + deriving newtype (ConfigSource, Show) + +mkYamlSource :: A.Value -> SomeSource +mkYamlSource value = mkYamlSourceWith ("Yaml string " <> LT.toStrict (A.encodeToLazyText value)) value + +mkYamlSourceWith :: Text -> A.Value -> SomeSource +mkYamlSourceWith description value = SomeSource (source, []) + where source = YamlSource (JsonSource value description) + +mkYamlFileSource :: OsPath -> IO (Either Y.ParseException SomeSource) +mkYamlFileSource path = do + bytes <- readFile path <&> BS.toStrict + pathAsText <- OS.decodeUtf path <&> LT.toStrict . LT.pack + pure $ Y.decodeEither' bytes + <&> mkYamlSourceWith ("YAML file " <> pathAsText) + diff --git a/src/Conftrack/Value.hs b/src/Conftrack/Value.hs index f934d51..5c8d949 100644 --- a/src/Conftrack/Value.hs +++ b/src/Conftrack/Value.hs @@ -35,7 +35,7 @@ prefixedWith (Key key) prefix = Key (prependList prefix key) data ConfigError = ParseError Text | TypeMismatch Text Value - | NotPresent + | NotPresent Key | Shadowed deriving Show @@ -53,6 +53,10 @@ instance ConfigValue Integer where fromConfig (ConfigInteger a) = Right a fromConfig val = Left (TypeMismatch "integer" val) +instance ConfigValue Int where + fromConfig (ConfigInteger a) = Right (fromInteger a) + fromConfig val = Left (TypeMismatch "integer" val) + instance ConfigValue Bool where fromConfig (ConfigBool b) = Right b fromConfig val = Left (TypeMismatch "bool" val) |