handle partially present optional nestings

these would previously silently fail and simply produce a Nothing if
only some (but not all) of the nested keys were present. This is not
reasonable behaviour that anyone would expect; whenever a nested key
is present, absence of another should be an error (the same goes for
any other errors in that key's definition).

2 files changed, 65 insertions, 17 deletions

diff --git a/src/Conftrack.hs b/src/Conftrack.hs
index b272e3f..e1652b1 100644
--- a/src/Conftrack.hs
+++ b/src/Conftrack.hs
@@ -162,16 +162,35 @@ readNested (Key prefix') = Fetch $ \s1 -> do
   (config, s2) <- nested (s1 { fetcherPrefix = fetcherPrefix s1 <> NonEmpty.toList prefix' })
   pure (config, s2 { fetcherPrefix = fetcherPrefix s1 })
 
-readNestedOptional :: forall a. Config a => Key -> Fetch (Maybe a)
+readNestedOptional :: forall a. (Show a, Config a) => Key -> Fetch (Maybe a)
 readNestedOptional (Key prefix) = Fetch $ \s1 -> do
   let (Fetch nested) = readConfig @a
-  (config, s2) <- nested (s1 { fetcherPrefix = fetcherPrefix s1 <> NonEmpty.toList prefix })
-
-  if null (fetcherErrors s2)
-    then pure (Just config, s2 { fetcherPrefix = fetcherPrefix s1 })
-    -- TODO: resetting errors like this makes configKeysOf less useful. Perhaps move nested errors to warnings?
-    else pure (Nothing, s2 { fetcherPrefix = fetcherPrefix s1
-                           , fetcherErrors = fetcherErrors s1 })
+  let nestedState = s1
+       { fetcherPrefix = fetcherPrefix s1 <> NonEmpty.toList prefix
+       , fetcherOrigins = [] -- pass an empy list so we can check if at least one element was present
+       , fetcherErrors = []
+       }
+
+  (config, s2) <- nested nestedState
+
+  let origins = fetcherOrigins s1 <> fetcherOrigins s2
+
+  -- none of the keys present? then return Nothing & produce no errors
+  if length (fetcherOrigins s2) == length (filter (\case {NotPresent _ -> True; _ -> False}) (fetcherErrors s2))
+     && length (fetcherOrigins s2) == length (fetcherErrors s2) then
+    pure (Nothing, s2 { fetcherPrefix = fetcherPrefix s1, fetcherErrors = fetcherErrors s1, fetcherOrigins = fetcherOrigins s1 })
+  else
+    -- any other errors? if so, forward those
+    if not (null (fetcherErrors s2)) then
+      pure (Nothing, s2 { fetcherPrefix = fetcherPrefix s1
+                        , fetcherOrigins = origins
+                        , fetcherErrors = fetcherErrors s2 <> fetcherErrors s1
+                        })
+    else
+      -- success!
+      pure (Just config, s2 { fetcherPrefix = fetcherPrefix s1
+                            , fetcherOrigins = origins
+                            })
 
 
 collectUnused :: [SomeSource] -> IO [Warning]
diff --git a/test/Main.hs b/test/Main.hs
index 2b96ac9..769f0d7 100644
--- a/test/Main.hs
+++ b/test/Main.hs
@@ -18,22 +18,26 @@ import Test.QuickCheck.Instances ()
 import System.Exit (exitFailure, exitSuccess)
 import qualified Data.Text.Encoding as BS
 import Data.List ((\\))
+import Data.Maybe (isNothing)
 
 
-data TestFlat = TestType { testFoo :: Text, testBar :: Integer }
+data TestFlat = TestFlat { testFoo :: Text, testBar :: Integer }
   deriving (Show, Eq)
 
 instance Arbitrary TestFlat where
-  arbitrary = TestType <$> arbitrary <*> arbitrary
+  arbitrary = TestFlat <$> arbitrary <*> arbitrary
 
 data TestNested = TestNested { nestedFoo :: Text, nestedTest :: TestFlat }
   deriving (Show, Eq)
 
+data TestOptionalNested = TestOptionalNested { opNestedFoo :: Text, opNestedTest :: Maybe TestFlat }
+  deriving (Show, Eq)
+
 instance Arbitrary TestNested where
   arbitrary = TestNested <$> arbitrary <*> arbitrary
 
 instance Config TestFlat where
-  readConfig = TestType
+  readConfig = TestFlat
     <$> readRequiredValue (Key ["foo"])
     <*> readRequiredValue (Key ["bar"])
 
@@ -43,22 +47,28 @@ instance Config TestNested where
     b <- readNested (Key ["nested"])
     pure (TestNested a b)
 
+instance Config TestOptionalNested where
+  readConfig = do
+    a <- readRequiredValue (Key ["foo"])
+    b <- readNestedOptional (Key ["nested"])
+    pure (TestOptionalNested a b)
+
 testTypeToTrivial :: TestFlat -> SomeSource
-testTypeToTrivial (TestType foo bar) = mkTrivialSource
+testTypeToTrivial (TestFlat foo bar) = mkTrivialSource
   [(Key ["foo"], ConfigString (BS.encodeUtf8 foo)), (Key ["bar"], ConfigInteger bar)]
 
-testTypeToJson :: TestFlat -> SomeSource
-testTypeToJson (TestType foo bar) = mkJsonSource $
+testTypeToJson :: TestFlat -> A.Value
+testTypeToJson (TestFlat foo bar) =
   A.object ["foo" A..= foo, "bar" A..= bar]
 
 nestedToTrivial :: TestNested -> SomeSource
-nestedToTrivial (TestNested nfoo (TestType foo bar)) =
+nestedToTrivial (TestNested nfoo (TestFlat foo bar)) =
   mkTrivialSource [ (Key ["foo"], ConfigString (BS.encodeUtf8 nfoo))
                   , (Key ["nested", "foo"], ConfigString (BS.encodeUtf8 foo))
                   , (Key ["nested", "bar"], ConfigInteger bar)]
 
 nestedToJson :: TestNested -> SomeSource
-nestedToJson (TestNested nfoo (TestType foo bar)) =
+nestedToJson (TestNested nfoo (TestFlat foo bar)) =
   mkJsonSource $ A.object
     [ "foo" A..= nfoo
     , "nested" A..= A.object
@@ -80,7 +90,7 @@ prop_nested :: TestNested -> Property
 prop_nested = roundtripVia nestedToTrivial
 
 prop_aeson_flat :: TestFlat -> Property
-prop_aeson_flat = roundtripVia testTypeToJson
+prop_aeson_flat = roundtripVia (mkJsonSource . testTypeToJson)
 
 prop_aeson_nested :: TestNested -> Property
 prop_aeson_nested = roundtripVia nestedToJson
@@ -95,6 +105,25 @@ prop_nested_keys = monadicIO $ do
   keys <- run $ configKeysOf @TestNested
   assert (null (keys \\ [ [key|foo|], [key|nested.bar|], [key|nested.foo|] ]))
 
+prop_nested_optional_nothing :: Property
+prop_nested_optional_nothing = monadicIO $ do
+  Right (conf, _, warnings) <- run $ runFetchConfig [ mkJsonSource (A.object ["foo" A..= ("bar" :: Text)]) ]
+  assert (null warnings)
+  assert (isNothing (opNestedTest conf))
+
+prop_nested_optional_partial :: Property
+prop_nested_optional_partial = monadicIO $ do
+  Left errors <- run $ runFetchConfig @TestOptionalNested [ mkJsonSource (A.object ["foo" A..= ("bar" :: Text), "nested" A..= A.object [ "foo" A..= ("bar" :: Text) ]]) ]
+  assert (not (null errors))
+
+prop_nested_optional_just :: TestFlat -> Property
+prop_nested_optional_just nested = monadicIO $ do
+  Right (conf, _, warnings) <- run $ runFetchConfig [
+    mkJsonSource (A.object ["foo" A..= ("bar" :: Text), "nested" A..= testTypeToJson nested ])
+    ]
+  assert (null warnings)
+  assert (opNestedTest conf == Just nested)
+
 -- see quickcheck docs for why this return is here
 return []
 runTests :: IO Bool