Fix #18: add support for deprecated-versions

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
@@ -115,6 +121,9 @@ buildAction
             -- all revised cabal files, with their timestamp
             revcf <- for cabalFileRevisions $ uncurry (prepareIndexPkgCabal pkgId)
 
+            -- WARN: So far Foliage allows publishing a package and a cabal file revision with the same timestamp
+            -- This accidentally works because 1) the following inserts the original cabal file before the revisions
+            -- AND 2) Data.List.sortOn is stable. The revised cabal file will always be after the original one.
             return $ cf : revcf
         )
         packageVersions
@@ -133,7 +142,10 @@ buildAction
             (IndexPkgMetadata pkgId)
             (fromMaybe currentTime pkgTimestamp)
 
-    let tarContents = Tar.write $ sortOn Tar.entryTime (cabalEntries ++ metadataEntries)
+    let extraEntries = getExtraEntries packageVersions
+
+    -- WARN: See note above, the sorting here has to be stable
+    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 +302,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 $ prettyShow 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)

app/Foliage/CmdImportIndex.hs

@@ -27,7 +27,11 @@ import System.FilePath
 
 cmdImportIndex :: ImportIndexOptions -> IO ()
 cmdImportIndex opts = do
-  putStrLn "EXPERIMENTAL. Import the Hackage index from $HOME/.cabal. Make sure you have done `cabal update` recently."
+  putStrLn $
+    unlines
+      [ "This command is EXPERIMENTAL and INCOMPLETE!",
+        "Import the Hackage index from $HOME/.cabal. Make sure you have done `cabal update` recently."
+      ]
   home <- getEnv "HOME"
   entries <- Tar.read <$> BSL.readFile (home </> ".cabal/packages/hackage.haskell.org/01-index.tar")
   m <- importIndex indexfilter entries M.empty
@@ -60,6 +64,7 @@ importIndex f (Tar.Next e es) m =
                         { packageVersionSource = TarballSource (pkgIdToHackageUrl pkgId) Nothing,
                           packageVersionTimestamp = Just time,
                           packageVersionRevisions = [],
+                          packageVersionDeprecations = [],
                           packageVersionForce = False
                         }
                 -- Existing package, new revision

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,
+    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 "deprecations"
+    .= 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
 

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

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