diff --git a/app/Foliage/CmdBuild.hs b/app/Foliage/CmdBuild.hs index 067895a..36540a1 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,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) diff --git a/app/Foliage/CmdImportIndex.hs b/app/Foliage/CmdImportIndex.hs index 25ec972..1a4522f 100644 --- a/app/Foliage/CmdImportIndex.hs +++ b/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 diff --git a/app/Foliage/Meta.hs b/app/Foliage/Meta.hs index 7130367..b5642d8 100644 --- a/app/Foliage/Meta.hs +++ b/app/Foliage/Meta.hs @@ -6,16 +6,10 @@ {-# 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, @@ -23,6 +17,9 @@ module Foliage.Meta RevisionSpec (RevisionSpec), revisionTimestamp, revisionNumber, + DeprecationSpec (DeprecationSpec), + deprecationTimestamp, + deprecationIsDeprecated, PackageVersionSource, pattern TarballSource, pattern GitHubSource, @@ -30,7 +27,6 @@ module Foliage.Meta GitHubRev (..), UTCTime, latestRevisionNumber, - consolidateRanges, ) where @@ -44,12 +40,7 @@ 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) @@ -57,58 +48,6 @@ 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) diff --git a/app/Foliage/Meta/Aeson.hs b/app/Foliage/Meta/Aeson.hs index 339b39c..47a7462 100644 --- a/app/Foliage/Meta/Aeson.hs +++ b/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 diff --git a/app/Foliage/Pages.hs b/app/Foliage/Pages.hs index 9df7777..c0c103f 100644 --- a/app/Foliage/Pages.hs +++ b/app/Foliage/Pages.hs @@ -90,17 +90,20 @@ makeAllPackagesPage currentTime outputDir packageVersions = -- sort packages by pkgId & sortOn allPackagesPageEntryPkgId +-- FIXME: refactor this data AllPackageVersionsPageEntry = AllPackageVersionsPageEntryPackage { allPackageVersionsPageEntryPkgId :: PackageIdentifier, allPackageVersionsPageEntryTimestamp :: UTCTime, allPackageVersionsPageEntryTimestampPosix :: POSIXTime, - allPackageVersionsPageEntrySource :: PackageVersionSource + allPackageVersionsPageEntrySource :: PackageVersionSource, + allPackageVersionsPageEntryDeprecated :: Bool } | AllPackageVersionsPageEntryRevision { allPackageVersionsPageEntryPkgId :: PackageIdentifier, allPackageVersionsPageEntryTimestamp :: UTCTime, - allPackageVersionsPageEntryTimestampPosix :: POSIXTime + allPackageVersionsPageEntryTimestampPosix :: POSIXTime, + allPackageVersionsPageEntryDeprecated :: Bool } deriving stock (Generic) deriving (ToJSON) via MyAesonEncoding AllPackageVersionsPageEntry @@ -116,19 +119,21 @@ 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, + allPackageVersionsPageEntryDeprecated = pkgVersionIsDeprecated } -- list of revisions : [ AllPackageVersionsPageEntryRevision { allPackageVersionsPageEntryPkgId = pkgId, allPackageVersionsPageEntryTimestamp = revisionTimestamp, - allPackageVersionsPageEntryTimestampPosix = utcTimeToPOSIXSeconds revisionTimestamp + allPackageVersionsPageEntryTimestampPosix = utcTimeToPOSIXSeconds revisionTimestamp, + allPackageVersionsPageEntryDeprecated = pkgVersionIsDeprecated } | (revisionTimestamp, _) <- cabalFileRevisions ] @@ -138,7 +143,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 +152,8 @@ makePackageVersionPage outputDir PreparedPackageVersion {pkgId, pkgTimestamp, pk [ "pkgVersionSource" .= pkgVersionSource, "cabalFileRevisions" .= map fst cabalFileRevisions, "pkgDesc" .= jsonGenericPackageDescription pkgDesc, - "pkgTimestamp" .= pkgTimestamp + "pkgTimestamp" .= pkgTimestamp, + "pkgVersionDeprecated" .= pkgVersionIsDeprecated ] indexPageTemplate :: Template diff --git a/app/Foliage/PreparePackageVersion.hs b/app/Foliage/PreparePackageVersion.hs index 854bdda..2027d1f 100644 --- a/app/Foliage/PreparePackageVersion.hs +++ b/app/Foliage/PreparePackageVersion.hs @@ -1,5 +1,6 @@ -{-# LANGUAGE LambdaCase #-} {-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ViewPatterns #-} module Foliage.PreparePackageVersion ( PreparedPackageVersion @@ -7,6 +8,8 @@ module Foliage.PreparePackageVersion pkgTimestamp, pkgVersionSource, pkgVersionForce, + pkgVersionIsDeprecated, + pkgVersionDeprecationChanges, pkgDesc, sdistPath, cabalFilePath, @@ -20,7 +23,9 @@ where import Control.Monad (unless) import Data.List (sortOn) -import Data.Ord (Down (Down)) +import Data.List.NonEmpty qualified as NE +import Data.Maybe (listToMaybe, mapMaybe) +import Data.Ord (Down (..)) import Development.Shake (Action) import Development.Shake.FilePath (joinPath, splitDirectories) import Distribution.Client.Compat.Prelude (fromMaybe, prettyShow) @@ -28,17 +33,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: can we ensure that `pkgVersionDeprecationChanges` and `cabalFileRevisions` are +-- sorted by timestamp? e.g 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 +55,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 @@ -57,27 +93,67 @@ preparePackageVersion inputDir metaFile = do let pkgId = PackageIdentifier pkgName pkgVersion pkgSpec <- - 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" - ] - 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" - ] - meta -> - return meta + readPackageVersionSpec' (inputDir metaFile) >>= \meta@PackageVersionSpec {..} -> do + case (NE.nonEmpty packageVersionRevisions, packageVersionTimestamp) of + (Just _someRevisions, Nothing) -> + error $ + unlines + [ inputDir metaFile <> " has cabal file revisions but the package has no timestamp.", + "This combination doesn't make sense. Either add a timestamp on the original package or remove the revisions." + ] + (Just (NE.sort -> someRevisions), Just ts) + -- WARN: this should really be a <= + | revisionTimestamp (NE.head someRevisions) < ts -> + error $ + unlines + [ inputDir metaFile <> " has a revision with timestamp earlier than the package itself.", + "Adjust the timestamps so that all revisions come after the package publication." + ] + | not (null $ duplicates (revisionTimestamp <$> someRevisions)) -> + error $ + unlines + [ inputDir metaFile <> " has two revisions entries with the same timestamp.", + "Adjust the timestamps so that all the revisions happen at a different time." + ] + _otherwise -> return () + + case (NE.nonEmpty packageVersionDeprecations, packageVersionTimestamp) of + (Just _someDeprecations, Nothing) -> + error $ + unlines + [ inputDir metaFile <> " has deprecations but the package has no timestamp.", + "This combination doesn't make sense. Either add a timestamp on the original package or remove the deprecation." + ] + (Just (NE.sort -> someDeprecations), Just ts) + | deprecationTimestamp (NE.head someDeprecations) <= ts -> + error $ + unlines + [ inputDir metaFile <> " has a deprecation entry with timestamp earlier (or equal) than the package itself.", + "Adjust the timestamps so that all the (un-)deprecations come after the package publication." + ] + | not (deprecationIsDeprecated (NE.head someDeprecations)) -> + error $ + "The first deprecation entry in" <> inputDir metaFile <> " cannot be an un-deprecation" + | not (null $ duplicates (deprecationTimestamp <$> someDeprecations)) -> + error $ + unlines + [ inputDir metaFile <> " has two deprecation entries with the same timestamp.", + "Adjust the timestamps so that all the (un-)deprecations happen at a different time." + ] + | not (null $ doubleDeprecations someDeprecations) -> + error $ + unlines + [ inputDir metaFile <> " contains two consecutive deprecations or two consecutive un-deprecations.", + "Make sure deprecations and un-deprecations alternate in time." + ] + _otherwise -> return () + + return meta srcDir <- prepareSource pkgId pkgSpec let originalCabalFilePath = srcDir prettyShow pkgName <.> "cabal" + cabalFileRevisionPath revisionNumber = joinPath [ inputDir, @@ -88,7 +164,7 @@ preparePackageVersion inputDir metaFile = do ] <.> "cabal" - let cabalFilePath = + cabalFilePath = maybe originalCabalFilePath cabalFileRevisionPath @@ -113,20 +189,37 @@ preparePackageVersion inputDir metaFile = do let cabalFileRevisions = sortOn - (Down . fst) + Down [ (revisionTimestamp, cabalFileRevisionPath revisionNumber) | RevisionSpec {revisionTimestamp, revisionNumber} <- packageVersionRevisions pkgSpec ] + let pkgVersionDeprecationChanges = + sortOn + Down + [ (deprecationTimestamp, deprecationIsDeprecated) + | DeprecationSpec {deprecationTimestamp, deprecationIsDeprecated} <- packageVersionDeprecations pkgSpec + ] + + let pkgVersionIsDeprecated = maybe False snd $ listToMaybe pkgVersionDeprecationChanges + return PreparedPackageVersion { pkgId, pkgTimestamp = packageVersionTimestamp pkgSpec, pkgVersionSource = packageVersionSource pkgSpec, pkgVersionForce = packageVersionForce pkgSpec, + pkgVersionDeprecationChanges, + pkgVersionIsDeprecated, pkgDesc, sdistPath, cabalFilePath, originalCabalFilePath, cabalFileRevisions } + +duplicates :: Ord a => NE.NonEmpty a -> [a] +duplicates = mapMaybe (listToMaybe . NE.tail) . NE.group + +doubleDeprecations :: NE.NonEmpty DeprecationSpec -> [NE.NonEmpty DeprecationSpec] +doubleDeprecations = filter ((> 1) . length) . NE.groupWith deprecationIsDeprecated diff --git a/templates/allPackageVersions.mustache b/templates/allPackageVersions.mustache index 0a3cb9a..22338fc 100644 --- a/templates/allPackageVersions.mustache +++ b/templates/allPackageVersions.mustache @@ -10,9 +10,7 @@ - - + All package versions @@ -49,7 +47,12 @@ {{#entries}} {{#AllPackageVersionsPageEntryPackage}} - {{allPackageVersionsPageEntryPkgId}} + + {{allPackageVersionsPageEntryPkgId}} + {{#allPackageVersionsPageEntryDeprecated}} + Deprecated + {{/allPackageVersionsPageEntryDeprecated}} + Version {{allPackageVersionsPageEntryTimestamp}} @@ -63,10 +66,15 @@ {{/AllPackageVersionsPageEntryPackage}} {{#AllPackageVersionsPageEntryRevision}} - {{allPackageVersionsPageEntryPkgId}} - Revision - {{allPackageVersionsPageEntryTimestamp}} - + + {{allPackageVersionsPageEntryPkgId}} + {{#allPackageVersionsPageEntryDeprecated}} + Deprecated + {{/allPackageVersionsPageEntryDeprecated}} + + Revision + {{allPackageVersionsPageEntryTimestamp}} + {{/AllPackageVersionsPageEntryRevision}} {{/entries}} diff --git a/templates/packageVersion.mustache b/templates/packageVersion.mustache index 91b95e6..8784008 100644 --- a/templates/packageVersion.mustache +++ b/templates/packageVersion.mustache @@ -27,10 +27,15 @@
  • All package versions
    • -

    + +

    {{name}}-{{version}}

    + {{#pkgVersionDeprecated}} +
    Deprecated
    +
    + {{/pkgVersionDeprecated}}
    Synopsis

    {{synopsis}}

    Description