add yaml source

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)