Fix input-output-hk#18: add support for deprecated-versions

yvan-sraka · Apr 16, 2023 · 2f68caf · 2f68caf
1 parent 586b692
commit 2f68caf
Show file tree

Hide file tree

Showing 7 changed files with 114 additions and 17 deletions.
diff --git 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,19 @@ 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.ByteString.Char8 qualified as BS
+import Data.ByteString.Lazy.Char8 qualified as BL
 import Data.List (sortOn)
+import Data.Map qualified as Map
 import Data.Maybe (fromMaybe)
 import Data.Text qualified as T
 import Data.Traversable (for)
 import Development.Shake
 import Development.Shake.FilePath
 import Distribution.Package
 import Distribution.Pretty (prettyShow)
+-- import Distribution.Types.VersionRange -- needed by `consolidateRanges`
+import Distribution.Version
 import Foliage.HackageSecurity hiding (ToJSON, toJSON)
 import Foliage.Meta
 import Foliage.Meta.Aeson ()
@@ -101,9 +105,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 +138,9 @@ buildAction
             (IndexPkgMetadata pkgId)
             (fromMaybe currentTime pkgTimestamp)
 
-    let tarContents = Tar.write $ sortOn Tar.entryTime (cabalEntries ++ metadataEntries)
+    let extraEntries = prepareIndexPkgExtraEntries currentTime 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,8 +297,48 @@ prepareIndexPkgMetadata expiryTime PreparedPackageVersion {pkgId, sdistPath} = d
         targetsDelegations = Nothing
       }
 
+prepareIndexPkgExtraEntries :: UTCTime -> [PreparedPackageVersion] -> [Tar.Entry]
+prepareIndexPkgExtraEntries timestamp packageVersions = map buildTarEntry $ Map.toList $ getPreferredVersions packageVersions
+  where
+    buildTarEntry (pkgName, pkgVersions) = mkTarEntry' content path timestamp
+      --                                                            ^^^^^^^^^ TODO: this is for now set to `currentTime` ...
+      --                                                            ... should it be the timestamp of the latest version of the package?
+      where
+        path = "index" </> prettyShow pkgName </> "preferred-versions"
+        content = generatePreferredVersionsFileContent $ map snd pkgVersions
+
+getPreferredVersions :: [PreparedPackageVersion] -> Map.Map PackageName [(Maybe UTCTime, Version)]
+--                                                                        ^^^^^^^^^^^^^ TODO: actually I don't use this value yet, should I?
+getPreferredVersions packageVersions = Map.fromListWith (++) [(getKey p, getValue p) | p <- packageVersions]
+  --                                                     ^^ TODO: replace it by `consolidateRanges`? To work with a list of `VersionRange` instead of a list of `Version`?
+  where
+    getKey PreparedPackageVersion {pkgId = PackageIdentifier {pkgName}} = pkgName
+    getValue PreparedPackageVersion {pkgTimestamp, pkgVersionDeprecated, pkgId = PackageIdentifier {pkgVersion}} = [(pkgTimestamp, pkgVersion) | not pkgVersionDeprecated]
+
+-- @andreabedini points that the logic of computing the preferred versions seems in `hackage-server` to be here:
+-- https://github.com/haskell/hackage-server/blob/master/src/Distribution/Server/Features/PreferredVersions/State.hs#L39-L44
+-- In particular the `VersionRange` is computed from the preferred versions ranges and the deprecated versions with this function:
+--
+-- consolidateRanges ranges depr =
+--   let range = simplifyVersionRange $ foldr intersectVersionRanges anyVersion (map notThisVersion depr ++ ranges)
+--    in if isAnyVersion range || isNoVersion range
+--         then Nothing
+--         else Just range
+--
+
+-- TODO: This is a cheap implementation, rather than writing `VersionRange` it just enumerate prefered `Version`...
+-- ... is this enough to encode all of our use cases? I think so...
+generatePreferredVersionsFileContent :: [Version] -> BL.ByteString
+generatePreferredVersionsFileContent versions =
+  BL.intercalate " || " $ map (BL.fromStrict . (\v -> BS.pack $ "=" ++ prettyShow v)) versions
+-- ... also when all versions of a package are deprecated, it generate an empty file, is it the right behavior?
+
 mkTarEntry :: BL.ByteString -> IndexFile dec -> UTCTime -> Tar.Entry
-mkTarEntry contents indexFile timestamp =
+mkTarEntry contents indexFile =
+  mkTarEntry' contents (toFilePath $ castRoot $ indexFileToPath hackageIndexLayout indexFile)
+
+mkTarEntry' :: BL.ByteString -> [Char] -> UTCTime -> Tar.Entry
+mkTarEntry' contents indexPath timestamp =
   (Tar.fileEntry tarPath contents)
     { Tar.entryTime = floor $ Time.utcTimeToPOSIXSeconds timestamp,
       Tar.entryOwnership =
@@ -307,8 +354,6 @@ mkTarEntry contents indexFile timestamp =
       Left e -> error $ "Invalid tar path " ++ indexPath ++ "(" ++ e ++ ")"
       Right tp -> tp
 
-    indexPath = toFilePath $ castRoot $ indexFileToPath hackageIndexLayout indexFile
-
 anchorPath :: Path Absolute -> (RepoLayout -> RepoPath) -> FilePath
 anchorPath outputDirRoot p =
   toFilePath $ anchorRepoPathLocally outputDirRoot $ p hackageRepoLayout
diff --git a/app/Foliage/Meta.hs b/app/Foliage/Meta.hs
@@ -16,13 +16,17 @@ module Foliage.Meta
     packageVersionTimestamp,
     packageVersionSource,
     packageVersionRevisions,
+    packageVersionDeprecations,
     packageVersionForce,
     PackageVersionSpec (PackageVersionSpec),
     readPackageVersionSpec,
     writePackageVersionSpec,
     RevisionSpec (RevisionSpec),
     revisionTimestamp,
     revisionNumber,
+    DeprecationSpec (DeprecationSpec),
+    deprecationTimestamp,
+    isDeprecated,
     PackageVersionSource,
     pattern TarballSource,
     pattern GitHubSource,
@@ -174,6 +178,8 @@ data PackageVersionSpec = PackageVersionSpec
     packageVersionSource :: PackageVersionSource,
     -- | revisions
     packageVersionRevisions :: [RevisionSpec],
+    -- | deprpecations
+    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
 
@@ -213,6 +221,21 @@ revisionMetaCodec =
     <*> Toml.int "number"
     .= revisionNumber
 
+data DeprecationSpec = DeprecationSpec
+  { deprecationTimestamp :: UTCTime,
+    isDeprecated :: Bool
+  }
+  deriving (Show, Eq, Generic)
+  deriving anyclass (Binary, Hashable, NFData)
+
+deprecationMetaCodec :: TomlCodec DeprecationSpec
+deprecationMetaCodec =
+  DeprecationSpec
+    <$> timeCodec "timestamp"
+    .= deprecationTimestamp
+    <*> withDefault True (Toml.bool "deprecated")
+    .= isDeprecated
+
 timeCodec :: Toml.Key -> TomlCodec UTCTime
 timeCodec key = Toml.dimap (utcToZonedTime utc) zonedTimeToUTC $ Toml.zonedTime key
 

diff --git 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

diff --git 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, pkgVersionDeprecated, 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 = pkgVersionDeprecated
               }
               -- 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, pkgVersionDeprecated} = 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" .= pkgVersionDeprecated
           ]
 
 indexPageTemplate :: Template

diff --git a/app/Foliage/PreparePackageVersion.hs b/app/Foliage/PreparePackageVersion.hs
@@ -7,6 +7,7 @@ module Foliage.PreparePackageVersion
         pkgTimestamp,
         pkgVersionSource,
         pkgVersionForce,
+        pkgVersionDeprecated,
         pkgDesc,
         sdistPath,
         cabalFilePath,
@@ -28,7 +29,7 @@ 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 (PackageVersionSource, PackageVersionSpec (..), RevisionSpec (..), DeprecationSpec (..), UTCTime, latestRevisionNumber)
 import Foliage.PrepareSdist (prepareSdist)
 import Foliage.PrepareSource (prepareSource)
 import Foliage.Shake (readGenericPackageDescription', readPackageVersionSpec')
@@ -39,6 +40,7 @@ data PreparedPackageVersion = PreparedPackageVersion
     pkgTimestamp :: Maybe UTCTime,
     pkgVersionSource :: PackageVersionSource,
     pkgVersionForce :: Bool,
+    pkgVersionDeprecated :: Bool,
     pkgDesc :: GenericPackageDescription,
     sdistPath :: FilePath,
     cabalFilePath :: FilePath,
@@ -118,12 +120,24 @@ preparePackageVersion inputDir metaFile = do
             | RevisionSpec {revisionTimestamp, revisionNumber} <- packageVersionRevisions pkgSpec
           ]
 
+  let lastDeprecation =
+        sortOn
+          (Down . fst)
+          [ (deprecationTimestamp, isDeprecated)
+            | DeprecationSpec {deprecationTimestamp, isDeprecated} <- packageVersionDeprecations pkgSpec
+          ]
+
+  let isDeprecated = case lastDeprecation of
+        ((_, x):_) -> x
+        [] -> False
+
   return
     PreparedPackageVersion
       { pkgId,
         pkgTimestamp = packageVersionTimestamp pkgSpec,
         pkgVersionSource = packageVersionSource pkgSpec,
         pkgVersionForce = packageVersionForce pkgSpec,
+        pkgVersionDeprecated = isDeprecated,
         pkgDesc,
         sdistPath,
         cabalFilePath,

diff --git 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">

diff --git 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">