diff --git a/app/Foliage/CmdBuild.hs b/app/Foliage/CmdBuild.hs index 067895a..670219d 100644 --- 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,9 +9,10 @@ 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) @@ -18,6 +20,8 @@ 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 index 7130367..1d52505 100644 --- 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, + 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 index 339b39c..dfe0240 100644 --- 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 index 9df7777..8c9a501 100644 --- 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 index 854bdda..fae2e39 100644 --- 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 index 0a3cb9a..9e1b08a 100644 --- a/templates/allPackageVersions.mustache +++ b/templates/allPackageVersions.mustache @@ -49,7 +49,11 @@ {{#entries}} {{#AllPackageVersionsPageEntryPackage}} - {{allPackageVersionsPageEntryPkgId}} + + {{allPackageVersionsPageEntryPkgId}} + {{#allPackageVersionsPageEntryDeprecated}} + Deprecated + {{/allPackageVersionsPageEntryDeprecated}} Version {{allPackageVersionsPageEntryTimestamp}} diff --git a/templates/packageVersion.mustache b/templates/packageVersion.mustache index 91b95e6..99361f1 100644 --- a/templates/packageVersion.mustache +++ b/templates/packageVersion.mustache @@ -27,7 +27,11 @@
  • All package versions
    • -

    + +

    + {{#pkgVersionDeprecated}} + Deprecated + {{/pkgVersionDeprecated}} {{name}}-{{version}}