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,55 @@ prepareIndexPkgMetadata expiryTime PreparedPackageVersion {pkgId, sdistPath} = d
         targetsDelegations = Nothing
       }
 
+-- Currently `extraEntries` are only used for encoding `prefered-versions`.
+getExtraEntries :: [PreparedPackageVersion] -> [Tar.Entry]
+getExtraEntries packageVersions =
+  let -- Group all (package) versions by package (name)
+      groupedPackageVersions :: [NE.NonEmpty PreparedPackageVersion]
+      groupedPackageVersions = NE.groupWith (pkgName . pkgId) packageVersions
+
+      -- All versions of a given package together form a list of entries
+      -- The list of entries might be empty (in case no version has been deprecated)
+      generateEntriesForGroup :: NE.NonEmpty PreparedPackageVersion -> [Tar.Entry]
+      generateEntriesForGroup packageGroup = map createTarEntry effectiveRanges
+        where
+          -- Get the package name of the current group.
+          pn :: PackageName
+          pn = pkgName $ pkgId $ NE.head packageGroup
+          -- Collect and sort the deprecation changes for the package group, turning them into a action on VersionRange
+          deprecationChanges :: [(UTCTime, VersionRange -> VersionRange)]
+          deprecationChanges = sortOn fst $ foldMap versionDeprecationChanges packageGroup
+          -- Calculate (by applying them chronologically) the effective `VersionRange` for the package group.
+          effectiveRanges :: [(UTCTime, VersionRange)]
+          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
+
+-- TODO: the functions belows should be moved to Foliage.PreparedPackageVersion
+
+-- 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

@@ -6,31 +6,27 @@
 {-# OPTIONS_GHC -Wno-orphans #-}
 
 module Foliage.Meta
-  ( PackageMeta (PackageMeta),
-    PackageMetaEntry (PackageMetaEntry),
-    packageMetaEntryDeprecated,
-    packageMetaEntryPreferred,
-    packageMetaEntryTimestamp,
-    readPackageMeta,
-    writePackageMeta,
-    packageVersionTimestamp,
+  ( packageVersionTimestamp,
     packageVersionSource,
     packageVersionRevisions,
+    packageVersionDeprecations,
     packageVersionForce,
     PackageVersionSpec (PackageVersionSpec),
     readPackageVersionSpec,
     writePackageVersionSpec,
     RevisionSpec (RevisionSpec),
     revisionTimestamp,
     revisionNumber,
+    DeprecationSpec (DeprecationSpec),
+    deprecationTimestamp,
+    deprecationIsDeprecated,
     PackageVersionSource,
     pattern TarballSource,
     pattern GitHubSource,
     GitHubRepo (..),
     GitHubRev (..),
     UTCTime,
     latestRevisionNumber,
-    consolidateRanges,
   )
 where
 
@@ -44,71 +40,14 @@ import Data.Text qualified as T
 import Data.Time.LocalTime (utc, utcToZonedTime, zonedTimeToUTC)
 import Development.Shake.Classes (Binary, Hashable, NFData)
 import Distribution.Aeson ()
-import Distribution.Parsec (simpleParsec)
-import Distribution.Pretty (prettyShow)
 import Distribution.Types.Orphans ()
-import Distribution.Types.Version (Version)
-import Distribution.Types.VersionRange (VersionRange, anyVersion, intersectVersionRanges, notThisVersion)
-import Distribution.Version (isAnyVersion, isNoVersion, simplifyVersionRange)
 import Foliage.Time (UTCTime)
 import GHC.Generics (Generic)
 import Network.URI (URI, parseURI)
 import Network.URI.Orphans ()
 import Toml (TomlCodec, (.=))
 import Toml qualified
 
-newtype PackageMeta = PackageMeta
-  { packageMetaEntries :: [PackageMetaEntry]
-  }
-  deriving (Show, Eq, Generic)
-  deriving anyclass (Binary, Hashable, NFData)
-
-data PackageMetaEntry = PackageMetaEntry
-  { packageMetaEntryTimestamp :: UTCTime,
-    packageMetaEntryPreferred :: [VersionRange],
-    packageMetaEntryDeprecated :: [Version]
-  }
-  deriving (Show, Eq, Generic)
-  deriving anyclass (Binary, Hashable, NFData)
-
-readPackageMeta :: FilePath -> IO PackageMeta
-readPackageMeta = Toml.decodeFile packageMetaCodec
-
-writePackageMeta :: FilePath -> PackageMeta -> IO ()
-writePackageMeta fp a = void $ Toml.encodeToFile packageMetaCodec fp a
-
-packageMetaCodec :: TomlCodec PackageMeta
-packageMetaCodec =
-  PackageMeta
-    <$> Toml.list packageMetaEntryCodec "entries"
-    .= packageMetaEntries
-
-packageMetaEntryCodec :: TomlCodec PackageMetaEntry
-packageMetaEntryCodec =
-  PackageMetaEntry
-    <$> timeCodec "timestamp"
-    .= packageMetaEntryTimestamp
-    <*> Toml.arrayOf _VersionRange "preferred-versions"
-    .= packageMetaEntryPreferred
-    <*> Toml.arrayOf _Version "deprecated-versions"
-    .= packageMetaEntryDeprecated
-
-_Version :: Toml.TomlBiMap Version Toml.AnyValue
-_Version = Toml._TextBy showVersion parseVersion
-  where
-    showVersion = T.pack . prettyShow
-    parseVersion t = case simpleParsec (T.unpack t) of
-      Nothing -> Left $ T.pack $ "unable to parse version" ++ T.unpack t
-      Just v -> Right v
-
-_VersionRange :: Toml.TomlBiMap VersionRange Toml.AnyValue
-_VersionRange = Toml._TextBy showVersion parseVersion
-  where
-    showVersion = T.pack . prettyShow
-    parseVersion t = case simpleParsec (T.unpack t) of
-      Nothing -> Left $ T.pack $ "unable to parse version" ++ T.unpack t
-      Just v -> Right v
-
 newtype GitHubRepo = GitHubRepo {unGitHubRepo :: Text}
   deriving (Show, Eq, Binary, Hashable, NFData) via Text
 
@@ -174,6 +113,8 @@ data PackageVersionSpec = PackageVersionSpec
     packageVersionSource :: PackageVersionSource,
     -- | revisions
     packageVersionRevisions :: [RevisionSpec],
+    -- | deprecations
+    packageVersionDeprecations :: [DeprecationSpec],
     -- | force version
     packageVersionForce :: Bool
   }
@@ -189,6 +130,8 @@ sourceMetaCodec =
     .= packageVersionSource
     <*> Toml.list revisionMetaCodec "revisions"
     .= packageVersionRevisions
+    <*> Toml.list deprecationMetaCodec "deprecations"
+    .= packageVersionDeprecations
     <*> withDefault False (Toml.bool "force-version")
     .= packageVersionForce
 
@@ -202,7 +145,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 +156,24 @@ revisionMetaCodec =
     <*> Toml.int "number"
     .= revisionNumber
 
+data DeprecationSpec = DeprecationSpec
+  { deprecationTimestamp :: UTCTime,
+    -- | 'True' means the package version has been deprecated
+    --   'False' means the package version has been undeprecated
+    --   FIXME: we should consider something better than 'Bool'
+    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
 
@@ -226,12 +187,3 @@ 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
-
--- | copied from hackage-server
-consolidateRanges :: PackageMetaEntry -> Maybe VersionRange
-consolidateRanges PackageMetaEntry {packageMetaEntryPreferred, packageMetaEntryDeprecated} =
-  if isAnyVersion range || isNoVersion range then Nothing else Just range
-  where
-    range =
-      simplifyVersionRange $
-        foldr intersectVersionRanges anyVersion (map notThisVersion packageMetaEntryDeprecated ++ packageMetaEntryPreferred)

app/Foliage/Meta/Aeson.hs

@@ -12,12 +12,10 @@ import Foliage.Meta
 import Foliage.Utils.Aeson
 import Network.URI (URI)
 
-deriving via MyAesonEncoding PackageMeta instance ToJSON PackageMeta
-
-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