Fix #11: reject quoted timestamps instead of silently parsing as null

Author: andreabedini

app/Foliage/Meta.hs

@@ -32,6 +32,8 @@ where
 
 import Control.Applicative ((<|>))
 import Control.Monad (void)
+import Control.Monad.State (modify)
+import Data.HashMap.Strict qualified as HashMap
 import Data.List (sortOn)
 import Data.Maybe (fromMaybe)
 import Data.Ord (Down (Down))
@@ -138,7 +140,7 @@ data PackageVersionSpec = PackageVersionSpec
 sourceMetaCodec :: TomlCodec PackageVersionSpec
 sourceMetaCodec =
   PackageVersionSpec
-    <$> Toml.dioptional (timeCodec "timestamp")
+    <$> optionalTimeCodec "timestamp"
       .= packageVersionTimestamp
     <*> packageSourceCodec
       .= packageVersionSource
@@ -200,3 +202,38 @@ withDefault :: (Eq a) => a -> TomlCodec a -> TomlCodec a
 withDefault d c = (fromMaybe d <$> Toml.dioptional c) .= f
  where
   f a = if a == d then Nothing else Just a
+
+{- | Codec for a maybe-missing time value.
+
+Note this is different from dioptional timeCodec. With dioptional timeCodec,
+if the user writes
+    timestamp = '2022-08-22T10:38:45Z'
+rather than
+    timestamp = 2022-08-22T10:38:45Z
+the timestamp will parse as Nothing because it won't match the zoneTime
+type and it is not an error because it is optional.
+
+We use a handrolled version of match (matchMaybe) to make it work.
+
+See discussions at
+ 1. https://github.com/input-output-hk/foliage/issues/11
+ 2. https://github.com/input-output-hk/foliage/pull/57
+ 3. https://github.com/kowainik/tomland/issues/223
+-}
+optionalTimeCodec :: Toml.Key -> TomlCodec (Maybe UTCTime)
+optionalTimeCodec key =
+  Toml.dimap (fmap $ utcToZonedTime utc) (fmap zonedTimeToUTC) $ matchMaybe Toml._ZonedTime key
+
+matchMaybe :: forall a. Toml.TomlBiMap a Toml.AnyValue -> Toml.Key -> TomlCodec (Maybe a)
+matchMaybe bimap key = Toml.Codec input output
+ where
+  input :: Toml.TomlEnv (Maybe a)
+  input toml = case HashMap.lookup key (Toml.tomlPairs toml) of
+    Nothing -> pure Nothing
+    Just anyVal -> pure <$> Toml.whenLeftBiMapError key (Toml.backward bimap anyVal) pure
+
+  output :: Maybe a -> Toml.TomlState (Maybe a)
+  output Nothing = pure Nothing
+  output (Just a) = do
+    anyVal <- Toml.eitherToTomlState $ Toml.forward bimap a
+    Just a <$ modify (Toml.insertKeyAnyVal key anyVal)

foliage.cabal

@@ -57,6 +57,7 @@ executable foliage
         ed25519              >=0.0.5.0    && <0.1,
         filepath             >=1.4.2.1    && <1.6,
         hackage-security     >=0.6.2.1    && <0.7,
+        mtl                  >=2.2        && <2.4,
         network-uri          >=2.6.4.1    && <2.8,
         optparse-applicative >=0.17.0.0   && <0.20,
         shake                >=0.19.6     && <0.20,
@@ -66,6 +67,7 @@ executable foliage
         time                 >=1.9.3      && <1.16,
         time-compat          >=1.9.6.1    && <1.10,
         tomland              >=1.3.3.1    && <1.4,
+        unordered-containers >=0.2        && <0.3,
         vector               >=0.13.0.0   && <0.14,
         with-utf8            >=1.0.2.3    && <1.2,
         zlib                 >=0.6.2.3    && <0.8,

tests/Tests.hs

@@ -1,6 +1,7 @@
 {-# LANGUAGE LambdaCase #-}
 
 import Codec.Archive.Tar.Entry (GenEntry (entryContent, entryTime), GenEntryContent (NormalFile))
+import Control.Exception (SomeException, try)
 import Data.ByteString.Lazy qualified as BL
 import Foliage.Tests.Tar
 import Foliage.Tests.Utils
@@ -68,4 +69,12 @@ main = do
 
             step "Running checks"
             doesFileExist "_repo/foliage/packages.json" @? "foliage/packages.json does not exist"
+      , ---
+        testCaseSteps "rejects quoted timestamp in meta.toml" $ \step ->
+          inTemporaryDirectoryWithFixture "tests/fixtures/bad-timestamp" $ do
+            step "Building repository (expecting failure)"
+            result <- try @SomeException (callCommand "foliage build --no-signatures")
+            case result of
+              Left _ -> pure ()
+              Right _ -> assertFailure "foliage build should have failed on a quoted timestamp"
       ]

tests/fixtures/bad-timestamp/_sources/pkg-a/2.3.4.5/meta.toml

@@ -0,0 +1,2 @@
+url = "file:tarballs/pkg-a-2.3.4.5.tar.gz"
+timestamp = '2022-03-29T06:19:50+00:00'

tests/fixtures/bad-timestamp/tarballs

@@ -0,0 +1 @@
+../simple/tarballs