diff --git a/app/Foliage/Meta.hs b/app/Foliage/Meta.hs index 71d7942..7f9ec5e 100644 --- a/app/Foliage/Meta.hs +++ b/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) diff --git a/foliage.cabal b/foliage.cabal index d817eea..1d0f53e 100644 --- a/foliage.cabal +++ b/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, diff --git a/tests/Tests.hs b/tests/Tests.hs index 20119ea..7f41743 100644 --- a/tests/Tests.hs +++ b/tests/Tests.hs @@ -52,4 +52,9 @@ main = do step "Running checks" doesFileExist "_repo/foliage/packages.json" @? "foliage/packages.json does not exist" + , --- + testCaseSteps "one" $ \step -> + inTemporaryDirectoryWithFixture "tests/fixtures/timecodec" $ do + step "Building repository" + callCommand "foliage build" ] diff --git a/tests/fixtures/timecodec/_sources/pkg-a/2.3.4.5/meta.toml b/tests/fixtures/timecodec/_sources/pkg-a/2.3.4.5/meta.toml new file mode 100644 index 0000000..ce52f3f --- /dev/null +++ b/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" diff --git a/tests/fixtures/timecodec/tarballs b/tests/fixtures/timecodec/tarballs new file mode 120000 index 0000000..73b8fe4 --- /dev/null +++ b/tests/fixtures/timecodec/tarballs @@ -0,0 +1 @@ +../simple/tarballs \ No newline at end of file