Fix input-output-hk#11: improve parsing

co-authored by @andreabedini

app/Foliage/Meta.hs

@@ -33,6 +33,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))
@@ -141,7 +143,7 @@ data PackageVersionSpec = PackageVersionSpec
 sourceMetaCodec :: TomlCodec PackageVersionSpec
 sourceMetaCodec =
   PackageVersionSpec
-    <$> Toml.dioptional (timeCodec "timestamp")
+    <$> optionalTimeCodec "timestamp"
       .= packageVersionTimestamp
     <*> packageSourceCodec
       .= packageVersionSource
@@ -204,3 +206,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 then
+    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.5,
         hackage-security     >=0.6.2.1    && <0.7,
+        mtl,
         network-uri          >=2.6.4.1    && <2.7,
         optparse-applicative >=0.17.0.0   && <0.18,
         shake                >=0.19.6     && <0.20,
@@ -66,6 +67,7 @@ executable foliage
         time                 >=1.9.3      && <1.13,
         time-compat          >=1.9.6.1    && <1.10,
         tomland              >=1.3.3.1    && <1.4,
+        unordered-containers,
         vector               >=0.13.0.0   && <0.14,
         with-utf8            >=1.0.2.3    && <1.1,
         zlib                 >=0.6.2.3    && <0.7,

tests/Tests.hs

@@ -52,4 +52,9 @@ main = do
 
             step "Running checks"
             doesFileExist "_repo/foliage/packages.json" @? "foliage/packages.json does not exist"
+      , ---
+        testCaseSteps "timecodec" $ \step ->
+          inTemporaryDirectoryWithFixture "tests/fixtures/timecodec" $ do
+            step "Building repository"
+            callCommand "foliage build"
       ]

tests/fixtures/timecodec/_sources/pkg-a/2.3.4.5/meta.toml

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

tests/fixtures/timecodec/tarballs

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