Fix #18: add support for deprecated-versions

Co-authored-by: Andrea Bedini <andrea@andreabedini.com>
2024-09-11 20:27:09 +03:00 · 2023-04-20 15:25:00 +02:00 · 2023-04-20 15:25:00 +02:00 · 7da6927247
commit 7da6927247
parent 586b692c5c
7 changed files with 168 additions and 34 deletions
--- a/app/Foliage/CmdBuild.hs
+++ b/app/Foliage/CmdBuild.hs
@ -1,4 +1,5 @@
 {-# LANGUAGE DerivingVia #-}
+{-# LANGUAGE ImportQualifiedPost #-}
 {-# LANGUAGE OverloadedStrings #-}

 module Foliage.CmdBuild (cmdBuild) where
@ -8,16 +9,20 @@ import Codec.Archive.Tar.Entry qualified as Tar
 import Codec.Compression.GZip qualified as GZip
 import Control.Monad (unless, void, when)
 import Data.Aeson qualified as Aeson
-import Data.ByteString qualified as BS
-import Data.ByteString.Lazy qualified as BL
+import Data.Bifunctor (second)
+import Data.ByteString.Char8 qualified as BS
+import Data.ByteString.Lazy.Char8 qualified as BL
 import Data.List (sortOn)
+import Data.List.NonEmpty qualified as NE
 import Data.Maybe (fromMaybe)
 import Data.Text qualified as T
+import Data.Time.Clock.POSIX (posixSecondsToUTCTime)
 import Data.Traversable (for)
 import Development.Shake
 import Development.Shake.FilePath
 import Distribution.Package
 import Distribution.Pretty (prettyShow)
+import Distribution.Version
 import Foliage.HackageSecurity hiding (ToJSON, toJSON)
 import Foliage.Meta
 import Foliage.Meta.Aeson ()
@ -35,7 +40,7 @@ import System.Directory (createDirectoryIfMissing)

 cmdBuild :: BuildOptions -> IO ()
 cmdBuild buildOptions = do
-  outputDirRoot <- liftIO $ makeAbsolute (fromFilePath (buildOptsOutputDir buildOptions))
+  outputDirRoot <- makeAbsolute (fromFilePath (buildOptsOutputDir buildOptions))
  shake opts $
    do
      addFetchRemoteAssetRule cacheDir
@ -72,7 +77,7 @@ buildAction
          liftIO $ createKeys keysPath
        return $ \name -> readKeysAt (keysPath </> name)
      SignOptsDon'tSign ->
-        return $ const $ return []
+        return $ const $ pure []

    expiryTime <-
      for mExpireSignaturesOn $ \expireSignaturesOn -> do
@ -101,9 +106,10 @@ buildAction

    void $ forP packageVersions $ makePackageVersionPage outputDir

-    void $ forP packageVersions $ \PreparedPackageVersion {pkgId, cabalFilePath} -> do
-      let PackageIdentifier {pkgName, pkgVersion} = pkgId
-      copyFileChanged cabalFilePath (outputDir </> "index" </> prettyShow pkgName </> prettyShow pkgVersion </> prettyShow pkgName <.> "cabal")
+    void $
+      forP packageVersions $ \PreparedPackageVersion {pkgId, cabalFilePath} -> do
+        let PackageIdentifier {pkgName, pkgVersion} = pkgId
+        copyFileChanged cabalFilePath (outputDir </> "index" </> prettyShow pkgName </> prettyShow pkgVersion </> prettyShow pkgName <.> "cabal")

    cabalEntries <-
      foldMap
@ -133,7 +139,9 @@ buildAction
            (IndexPkgMetadata pkgId)
            (fromMaybe currentTime pkgTimestamp)

-    let tarContents = Tar.write $ sortOn Tar.entryTime (cabalEntries ++ metadataEntries)
+    let extraEntries = getExtraEntries packageVersions
+
+    let tarContents = Tar.write $ sortOn Tar.entryTime (cabalEntries ++ metadataEntries ++ extraEntries)
    traced "Writing index" $ do
      BL.writeFile (anchorPath outputDirRoot repoLayoutIndexTar) tarContents
      BL.writeFile (anchorPath outputDirRoot repoLayoutIndexTarGz) $ GZip.compress tarContents
@ -290,6 +298,39 @@ prepareIndexPkgMetadata expiryTime PreparedPackageVersion {pkgId, sdistPath} = d
        targetsDelegations = Nothing
      }

+-- Currently `extraEntries` are only used for encoding `prefered-versions`.
+getExtraEntries :: [PreparedPackageVersion] -> [Tar.Entry]
+getExtraEntries packageVersions =
+  let groupedPackageVersions = NE.groupWith (pkgName . pkgId) packageVersions
+      generateEntriesForGroup packageGroup = map createTarEntry effectiveRanges
+        where
+          -- Get the package name of the current group.
+          pn = pkgName $ pkgId $ NE.head packageGroup
+          -- Collect and sort the deprecation changes for the package group.
+          deprecationChanges = sortOn fst $ foldMap versionDeprecationChanges packageGroup
+          -- Calculate (by applying them chronologically) the effective `VersionRange` for the package group.
+          effectiveRanges = NE.tail $ NE.scanl applyChangeToRange (posixSecondsToUTCTime 0, anyVersion) deprecationChanges
+          -- Create a `Tar.Entry` for the package group, its computed `VersionRange` and a timestamp.
+          createTarEntry (ts, effectiveRange) = mkTarEntry (BL.pack $ show effectiveRange) (IndexPkgPrefs pn) ts
+   in foldMap generateEntriesForGroup groupedPackageVersions
+
+-- Extract deprecation changes for a given `PreparedPackageVersion`.
+versionDeprecationChanges :: PreparedPackageVersion -> [(UTCTime, VersionRange -> VersionRange)]
+versionDeprecationChanges PreparedPackageVersion {pkgId = PackageIdentifier {pkgVersion}, pkgVersionDeprecationChanges} = map (second $ applyDeprecation pkgVersion) pkgVersionDeprecationChanges
+
+-- Apply a given change (`VersionRange -> VersionRange`) to a `VersionRange` and
+-- return the simplified the result with a new timestamp.
+applyChangeToRange :: (UTCTime, VersionRange) -> (UTCTime, VersionRange -> VersionRange) -> (UTCTime, VersionRange)
+applyChangeToRange (_, range) (ts, change) = (ts, simplifyVersionRange $ change range)
+
+-- Exclude (or include) to the `VersionRange` of prefered versions, a given
+-- `Version`, if the `Version` is (or not) tagged as "deprecated".
+applyDeprecation :: Version -> Bool -> VersionRange -> VersionRange
+applyDeprecation pkgVersion deprecated =
+  if deprecated
+    then intersectVersionRanges (notThisVersion pkgVersion)
+    else unionVersionRanges (thisVersion pkgVersion)
+
 mkTarEntry :: BL.ByteString -> IndexFile dec -> UTCTime -> Tar.Entry
 mkTarEntry contents indexFile timestamp =
  (Tar.fileEntry tarPath contents)
--- a/app/Foliage/Meta.hs
+++ b/app/Foliage/Meta.hs
@ -16,6 +16,7 @@ module Foliage.Meta
    packageVersionTimestamp,
    packageVersionSource,
    packageVersionRevisions,
+    packageVersionDeprecations,
    packageVersionForce,
    PackageVersionSpec (PackageVersionSpec),
    readPackageVersionSpec,
@ -23,6 +24,9 @@ module Foliage.Meta
    RevisionSpec (RevisionSpec),
    revisionTimestamp,
    revisionNumber,
+    DeprecationSpec (DeprecationSpec),
+    deprecationTimestamp,
+    deprecationIsDeprecated,
    PackageVersionSource,
    pattern TarballSource,
    pattern GitHubSource,
@ -174,6 +178,8 @@ data PackageVersionSpec = PackageVersionSpec
    packageVersionSource :: PackageVersionSource,
    -- | revisions
    packageVersionRevisions :: [RevisionSpec],
+    -- | deprecations
+    packageVersionDeprecations :: [DeprecationSpec],
    -- | force version
    packageVersionForce :: Bool
  }
@ -189,6 +195,8 @@ sourceMetaCodec =
    .= packageVersionSource
    <*> Toml.list revisionMetaCodec "revisions"
    .= packageVersionRevisions
+    <*> Toml.list deprecationMetaCodec "deprecation"
+    .= packageVersionDeprecations
    <*> withDefault False (Toml.bool "force-version")
    .= packageVersionForce

@ -202,7 +210,7 @@ data RevisionSpec = RevisionSpec
  { revisionTimestamp :: UTCTime,
    revisionNumber :: Int
  }
-  deriving (Show, Eq, Generic)
+  deriving (Show, Eq, Generic, Ord)
  deriving anyclass (Binary, Hashable, NFData)

 revisionMetaCodec :: TomlCodec RevisionSpec
@ -213,6 +221,21 @@ revisionMetaCodec =
    <*> Toml.int "number"
    .= revisionNumber

+data DeprecationSpec = DeprecationSpec
+  { deprecationTimestamp :: UTCTime,
+    deprecationIsDeprecated :: Bool
+  }
+  deriving (Show, Eq, Generic, Ord)
+  deriving anyclass (Binary, Hashable, NFData)
+
+deprecationMetaCodec :: TomlCodec DeprecationSpec
+deprecationMetaCodec =
+  DeprecationSpec
+    <$> timeCodec "timestamp"
+    .= deprecationTimestamp
+    <*> withDefault True (Toml.bool "deprecated")
+    .= deprecationIsDeprecated
+
 timeCodec :: Toml.Key -> TomlCodec UTCTime
 timeCodec key = Toml.dimap (utcToZonedTime utc) zonedTimeToUTC $ Toml.zonedTime key

--- a/app/Foliage/Meta/Aeson.hs
+++ b/app/Foliage/Meta/Aeson.hs
@ -18,6 +18,8 @@ deriving via MyAesonEncoding PackageMetaEntry instance ToJSON PackageMetaEntry

 deriving via MyAesonEncoding RevisionSpec instance ToJSON RevisionSpec

+deriving via MyAesonEncoding DeprecationSpec instance ToJSON DeprecationSpec
+
 deriving via MyAesonEncoding PackageVersionSpec instance ToJSON PackageVersionSpec

 deriving via Text instance ToJSON GitHubRepo
--- a/app/Foliage/Pages.hs
+++ b/app/Foliage/Pages.hs
@ -95,7 +95,8 @@ data AllPackageVersionsPageEntry
      { allPackageVersionsPageEntryPkgId :: PackageIdentifier,
        allPackageVersionsPageEntryTimestamp :: UTCTime,
        allPackageVersionsPageEntryTimestampPosix :: POSIXTime,
-        allPackageVersionsPageEntrySource :: PackageVersionSource
+        allPackageVersionsPageEntrySource :: PackageVersionSource,
+        allPackageVersionsPageEntryDeprecated :: Bool
      }
  | AllPackageVersionsPageEntryRevision
      { allPackageVersionsPageEntryPkgId :: PackageIdentifier,
@ -116,13 +117,16 @@ makeAllPackageVersionsPage currentTime outputDir packageVersions =
    entries =
      -- collect all cabal file revisions including the original cabal file
      foldMap
-        ( \PreparedPackageVersion {pkgId, pkgTimestamp, pkgVersionSource, cabalFileRevisions} ->
+        ( \PreparedPackageVersion {pkgId, pkgTimestamp, pkgVersionSource, pkgVersionIsDeprecated, cabalFileRevisions} ->
            -- original cabal file
            AllPackageVersionsPageEntryPackage
              { allPackageVersionsPageEntryPkgId = pkgId,
                allPackageVersionsPageEntryTimestamp = fromMaybe currentTime pkgTimestamp,
                allPackageVersionsPageEntryTimestampPosix = utcTimeToPOSIXSeconds (fromMaybe currentTime pkgTimestamp),
-                allPackageVersionsPageEntrySource = pkgVersionSource
+                allPackageVersionsPageEntrySource = pkgVersionSource,
+                -- FIXME: this weirdly seems to not work (display a `Deprecated` badge on all package version page) ...
+                -- don't understand yet why! :/
+                allPackageVersionsPageEntryDeprecated = pkgVersionIsDeprecated
              }
              -- list of revisions
              : [ AllPackageVersionsPageEntryRevision
@ -138,7 +142,7 @@ makeAllPackageVersionsPage currentTime outputDir packageVersions =
        & sortOn (Down . allPackageVersionsPageEntryTimestamp)

 makePackageVersionPage :: FilePath -> PreparedPackageVersion -> Action ()
-makePackageVersionPage outputDir PreparedPackageVersion {pkgId, pkgTimestamp, pkgVersionSource, pkgDesc, cabalFileRevisions} = do
+makePackageVersionPage outputDir PreparedPackageVersion {pkgId, pkgTimestamp, pkgVersionSource, pkgDesc, cabalFileRevisions, pkgVersionIsDeprecated} = do
  traced ("webpages / package / " ++ prettyShow pkgId) $ do
    IO.createDirectoryIfMissing True (outputDir </> "package" </> prettyShow pkgId)
    TL.writeFile (outputDir </> "package" </> prettyShow pkgId </> "index.html") $
@ -147,7 +151,8 @@ makePackageVersionPage outputDir PreparedPackageVersion {pkgId, pkgTimestamp, pk
          [ "pkgVersionSource" .= pkgVersionSource,
            "cabalFileRevisions" .= map fst cabalFileRevisions,
            "pkgDesc" .= jsonGenericPackageDescription pkgDesc,
-            "pkgTimestamp" .= pkgTimestamp
+            "pkgTimestamp" .= pkgTimestamp,
+            "pkgVersionDeprecated" .= pkgVersionIsDeprecated
          ]

 indexPageTemplate :: Template
--- a/app/Foliage/PreparePackageVersion.hs
+++ b/app/Foliage/PreparePackageVersion.hs
@ -7,6 +7,8 @@ module Foliage.PreparePackageVersion
        pkgTimestamp,
        pkgVersionSource,
        pkgVersionForce,
+        pkgVersionIsDeprecated,
+        pkgVersionDeprecationChanges,
        pkgDesc,
        sdistPath,
        cabalFilePath,
@ -20,7 +22,8 @@ where

 import Control.Monad (unless)
 import Data.List (sortOn)
-import Data.Ord (Down (Down))
+import Data.Maybe (listToMaybe)
+import Data.Ord (Down (..))
 import Development.Shake (Action)
 import Development.Shake.FilePath (joinPath, splitDirectories)
 import Distribution.Client.Compat.Prelude (fromMaybe, prettyShow)
@ -28,17 +31,21 @@ import Distribution.Parsec (simpleParsec)
 import Distribution.Types.GenericPackageDescription (GenericPackageDescription (packageDescription))
 import Distribution.Types.PackageDescription (PackageDescription (package))
 import Distribution.Types.PackageId
-import Foliage.Meta (PackageVersionSource, PackageVersionSpec (..), RevisionSpec (..), UTCTime, latestRevisionNumber)
+import Foliage.Meta (DeprecationSpec (..), PackageVersionSource, PackageVersionSpec (..), RevisionSpec (..), UTCTime, latestRevisionNumber)
 import Foliage.PrepareSdist (prepareSdist)
 import Foliage.PrepareSource (prepareSource)
 import Foliage.Shake (readGenericPackageDescription', readPackageVersionSpec')
 import System.FilePath (takeBaseName, takeFileName, (<.>), (</>))

+-- TODO: ensure that `pkgVersionDeprecationChanges` and `cabalFileRevisions` are
+-- sorted by timestamp, with https://hackage.haskell.org/package/sorted-list ?!
 data PreparedPackageVersion = PreparedPackageVersion
  { pkgId :: PackageId,
    pkgTimestamp :: Maybe UTCTime,
    pkgVersionSource :: PackageVersionSource,
    pkgVersionForce :: Bool,
+    pkgVersionIsDeprecated :: Bool,
+    pkgVersionDeprecationChanges :: [(UTCTime, Bool)],
    pkgDesc :: GenericPackageDescription,
    sdistPath :: FilePath,
    cabalFilePath :: FilePath,
@ -46,6 +53,33 @@ data PreparedPackageVersion = PreparedPackageVersion
    cabalFileRevisions :: [(UTCTime, FilePath)]
  }

+-- @andreabedini comments:
+--
+-- The function `preparePackageVersion` has a bit of a special role which I
+-- should comment upon.
+--
+-- There are at three sources of information about a package:
+--
+--   * the path of the meta file: `_sources/pkg-name/pkg-version/meta.toml`
+--   * the content of `meta.toml`
+--   * the tarball/sdist pointed by `meta.toml`
+--
+--
+-- Before #37 I used to refer to these three pieces of data independently,
+-- thinking it would be a good idea to keep the data-pipeline granular.
+--
+-- While working on #37, I realised this granularity was leading me to have
+-- consistency checks scattered around the code so I figured it would make more
+-- sense to centralise these checks into a single function and to use a type
+-- (`PreparedPackageVersion`) as evidence that everything is consistent (e.g.
+-- the package name inferred from the meta.toml path is the same as the one in
+-- the cabal file of the source distribution).
+--
+-- This function has also the chance to denormalise some data (i.e. repeating it
+-- multiple times in different forms) for easy consumption downstream. This
+-- could be split out in the future if `PreparedPackageVersion` starts to become
+-- a kitchen sink.
+
 preparePackageVersion :: FilePath -> FilePath -> Action PreparedPackageVersion
 preparePackageVersion inputDir metaFile = do
  let (name, version) = case splitDirectories metaFile of
@ -60,18 +94,18 @@ preparePackageVersion inputDir metaFile = do
    readPackageVersionSpec' (inputDir </> metaFile) >>= \case
      PackageVersionSpec {packageVersionRevisions, packageVersionTimestamp = Nothing}
        | not (null packageVersionRevisions) -> do
-            error $
-              unlines
-                [ inputDir </> metaFile <> " has cabal file revisions but the original package has no timestamp.",
-                  "This combination doesn't make sense. Either add a timestamp on the original package or remove the revisions"
-                ]
+          error $
+            unlines
+              [ inputDir </> metaFile <> " has cabal file revisions but the original package has no timestamp.",
+                "This combination doesn't make sense. Either add a timestamp on the original package or remove the revisions"
+              ]
      PackageVersionSpec {packageVersionRevisions, packageVersionTimestamp = Just pkgTs}
        | any ((< pkgTs) . revisionTimestamp) packageVersionRevisions -> do
-            error $
-              unlines
-                [ inputDir </> metaFile <> " has a revision with timestamp earlier than the package itself.",
-                  "Adjust the timestamps so that all revisions come after the original package"
-                ]
+          error $
+            unlines
+              [ inputDir </> metaFile <> " has a revision with timestamp earlier than the package itself.",
+                "Adjust the timestamps so that all revisions come after the original package"
+              ]
      meta ->
        return meta

@ -111,12 +145,31 @@ preparePackageVersion inputDir metaFile = do
          "version in cabal file: " ++ prettyShow (Distribution.Types.PackageId.pkgVersion $ package $ packageDescription pkgDesc)
        ]

-  let cabalFileRevisions =
-        sortOn
-          (Down . fst)
-          [ (revisionTimestamp, cabalFileRevisionPath revisionNumber)
-            | RevisionSpec {revisionTimestamp, revisionNumber} <- packageVersionRevisions pkgSpec
-          ]
+  let cabalFileRevisions = sortOn Down [(revisionTimestamp, cabalFileRevisionPath revisionNumber) | RevisionSpec {revisionTimestamp, revisionNumber} <- packageVersionRevisions pkgSpec]
+
+  let pkgVersionDeprecationChanges = sortOn Down [(deprecationTimestamp, deprecationIsDeprecated) | DeprecationSpec {deprecationTimestamp, deprecationIsDeprecated} <- packageVersionDeprecations pkgSpec]
+
+  -- Here is where we check that there are no "double deprecations" (i.e. two
+  -- consecutive (in time) `deprecated = true` or `deprecated = false`)
+  let noDoubleDeprecations xs = and $ zipWith (/=) xs' (tail xs')
+        where
+          xs' = map snd xs
+
+  -- Ensure the package version is not introduced already deprecated
+  let notIntroducedDeprecated = all (\(timestamp, _) -> packageVersionTimestamp pkgSpec > Just timestamp)
+
+  -- Ensure the first deprecation is an actual deprecation
+  let firstDeprecationIsActual = maybe True snd . listToMaybe
+
+  let deprecationChangesValid =
+        noDoubleDeprecations pkgVersionDeprecationChanges
+          && notIntroducedDeprecated pkgVersionDeprecationChanges
+          && firstDeprecationIsActual pkgVersionDeprecationChanges
+
+  unless deprecationChangesValid $
+    error $ "The deprecation changes for " ++ prettyShow pkgId ++ " are inconsistent."
+
+  let pkgVersionIsDeprecated = maybe False snd $ listToMaybe pkgVersionDeprecationChanges

  return
    PreparedPackageVersion
@ -124,6 +177,8 @@ preparePackageVersion inputDir metaFile = do
        pkgTimestamp = packageVersionTimestamp pkgSpec,
        pkgVersionSource = packageVersionSource pkgSpec,
        pkgVersionForce = packageVersionForce pkgSpec,
+        pkgVersionDeprecationChanges,
+        pkgVersionIsDeprecated,
        pkgDesc,
        sdistPath,
        cabalFilePath,
--- a/templates/allPackageVersions.mustache
+++ b/templates/allPackageVersions.mustache
@ -49,7 +49,11 @@
        {{#entries}}
          {{#AllPackageVersionsPageEntryPackage}}
          <tr>
-            <td class="col-sm-2"><a href="../package/{{allPackageVersionsPageEntryPkgId}}">{{allPackageVersionsPageEntryPkgId}}</a></td>
+            <td class="col-sm-2">
+              <a href="../package/{{allPackageVersionsPageEntryPkgId}}">{{allPackageVersionsPageEntryPkgId}}</a></td>
+              {{#allPackageVersionsPageEntryDeprecated}}
+              <span class="badge bg-danger">Deprecated</span>
+              {{/allPackageVersionsPageEntryDeprecated}}
            <td class="col-sm-1">Version</td>
            <td class="col-sm-3" data-order="{{allPackageVersionsPageEntryTimestampPosix}}">{{allPackageVersionsPageEntryTimestamp}}</td>
            <td class="col-sm-6">
--- a/templates/packageVersion.mustache
+++ b/templates/packageVersion.mustache
@ -27,7 +27,11 @@
        <li class="nav-item">
          <a class="nav-link" href="../../all-package-versions/index.html">All package versions</a>
        </li>
-      </ul>      <h1 class="py-5">
+      </ul>
+      <h1 class="py-5">
+        {{#pkgVersionDeprecated}}
+        <span class="badge bg-danger" style="font-size: 1em">Deprecated</span>
+        {{/pkgVersionDeprecated}}
        {{name}}-{{version}}
      </h1>
      <dl class="row class="px-4 py-5">