From e55bd966d234a6743c26e31fd7a315fa9f581ea4 Mon Sep 17 00:00:00 2001 From: Sandy Maguire Date: Mon, 4 May 2026 08:58:53 -0700 Subject: [PATCH 01/12] Split out utils --- hackage-server.cabal | 1 + src/Distribution/Server/Features/Core.hs | 1 + .../Server/Features/Core/State.hs | 1 + .../Server/Features/EditCabalFiles.hs | 1 + src/Distribution/Server/Features/Html.hs | 1 + src/Distribution/Server/Features/Mirror.hs | 1 + .../Server/Features/PackageCandidates.hs | 1 + .../Server/Features/PackageContents.hs | 1 + .../Server/Features/PackageFeed.hs | 1 + .../Server/Features/PackageInfoJSON.hs | 3 +- .../Server/Features/PackageList.hs | 1 + .../Server/Features/RecentPackages.hs | 5 +- .../Features/ReverseDependencies/State.hs | 1 + src/Distribution/Server/Features/Search.hs | 2 +- src/Distribution/Server/Features/Security.hs | 1 + .../Server/Features/Security/Migration.hs | 1 + src/Distribution/Server/Features/Sitemap.hs | 1 + src/Distribution/Server/Features/Tags.hs | 1 + .../Server/Features/TarIndexCache.hs | 1 + .../Server/Features/UserNotify.hs | 1 + src/Distribution/Server/Packages/Index.hs | 5 +- src/Distribution/Server/Packages/Metadata.hs | 2 +- src/Distribution/Server/Packages/Render.hs | 2 +- src/Distribution/Server/Packages/Types.hs | 91 ---------------- src/Distribution/Server/Packages/Utils.hs | 100 ++++++++++++++++++ src/Distribution/Server/Pages/Index.hs | 1 + .../Server/Pages/PackageFromTemplate.hs | 1 + src/Distribution/Server/Pages/Recent.hs | 25 ++--- 28 files changed, 143 insertions(+), 111 deletions(-) create mode 100644 src/Distribution/Server/Packages/Utils.hs diff --git a/hackage-server.cabal b/hackage-server.cabal index 16afe763b..dcf6da947 100644 --- a/hackage-server.cabal +++ b/hackage-server.cabal @@ -255,6 +255,7 @@ library Distribution.Server.Packages.PackageIndex Distribution.Server.Packages.Types Distribution.Server.Packages.Unpack + Distribution.Server.Packages.Utils Distribution.Server.Packages.Render Distribution.Server.Packages.ChangeLog Distribution.Server.Packages.Readme diff --git a/src/Distribution/Server/Features/Core.hs b/src/Distribution/Server/Features/Core.hs index 2bc6ff059..e91dc756d 100644 --- a/src/Distribution/Server/Features/Core.hs +++ b/src/Distribution/Server/Features/Core.hs @@ -50,6 +50,7 @@ import qualified Distribution.Server.Packages.Index as Packages. import Distribution.Server.Packages.PackageIndex (PackageIndex) import qualified Distribution.Server.Packages.PackageIndex as PackageIndex import Distribution.Server.Packages.Types +import Distribution.Server.Packages.Utils import Distribution.Server.Users.Types (UserId, userName) import Distribution.Server.Users.Users (lookupUserId, diff --git a/src/Distribution/Server/Features/Core/State.hs b/src/Distribution/Server/Features/Core/State.hs index 401eb5132..275371cd3 100644 --- a/src/Distribution/Server/Features/Core/State.hs +++ b/src/Distribution/Server/Features/Core/State.hs @@ -29,6 +29,7 @@ import Distribution.Package import Distribution.Server.Packages.PackageIndex (PackageIndex) import qualified Distribution.Server.Packages.PackageIndex as PackageIndex import Distribution.Server.Packages.Types +import Distribution.Server.Packages.Utils import Distribution.Server.Packages.Index import Distribution.Server.Users.Types (UserId, UserName(..), UserInfo(..)) import Distribution.Server.Users.Users (Users, lookupUserId) diff --git a/src/Distribution/Server/Features/EditCabalFiles.hs b/src/Distribution/Server/Features/EditCabalFiles.hs index 6161ccf47..fdcb676d7 100644 --- a/src/Distribution/Server/Features/EditCabalFiles.hs +++ b/src/Distribution/Server/Features/EditCabalFiles.hs @@ -13,6 +13,7 @@ import Distribution.Server.Framework.Templating import Distribution.Server.Features.Users import Distribution.Server.Features.Core import Distribution.Server.Packages.Types +import Distribution.Server.Packages.Utils import Distribution.Server.Features.Upload import Distribution.Package diff --git a/src/Distribution/Server/Features/Html.hs b/src/Distribution/Server/Features/Html.hs index a5b031980..6252f5d82 100644 --- a/src/Distribution/Server/Features/Html.hs +++ b/src/Distribution/Server/Features/Html.hs @@ -42,6 +42,7 @@ import qualified Distribution.Server.Features.BuildReports.BuildReport as BR import Distribution.Server.Users.Types import qualified Distribution.Server.Users.Group as Group import Distribution.Server.Packages.Types +import Distribution.Server.Packages.Utils import Distribution.Server.Packages.Render import qualified Distribution.Server.Users.Users as Users import qualified Distribution.Server.Packages.PackageIndex as PackageIndex diff --git a/src/Distribution/Server/Features/Mirror.hs b/src/Distribution/Server/Features/Mirror.hs index 0db7660cd..45c29f16e 100644 --- a/src/Distribution/Server/Features/Mirror.hs +++ b/src/Distribution/Server/Features/Mirror.hs @@ -15,6 +15,7 @@ import Distribution.Server.Features.Users import Distribution.Server.Users.State import Distribution.Server.Packages.Types +import Distribution.Server.Packages.Utils import Distribution.Server.Users.Backup import Distribution.Server.Users.Types import Distribution.Server.Users.Users hiding (lookupUserName) diff --git a/src/Distribution/Server/Features/PackageCandidates.hs b/src/Distribution/Server/Features/PackageCandidates.hs index 7ad2c22c4..02e589fa9 100644 --- a/src/Distribution/Server/Features/PackageCandidates.hs +++ b/src/Distribution/Server/Features/PackageCandidates.hs @@ -20,6 +20,7 @@ import Distribution.Server.Features.Users import Distribution.Server.Features.TarIndexCache import Distribution.Server.Packages.Types +import Distribution.Server.Packages.Utils import Distribution.Server.Packages.Render import Distribution.Server.Packages.ChangeLog import Distribution.Server.Packages.Readme diff --git a/src/Distribution/Server/Features/PackageContents.hs b/src/Distribution/Server/Features/PackageContents.hs index 43b2df134..b81286084 100644 --- a/src/Distribution/Server/Features/PackageContents.hs +++ b/src/Distribution/Server/Features/PackageContents.hs @@ -14,6 +14,7 @@ import Distribution.Server.Features.TarIndexCache import Distribution.Server.Packages.ChangeLog import Distribution.Server.Packages.Readme import Distribution.Server.Packages.Types +import Distribution.Server.Packages.Utils import Distribution.Server.Packages.Render import Distribution.Server.Features.Users import Distribution.Server.Util.ServeTarball diff --git a/src/Distribution/Server/Features/PackageFeed.hs b/src/Distribution/Server/Features/PackageFeed.hs index d99432629..f573a18b7 100644 --- a/src/Distribution/Server/Features/PackageFeed.hs +++ b/src/Distribution/Server/Features/PackageFeed.hs @@ -8,6 +8,7 @@ import Distribution.Server.Features.Users import Distribution.Server.Framework import Distribution.Server.Packages.ChangeLog import Distribution.Server.Packages.Types +import Distribution.Server.Packages.Utils import qualified Distribution.Server.Users.Users as Users import Distribution.Server.Users.Users (Users) import Distribution.Server.Util.Parse (unpackUTF8) diff --git a/src/Distribution/Server/Features/PackageInfoJSON.hs b/src/Distribution/Server/Features/PackageInfoJSON.hs index 91f9b5cfc..83ddabecf 100644 --- a/src/Distribution/Server/Features/PackageInfoJSON.hs +++ b/src/Distribution/Server/Features/PackageInfoJSON.hs @@ -38,7 +38,8 @@ import qualified Distribution.Server.Framework as Framework import Distribution.Server.Features.Core (CoreFeature(..), CoreResource(..)) import qualified Distribution.Server.Features.PreferredVersions as Preferred -import Distribution.Server.Packages.Types (CabalFileText(..), MetadataRevIx(..), pkgSpecificRevision, pkgLatestRevision, pkgMaxRevision, pkgNumRevisions) +import Distribution.Server.Packages.Types (CabalFileText(..), MetadataRevIx(..)) +import Distribution.Server.Packages.Utils (pkgSpecificRevision, pkgLatestRevision, pkgMaxRevision, pkgNumRevisions) import Distribution.Utils.ShortText (fromShortText) import Data.Foldable (toList) diff --git a/src/Distribution/Server/Features/PackageList.hs b/src/Distribution/Server/Features/PackageList.hs index d2b063c29..527409c47 100644 --- a/src/Distribution/Server/Features/PackageList.hs +++ b/src/Distribution/Server/Features/PackageList.hs @@ -23,6 +23,7 @@ import qualified Distribution.Server.Packages.PackageIndex as PackageIndex import Distribution.Server.Util.CountingMap (cmFind) import Distribution.Server.Packages.Types +import Distribution.Server.Packages.Utils import Distribution.Server.Users.Types import Distribution.Package diff --git a/src/Distribution/Server/Features/RecentPackages.hs b/src/Distribution/Server/Features/RecentPackages.hs index 51fe5366a..e615a04e0 100644 --- a/src/Distribution/Server/Features/RecentPackages.hs +++ b/src/Distribution/Server/Features/RecentPackages.hs @@ -9,6 +9,7 @@ import Distribution.Server.Framework import Distribution.Server.Features.Core import Distribution.Server.Features.Users import Distribution.Server.Packages.Types +import Distribution.Server.Packages.Utils import qualified Distribution.Server.Packages.PackageIndex as PackageIndex import Data.List (sortOn) import Data.Ord (Down(Down)) @@ -82,7 +83,7 @@ recentPackagesFeature _ getRecentPackages :: MonadIO m => m [PkgInfo] getRecentPackages = fst <$> readAsyncCache cacheRecent - + getRecentRevisions :: MonadIO m => m [PkgInfo] getRecentRevisions = snd <$> readAsyncCache cacheRecent @@ -96,4 +97,4 @@ recentPackagesFeature _ recentChanges = sortOn (Down . pkgOriginalUploadTime) packages recentRevisions = sortOn (Down . revisionTime) . filter isRevised $ packages - return (recentChanges, recentRevisions) \ No newline at end of file + return (recentChanges, recentRevisions) diff --git a/src/Distribution/Server/Features/ReverseDependencies/State.hs b/src/Distribution/Server/Features/ReverseDependencies/State.hs index a8345fe3f..d9832743c 100644 --- a/src/Distribution/Server/Features/ReverseDependencies/State.hs +++ b/src/Distribution/Server/Features/ReverseDependencies/State.hs @@ -46,6 +46,7 @@ import qualified Data.Graph as Gr import Distribution.Package import Distribution.PackageDescription import Distribution.Server.Packages.Types +import Distribution.Server.Packages.Utils import Distribution.Server.Framework.MemSize import Distribution.Server.Features.PreferredVersions (maybeBestVersion) import Distribution.Server.Features.PreferredVersions.State diff --git a/src/Distribution/Server/Features/Search.hs b/src/Distribution/Server/Features/Search.hs index 9bae0e2f3..f8f721f31 100644 --- a/src/Distribution/Server/Features/Search.hs +++ b/src/Distribution/Server/Features/Search.hs @@ -14,7 +14,7 @@ import Distribution.Server.Features.Search.PkgSearch import qualified Distribution.Server.Features.Search.SearchEngine as SearchEngine import qualified Distribution.Server.Packages.PackageIndex as PackageIndex -import Distribution.Server.Packages.Types +import Distribution.Server.Packages.Utils import Distribution.Package import Distribution.PackageDescription.Configuration (flattenPackageDescription) diff --git a/src/Distribution/Server/Features/Security.hs b/src/Distribution/Server/Features/Security.hs index 71780d0ce..b07184cac 100644 --- a/src/Distribution/Server/Features/Security.hs +++ b/src/Distribution/Server/Features/Security.hs @@ -21,6 +21,7 @@ import Distribution.Server.Features.Security.FileInfo import Distribution.Server.Framework import Distribution.Server.Packages.Index import Distribution.Server.Packages.Types +import Distribution.Server.Packages.Utils -- Hackage security import Hackage.Security.Util.Some diff --git a/src/Distribution/Server/Features/Security/Migration.hs b/src/Distribution/Server/Features/Security/Migration.hs index c30fe525b..1a66f8cea 100644 --- a/src/Distribution/Server/Features/Security/Migration.hs +++ b/src/Distribution/Server/Features/Security/Migration.hs @@ -31,6 +31,7 @@ import Distribution.Server.Features.Security.Layout import Distribution.Server.Framework hiding (Length) import Distribution.Server.Framework.BlobStorage import Distribution.Server.Packages.Types +import Distribution.Server.Packages.Utils import Distribution.Server.Util.ReadDigest import qualified Distribution.Server.Packages.PackageIndex as PackageIndex diff --git a/src/Distribution/Server/Features/Sitemap.hs b/src/Distribution/Server/Features/Sitemap.hs index 04fcc0cc1..f27d7ee0d 100644 --- a/src/Distribution/Server/Features/Sitemap.hs +++ b/src/Distribution/Server/Features/Sitemap.hs @@ -17,6 +17,7 @@ import Distribution.Server.Features.Tags import Distribution.Package import Distribution.Text (display) import Distribution.Server.Packages.Types +import Distribution.Server.Packages.Utils import qualified Distribution.Server.Packages.PackageIndex as PackageIndex import qualified Data.Map as Map diff --git a/src/Distribution/Server/Features/Tags.hs b/src/Distribution/Server/Features/Tags.hs index 09b4723e8..5cea81547 100644 --- a/src/Distribution/Server/Features/Tags.hs +++ b/src/Distribution/Server/Features/Tags.hs @@ -22,6 +22,7 @@ import Distribution.Server.Features.Users import qualified Distribution.Server.Packages.PackageIndex as PackageIndex import Distribution.Server.Packages.PackageIndex (PackageIndex) import Distribution.Server.Packages.Types +import Distribution.Server.Packages.Utils import Distribution.Server.Packages.Render (categorySplit) import Distribution.Utils.ShortText (fromShortText) diff --git a/src/Distribution/Server/Features/TarIndexCache.hs b/src/Distribution/Server/Features/TarIndexCache.hs index e075d1b8c..068204f0f 100644 --- a/src/Distribution/Server/Features/TarIndexCache.hs +++ b/src/Distribution/Server/Features/TarIndexCache.hs @@ -20,6 +20,7 @@ import Distribution.Server.Framework.BackupRestore import qualified Distribution.Server.Features.TarIndexCache.State as Acid import Distribution.Server.Features.Users import Distribution.Server.Packages.Types +import Distribution.Server.Packages.Utils import Data.TarIndex import qualified Data.TarIndex as TarIndex import Distribution.Server.Util.ServeTarball (constructTarIndex) diff --git a/src/Distribution/Server/Features/UserNotify.hs b/src/Distribution/Server/Features/UserNotify.hs index 9f753fc31..2cea9edf7 100644 --- a/src/Distribution/Server/Features/UserNotify.hs +++ b/src/Distribution/Server/Features/UserNotify.hs @@ -33,6 +33,7 @@ import Distribution.Server.Users.Types (UserId, UserInfo (..)) import Distribution.Server.Users.UserIdSet as UserIdSet import Distribution.Server.Packages.Types +import Distribution.Server.Packages.Utils import qualified Distribution.Server.Packages.PackageIndex as PackageIndex import Distribution.Server.Framework diff --git a/src/Distribution/Server/Packages/Index.hs b/src/Distribution/Server/Packages/Index.hs index 76ac2098f..7c4170b95 100644 --- a/src/Distribution/Server/Packages/Index.hs +++ b/src/Distribution/Server/Packages/Index.hs @@ -18,7 +18,9 @@ import Distribution.Server.Framework.MemSize import Distribution.Server.Packages.Types ( CabalFileText(..), PkgInfo(..) , TarballRevIx, MetadataRevIx - , pkgSpecificRevision + ) +import Distribution.Server.Packages.Utils + ( pkgSpecificRevision , pkgLatestCabalFileText, pkgLatestUploadInfo ) import Distribution.Server.Packages.Metadata @@ -41,7 +43,6 @@ import Data.SafeCopy (base, deriveSafeCopy) import Data.Map (Map) import qualified Data.Map as Map -import qualified Data.Vector as Vec import Data.ByteString.Lazy (LazyByteString, fromStrict) import System.FilePath.Posix import Data.Maybe (mapMaybe) diff --git a/src/Distribution/Server/Packages/Metadata.hs b/src/Distribution/Server/Packages/Metadata.hs index 11239225b..67ad619bf 100644 --- a/src/Distribution/Server/Packages/Metadata.hs +++ b/src/Distribution/Server/Packages/Metadata.hs @@ -5,13 +5,13 @@ module Distribution.Server.Packages.Metadata ( ) where -- Standard libraries -import qualified Data.Vector as Vec import qualified Data.ByteString.Lazy as BS.Lazy -- Hackage import Distribution.Server.Features.Security.FileInfo import Distribution.Server.Features.Security.Layout import Distribution.Server.Packages.Types +import Distribution.Server.Packages.Utils -- Cabal import Distribution.Package diff --git a/src/Distribution/Server/Packages/Render.hs b/src/Distribution/Server/Packages/Render.hs index 83eed1675..8f10e20e2 100644 --- a/src/Distribution/Server/Packages/Render.hs +++ b/src/Distribution/Server/Packages/Render.hs @@ -21,7 +21,6 @@ import Control.Arrow ((&&&), (***)) import Data.Char (toLower, isSpace) import qualified Data.Map as Map import qualified Data.Set as Set -import qualified Data.Vector as Vec import Data.List (intercalate) import Data.Time.Clock (UTCTime) import System.FilePath.Posix ((), (<.>)) @@ -47,6 +46,7 @@ import Distribution.Types.LibraryVisibility (LibraryVisibility(LibraryVisibility -- hackage-server import Distribution.Server.Framework.CacheControl (ETag) import Distribution.Server.Packages.Types +import Distribution.Server.Packages.Utils import Distribution.Server.Packages.ModuleForest import qualified Distribution.Server.Users.Users as Users import Distribution.Server.Users.Types diff --git a/src/Distribution/Server/Packages/Types.hs b/src/Distribution/Server/Packages/Types.hs index 9da48e183..3e6025e75 100644 --- a/src/Distribution/Server/Packages/Types.hs +++ b/src/Distribution/Server/Packages/Types.hs @@ -32,10 +32,6 @@ import qualified Distribution.Server.Framework.BlobStorage as BlobStorage import Distribution.Package ( PackageIdentifier(..), Package(..) ) -import Distribution.PackageDescription - ( GenericPackageDescription(..)) -import Distribution.PackageDescription.Parsec - ( parseGenericPackageDescription, runParseResult ) import Data.Aeson (ToJSON) import Data.Serialize (Serialize) @@ -181,93 +177,6 @@ instance SafeCopy TarballRevIx where cabalFileString :: CabalFileText -> String cabalFileString = unpackUTF8Strict . cabalFileByteString -pkgOriginalRevision :: PkgInfo -> (CabalFileText, UploadInfo) -pkgOriginalRevision = Vec.head . pkgMetadataRevisions - -pkgOriginalUploadInfo :: PkgInfo -> UploadInfo -pkgOriginalUploadInfo = snd . pkgOriginalRevision - -pkgOriginalUploadTime :: PkgInfo -> UTCTime -pkgOriginalUploadTime = fst . pkgOriginalUploadInfo - -pkgOriginalUploadUser :: PkgInfo -> UserId -pkgOriginalUploadUser = snd . pkgOriginalUploadInfo - -pkgLatestRevision :: PkgInfo -> (CabalFileText, UploadInfo) -pkgLatestRevision = Vec.last . pkgMetadataRevisions - -pkgSpecificRevision :: PkgInfo -> MetadataRevIx -> Maybe (CabalFileText, UploadInfo) -pkgSpecificRevision pkg (MetadataRevIx revno) = pkgMetadataRevisions pkg Vec.!? revno - -pkgAllRevisionsCabalFiles :: PkgInfo -> [CabalFileText] -pkgAllRevisionsCabalFiles = fmap fst . Vec.toList . pkgMetadataRevisions - -pkgSpecificTarball :: PkgInfo -> TarballRevIx -> Maybe (PkgTarball, UploadInfo) -pkgSpecificTarball pkg (TarballRevIx revno) = pkgTarballRevisions pkg Vec.!? revno - -pkgAllTarballs :: PkgInfo -> [(PkgTarball, UploadInfo)] -pkgAllTarballs = Vec.toList . pkgTarballRevisions - -pkgAllRevisionsUploadInfos :: PkgInfo -> [UploadInfo] -pkgAllRevisionsUploadInfos = fmap snd . Vec.toList . pkgMetadataRevisions - -pkgLatestCabalFileText :: PkgInfo -> CabalFileText -pkgLatestCabalFileText = fst . pkgLatestRevision - -pkgLatestUploadInfo :: PkgInfo -> UploadInfo -pkgLatestUploadInfo = snd . pkgLatestRevision - -pkgLatestUploadTime :: PkgInfo -> UTCTime -pkgLatestUploadTime = fst . pkgLatestUploadInfo - -pkgLatestUploadUser :: PkgInfo -> UserId -pkgLatestUploadUser = snd . pkgLatestUploadInfo - -pkgNumRevisions :: PkgInfo -> Int -pkgNumRevisions = Vec.length . pkgMetadataRevisions - -pkgMaxRevision :: PkgInfo -> MetadataRevIx -pkgMaxRevision = MetadataRevIx . subtract 1 . pkgNumRevisions - --- | The latest tarball for a package (if any) --- --- For packages with a @.cabal@ file but no tarball we return 'Nothing'. --- For other package we return the latest tarball, corresponding upload info --- and revision number. The revision number will normally be 1, but may be --- higher if more tarballs were uploaded for this package (on the central --- Hackage server we disallow this). -pkgLatestTarball :: PkgInfo -> Maybe (PkgTarball, UploadInfo, Int) -pkgLatestTarball pkginfo = - if Vec.null tarballs - then Nothing - else let (tarball, uploadInfo) = Vec.last tarballs - in Just (tarball, uploadInfo, Vec.length tarballs - 1) - where - tarballs = pkgTarballRevisions pkginfo - --- | The information held in a parsed .cabal file (used by cabal-install) -pkgDesc :: PkgInfo -> GenericPackageDescription -pkgDesc pkgInfo = - case runParseResult $ parseGenericPackageDescription $ - cabalFileByteString $ fst $ - pkgLatestRevision pkgInfo of - -- We only make PkgInfos with parsable pkgDatas, so if it - -- doesn't parse then something has gone wrong. - (_, Left (_,es)) -> error ("Internal error: " ++ show es) - (_, Right x) -> x - --- | The information held in a parsed .cabal file, with nicer failure -pkgDescMaybe :: PkgInfo -> Maybe GenericPackageDescription -pkgDescMaybe pkgInfo = - case runParseResult $ parseGenericPackageDescription $ - cabalFileByteString $ fst $ - pkgLatestRevision pkgInfo of - -- We only make PkgInfos with parsable pkgDatas, so if it - -- doesn't parse then something has gone wrong. - (_, Left (_, _es)) -> Nothing - (_, Right x) -> Just x - - blobInfoFromBS :: BlobId -> LazyByteString -> BlobInfo blobInfoFromBS blobId bs = BlobInfo { blobInfoId = blobId diff --git a/src/Distribution/Server/Packages/Utils.hs b/src/Distribution/Server/Packages/Utils.hs new file mode 100644 index 000000000..a6966c125 --- /dev/null +++ b/src/Distribution/Server/Packages/Utils.hs @@ -0,0 +1,100 @@ +module Distribution.Server.Packages.Utils where + +import Distribution.Server.Packages.Types + +import Distribution.Server.Users.Types (UserId(..)) + +import Distribution.PackageDescription + ( GenericPackageDescription(..)) +import Distribution.PackageDescription.Parsec + ( parseGenericPackageDescription, runParseResult ) + +import Data.Time.Clock (UTCTime(..)) +import qualified Data.Vector as Vec + +pkgOriginalRevision :: PkgInfo -> (CabalFileText, OldUploadInfo) +pkgOriginalRevision = Vec.head . pkgMetadataRevisions + +pkgOriginalUploadInfo :: PkgInfo -> OldUploadInfo +pkgOriginalUploadInfo = snd . pkgOriginalRevision + +pkgOriginalUploadTime :: PkgInfo -> UTCTime +pkgOriginalUploadTime = fst . pkgOriginalUploadInfo + +pkgOriginalUploadUser :: PkgInfo -> UserId +pkgOriginalUploadUser = snd . pkgOriginalUploadInfo + +pkgLatestRevision :: PkgInfo -> (CabalFileText, OldUploadInfo) +pkgLatestRevision = Vec.last . pkgMetadataRevisions + +pkgSpecificRevision :: PkgInfo -> MetadataRevIx -> Maybe (CabalFileText, OldUploadInfo) +pkgSpecificRevision pkg (MetadataRevIx revno) = pkgMetadataRevisions pkg Vec.!? revno + +pkgAllRevisionsCabalFiles :: PkgInfo -> [CabalFileText] +pkgAllRevisionsCabalFiles = fmap fst . Vec.toList . pkgMetadataRevisions + +pkgSpecificTarball :: PkgInfo -> TarballRevIx -> Maybe (PkgTarball, OldUploadInfo) +pkgSpecificTarball pkg (TarballRevIx revno) = pkgTarballRevisions pkg Vec.!? revno + +pkgAllTarballs :: PkgInfo -> [(PkgTarball, OldUploadInfo)] +pkgAllTarballs = Vec.toList . pkgTarballRevisions + +pkgAllRevisionsUploadInfos :: PkgInfo -> [OldUploadInfo] +pkgAllRevisionsUploadInfos = fmap snd . Vec.toList . pkgMetadataRevisions + +pkgLatestCabalFileText :: PkgInfo -> CabalFileText +pkgLatestCabalFileText = fst . pkgLatestRevision + +pkgLatestUploadInfo :: PkgInfo -> OldUploadInfo +pkgLatestUploadInfo = snd . pkgLatestRevision + +pkgLatestUploadTime :: PkgInfo -> UTCTime +pkgLatestUploadTime = fst . pkgLatestUploadInfo + +pkgLatestUploadUser :: PkgInfo -> UserId +pkgLatestUploadUser = snd . pkgLatestUploadInfo + +pkgNumRevisions :: PkgInfo -> Int +pkgNumRevisions = Vec.length . pkgMetadataRevisions + +pkgMaxRevision :: PkgInfo -> MetadataRevIx +pkgMaxRevision = MetadataRevIx . subtract 1 . pkgNumRevisions + +-- | The latest tarball for a package (if any) +-- +-- For packages with a @.cabal@ file but no tarball we return 'Nothing'. +-- For other package we return the latest tarball, corresponding upload info +-- and revision number. The revision number will normally be 1, but may be +-- higher if more tarballs were uploaded for this package (on the central +-- Hackage server we disallow this). +pkgLatestTarball :: PkgInfo -> Maybe (PkgTarball, OldUploadInfo, Int) +pkgLatestTarball pkginfo = + if Vec.null tarballs + then Nothing + else let (tarball, uploadInfo) = Vec.last tarballs + in Just (tarball, uploadInfo, Vec.length tarballs - 1) + where + tarballs = pkgTarballRevisions pkginfo + +-- | The information held in a parsed .cabal file (used by cabal-install) +pkgDesc :: PkgInfo -> GenericPackageDescription +pkgDesc pkgInfo = + case runParseResult $ parseGenericPackageDescription $ + cabalFileByteString $ fst $ + pkgLatestRevision pkgInfo of + -- We only make PkgInfos with parsable pkgDatas, so if it + -- doesn't parse then something has gone wrong. + (_, Left (_,es)) -> error ("Internal error: " ++ show es) + (_, Right x) -> x + +-- | The information held in a parsed .cabal file, with nicer failure +pkgDescMaybe :: PkgInfo -> Maybe GenericPackageDescription +pkgDescMaybe pkgInfo = + case runParseResult $ parseGenericPackageDescription $ + cabalFileByteString $ fst $ + pkgLatestRevision pkgInfo of + -- We only make PkgInfos with parsable pkgDatas, so if it + -- doesn't parse then something has gone wrong. + (_, Left (_, _es)) -> Nothing + (_, Right x) -> Just x + diff --git a/src/Distribution/Server/Pages/Index.hs b/src/Distribution/Server/Pages/Index.hs index c4148f6d4..2085ba277 100644 --- a/src/Distribution/Server/Pages/Index.hs +++ b/src/Distribution/Server/Pages/Index.hs @@ -11,6 +11,7 @@ import Distribution.PackageDescription.Configuration ( flattenPackageDescription ) import qualified Distribution.Server.Packages.PackageIndex as PackageIndex import Distribution.Server.Packages.Types +import Distribution.Server.Packages.Utils import Distribution.Simple.Utils (comparing, equating) import Distribution.ModuleName (toFilePath) import Distribution.Text (display) diff --git a/src/Distribution/Server/Pages/PackageFromTemplate.hs b/src/Distribution/Server/Pages/PackageFromTemplate.hs index d1b919857..954c1135a 100644 --- a/src/Distribution/Server/Pages/PackageFromTemplate.hs +++ b/src/Distribution/Server/Pages/PackageFromTemplate.hs @@ -17,6 +17,7 @@ import Distribution.Server.Packages.Render import qualified Distribution.Server.Packages.PackageIndex as PackageIndex import Distribution.Server.Packages.PackageIndex (PackageIndex) import Distribution.Server.Packages.Types +import Distribution.Server.Packages.Utils import Distribution.Server.Features.PackageCandidates import Distribution.Server.Users.Types (UserInfo, userStatus, userName, isActiveAccount) import Distribution.Server.Util.Markdown (renderMarkdown, supposedToBeMarkdown) diff --git a/src/Distribution/Server/Pages/Recent.hs b/src/Distribution/Server/Pages/Recent.hs index ac60f89af..5264a647a 100644 --- a/src/Distribution/Server/Pages/Recent.hs +++ b/src/Distribution/Server/Pages/Recent.hs @@ -9,6 +9,7 @@ module Distribution.Server.Pages.Recent ( ) where import Distribution.Server.Packages.Types +import Distribution.Server.Packages.Utils import qualified Distribution.Server.Users.Users as Users import Distribution.Server.Users.Users (Users) import Distribution.Server.Pages.Template @@ -58,7 +59,7 @@ recentPage conf users pkgs = pageSizeForm :: URL -> Html -pageSizeForm base = +pageSizeForm base = let pageSizeLabel = XHtml.label ! [XHtml.thefor "pageSize"] << "Page Size: " pageSizeInput = XHtml.input ! [XHtml.thetype "number", XHtml.name "pageSize", XHtml.strAttr "min" "0"] submitButton = XHtml.button ! [XHtml.thetype "submit"] << "Submit" @@ -66,20 +67,20 @@ pageSizeForm base = in theForm << (pageSizeLabel <> pageSizeInput <> submitButton) -paginator :: PaginatedConfiguration -> URL -> Html -paginator pc@PaginatedConfiguration{currPage} baseUrl = - let +paginator :: PaginatedConfiguration -> URL -> Html +paginator pc@PaginatedConfiguration{currPage} baseUrl = + let info = XHtml.thediv << pagingInfo pc - next = XHtml.anchor ! [XHtml.href (fromMaybe "" (nextURL baseUrl pc)) | hasNext pc] << "Next" + next = XHtml.anchor ! [XHtml.href (fromMaybe "" (nextURL baseUrl pc)) | hasNext pc] << "Next" prev = XHtml.anchor ! [XHtml.href (fromMaybe "" (prevURL baseUrl pc)) | hasPrev pc] << "Previous" - + pagedURLS = zip [1..] (allPagedURLs baseUrl pc) - pagedLinks = (\(x,y) -> XHtml.anchor ! [XHtml.href y, + pagedLinks = (\(x,y) -> XHtml.anchor ! [XHtml.href y, if currPage == x then XHtml.theclass "current" else noAttr ] << show x) <$> pagedURLS - wrapper = XHtml.thediv ! [XHtml.theclass "paginator"] << + wrapper = XHtml.thediv ! [XHtml.theclass "paginator"] << (prev <> reducePagedLinks pc pagedLinks <> next) @@ -100,10 +101,10 @@ reducePagedLinks PaginatedConfiguration{currPage} xs fillLast x = insertAt (pred . length $ x) filler x keepFirstPages x = case splitAt (length x - 2) x of (hts, hts') -> take 5 hts ++ hts' keepLastPages x = case splitAt 2 x of (hts, hts') -> hts ++ takeLast 5 hts' - keepMiddlePages x = - case splitAt currPage x of (hts, hts') -> take 2 hts ++ [last hts] ++ take 2 hts' + keepMiddlePages x = + case splitAt currPage x of (hts, hts') -> take 2 hts ++ [last hts] ++ take 2 hts' ++ takeLast 2 hts' - + insertAt :: Int -> a -> [a] -> [a] insertAt n a x = case splitAt n x of (hts, hts') -> hts ++ [a] ++ hts' @@ -217,7 +218,7 @@ recentRevisionsFeed conf users hostURI now pkgs = RSS updated = maybe now (fst . pkgOriginalUploadInfo) (listToMaybe pkgList) channel :: UTCTime -> [RSS.ChannelElem] -channel updated = +channel updated = [ RSS.Language "en" , RSS.ManagingEditor email , RSS.WebMaster email From 1600c667bf78460d154927adcd549ff616c6169b Mon Sep 17 00:00:00 2001 From: Sandy Maguire Date: Mon, 4 May 2026 10:00:38 -0700 Subject: [PATCH 02/12] Rename UploadInfo --- src/Distribution/Server/Features/Core.hs | 14 +++++----- .../Server/Features/Core/Backup.hs | 28 +++++++++---------- .../Server/Features/Core/State.hs | 18 ++++++------ src/Distribution/Server/Features/Html.hs | 2 +- .../Server/Features/UserNotify/Types.hs | 4 +-- src/Distribution/Server/Packages/Types.hs | 16 +++++------ 6 files changed, 41 insertions(+), 41 deletions(-) diff --git a/src/Distribution/Server/Features/Core.hs b/src/Distribution/Server/Features/Core.hs index e91dc756d..4b9755465 100644 --- a/src/Distribution/Server/Features/Core.hs +++ b/src/Distribution/Server/Features/Core.hs @@ -89,7 +89,7 @@ data CoreFeature = CoreFeature { -- If a package was able to be newly added, runs a `PackageChangeAdd` hook -- when done and returns True. updateAddPackage :: forall m. MonadIO m => PackageId -> - CabalFileText -> UploadInfo -> + CabalFileText -> OldUploadInfo -> Maybe PkgTarball -> m Bool, -- | Deletes a version of an existing package, deleting the package if it -- was the last version. @@ -104,14 +104,14 @@ data CoreFeature = CoreFeature { -- Runs either a `PackageChangeAdd` or `PackageChangeInfo` hook, depending -- on whether a package with the given version already existed. updateAddPackageRevision :: forall m. MonadIO m => PackageId -> - CabalFileText -> UploadInfo -> m (), + CabalFileText -> OldUploadInfo -> m (), -- | Sets the source tarball for an existing package version. References to -- previous tarballs, if any, are kept around. -- -- If this package was found, runs a `PackageChangeInfo` hook when done and -- returns True. updateAddPackageTarball :: forall m. MonadIO m => PackageId -> - PkgTarball -> UploadInfo -> m Bool, + PkgTarball -> OldUploadInfo -> m Bool, -- | Sets the uploader of an existing package version. -- -- If this package was found, runs a `PackageChangeInfo` hook when done and @@ -211,7 +211,7 @@ isPackageIndexChange = Just isPackageAddVersion :: Maybe PackageId, isPackageDeleteVersion :: Maybe PackageId, isPackageChangeCabalFile :: Maybe (PackageId, CabalFileText), -isPackageChangeCabalFileUploadInfo :: Maybe (PackageId, UploadInfo), +isPackageChangeCabalFileUploadInfo :: Maybe (PackageId, OldUploadInfo), isPackageChangeTarball :: Maybe (PackageId, PkgTarball), isPackageIndexExtraChange :: Maybe (String, LazyByteString, UTCTime) -} @@ -518,7 +518,7 @@ coreFeature ServerEnv{serverBlobStore = store} UserFeature{..} -- Update transactions -- updateAddPackage :: MonadIO m => PackageId - -> CabalFileText -> UploadInfo + -> CabalFileText -> OldUploadInfo -> Maybe PkgTarball -> m Bool updateAddPackage pkgid cabalFile uploadinfo@(_, uid) mtarball = logTiming maxBound ("updateAddPackage " ++ display pkgid) $ do usersdb <- queryGetUserDb @@ -549,7 +549,7 @@ coreFeature ServerEnv{serverBlobStore = store} UserFeature{..} runHook_ packageChangeHook (PackageChangeDelete pkginfo) return True - updateAddPackageRevision :: MonadIO m => PackageId -> CabalFileText -> UploadInfo -> m () + updateAddPackageRevision :: MonadIO m => PackageId -> CabalFileText -> OldUploadInfo -> m () updateAddPackageRevision pkgid cabalfile uploadinfo@(_, uid) = logTiming maxBound ("updateAddPackageRevision " ++ display pkgid) $ do usersdb <- queryGetUserDb let Just userInfo = lookupUserId uid usersdb @@ -566,7 +566,7 @@ coreFeature ServerEnv{serverBlobStore = store} UserFeature{..} Just oldpkginfo -> runHook_ packageChangeHook (PackageChangeInfo PackageUpdatedCabalFile oldpkginfo newpkginfo) - updateAddPackageTarball :: MonadIO m => PackageId -> PkgTarball -> UploadInfo -> m Bool + updateAddPackageTarball :: MonadIO m => PackageId -> PkgTarball -> OldUploadInfo -> m Bool updateAddPackageTarball pkgid tarball uploadinfo = logTiming maxBound ("updateAddPackageTarball " ++ display pkgid) $ do mpkginfo <- updateState packagesState (Acid.AddPackageTarball pkgid tarball uploadinfo) diff --git a/src/Distribution/Server/Features/Core/Backup.hs b/src/Distribution/Server/Features/Core/Backup.hs index 0fc1b6c45..3fbe418c0 100644 --- a/src/Distribution/Server/Features/Core/Backup.hs +++ b/src/Distribution/Server/Features/Core/Backup.hs @@ -65,9 +65,9 @@ data PartialIndex = PartialIndex !(Map PackageId PartialPkg) data PartialPkg = PartialPkg { partialCabal :: [(Int, CabalFileText)], - partialCabalUpload :: [(Int, UploadInfo)], + partialCabalUpload :: [(Int, OldUploadInfo)], partialTarball :: [(Int, (FilePath, BlobId))], - partialTarballUpload :: [(Int, (UploadInfo, Maybe TarballInfo))] + partialTarballUpload :: [(Int, (OldUploadInfo, Maybe TarballInfo))] } data TarballInfo = TarballInfo { @@ -132,11 +132,11 @@ parsePackageId pkgStr = case simpleParse pkgStr of Nothing -> fail $ "Package directory " ++ show pkgStr ++ " isn't a valid package id" Just pkgId -> return pkgId -importCabalMetadata :: [String] -> CSV -> Restore [(Int, UploadInfo)] +importCabalMetadata :: [String] -> CSV -> Restore [(Int, OldUploadInfo)] importCabalMetadata _fp (_versionStr:_headers:body) = mapM fromRecord body where - fromRecord :: Record -> Restore (Int, UploadInfo) + fromRecord :: Record -> Restore (Int, OldUploadInfo) fromRecord [strIndex, strTime, strUser] = do index <- parseRead "index" strIndex utcTime <- parseUTCTime "time" strTime @@ -146,14 +146,14 @@ importCabalMetadata _fp (_versionStr:_headers:body) = importCabalMetadata fp _ = fail $ "Invalid cabal metadata in " ++ foldr1 () fp -importTarballMetadata :: [String] -> CSV -> Restore [(Int, (UploadInfo, Maybe TarballInfo))] +importTarballMetadata :: [String] -> CSV -> Restore [(Int, (OldUploadInfo, Maybe TarballInfo))] importTarballMetadata _fp ([strVersion]:_headers:body) = do version <- parseVersion "CSV version header" strVersion if version >= Version [0,2] [] then mapM fromRecord_v2 body else mapM fromRecord_v1 body where - fromRecord_v2 :: Record -> Restore (Int, (UploadInfo, Maybe TarballInfo)) + fromRecord_v2 :: Record -> Restore (Int, (OldUploadInfo, Maybe TarballInfo)) fromRecord_v2 [strIndex, strTime, strUser, strTarGzMD5, strTarGzLen, strTarGzSHA256, strTarMD5] = do index <- parseRead "index" strIndex utcTime <- parseUTCTime "time" strTime @@ -165,7 +165,7 @@ importTarballMetadata _fp ([strVersion]:_headers:body) = do return (index, ((utcTime, user), Just TarballInfo{..})) fromRecord_v2 x = fail $ "Error processing versions list: " ++ show x - fromRecord_v1 :: Record -> Restore (Int, (UploadInfo, Maybe TarballInfo)) + fromRecord_v1 :: Record -> Restore (Int, (OldUploadInfo, Maybe TarballInfo)) fromRecord_v1 [strIndex, strTime, strUser] = do index <- parseRead "index" strIndex utcTime <- parseUTCTime "time" strTime @@ -208,10 +208,10 @@ partialToFullPkg (pkgId, PartialPkg{..}) = do pkgTarballRevisions = Vec.fromList tarballRevisions } where - combineCabal :: CabalFileText -> UploadInfo -> Restore (CabalFileText, UploadInfo) + combineCabal :: CabalFileText -> OldUploadInfo -> Restore (CabalFileText, OldUploadInfo) combineCabal cabalFile uploadInfo = return (cabalFile, uploadInfo) - combineTarball :: (FilePath, BlobId) -> (UploadInfo, Maybe TarballInfo) -> Restore (PkgTarball, UploadInfo) + combineTarball :: (FilePath, BlobId) -> (OldUploadInfo, Maybe TarballInfo) -> Restore (PkgTarball, OldUploadInfo) combineTarball (filename, blobId) (uploadInfo, Just TarballInfo{..}) = do pkgTarballGz <- -- If the blob ID of the restored file matches the one in the metadata, @@ -281,7 +281,7 @@ partialToFullPkg (pkgId, PartialPkg{..}) = do fail $ "Upload log entry for " ++ item ++ " (index " ++ show (fst y) ++") found, but file itself missing" - sortByUploadTimes :: [(a, UploadInfo)] -> [(a, UploadInfo)] + sortByUploadTimes :: [(a, OldUploadInfo)] -> [(a, OldUploadInfo)] sortByUploadTimes = sortBy (comparing (fst . snd)) -- Workaround: in zlib prior to 0.5.4.1, GZip.decompress would not fully @@ -313,7 +313,7 @@ infoToAllEntries pkg = in cabals ++ tarballs ----------- Converting pieces of PkgInfo to entries -cabalListToExport :: PackageId -> [(CabalFileText, UploadInfo)] -> [BackupEntry] +cabalListToExport :: PackageId -> [(CabalFileText, OldUploadInfo)] -> [BackupEntry] cabalListToExport pkgId cabalInfos = csvToBackup (pkgPath pkgId "uploads.csv") cabalMetadata : map blobEntry (zip [0..] cabals) @@ -334,14 +334,14 @@ cabalListToExport pkgId cabalInfos = versionCSVVer = Version [0,1] ["unstable"] versionCSVKey = ["index", "time", "user-id"] - metadataEntry :: (Int, UploadInfo) -> Record + metadataEntry :: (Int, OldUploadInfo) -> Record metadataEntry (index, (time, user)) = [ show (index :: Int) , formatUTCTime time , display user ] -tarballListToExport :: PackageId -> [(PkgTarball, UploadInfo)] -> [BackupEntry] +tarballListToExport :: PackageId -> [(PkgTarball, OldUploadInfo)] -> [BackupEntry] tarballListToExport pkgId tarballInfos = csvToBackup (pkgPath pkgId "tarball.csv") tarballMetadata : map blobEntry (zip [0..] (map fst tarballInfos)) @@ -372,7 +372,7 @@ tarballListToExport pkgId tarballInfos = , "tar-md5" ] - metadataEntry :: (Int, (TarballInfo, UploadInfo)) -> Record + metadataEntry :: (Int, (TarballInfo, OldUploadInfo)) -> Record metadataEntry (index, (TarballInfo{..}, (time, user))) = [ show (index :: Int) , formatUTCTime time diff --git a/src/Distribution/Server/Features/Core/State.hs b/src/Distribution/Server/Features/Core/State.hs index 275371cd3..424039efd 100644 --- a/src/Distribution/Server/Features/Core/State.hs +++ b/src/Distribution/Server/Features/Core/State.hs @@ -89,14 +89,14 @@ initialPackagesState freshDB = PackagesState { } -- old v0 transaction -addPackage :: PackageId -> CabalFileText -> UploadInfo +addPackage :: PackageId -> CabalFileText -> OldUploadInfo -> Maybe PkgTarball -> Update PackagesState (Maybe PkgInfo) addPackage pkgid cabalfile uploadinfo mtarball = addPackage2 pkgid cabalfile uploadinfo (UserName "") mtarball -- v1 transaction (adds username) -addPackage2 :: PackageId -> CabalFileText -> UploadInfo -> UserName +addPackage2 :: PackageId -> CabalFileText -> OldUploadInfo -> UserName -> Maybe PkgTarball -> Update PackagesState (Maybe PkgInfo) addPackage2 pkgid cabalfile uploadinfo@(timestamp, uid) username mtarball = do @@ -112,7 +112,7 @@ addPackage2 pkgid cabalfile uploadinfo@(timestamp, uid) username mtarball = do return (Just pkginfo) -- current transaction (takes tar index entries as well) -addPackage3 :: PkgInfo -> UploadInfo -> UserName -> [TarIndexEntry] -> Update PackagesState Bool +addPackage3 :: PkgInfo -> OldUploadInfo -> UserName -> [TarIndexEntry] -> Update PackagesState Bool addPackage3 !pkginfo (timestamp,uid) username entries = do PackagesState pkgindex updatelog <- State.get case PackageIndex.lookupPackageId pkgindex (pkgInfoId pkginfo) of @@ -124,7 +124,7 @@ addPackage3 !pkginfo (timestamp,uid) username entries = do State.put $! PackagesState pkgindex' updatelog' return True -mkPackageInfo :: PackageIdentifier -> CabalFileText -> UploadInfo -> Maybe PkgTarball -> PkgInfo +mkPackageInfo :: PackageIdentifier -> CabalFileText -> OldUploadInfo -> Maybe PkgTarball -> PkgInfo mkPackageInfo pkgid cabalfile uploadinfo mtarball = PkgInfo { pkgInfoId = pkgid, @@ -147,12 +147,12 @@ deletePackage pkgid = do State.put $! PackagesState pkgindex' updatelog return (Just pkginfo) -addPackageRevision :: PackageId -> CabalFileText -> UploadInfo +addPackageRevision :: PackageId -> CabalFileText -> OldUploadInfo -> Update PackagesState (Maybe PkgInfo, PkgInfo) addPackageRevision pkgid cabalfile uploadinfo = addPackageRevision2 pkgid cabalfile uploadinfo (UserName "") -addPackageRevision2 :: PackageId -> CabalFileText -> UploadInfo -> UserName +addPackageRevision2 :: PackageId -> CabalFileText -> OldUploadInfo -> UserName -> Update PackagesState (Maybe PkgInfo, PkgInfo) addPackageRevision2 pkgid cabalfile uploadinfo@(timestamp, uid) username = do PackagesState pkgindex updatelog <- State.get @@ -180,7 +180,7 @@ addPackageRevision2 pkgid cabalfile uploadinfo@(timestamp, uid) username = do State.put $! PackagesState pkgindex' updatelog' return (Nothing, pkginfo) -addPackageTarball :: PackageId -> PkgTarball -> UploadInfo +addPackageTarball :: PackageId -> PkgTarball -> OldUploadInfo -> Update PackagesState (Maybe (PkgInfo, PkgInfo)) addPackageTarball pkgid tarball uploadinfo = alterPackage pkgid $ \pkginfo -> @@ -282,11 +282,11 @@ initialUpdateLog oldExtras users pkgs = where pkgId = pkgInfoId pkgInfo - entryCabal :: PackageId -> (MetadataRevIx, (a, UploadInfo)) -> TarIndexEntry + entryCabal :: PackageId -> (MetadataRevIx, (a, OldUploadInfo)) -> TarIndexEntry entryCabal pkgId (revNo, (_cabalFile, (timestamp, uid))) = CabalFileEntry pkgId revNo timestamp uid (uidToName uid) - entryTUF :: PackageId -> (TarballRevIx, (a, UploadInfo)) -> TarIndexEntry + entryTUF :: PackageId -> (TarballRevIx, (a, OldUploadInfo)) -> TarIndexEntry entryTUF pkgId (revNo, (_tarball, (timestamp, _uid))) = MetadataEntry pkgId revNo timestamp diff --git a/src/Distribution/Server/Features/Html.hs b/src/Distribution/Server/Features/Html.hs index 6252f5d82..9552022e5 100644 --- a/src/Distribution/Server/Features/Html.hs +++ b/src/Distribution/Server/Features/Html.hs @@ -836,7 +836,7 @@ mkHtmlCore ServerEnv{serverBaseURI, serverBlobStore} revchanges ] where - revisionToTemplate :: Users.Users -> UploadInfo -> Int + revisionToTemplate :: Users.Users -> OldUploadInfo -> Int -> (SHA256Digest, [Change]) -> TemplateVal revisionToTemplate users (utime, uid) revision (sha256hash, changes) = diff --git a/src/Distribution/Server/Features/UserNotify/Types.hs b/src/Distribution/Server/Features/UserNotify/Types.hs index f6c172a02..bf22443e0 100644 --- a/src/Distribution/Server/Features/UserNotify/Types.hs +++ b/src/Distribution/Server/Features/UserNotify/Types.hs @@ -10,7 +10,7 @@ import Distribution.Pretty import Distribution.Server.Features.Tags.Types import Distribution.Server.Framework -import Distribution.Server.Packages.Types (UploadInfo, PkgInfo) +import Distribution.Server.Packages.Types (OldUploadInfo, PkgInfo) import Distribution.Server.Users.Types (UserId) import Data.Aeson.TH (defaultOptions, deriveJSON) @@ -62,7 +62,7 @@ data Notification } | NotifyNewRevision { notifyPackageId :: PackageId - , notifyRevisions :: [UploadInfo] + , notifyRevisions :: [OldUploadInfo] } | NotifyMaintainerUpdate { notifyMaintainerUpdateType :: NotifyMaintainerUpdateType diff --git a/src/Distribution/Server/Packages/Types.hs b/src/Distribution/Server/Packages/Types.hs index 3e6025e75..1f69445e4 100644 --- a/src/Distribution/Server/Packages/Types.hs +++ b/src/Distribution/Server/Packages/Types.hs @@ -63,7 +63,7 @@ data PkgInfo = PkgInfo { -- | The .cabal file text. This includes all revisions, indexed from the -- original vision (revision 0). This is always non-empty. -- - pkgMetadataRevisions :: !(Vec.Vector (CabalFileText, UploadInfo)), + pkgMetadataRevisions :: !(Vec.Vector (CabalFileText, OldUploadInfo)), -- | The package .tar.gz file. This includes all revisions but is typically -- of length 1. It can be empty (to allow a multi-stage upload process, or @@ -71,22 +71,22 @@ data PkgInfo = PkgInfo { -- of just the latest packages). The representation allows multiple versions -- but the normal policy is not to allow replacing the tarball. -- - pkgTarballRevisions :: !(Vec.Vector (PkgTarball, UploadInfo)) + pkgTarballRevisions :: !(Vec.Vector (PkgTarball, OldUploadInfo)) } deriving (Eq, Show) data PkgInfo_v2 = PkgInfo_v2 { v2_pkgInfoId :: !PackageIdentifier, - v2_pkgMetadataRevisions :: !(Vec.Vector (CabalFileText, UploadInfo)), - v2_pkgTarballRevisions :: !(Vec.Vector (PkgTarball, UploadInfo)) + v2_pkgMetadataRevisions :: !(Vec.Vector (CabalFileText, OldUploadInfo)), + v2_pkgTarballRevisions :: !(Vec.Vector (PkgTarball, OldUploadInfo)) } data PkgInfo_v1 = PkgInfo_v1 { v1_pkgInfoId :: !PackageIdentifier, v1_pkgData :: !CabalFileText, - v1_pkgTarball :: ![(PkgTarball, UploadInfo)], - v1_pkgDataOld :: ![(CabalFileText, UploadInfo)], - v1_pkgUploadData :: !UploadInfo + v1_pkgTarball :: ![(PkgTarball, OldUploadInfo)], + v1_pkgDataOld :: ![(CabalFileText, OldUploadInfo)], + v1_pkgUploadData :: !OldUploadInfo } data PkgInfo_v0 = PkgInfo_v0 !PackageIdentifier_v0 !CabalFileText @@ -121,7 +121,7 @@ data PkgTarball_v1 = PkgTarball_v1 { data PkgTarball_v0 = PkgTarball_v0 !BlobId_v0 !BlobId_v0 -type UploadInfo = (UTCTime, UserId) +type OldUploadInfo = (UTCTime, UserId) type UploadInfo_v0 = (UTCTime_v0, UserId_v0) newtype UTCTime_v0 = UTCTime_v0 UTCTime From 3a4382fdb91ebe00f8824e05150fc4382826284d Mon Sep 17 00:00:00 2001 From: Sandy Maguire Date: Mon, 4 May 2026 10:12:12 -0700 Subject: [PATCH 03/12] State should use old utils --- hackage-server.cabal | 1 + .../Server/Features/Core/State.hs | 2 +- .../Features/ReverseDependencies/State.hs | 2 +- .../Server/Packages/Utils/Acid.hs | 114 ++++++++++++++++++ 4 files changed, 117 insertions(+), 2 deletions(-) create mode 100644 src/Distribution/Server/Packages/Utils/Acid.hs diff --git a/hackage-server.cabal b/hackage-server.cabal index dcf6da947..e8ac102e7 100644 --- a/hackage-server.cabal +++ b/hackage-server.cabal @@ -256,6 +256,7 @@ library Distribution.Server.Packages.Types Distribution.Server.Packages.Unpack Distribution.Server.Packages.Utils + Distribution.Server.Packages.Utils.Acid Distribution.Server.Packages.Render Distribution.Server.Packages.ChangeLog Distribution.Server.Packages.Readme diff --git a/src/Distribution/Server/Features/Core/State.hs b/src/Distribution/Server/Features/Core/State.hs index 424039efd..649d048cb 100644 --- a/src/Distribution/Server/Features/Core/State.hs +++ b/src/Distribution/Server/Features/Core/State.hs @@ -29,7 +29,7 @@ import Distribution.Package import Distribution.Server.Packages.PackageIndex (PackageIndex) import qualified Distribution.Server.Packages.PackageIndex as PackageIndex import Distribution.Server.Packages.Types -import Distribution.Server.Packages.Utils +import Distribution.Server.Packages.Utils.Acid import Distribution.Server.Packages.Index import Distribution.Server.Users.Types (UserId, UserName(..), UserInfo(..)) import Distribution.Server.Users.Users (Users, lookupUserId) diff --git a/src/Distribution/Server/Features/ReverseDependencies/State.hs b/src/Distribution/Server/Features/ReverseDependencies/State.hs index d9832743c..4cb6156b6 100644 --- a/src/Distribution/Server/Features/ReverseDependencies/State.hs +++ b/src/Distribution/Server/Features/ReverseDependencies/State.hs @@ -46,7 +46,7 @@ import qualified Data.Graph as Gr import Distribution.Package import Distribution.PackageDescription import Distribution.Server.Packages.Types -import Distribution.Server.Packages.Utils +import Distribution.Server.Packages.Utils.Acid import Distribution.Server.Framework.MemSize import Distribution.Server.Features.PreferredVersions (maybeBestVersion) import Distribution.Server.Features.PreferredVersions.State diff --git a/src/Distribution/Server/Packages/Utils/Acid.hs b/src/Distribution/Server/Packages/Utils/Acid.hs new file mode 100644 index 000000000..1012face5 --- /dev/null +++ b/src/Distribution/Server/Packages/Utils/Acid.hs @@ -0,0 +1,114 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Server.Packages.Utils.Old +-- Copyright : (c) David Himmelstrup 2005 +-- License : BSD-like +-- +-- Maintainer : lemmih@gmail.com +-- Stability : provisional +-- Portability : portable +----------------------------------------------------------------------------- +module Distribution.Server.Packages.Utils.Acid where + +import Distribution.Server.Packages.Types + +import Distribution.Server.Users.Types (UserId(..)) +import Distribution.Server.Util.Parse (unpackUTF8Strict) + +import Distribution.PackageDescription + ( GenericPackageDescription(..)) +import Distribution.PackageDescription.Parsec + ( parseGenericPackageDescription, runParseResult ) + +import Data.Time.Clock (UTCTime(..)) +import qualified Data.Vector as Vec + +cabalFileString :: CabalFileText -> String +cabalFileString = unpackUTF8Strict . cabalFileByteString + +pkgOriginalRevision :: PkgInfo -> (CabalFileText, OldUploadInfo) +pkgOriginalRevision = Vec.head . pkgMetadataRevisions + +pkgOriginalUploadInfo :: PkgInfo -> OldUploadInfo +pkgOriginalUploadInfo = snd . pkgOriginalRevision + +pkgOriginalUploadTime :: PkgInfo -> UTCTime +pkgOriginalUploadTime = fst . pkgOriginalUploadInfo + +pkgOriginalUploadUser :: PkgInfo -> UserId +pkgOriginalUploadUser = snd . pkgOriginalUploadInfo + +pkgLatestRevision :: PkgInfo -> (CabalFileText, OldUploadInfo) +pkgLatestRevision = Vec.last . pkgMetadataRevisions + +pkgSpecificRevision :: PkgInfo -> MetadataRevIx -> Maybe (CabalFileText, OldUploadInfo) +pkgSpecificRevision pkg (MetadataRevIx revno) = pkgMetadataRevisions pkg Vec.!? revno + +pkgAllRevisionsCabalFiles :: PkgInfo -> [CabalFileText] +pkgAllRevisionsCabalFiles = fmap fst . Vec.toList . pkgMetadataRevisions + +pkgSpecificTarball :: PkgInfo -> TarballRevIx -> Maybe (PkgTarball, OldUploadInfo) +pkgSpecificTarball pkg (TarballRevIx revno) = pkgTarballRevisions pkg Vec.!? revno + +pkgAllTarballs :: PkgInfo -> [(PkgTarball, OldUploadInfo)] +pkgAllTarballs = Vec.toList . pkgTarballRevisions + +pkgAllRevisionsUploadInfos :: PkgInfo -> [OldUploadInfo] +pkgAllRevisionsUploadInfos = fmap snd . Vec.toList . pkgMetadataRevisions + +pkgLatestCabalFileText :: PkgInfo -> CabalFileText +pkgLatestCabalFileText = fst . pkgLatestRevision + +pkgLatestUploadInfo :: PkgInfo -> OldUploadInfo +pkgLatestUploadInfo = snd . pkgLatestRevision + +pkgLatestUploadTime :: PkgInfo -> UTCTime +pkgLatestUploadTime = fst . pkgLatestUploadInfo + +pkgLatestUploadUser :: PkgInfo -> UserId +pkgLatestUploadUser = snd . pkgLatestUploadInfo + +pkgNumRevisions :: PkgInfo -> Int +pkgNumRevisions = Vec.length . pkgMetadataRevisions + +pkgMaxRevision :: PkgInfo -> MetadataRevIx +pkgMaxRevision = MetadataRevIx . subtract 1 . pkgNumRevisions + +-- | The latest tarball for a package (if any) +-- +-- For packages with a @.cabal@ file but no tarball we return 'Nothing'. +-- For other package we return the latest tarball, corresponding upload info +-- and revision number. The revision number will normally be 1, but may be +-- higher if more tarballs were uploaded for this package (on the central +-- Hackage server we disallow this). +pkgLatestTarball :: PkgInfo -> Maybe (PkgTarball, OldUploadInfo, Int) +pkgLatestTarball pkginfo = + if Vec.null tarballs + then Nothing + else let (tarball, uploadInfo) = Vec.last tarballs + in Just (tarball, uploadInfo, Vec.length tarballs - 1) + where + tarballs = pkgTarballRevisions pkginfo + +-- | The information held in a parsed .cabal file (used by cabal-install) +pkgDesc :: PkgInfo -> GenericPackageDescription +pkgDesc pkgInfo = + case runParseResult $ parseGenericPackageDescription $ + cabalFileByteString $ fst $ + pkgLatestRevision pkgInfo of + -- We only make PkgInfos with parsable pkgDatas, so if it + -- doesn't parse then something has gone wrong. + (_, Left (_,es)) -> error ("Internal error: " ++ show es) + (_, Right x) -> x + +-- | The information held in a parsed .cabal file, with nicer failure +pkgDescMaybe :: PkgInfo -> Maybe GenericPackageDescription +pkgDescMaybe pkgInfo = + case runParseResult $ parseGenericPackageDescription $ + cabalFileByteString $ fst $ + pkgLatestRevision pkgInfo of + -- We only make PkgInfos with parsable pkgDatas, so if it + -- doesn't parse then something has gone wrong. + (_, Left (_, _es)) -> Nothing + (_, Right x) -> Just x + From a7eed0c55b07cf204381aab45b560f39c3acbb30 Mon Sep 17 00:00:00 2001 From: Sandy Maguire Date: Mon, 4 May 2026 09:58:49 -0700 Subject: [PATCH 04/12] Better types --- src/Distribution/Server/Packages/Utils.hs | 69 ++++++++++++++--------- 1 file changed, 43 insertions(+), 26 deletions(-) diff --git a/src/Distribution/Server/Packages/Utils.hs b/src/Distribution/Server/Packages/Utils.hs index a6966c125..4f9358edf 100644 --- a/src/Distribution/Server/Packages/Utils.hs +++ b/src/Distribution/Server/Packages/Utils.hs @@ -12,47 +12,59 @@ import Distribution.PackageDescription.Parsec import Data.Time.Clock (UTCTime(..)) import qualified Data.Vector as Vec -pkgOriginalRevision :: PkgInfo -> (CabalFileText, OldUploadInfo) -pkgOriginalRevision = Vec.head . pkgMetadataRevisions +data MetadataRevision = MetadataRevision + { metaRevCabalFile :: CabalFileText + , metaRevInfo :: UploadInfo + } -pkgOriginalUploadInfo :: PkgInfo -> OldUploadInfo -pkgOriginalUploadInfo = snd . pkgOriginalRevision +data UploadInfo = UploadInfo + { uploadInfoTime :: UTCTime + , uploadInfoUser :: UserId + } + +pkgOriginalRevision :: PkgInfo -> MetadataRevision +pkgOriginalRevision = fromOldMetadataRev . Vec.head . pkgMetadataRevisions + +pkgOriginalUploadInfo :: PkgInfo -> UploadInfo +pkgOriginalUploadInfo = metaRevInfo . pkgOriginalRevision pkgOriginalUploadTime :: PkgInfo -> UTCTime -pkgOriginalUploadTime = fst . pkgOriginalUploadInfo +pkgOriginalUploadTime = uploadInfoTime . pkgOriginalUploadInfo pkgOriginalUploadUser :: PkgInfo -> UserId -pkgOriginalUploadUser = snd . pkgOriginalUploadInfo +pkgOriginalUploadUser = uploadInfoUser . pkgOriginalUploadInfo -pkgLatestRevision :: PkgInfo -> (CabalFileText, OldUploadInfo) -pkgLatestRevision = Vec.last . pkgMetadataRevisions +pkgLatestRevision :: PkgInfo -> MetadataRevision +pkgLatestRevision = fromOldMetadataRev . Vec.last . pkgMetadataRevisions -pkgSpecificRevision :: PkgInfo -> MetadataRevIx -> Maybe (CabalFileText, OldUploadInfo) -pkgSpecificRevision pkg (MetadataRevIx revno) = pkgMetadataRevisions pkg Vec.!? revno +pkgSpecificRevision :: PkgInfo -> MetadataRevIx -> Maybe MetadataRevision +pkgSpecificRevision pkg (MetadataRevIx revno) + = fmap fromOldMetadataRev + $ pkgMetadataRevisions pkg Vec.!? revno pkgAllRevisionsCabalFiles :: PkgInfo -> [CabalFileText] pkgAllRevisionsCabalFiles = fmap fst . Vec.toList . pkgMetadataRevisions -pkgSpecificTarball :: PkgInfo -> TarballRevIx -> Maybe (PkgTarball, OldUploadInfo) -pkgSpecificTarball pkg (TarballRevIx revno) = pkgTarballRevisions pkg Vec.!? revno +pkgSpecificTarball :: PkgInfo -> TarballRevIx -> Maybe (PkgTarball, UploadInfo) +pkgSpecificTarball pkg (TarballRevIx revno) = fmap (fmap fromOldUploadInfo) $ pkgTarballRevisions pkg Vec.!? revno -pkgAllTarballs :: PkgInfo -> [(PkgTarball, OldUploadInfo)] -pkgAllTarballs = Vec.toList . pkgTarballRevisions +pkgAllTarballs :: PkgInfo -> [(PkgTarball, UploadInfo)] +pkgAllTarballs = fmap (fmap fromOldUploadInfo) . Vec.toList . pkgTarballRevisions -pkgAllRevisionsUploadInfos :: PkgInfo -> [OldUploadInfo] -pkgAllRevisionsUploadInfos = fmap snd . Vec.toList . pkgMetadataRevisions +pkgAllRevisionsUploadInfos :: PkgInfo -> [UploadInfo] +pkgAllRevisionsUploadInfos = fmap (fromOldUploadInfo . snd) . Vec.toList . pkgMetadataRevisions pkgLatestCabalFileText :: PkgInfo -> CabalFileText -pkgLatestCabalFileText = fst . pkgLatestRevision +pkgLatestCabalFileText = metaRevCabalFile . pkgLatestRevision -pkgLatestUploadInfo :: PkgInfo -> OldUploadInfo -pkgLatestUploadInfo = snd . pkgLatestRevision +pkgLatestUploadInfo :: PkgInfo -> UploadInfo +pkgLatestUploadInfo = metaRevInfo . pkgLatestRevision pkgLatestUploadTime :: PkgInfo -> UTCTime -pkgLatestUploadTime = fst . pkgLatestUploadInfo +pkgLatestUploadTime = uploadInfoTime . pkgLatestUploadInfo pkgLatestUploadUser :: PkgInfo -> UserId -pkgLatestUploadUser = snd . pkgLatestUploadInfo +pkgLatestUploadUser = uploadInfoUser . pkgLatestUploadInfo pkgNumRevisions :: PkgInfo -> Int pkgNumRevisions = Vec.length . pkgMetadataRevisions @@ -67,12 +79,12 @@ pkgMaxRevision = MetadataRevIx . subtract 1 . pkgNumRevisions -- and revision number. The revision number will normally be 1, but may be -- higher if more tarballs were uploaded for this package (on the central -- Hackage server we disallow this). -pkgLatestTarball :: PkgInfo -> Maybe (PkgTarball, OldUploadInfo, Int) +pkgLatestTarball :: PkgInfo -> Maybe (PkgTarball, UploadInfo, Int) pkgLatestTarball pkginfo = if Vec.null tarballs then Nothing - else let (tarball, uploadInfo) = Vec.last tarballs - in Just (tarball, uploadInfo, Vec.length tarballs - 1) + else let (tarball, (when, who)) = Vec.last tarballs + in Just (tarball, UploadInfo when who, Vec.length tarballs - 1) where tarballs = pkgTarballRevisions pkginfo @@ -80,7 +92,7 @@ pkgLatestTarball pkginfo = pkgDesc :: PkgInfo -> GenericPackageDescription pkgDesc pkgInfo = case runParseResult $ parseGenericPackageDescription $ - cabalFileByteString $ fst $ + cabalFileByteString $ metaRevCabalFile $ pkgLatestRevision pkgInfo of -- We only make PkgInfos with parsable pkgDatas, so if it -- doesn't parse then something has gone wrong. @@ -91,10 +103,15 @@ pkgDesc pkgInfo = pkgDescMaybe :: PkgInfo -> Maybe GenericPackageDescription pkgDescMaybe pkgInfo = case runParseResult $ parseGenericPackageDescription $ - cabalFileByteString $ fst $ + cabalFileByteString $ metaRevCabalFile $ pkgLatestRevision pkgInfo of -- We only make PkgInfos with parsable pkgDatas, so if it -- doesn't parse then something has gone wrong. (_, Left (_, _es)) -> Nothing (_, Right x) -> Just x +fromOldUploadInfo :: OldUploadInfo -> UploadInfo +fromOldUploadInfo = uncurry UploadInfo + +fromOldMetadataRev :: (CabalFileText, OldUploadInfo) -> MetadataRevision +fromOldMetadataRev (cabal, oui) = MetadataRevision cabal $ fromOldUploadInfo oui From 5e9e762629565c6a686883a15d894588211d6d0f Mon Sep 17 00:00:00 2001 From: Sandy Maguire Date: Mon, 4 May 2026 10:10:10 -0700 Subject: [PATCH 05/12] Fix pkgDesc --- src/Distribution/Server/Packages/Utils.hs | 27 ++++++++++------------- 1 file changed, 12 insertions(+), 15 deletions(-) diff --git a/src/Distribution/Server/Packages/Utils.hs b/src/Distribution/Server/Packages/Utils.hs index 4f9358edf..a486016ca 100644 --- a/src/Distribution/Server/Packages/Utils.hs +++ b/src/Distribution/Server/Packages/Utils.hs @@ -89,26 +89,23 @@ pkgLatestTarball pkginfo = tarballs = pkgTarballRevisions pkginfo -- | The information held in a parsed .cabal file (used by cabal-install) -pkgDesc :: PkgInfo -> GenericPackageDescription -pkgDesc pkgInfo = - case runParseResult $ parseGenericPackageDescription $ - cabalFileByteString $ metaRevCabalFile $ - pkgLatestRevision pkgInfo of - -- We only make PkgInfos with parsable pkgDatas, so if it - -- doesn't parse then something has gone wrong. - (_, Left (_,es)) -> error ("Internal error: " ++ show es) - (_, Right x) -> x +pkgDesc :: MetadataRevision -> GenericPackageDescription +pkgDesc = either (error . mappend "Internal error: ") id . pkgDescImpl + +-- | The information held in a parsed .cabal file, with nicer failure +pkgDescMaybe :: MetadataRevision -> Maybe GenericPackageDescription +pkgDescMaybe = either (const Nothing) Just . pkgDescImpl + -- | The information held in a parsed .cabal file, with nicer failure -pkgDescMaybe :: PkgInfo -> Maybe GenericPackageDescription -pkgDescMaybe pkgInfo = +pkgDescImpl :: MetadataRevision -> Either String GenericPackageDescription +pkgDescImpl rev = case runParseResult $ parseGenericPackageDescription $ - cabalFileByteString $ metaRevCabalFile $ - pkgLatestRevision pkgInfo of + cabalFileByteString $ metaRevCabalFile rev of -- We only make PkgInfos with parsable pkgDatas, so if it -- doesn't parse then something has gone wrong. - (_, Left (_, _es)) -> Nothing - (_, Right x) -> Just x + (_, Left (_, es)) -> Left $ show es + (_, Right x) -> Right x fromOldUploadInfo :: OldUploadInfo -> UploadInfo fromOldUploadInfo = uncurry UploadInfo From 9ee6a6a97c12a15e0dfc219d07fb07679a164496 Mon Sep 17 00:00:00 2001 From: Sandy Maguire Date: Mon, 4 May 2026 10:12:12 -0700 Subject: [PATCH 06/12] Fix downstream --- src/Distribution/Server/Features/Core.hs | 10 +++------ src/Distribution/Server/Features/Html.hs | 6 +++--- .../Server/Features/PackageCandidates.hs | 6 ++---- .../Server/Features/PackageContents.hs | 2 +- .../Server/Features/PackageFeed.hs | 6 +++--- .../Server/Features/PackageInfoJSON.hs | 6 +++--- .../Server/Features/PackageList.hs | 4 ++-- src/Distribution/Server/Features/Search.hs | 2 +- src/Distribution/Server/Features/Sitemap.hs | 2 +- src/Distribution/Server/Features/Tags.hs | 6 +++--- .../Server/Features/UserNotify.hs | 11 +++++----- .../Server/Features/UserNotify/Types.hs | 3 ++- src/Distribution/Server/Packages/Index.hs | 7 ++----- src/Distribution/Server/Packages/Render.hs | 10 ++++----- src/Distribution/Server/Packages/Utils.hs | 21 ++++++++++++++----- src/Distribution/Server/Pages/Index.hs | 1 + .../Server/Pages/PackageFromTemplate.hs | 2 +- src/Distribution/Server/Pages/Recent.hs | 12 +++++------ 18 files changed, 61 insertions(+), 56 deletions(-) diff --git a/src/Distribution/Server/Features/Core.hs b/src/Distribution/Server/Features/Core.hs index 4b9755465..7ec58d067 100644 --- a/src/Distribution/Server/Features/Core.hs +++ b/src/Distribution/Server/Features/Core.hs @@ -721,9 +721,8 @@ coreFeature ServerEnv{serverBlobStore = store} UserFeature{..} pkginfo <- packageInPath dpath >>= lookupPackageId -- check that the cabal name matches the package guard (lookup "cabal" dpath == Just (display $ packageName pkginfo)) - let (fileRev, (utime, _uid)) = pkgLatestRevision pkginfo - cabalfile = Resource.CabalFile (fromStrict $ cabalFileByteString fileRev) utime - return $ toResponse cabalfile + let rev = pkgLatestRevision pkginfo + return $ toResponse $ toCabalResource rev serveCabalFileRevisionsList :: DynamicPath -> ServerPartE Response serveCabalFileRevisionsList dpath = do @@ -747,13 +746,10 @@ coreFeature ServerEnv{serverBlobStore = store} UserFeature{..} pkginfo <- packageInPath dpath >>= lookupPackageId let mrev = lookup "revision" dpath >>= fromReqURI case mrev >>= pkgSpecificRevision pkginfo of - Just (fileRev, (utime, _uid)) -> return $ toResponse cabalfile - where - cabalfile = Resource.CabalFile (fromStrict $ cabalFileByteString fileRev) utime + Just rev -> return $ toResponse $ toCabalResource rev Nothing -> errNotFound "Package revision not found" [MText "Cannot parse revision, or revision out of range."] - deauth :: DynamicPath -> ServerPartE Response deauth _ = do return $ (toResponse (""::String)) { diff --git a/src/Distribution/Server/Features/Html.hs b/src/Distribution/Server/Features/Html.hs index 9552022e5..f93656ea2 100644 --- a/src/Distribution/Server/Features/Html.hs +++ b/src/Distribution/Server/Features/Html.hs @@ -641,7 +641,7 @@ mkHtmlCore ServerEnv{serverBaseURI, serverBlobStore} pkgname = packageName realpkg docURL = packageDocsContentUri docs realpkg execs = rendExecNames render - pkgdesc = flattenPackageDescription $ pkgDesc pkg + pkgdesc = flattenPackageDescription $ pkgDesc $ pkgLatestRevision pkg maintainers = maintainersGroup pkgname prefInfo <- queryGetPreferredInfo pkgname @@ -836,10 +836,10 @@ mkHtmlCore ServerEnv{serverBaseURI, serverBlobStore} revchanges ] where - revisionToTemplate :: Users.Users -> OldUploadInfo -> Int + revisionToTemplate :: Users.Users -> UploadInfo -> Int -> (SHA256Digest, [Change]) -> TemplateVal - revisionToTemplate users (utime, uid) revision (sha256hash, changes) = + revisionToTemplate users (UploadInfo utime uid) revision (sha256hash, changes) = let uname = Users.userIdToName users uid in templateDict [ templateVal "number" revision diff --git a/src/Distribution/Server/Features/PackageCandidates.hs b/src/Distribution/Server/Features/PackageCandidates.hs index 02e589fa9..babb295ef 100644 --- a/src/Distribution/Server/Features/PackageCandidates.hs +++ b/src/Distribution/Server/Features/PackageCandidates.hs @@ -385,9 +385,7 @@ candidatesFeature ServerEnv{serverBlobStore = store} serveCandidateCabal dpath = do pkg <- packageInPath dpath >>= lookupCandidateId guard (lookup "cabal" dpath == Just (display $ packageName pkg)) - let (fileRev, (utime, _uid)) = pkgLatestRevision (candPkgInfo pkg) - cabalfile = Resource.CabalFile (BS.fromStrict (cabalFileByteString fileRev)) utime - return $ toResponse cabalfile + return $ toResponse $ toCabalResource $ pkgLatestRevision $ candPkgInfo pkg uploadCandidate :: (PackageId -> Bool) -> ServerPartE CandPkgInfo uploadCandidate isRight = do @@ -458,7 +456,7 @@ candidatesFeature ServerEnv{serverBlobStore = store} Nothing -> do -- run filters let pkgInfo = candPkgInfo candidate - uresult = UploadResult (pkgDesc pkgInfo) + uresult = UploadResult (pkgDesc $ pkgLatestRevision pkgInfo) (BS.fromStrict (cabalFileByteString (pkgLatestCabalFileText pkgInfo))) (candWarnings candidate) time <- liftIO getCurrentTime diff --git a/src/Distribution/Server/Features/PackageContents.hs b/src/Distribution/Server/Features/PackageContents.hs index b81286084..46a0504ee 100644 --- a/src/Distribution/Server/Features/PackageContents.hs +++ b/src/Distribution/Server/Features/PackageContents.hs @@ -138,7 +138,7 @@ packageContentsFeature CoreFeature{ coreResource = CoreResource{ case mChangeLog of Left _ -> do let message = [MText "Package ", MLink pkgName url, MText " has no changelog file in source distribution. "] - let home = homepage $ packageDescription $ pkgDesc pkg + let home = homepage $ packageDescription $ pkgDesc $ pkgLatestRevision pkg if ST.null home then errNotFound "Changelog not found" message else diff --git a/src/Distribution/Server/Features/PackageFeed.hs b/src/Distribution/Server/Features/PackageFeed.hs index f573a18b7..f624cd533 100644 --- a/src/Distribution/Server/Features/PackageFeed.hs +++ b/src/Distribution/Server/Features/PackageFeed.hs @@ -102,7 +102,7 @@ renderPackageFeed users hostURI now name pkgs = RSS title uri desc (channel upda desc = "New releases of package '" ++ unPackageName name ++ "' on Hackage." items = feedItems users uri <$> pkgs uri = hostURI { uriPath = "/package/" ++ display name } - updated = maybe now (fst . pkgOriginalUploadInfo . fst) (listToMaybe pkgs) + updated = maybe now (pkgOriginalUploadTime . fst) (listToMaybe pkgs) channel :: UTCTime -> [RSS.ChannelElem] channel updated = @@ -132,8 +132,8 @@ feedItems users hostURI (pkgInfo, chlog) = , d "Maintainer" $ maintainer pd ] +++ XHtml.hr +++ chlog pkgName = display (pkgInfoId pkgInfo) - (time, uploaderId) = pkgOriginalUploadInfo pkgInfo + UploadInfo time uploaderId = pkgOriginalUploadInfo pkgInfo timestr = formatTime defaultTimeLocale "%Y-%m-%dT%H:%M:%SZ" time uploader = display $ Users.userIdToName users uploaderId - pd = packageDescription (pkgDesc pkgInfo) + pd = packageDescription $ pkgDesc $ pkgLatestRevision pkgInfo d dt dd = XHtml.dterm (XHtml.toHtml dt) +++ XHtml.ddef (XHtml.toHtml dd) diff --git a/src/Distribution/Server/Features/PackageInfoJSON.hs b/src/Distribution/Server/Features/PackageInfoJSON.hs index 83ddabecf..3ac5be6a2 100644 --- a/src/Distribution/Server/Features/PackageInfoJSON.hs +++ b/src/Distribution/Server/Features/PackageInfoJSON.hs @@ -39,7 +39,7 @@ import Distribution.Server.Features.Core (CoreFeature(..), CoreResource(..)) import qualified Distribution.Server.Features.PreferredVersions as Preferred import Distribution.Server.Packages.Types (CabalFileText(..), MetadataRevIx(..)) -import Distribution.Server.Packages.Utils (pkgSpecificRevision, pkgLatestRevision, pkgMaxRevision, pkgNumRevisions) +import Distribution.Server.Packages.Utils import Distribution.Utils.ShortText (fromShortText) import Data.Foldable (toList) @@ -245,7 +245,7 @@ servePackageBasicDescription resource userFeature preferred dpath = do guardValidPackageId resource pkgid pkg <- lookupPackageId resource pkgid - (metadataInd, (cabalFile, uploadInfo)) <- do + (metadataInd, (MetadataRevision cabalFile uploadInfo)) <- do case metadataRev of Nothing -> pure (pkgMaxRevision pkg, pkgLatestRevision pkg) @@ -261,7 +261,7 @@ servePackageBasicDescription resource userFeature preferred dpath = do descr <- getPackageDescr cabalFile uploadInfo metadataInd return $ Framework.toResponse $ Aeson.toJSON descr - getPackageDescr cabalFile (uploadedAt, uploaderId) metadataInd = do + getPackageDescr cabalFile (UploadInfo uploadedAt uploaderId) metadataInd = do uploader <- userName <$> lookupUserInfo userFeature uploaderId let pkgDescr = getBasicDescription uploadedAt cabalFile metadataInd case pkgDescr of diff --git a/src/Distribution/Server/Features/PackageList.hs b/src/Distribution/Server/Features/PackageList.hs index 527409c47..504530da3 100644 --- a/src/Distribution/Server/Features/PackageList.hs +++ b/src/Distribution/Server/Features/PackageList.hs @@ -264,7 +264,7 @@ listFeature CoreFeature{..} let pkgs = PackageIndex.lookupPackageName index pkgname case pkgs of [] -> modifyMemState itemCache (Map.delete pkgname) - _ -> modifyItem pkgname (updateDescriptionItem $ pkgDesc $ last pkgs) + _ -> modifyItem pkgname (updateDescriptionItem $ pkgDesc $ pkgLatestRevision $ last pkgs) runHook_ itemUpdate (Set.singleton pkgname) refreshDownloads = do @@ -284,7 +284,7 @@ listFeature CoreFeature{..} constructItem :: PkgInfo -> IO (PackageName, PackageItem) constructItem pkg = do let pkgname = packageName pkg - desc = pkgDesc pkg + desc = pkgDesc $ pkgLatestRevision pkg intRevDirectCount <- revDirectCount pkgname users <- queryGetUserDb tags <- queryTagsForPackage pkgname diff --git a/src/Distribution/Server/Features/Search.hs b/src/Distribution/Server/Features/Search.hs index f8f721f31..70dbd3759 100644 --- a/src/Distribution/Server/Features/Search.hs +++ b/src/Distribution/Server/Features/Search.hs @@ -99,7 +99,7 @@ searchFeature ServerEnv{serverBaseURI} CoreFeature{..} ListFeature{getAllLists} -- resourceGet = [("json", \_ -> suggestJson)] -- } - getSearchDoc = flattenPackageDescription . pkgDesc + getSearchDoc = flattenPackageDescription . pkgDesc . pkgLatestRevision postInit = do pkgindex <- queryGetPackageIndex diff --git a/src/Distribution/Server/Features/Sitemap.hs b/src/Distribution/Server/Features/Sitemap.hs index f27d7ee0d..3f1852267 100644 --- a/src/Distribution/Server/Features/Sitemap.hs +++ b/src/Distribution/Server/Features/Sitemap.hs @@ -233,7 +233,7 @@ generateSitemap serverBaseURI pageBuildDate alltags pkgIndex docIndex cachedTarI [ ( prefixPkgURI ++ display (packageName pkg) , uploadtime) | pkg <- map head pkgss - , let (uploadtime, _user) = pkgLatestUploadInfo pkg + , let uploadtime = pkgLatestUploadTime pkg ] Daily 1.0 diff --git a/src/Distribution/Server/Features/Tags.hs b/src/Distribution/Server/Features/Tags.hs index 5cea81547..712d7a1be 100644 --- a/src/Distribution/Server/Features/Tags.hs +++ b/src/Distribution/Server/Features/Tags.hs @@ -110,7 +110,7 @@ initTagsFeature ServerEnv{serverStateDir} = do Nothing -> return () Just pkginfo -> do let pkgname = packageName pkgid - itags = constructImmutableTags . pkgDesc $ pkginfo + itags = constructImmutableTags . pkgDesc . pkgLatestRevision $ pkginfo curtags <- queryState tagsState $ Acid.TagsForPackage pkgname aliases <- mapM (queryState tagAlias . Acid.GetTagAlias) (itags ++ Set.toList curtags) let newtags = Set.fromList aliases @@ -306,7 +306,7 @@ tagsFeature CoreFeature{ queryGetPackageIndex } constructTagIndex :: PackageIndex PkgInfo -> Acid.PackageTags constructTagIndex = foldl' addToTags Acid.emptyPackageTags . PackageIndex.allPackagesByName where addToTags pkgTags pkgList = - let info = pkgDesc $ last pkgList + let info = pkgDesc $ pkgLatestRevision $ last pkgList pkgname = packageName info categoryTags = Set.fromList . constructCategoryTags . packageDescription $ info immutableTags = Set.fromList . constructImmutableTags $ info @@ -316,7 +316,7 @@ constructTagIndex = foldl' addToTags Acid.emptyPackageTags . PackageIndex.allPac constructImmutableTagIndex :: PackageIndex PkgInfo -> Acid.PackageTags constructImmutableTagIndex = foldl' addToTags Acid.emptyPackageTags . PackageIndex.allPackagesByName where addToTags calcTags pkgList = - let info = pkgDesc $ last pkgList + let info = pkgDesc $ pkgLatestRevision $ last pkgList !pn = packageName info !tags = constructImmutableTags info in Acid.setTags pn (Set.fromList tags) calcTags diff --git a/src/Distribution/Server/Features/UserNotify.hs b/src/Distribution/Server/Features/UserNotify.hs index 2cea9edf7..e6a4cadd7 100644 --- a/src/Distribution/Server/Features/UserNotify.hs +++ b/src/Distribution/Server/Features/UserNotify.hs @@ -581,7 +581,7 @@ userNotifyFeature UserFeature{..} NotifyNewRevision { notifyPackageId = pkgInfoId pkg , notifyRevisions = - filter (\(t, _) -> earlier < t && t <= now) + filter ((\t -> earlier < t && t <= now) . uploadInfoTime) $ pkgAllRevisionsUploadInfos pkg } else do @@ -801,14 +801,15 @@ getNotificationEmails renderNotifyNewVersion pkg = EmailContentParagraph $ "Package upload, " <> renderPkgLink (pkgInfoId pkg) <> ", by " <> - renderUserTime (pkgLatestUploadUser pkg) (pkgLatestUploadTime pkg) + renderUploadInfo (UploadInfo (pkgLatestUploadTime pkg) (pkgLatestUploadUser pkg)) + renderNotifyNewRevision :: PackageIdentifier -> [UploadInfo] -> EmailContent renderNotifyNewRevision pkg revs = EmailContentParagraph ("Package metadata revision(s), " <> renderPkgLink pkg <> ":") - <> EmailContentList (map (uncurry $ flip renderUserTime) $ sortOn (Down . fst) revs) + <> EmailContentList (map renderUploadInfo $ sortOn (Down . uploadInfoTime) revs) renderNotifyMaintainerUpdate updateType userActor userSubject pkg reason time = - EmailContentParagraph ("Group modified by " <> renderUserTime userActor time <> ":") + EmailContentParagraph ("Group modified by " <> renderUploadInfo (UploadInfo time userActor) <> ":") <> EmailContentList [ case updateType of MaintainerAdded -> @@ -875,7 +876,7 @@ getNotificationEmails renderTime = emailContentStr . formatTime defaultTimeLocale "%c" - renderUserTime u t = renderUser u <> " [" <> renderTime t <> "]" + renderUploadInfo (UploadInfo t u) = renderUser u <> " [" <> renderTime t <> "]" {----- Utilities -----} diff --git a/src/Distribution/Server/Features/UserNotify/Types.hs b/src/Distribution/Server/Features/UserNotify/Types.hs index bf22443e0..808e5b012 100644 --- a/src/Distribution/Server/Features/UserNotify/Types.hs +++ b/src/Distribution/Server/Features/UserNotify/Types.hs @@ -10,6 +10,7 @@ import Distribution.Pretty import Distribution.Server.Features.Tags.Types import Distribution.Server.Framework +import Distribution.Server.Packages.Utils (UploadInfo) import Distribution.Server.Packages.Types (OldUploadInfo, PkgInfo) import Distribution.Server.Users.Types (UserId) @@ -62,7 +63,7 @@ data Notification } | NotifyNewRevision { notifyPackageId :: PackageId - , notifyRevisions :: [OldUploadInfo] + , notifyRevisions :: [UploadInfo] } | NotifyMaintainerUpdate { notifyMaintainerUpdateType :: NotifyMaintainerUpdateType diff --git a/src/Distribution/Server/Packages/Index.hs b/src/Distribution/Server/Packages/Index.hs index 7c4170b95..3eef5d5ae 100644 --- a/src/Distribution/Server/Packages/Index.hs +++ b/src/Distribution/Server/Packages/Index.hs @@ -20,9 +20,6 @@ import Distribution.Server.Packages.Types , TarballRevIx, MetadataRevIx ) import Distribution.Server.Packages.Utils - ( pkgSpecificRevision - , pkgLatestCabalFileText, pkgLatestUploadInfo - ) import Distribution.Server.Packages.Metadata import Distribution.Server.Users.Users ( Users, userIdToName ) @@ -100,7 +97,7 @@ writeIncremental pkgs = mkTarEntry (CabalFileEntry pkgid revno timestamp userid username) = do pkginfo <- PackageIndex.lookupPackageId pkgs pkgid - cabalfile <- fmap (cabalFileByteString . fst) $ + cabalfile <- fmap (cabalFileByteString . metaRevCabalFile) $ pkgSpecificRevision pkginfo revno tarPath <- either (const Nothing) Just $ Tar.toTarPath False fileName @@ -177,7 +174,7 @@ writeLegacy users = . extraEntries where setModTime pkgInfo entry = - let (utime, uuser) = pkgLatestUploadInfo pkgInfo in + let (UploadInfo utime uuser) = pkgLatestUploadInfo pkgInfo in entry { Tar.entryTime = utcToUnixTime utime, Tar.entryOwnership = Tar.Ownership { diff --git a/src/Distribution/Server/Packages/Render.hs b/src/Distribution/Server/Packages/Render.hs index 8f10e20e2..7936f9a1e 100644 --- a/src/Distribution/Server/Packages/Render.hs +++ b/src/Distribution/Server/Packages/Render.hs @@ -122,11 +122,11 @@ doPackageRender users info = PackageRender , rendHasTarball = not . null $ pkgAllTarballs info , rendChangeLog = Nothing -- populated later , rendReadme = Nothing -- populated later - , rendUploadInfo = let (utime, uid) = pkgOriginalUploadInfo info + , rendUploadInfo = let UploadInfo utime uid = pkgOriginalUploadInfo info in (utime, Users.lookupUserId uid users) - , rendUpdateInfo = let maxrevision = pkgMaxRevision info - (utime, uid) = pkgLatestUploadInfo info - uinfo = Users.lookupUserId uid users + , rendUpdateInfo = let maxrevision = pkgMaxRevision info + UploadInfo utime uid = pkgLatestUploadInfo info + uinfo = Users.lookupUserId uid users in if maxrevision > MetadataRevIx 0 then Just (maxrevision, utime, uinfo) else Nothing @@ -135,7 +135,7 @@ doPackageRender users info = PackageRender , rendOther = desc } where - genDesc = pkgDesc info + genDesc = pkgDesc $ pkgLatestRevision info flatDesc = flattenPackageDescription genDesc desc = packageDescription genDesc pkgUri = "/package/" ++ display (pkgInfoId info) diff --git a/src/Distribution/Server/Packages/Utils.hs b/src/Distribution/Server/Packages/Utils.hs index a486016ca..effdd9c58 100644 --- a/src/Distribution/Server/Packages/Utils.hs +++ b/src/Distribution/Server/Packages/Utils.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE DerivingStrategies #-} + module Distribution.Server.Packages.Utils where import Distribution.Server.Packages.Types @@ -8,7 +10,9 @@ import Distribution.PackageDescription ( GenericPackageDescription(..)) import Distribution.PackageDescription.Parsec ( parseGenericPackageDescription, runParseResult ) +import qualified Distribution.Server.Framework.ResponseContentTypes as Resource +import Data.ByteString.Lazy (fromStrict) import Data.Time.Clock (UTCTime(..)) import qualified Data.Vector as Vec @@ -16,11 +20,13 @@ data MetadataRevision = MetadataRevision { metaRevCabalFile :: CabalFileText , metaRevInfo :: UploadInfo } + deriving stock Show data UploadInfo = UploadInfo { uploadInfoTime :: UTCTime , uploadInfoUser :: UserId } + deriving stock Show pkgOriginalRevision :: PkgInfo -> MetadataRevision pkgOriginalRevision = fromOldMetadataRev . Vec.head . pkgMetadataRevisions @@ -48,8 +54,8 @@ pkgAllRevisionsCabalFiles = fmap fst . Vec.toList . pkgMetadataRevisions pkgSpecificTarball :: PkgInfo -> TarballRevIx -> Maybe (PkgTarball, UploadInfo) pkgSpecificTarball pkg (TarballRevIx revno) = fmap (fmap fromOldUploadInfo) $ pkgTarballRevisions pkg Vec.!? revno -pkgAllTarballs :: PkgInfo -> [(PkgTarball, UploadInfo)] -pkgAllTarballs = fmap (fmap fromOldUploadInfo) . Vec.toList . pkgTarballRevisions +pkgAllTarballs :: PkgInfo -> [(PkgTarball, OldUploadInfo)] +pkgAllTarballs = Vec.toList . pkgTarballRevisions pkgAllRevisionsUploadInfos :: PkgInfo -> [UploadInfo] pkgAllRevisionsUploadInfos = fmap (fromOldUploadInfo . snd) . Vec.toList . pkgMetadataRevisions @@ -79,12 +85,12 @@ pkgMaxRevision = MetadataRevIx . subtract 1 . pkgNumRevisions -- and revision number. The revision number will normally be 1, but may be -- higher if more tarballs were uploaded for this package (on the central -- Hackage server we disallow this). -pkgLatestTarball :: PkgInfo -> Maybe (PkgTarball, UploadInfo, Int) +pkgLatestTarball :: PkgInfo -> Maybe (PkgTarball, OldUploadInfo, Int) pkgLatestTarball pkginfo = if Vec.null tarballs then Nothing - else let (tarball, (when, who)) = Vec.last tarballs - in Just (tarball, UploadInfo when who, Vec.length tarballs - 1) + else let (tarball, oui) = Vec.last tarballs + in Just (tarball, oui, Vec.length tarballs - 1) where tarballs = pkgTarballRevisions pkginfo @@ -107,6 +113,11 @@ pkgDescImpl rev = (_, Left (_, es)) -> Left $ show es (_, Right x) -> Right x + +toCabalResource :: MetadataRevision -> Resource.CabalFile +toCabalResource (MetadataRevision fileRev ui) = + Resource.CabalFile (fromStrict $ cabalFileByteString fileRev) $ uploadInfoTime ui + fromOldUploadInfo :: OldUploadInfo -> UploadInfo fromOldUploadInfo = uncurry UploadInfo diff --git a/src/Distribution/Server/Pages/Index.hs b/src/Distribution/Server/Pages/Index.hs index 2085ba277..348f8b366 100644 --- a/src/Distribution/Server/Pages/Index.hs +++ b/src/Distribution/Server/Pages/Index.hs @@ -29,6 +29,7 @@ packageIndex = formatPkgGroups . map (mkPackageIndexInfo . flattenPackageDescription . pkgDesc + . pkgLatestRevision . maximumBy (comparing packageVersion)) . PackageIndex.allPackagesByName diff --git a/src/Distribution/Server/Pages/PackageFromTemplate.hs b/src/Distribution/Server/Pages/PackageFromTemplate.hs index 954c1135a..417fda68e 100644 --- a/src/Distribution/Server/Pages/PackageFromTemplate.hs +++ b/src/Distribution/Server/Pages/PackageFromTemplate.hs @@ -334,7 +334,7 @@ candidatesPageTemplate cands candidates candidatesCore= ]) ,"list" $= (unordList $ map showCands $ PackageIndex.allPackagesByName cands) ] - where showCands pkgs = case packageDescription <$> pkgDescMaybe (candPkgInfo $ last pkgs) of + where showCands pkgs = case packageDescription <$> pkgDescMaybe (pkgLatestRevision $ candPkgInfo $ last pkgs) of Nothing -> [] Just desc -> -- TODO: Duncan changed this to packageSynopsis but without an diff --git a/src/Distribution/Server/Pages/Recent.hs b/src/Distribution/Server/Pages/Recent.hs index 5264a647a..947bbe29a 100644 --- a/src/Distribution/Server/Pages/Recent.hs +++ b/src/Distribution/Server/Pages/Recent.hs @@ -143,7 +143,7 @@ makeRow users pkginfo = nbsp = XHtml.primHtmlChar "nbsp" user = Users.userIdToName users userId - (time, userId) = pkgOriginalUploadInfo pkginfo + UploadInfo time userId = pkgOriginalUploadInfo pkginfo pkgid = pkgInfoId pkginfo makeRevisionRow :: Users -> PkgInfo -> Html @@ -159,7 +159,7 @@ makeRevisionRow users pkginfo = nbsp = XHtml.primHtmlChar "nbsp" user = Users.userIdToName users userId - (time, userId) = pkgLatestUploadInfo pkginfo + UploadInfo time userId = pkgLatestUploadInfo pkginfo pkgid = pkgInfoId pkginfo revno = "-r" ++ show (pkgNumRevisions pkginfo - 1) revlabel = [XHtml.toHtml (display pkgid), XHtml.toHtml revno] @@ -202,7 +202,7 @@ recentFeed conf users hostURI now pkgs = RSS (start,end) = pageIndexRange conf desc = "Showing " ++ show start ++ " - " ++ show end ++ " most recent additions to Hackage, the Haskell package database." pkgList = paginate conf pkgs - updated = maybe now (fst . pkgOriginalUploadInfo) (listToMaybe pkgList) + updated = maybe now pkgOriginalUploadTime (listToMaybe pkgList) recentRevisionsFeed :: PaginatedConfiguration -> Users -> URI -> UTCTime -> [PkgInfo] -> RSS recentRevisionsFeed conf users hostURI now pkgs = RSS @@ -215,7 +215,7 @@ recentRevisionsFeed conf users hostURI now pkgs = RSS (start, end) = pageIndexRange conf desc = "Showing " ++ show start ++ " - " ++ show end ++ " most recent revisions to cabal metadata in Hackage, the Haskell package database." pkgList = paginate conf pkgs - updated = maybe now (fst . pkgOriginalUploadInfo) (listToMaybe pkgList) + updated = maybe now pkgOriginalUploadTime (listToMaybe pkgList) channel :: UTCTime -> [RSS.ChannelElem] channel updated = @@ -245,7 +245,7 @@ releaseItem users hostURI pkgInfo = ++ if null body then "" else "

" ++ body ++ "

" user = Users.userIdToName users userId - (time, userId) = pkgOriginalUploadInfo pkgInfo + UploadInfo time userId = pkgOriginalUploadInfo pkgInfo pkgId = pkgInfoId pkgInfo revisionItem :: Users -> URI -> PkgInfo -> [RSS.ItemElem] @@ -266,5 +266,5 @@ revisionItem users hostURI pkgInfo = user = Users.userIdToName users userId revision = pkgNumRevisions pkgInfo - 1 - (time, userId) = pkgLatestUploadInfo pkgInfo + UploadInfo time userId = pkgLatestUploadInfo pkgInfo pkgId = pkgInfoId pkgInfo From 08790160b35b2c586fe07eab35cdea7776acc5f6 Mon Sep 17 00:00:00 2001 From: Sandy Maguire Date: Mon, 4 May 2026 10:12:12 -0700 Subject: [PATCH 07/12] Time changes --- src/Distribution/Server/Features/PackageList.hs | 4 ++-- src/Distribution/Server/Pages/Recent.hs | 2 +- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/src/Distribution/Server/Features/PackageList.hs b/src/Distribution/Server/Features/PackageList.hs index 504530da3..d38641f4c 100644 --- a/src/Distribution/Server/Features/PackageList.hs +++ b/src/Distribution/Server/Features/PackageList.hs @@ -158,7 +158,7 @@ initListFeature _env = do modifyItem pkgname $ \x -> updateReferenceVersion prefsinfo allVersions $ x - { itemLastUpload = fst (pkgOriginalUploadInfo pkg) + { itemLastUpload = pkgOriginalUploadTime pkg } runHook_ itemUpdate (Set.singleton pkgname) @@ -300,7 +300,7 @@ listFeature CoreFeature{..} , itemDeprecated = deprs , itemDownloads = cmFind pkgname downs , itemVotes = votes - , itemLastUpload = fst (pkgOriginalUploadInfo pkg) + , itemLastUpload = pkgOriginalUploadTime pkg , itemRevDepsCount = intRevDirectCount , itemHotness = votes + fromIntegral (cmFind pkgname downs) + fromIntegral intRevDirectCount * 2 } diff --git a/src/Distribution/Server/Pages/Recent.hs b/src/Distribution/Server/Pages/Recent.hs index 947bbe29a..5c7899456 100644 --- a/src/Distribution/Server/Pages/Recent.hs +++ b/src/Distribution/Server/Pages/Recent.hs @@ -240,7 +240,7 @@ releaseItem users hostURI pkgInfo = where uri = hostURI { uriPath = packageURL pkgId } title = display (packageName pkgId) ++ " " ++ display (packageVersion pkgId) - body = fromShortText $ synopsis (packageDescription (pkgDesc pkgInfo)) + body = fromShortText $ synopsis $ packageDescription $ pkgDesc $ pkgLatestRevision pkgInfo desc = "Added by " ++ display user ++ ", " ++ showTime time ++ "." ++ if null body then "" else "

" ++ body ++ "

" user = Users.userIdToName users userId From 98b29592f57687b3e65194b3c2149f53b8c57502 Mon Sep 17 00:00:00 2001 From: Sandy Maguire Date: Mon, 4 May 2026 10:40:43 -0700 Subject: [PATCH 08/12] Fix tests --- tests/ReverseDependenciesTest.hs | 13 +++++++------ 1 file changed, 7 insertions(+), 6 deletions(-) diff --git a/tests/ReverseDependenciesTest.hs b/tests/ReverseDependenciesTest.hs index b536633eb..487f292d8 100644 --- a/tests/ReverseDependenciesTest.hs +++ b/tests/ReverseDependenciesTest.hs @@ -38,6 +38,7 @@ import Distribution.Server.Framework.Hook (newHook) import Distribution.Server.Framework.MemState (newMemStateWHNF) import Distribution.Server.Framework.ServerEnv (ServerEnv(..)) import Distribution.Server.Packages.PackageIndex as PackageIndex +import Distribution.Server.Packages.Utils import Distribution.Server.Packages.Types (CabalFileText(..), PkgInfo(..)) import Distribution.Server.Framework.Templating import Distribution.Server.Users.Types @@ -330,14 +331,13 @@ getNotificationEmailsTests = } } , testGolden "Render NotifyNewRevision" "getNotificationEmails-NotifyNewRevision.golden" $ do - let mkRev rev = (CabalFileText "", (rev, userActor)) - rev0 = (0 * Time.nominalDay) `Time.addUTCTime` timestamp + let rev0 = (0 * Time.nominalDay) `Time.addUTCTime` timestamp rev1 = (1 * Time.nominalDay) `Time.addUTCTime` timestamp rev2 = (2 * Time.nominalDay) `Time.addUTCTime` timestamp fmap renderMail . getNotificationEmailMocked userWatcher $ NotifyNewRevision { notifyPackageId = PackageIdentifier "base" (mkVersion [4, 18, 0, 0]) - , notifyRevisions = map (, userActor) [rev1, rev2] + , notifyRevisions = map (flip UploadInfo userActor) [rev1, rev2] } , testGolden "Render NotifyMaintainerUpdate-MaintainerAdded" "getNotificationEmails-NotifyMaintainerUpdate-MaintainerAdded.golden" $ fmap renderMail . getNotificationEmailMocked userWatcher $ @@ -421,7 +421,7 @@ getNotificationEmailsTests = getNotificationEmailsMocked . map (userWatcher,) $ [ NotifyNewRevision { notifyPackageId = PackageIdentifier "base" (mkVersion [4, 18, 0, 0]) - , notifyRevisions = [(timestamp, userActor)] + , notifyRevisions = [UploadInfo timestamp userActor] } , NotifyDocsBuild { notifyPackageId = PackageIdentifier "base" (mkVersion [4, 18, 0, 0]) @@ -544,12 +544,13 @@ getNotificationEmailsTests = genPackageId = PackageIdentifier <$> genPackageName <*> genVersion genCabalFileText = CabalFileText <$> Gen.utf8 (Range.linear 0 50000) Gen.unicode genNonExistentUserId = UserId <$> Gen.int (Range.linear (-1000) (-1)) - genUploadInfo = (,) <$> genUTCTime <*> genNonExistentUserId + genOldUploadInfo = (,) <$> genUTCTime <*> genNonExistentUserId + genUploadInfo = fmap fromOldUploadInfo genOldUploadInfo genTag = Tag <$> Gen.string (Range.linear 1 10) Gen.unicode genPkgInfo = PkgInfo <$> genPackageId - <*> genVec (Range.linear 1 5) ((,) <$> genCabalFileText <*> genUploadInfo) + <*> genVec (Range.linear 1 5) ((,) <$> genCabalFileText <*> genOldUploadInfo) <*> pure Vector.empty -- ignoring pkgTarballRevisions for now genPacks :: PropertyT IO [Package TestPackage] From 7a7037b743a100dcd157a7f99a1034568b127add Mon Sep 17 00:00:00 2001 From: Sandy Maguire Date: Mon, 4 May 2026 10:51:36 -0700 Subject: [PATCH 09/12] Commentary --- src/Distribution/Server/Packages/Types.hs | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/Distribution/Server/Packages/Types.hs b/src/Distribution/Server/Packages/Types.hs index 1f69445e4..3f7d87d42 100644 --- a/src/Distribution/Server/Packages/Types.hs +++ b/src/Distribution/Server/Packages/Types.hs @@ -121,6 +121,9 @@ data PkgTarball_v1 = PkgTarball_v1 { data PkgTarball_v0 = PkgTarball_v0 !BlobId_v0 !BlobId_v0 +-- | This type is deprecated for +-- 'Distribution.Server.Packages.Utils.UploadInfo', but remains here because it +-- would be a breaking change in the acid-state serialization. type OldUploadInfo = (UTCTime, UserId) type UploadInfo_v0 = (UTCTime_v0, UserId_v0) From d5b1e2a2cc8ad2edc2baad44cad91494a8b76ebd Mon Sep 17 00:00:00 2001 From: Sandy Maguire Date: Mon, 4 May 2026 11:07:48 -0700 Subject: [PATCH 10/12] Dont use constructor --- src/Distribution/Server/Features/PackageInfoJSON.hs | 4 +++- src/Distribution/Server/Packages/Utils.hs | 6 +++--- 2 files changed, 6 insertions(+), 4 deletions(-) diff --git a/src/Distribution/Server/Features/PackageInfoJSON.hs b/src/Distribution/Server/Features/PackageInfoJSON.hs index 3ac5be6a2..852af3452 100644 --- a/src/Distribution/Server/Features/PackageInfoJSON.hs +++ b/src/Distribution/Server/Features/PackageInfoJSON.hs @@ -245,7 +245,7 @@ servePackageBasicDescription resource userFeature preferred dpath = do guardValidPackageId resource pkgid pkg <- lookupPackageId resource pkgid - (metadataInd, (MetadataRevision cabalFile uploadInfo)) <- do + (metadataInd, rev) <- do case metadataRev of Nothing -> pure (pkgMaxRevision pkg, pkgLatestRevision pkg) @@ -257,6 +257,8 @@ servePackageBasicDescription resource userFeature preferred dpath = do $ "There are " <> show (pkgNumRevisions pkg) <> " metadata revisions. Index " <> show ix <> " is out of bounds."] Just rev -> pure (ix, rev) + let cabalFile = metaRevCabalFile rev + uploadInfo = metaRevUploadInfo rev descr <- getPackageDescr cabalFile uploadInfo metadataInd return $ Framework.toResponse $ Aeson.toJSON descr diff --git a/src/Distribution/Server/Packages/Utils.hs b/src/Distribution/Server/Packages/Utils.hs index effdd9c58..763ae84cd 100644 --- a/src/Distribution/Server/Packages/Utils.hs +++ b/src/Distribution/Server/Packages/Utils.hs @@ -18,7 +18,7 @@ import qualified Data.Vector as Vec data MetadataRevision = MetadataRevision { metaRevCabalFile :: CabalFileText - , metaRevInfo :: UploadInfo + , metaRevUploadInfo :: UploadInfo } deriving stock Show @@ -32,7 +32,7 @@ pkgOriginalRevision :: PkgInfo -> MetadataRevision pkgOriginalRevision = fromOldMetadataRev . Vec.head . pkgMetadataRevisions pkgOriginalUploadInfo :: PkgInfo -> UploadInfo -pkgOriginalUploadInfo = metaRevInfo . pkgOriginalRevision +pkgOriginalUploadInfo = metaRevUploadInfo . pkgOriginalRevision pkgOriginalUploadTime :: PkgInfo -> UTCTime pkgOriginalUploadTime = uploadInfoTime . pkgOriginalUploadInfo @@ -64,7 +64,7 @@ pkgLatestCabalFileText :: PkgInfo -> CabalFileText pkgLatestCabalFileText = metaRevCabalFile . pkgLatestRevision pkgLatestUploadInfo :: PkgInfo -> UploadInfo -pkgLatestUploadInfo = metaRevInfo . pkgLatestRevision +pkgLatestUploadInfo = metaRevUploadInfo . pkgLatestRevision pkgLatestUploadTime :: PkgInfo -> UTCTime pkgLatestUploadTime = uploadInfoTime . pkgLatestUploadInfo From e8f9bedc99b320368e05b4108b9a87eb05d2b855 Mon Sep 17 00:00:00 2001 From: Sandy Maguire Date: Mon, 4 May 2026 15:14:32 -0700 Subject: [PATCH 11/12] Migration should be Acid --- src/Distribution/Server/Features/Security/Migration.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Distribution/Server/Features/Security/Migration.hs b/src/Distribution/Server/Features/Security/Migration.hs index 1a66f8cea..a86a5e072 100644 --- a/src/Distribution/Server/Features/Security/Migration.hs +++ b/src/Distribution/Server/Features/Security/Migration.hs @@ -31,7 +31,7 @@ import Distribution.Server.Features.Security.Layout import Distribution.Server.Framework hiding (Length) import Distribution.Server.Framework.BlobStorage import Distribution.Server.Packages.Types -import Distribution.Server.Packages.Utils +import Distribution.Server.Packages.Utils.Acid import Distribution.Server.Util.ReadDigest import qualified Distribution.Server.Packages.PackageIndex as PackageIndex From a16871593e5e95fe824636bc8b40bf6cabc72a0c Mon Sep 17 00:00:00 2001 From: Sandy Maguire Date: Mon, 4 May 2026 09:58:25 -0700 Subject: [PATCH 12/12] refactor: new Package.Utils, better types