From b60aa1bed58e1c7e97d3a936477883ee2ce77151 Mon Sep 17 00:00:00 2001 From: Tom Ellis Date: Sat, 11 Jul 2026 11:36:55 +0100 Subject: [PATCH 01/33] (refactor) Import votesStore unqualified --- src/Distribution/Server/Features/Votes.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/Distribution/Server/Features/Votes.hs b/src/Distribution/Server/Features/Votes.hs index 8739824c1..530b07817 100644 --- a/src/Distribution/Server/Features/Votes.hs +++ b/src/Distribution/Server/Features/Votes.hs @@ -9,6 +9,7 @@ module Distribution.Server.Features.Votes import Distribution.Server.Features.Votes.Types (Score) import qualified Distribution.Server.Features.Votes.State as Acid +import Distribution.Server.Features.Votes.State (votesScore) import qualified Distribution.Server.Features.Votes.Render as Render import Distribution.Server.Framework @@ -131,7 +132,7 @@ votesFeature ServerEnv{..} cacheControlWithoutETag [Public, maxAgeMinutes 10] votesMap <- queryState votesState Acid.GetAllPackageVoteSets ok . toResponse $ objectL - [ (display pkgname, toJSON (Acid.votesScore pkgMap)) + [ (display pkgname, toJSON (votesScore pkgMap)) | (pkgname, pkgMap) <- Map.toList votesMap ] -- Get the number of votes a package has. If the package From 6fab88034d048f7db2bb9ceed4750a3329c2adab Mon Sep 17 00:00:00 2001 From: Tom Ellis Date: Sat, 11 Jul 2026 11:37:07 +0100 Subject: [PATCH 02/33] (refactor) Move votesScore --- hackage-server.cabal | 1 + src/Distribution/Server/Features/Votes.hs | 2 +- .../Server/Features/Votes/State.hs | 13 +----------- .../Server/Features/Votes/Store.hs | 21 +++++++++++++++++++ 4 files changed, 24 insertions(+), 13 deletions(-) create mode 100644 src/Distribution/Server/Features/Votes/Store.hs diff --git a/hackage-server.cabal b/hackage-server.cabal index bd88d1455..cf9c42f5f 100644 --- a/hackage-server.cabal +++ b/hackage-server.cabal @@ -387,6 +387,7 @@ library Distribution.Server.Features.Votes Distribution.Server.Features.Votes.Render Distribution.Server.Features.Votes.State + Distribution.Server.Features.Votes.Store Distribution.Server.Features.Votes.Types Distribution.Server.Features.Vouch Distribution.Server.Features.Vouch.State diff --git a/src/Distribution/Server/Features/Votes.hs b/src/Distribution/Server/Features/Votes.hs index 530b07817..8af72c9e0 100644 --- a/src/Distribution/Server/Features/Votes.hs +++ b/src/Distribution/Server/Features/Votes.hs @@ -9,8 +9,8 @@ module Distribution.Server.Features.Votes import Distribution.Server.Features.Votes.Types (Score) import qualified Distribution.Server.Features.Votes.State as Acid -import Distribution.Server.Features.Votes.State (votesScore) import qualified Distribution.Server.Features.Votes.Render as Render +import Distribution.Server.Features.Votes.Store (votesScore) import Distribution.Server.Framework import Distribution.Server.Framework.BackupRestore diff --git a/src/Distribution/Server/Features/Votes/State.hs b/src/Distribution/Server/Features/Votes/State.hs index 17b05bda3..3cb718d7e 100644 --- a/src/Distribution/Server/Features/Votes/State.hs +++ b/src/Distribution/Server/Features/Votes/State.hs @@ -4,6 +4,7 @@ module Distribution.Server.Features.Votes.State where import Distribution.Server.Features.Votes.Types +import Distribution.Server.Features.Votes.Store (votesScore) import Distribution.Server.Framework.MemSize import Distribution.Package (PackageName) @@ -15,9 +16,7 @@ import Distribution.Server.Users.State () import Data.Map (Map) import qualified Data.Map as Map -import Data.List import Data.Maybe (fromMaybe) -import Control.Arrow ((&&&)) import Data.Acid (Query, Update, makeAcidic) import Data.SafeCopy (base, extension, deriveSafeCopy, Migrate(..)) @@ -55,16 +54,6 @@ userVotedForPackage pkgname uid votes = Nothing -> False Just _ -> True --- Using a Bayesian average (m=1.5, C=2) to calculate scoring -votesScore :: Map UserId Score -> Float -votesScore m = - let grouping = map (head &&& length) . group . sort . Map.elems $ m - score :: Float - score = fromIntegral ((sum $ map (uncurry (*)) grouping) + 3)/ - fromIntegral (2 + sum (map snd grouping)) - roundedScore = fromIntegral (round (score * 4) :: Int) / 4 - in roundedScore - -- All the acid state transactions addVote :: PackageName -> UserId -> Score -> Update VotesState Float diff --git a/src/Distribution/Server/Features/Votes/Store.hs b/src/Distribution/Server/Features/Votes/Store.hs new file mode 100644 index 000000000..03ee1f0b5 --- /dev/null +++ b/src/Distribution/Server/Features/Votes/Store.hs @@ -0,0 +1,21 @@ +module Distribution.Server.Features.Votes.Store + ( votesScore + ) where + +import Distribution.Server.Features.Votes.Types +import Distribution.Server.Users.Types (UserId) + +import Control.Arrow ((&&&)) +import Data.List (group, sort) +import Data.Map (Map) +import qualified Data.Map as Map + +-- Using a Bayesian average (m=1.5, C=2) to calculate scoring +votesScore :: Map UserId Score -> Float +votesScore m = + let grouping = map (head &&& length) . group . sort . Map.elems $ m + score :: Float + score = fromIntegral ((sum $ map (uncurry (*)) grouping) + 3)/ + fromIntegral (2 + sum (map snd grouping)) + roundedScore = fromIntegral (round (score * 4) :: Int) / 4 + in roundedScore From a42ddfd4696f8b94f8549446aaefb5984c6120fa Mon Sep 17 00:00:00 2001 From: Tom Ellis Date: Sat, 11 Jul 2026 08:11:52 +0100 Subject: [PATCH 03/33] (refactor) Move votesStateComponent --- hackage-server.cabal | 1 + src/Distribution/Server/Features/Votes.hs | 20 +------------- .../Server/Features/Votes/Acid.hs | 27 +++++++++++++++++++ 3 files changed, 29 insertions(+), 19 deletions(-) create mode 100644 src/Distribution/Server/Features/Votes/Acid.hs diff --git a/hackage-server.cabal b/hackage-server.cabal index cf9c42f5f..a92e07a2c 100644 --- a/hackage-server.cabal +++ b/hackage-server.cabal @@ -385,6 +385,7 @@ library Distribution.Server.Features.Search.TermBag Distribution.Server.Features.Sitemap.Functions Distribution.Server.Features.Votes + Distribution.Server.Features.Votes.Acid Distribution.Server.Features.Votes.Render Distribution.Server.Features.Votes.State Distribution.Server.Features.Votes.Store diff --git a/src/Distribution/Server/Features/Votes.hs b/src/Distribution/Server/Features/Votes.hs index 8af72c9e0..4eeaccf6e 100644 --- a/src/Distribution/Server/Features/Votes.hs +++ b/src/Distribution/Server/Features/Votes.hs @@ -8,12 +8,12 @@ module Distribution.Server.Features.Votes ) where import Distribution.Server.Features.Votes.Types (Score) +import Distribution.Server.Features.Votes.Acid (votesStateComponent) import qualified Distribution.Server.Features.Votes.State as Acid import qualified Distribution.Server.Features.Votes.Render as Render import Distribution.Server.Features.Votes.Store (votesScore) import Distribution.Server.Framework -import Distribution.Server.Framework.BackupRestore import Distribution.Server.Features.Core import Distribution.Server.Features.Users @@ -63,24 +63,6 @@ initVotesFeature env@ServerEnv{serverStateDir} = do return feature --- | Define the backing store (i.e. database component) -votesStateComponent :: FilePath -> IO (StateComponent AcidState Acid.VotesState) -votesStateComponent stateDir = do - st <- openLocalStateFrom (stateDir "db" "Votes") Acid.initialVotesState - return StateComponent { - stateDesc = "Backing store for Map PackageName -> Users who voted for it" - , stateHandle = st - , getState = query st Acid.GetVotesState - , putState = update st . Acid.ReplaceVotesState - , resetState = votesStateComponent - , backupState = \_ _ -> [] - , restoreState = RestoreBackup { - restoreEntry = error "Unexpected backup entry" - , restoreFinalize = return $ Acid.VotesState Map.empty - } - } - - -- | Default constructor for building this feature. votesFeature :: ServerEnv -> StateComponent AcidState Acid.VotesState diff --git a/src/Distribution/Server/Features/Votes/Acid.hs b/src/Distribution/Server/Features/Votes/Acid.hs new file mode 100644 index 000000000..53bf0dd94 --- /dev/null +++ b/src/Distribution/Server/Features/Votes/Acid.hs @@ -0,0 +1,27 @@ +module Distribution.Server.Framework.Votes.Acid + ( votesStateComponent + ) where + +import qualified Distribution.Server.Features.Votes.State as Acid + +import Distribution.Server.Framework +import Distribution.Server.Framework.BackupRestore + +import qualified Data.Map as Map + +-- | Define the backing store (i.e. database component) +votesStateComponent :: FilePath -> IO (StateComponent AcidState Acid.VotesState) +votesStateComponent stateDir = do + st <- openLocalStateFrom (stateDir "db" "Votes") Acid.initialVotesState + return StateComponent { + stateDesc = "Backing store for Map PackageName -> Users who voted for it" + , stateHandle = st + , getState = query st Acid.GetVotesState + , putState = update st . Acid.ReplaceVotesState + , resetState = votesStateComponent + , backupState = \_ _ -> [] + , restoreState = RestoreBackup { + restoreEntry = error "Unexpected backup entry" + , restoreFinalize = return $ Acid.VotesState Map.empty + } + } From 89be3686dec4ad915230b3104c282ae9366596f1 Mon Sep 17 00:00:00 2001 From: Tom Ellis Date: Sat, 11 Jul 2026 08:38:58 +0100 Subject: [PATCH 04/33] (refactor) Introduce Votes abstraction layer --- src/Distribution/Server/Features/Votes.hs | 41 ++++++++++++------- .../Server/Features/Votes/Acid.hs | 22 +++++++++- .../Server/Features/Votes/Store.hs | 25 ++++++++++- 3 files changed, 71 insertions(+), 17 deletions(-) diff --git a/src/Distribution/Server/Features/Votes.hs b/src/Distribution/Server/Features/Votes.hs index 4eeaccf6e..df75a3acb 100644 --- a/src/Distribution/Server/Features/Votes.hs +++ b/src/Distribution/Server/Features/Votes.hs @@ -4,14 +4,19 @@ -- module Distribution.Server.Features.Votes ( VotesFeature(..) + , Backend(..) + , Store(..) , initVotesFeature + , initVotesFeatureWith ) where import Distribution.Server.Features.Votes.Types (Score) -import Distribution.Server.Features.Votes.Acid (votesStateComponent) -import qualified Distribution.Server.Features.Votes.State as Acid +import Distribution.Server.Features.Votes.Acid (acidStore) import qualified Distribution.Server.Features.Votes.Render as Render -import Distribution.Server.Features.Votes.Store (votesScore) +import Distribution.Server.Features.Votes.Store + ( votesScore + , Backend(..) + , Store(..) ) import Distribution.Server.Framework @@ -53,7 +58,15 @@ initVotesFeature :: ServerEnv -> UserFeature -> IO VotesFeature) initVotesFeature env@ServerEnv{serverStateDir} = do - dbVotesState <- votesStateComponent serverStateDir + initVotesFeatureWith (acidStore serverStateDir) env + +initVotesFeatureWith :: IO Backend + -> ServerEnv + -> IO ( CoreFeature + -> UserFeature + -> IO VotesFeature ) +initVotesFeatureWith openVotesStore env = do + dbVotesState <- openVotesStore updateVotes <- newHook return $ \coref@CoreFeature{..} userf@UserFeature{..} -> do @@ -65,14 +78,14 @@ initVotesFeature env@ServerEnv{serverStateDir} = do -- | Default constructor for building this feature. votesFeature :: ServerEnv - -> StateComponent AcidState Acid.VotesState + -> Backend -> CoreFeature -- To get site package list -> UserFeature -- To authenticate users -> Hook (PackageName, Float) () -> VotesFeature votesFeature ServerEnv{..} - votesState + Backend{backendStore = votesState, backendState} CoreFeature { coreResource = CoreResource{..} } UserFeature{..} votesUpdated @@ -83,7 +96,7 @@ votesFeature ServerEnv{..} featureResources = [ packagesVotesResource , packageVotesResource ] - , featureState = [abstractAcidStateComponent votesState] + , featureState = backendState } @@ -112,7 +125,7 @@ votesFeature ServerEnv{..} servePackageVotesGet :: DynamicPath -> ServerPartE Response servePackageVotesGet _ = do cacheControlWithoutETag [Public, maxAgeMinutes 10] - votesMap <- queryState votesState Acid.GetAllPackageVoteSets + votesMap <- getAllPackageVoteSets votesState ok . toResponse $ objectL [ (display pkgname, toJSON (votesScore pkgMap)) | (pkgname, pkgMap) <- Map.toList votesMap ] @@ -144,7 +157,7 @@ votesFeature ServerEnv{..} "2" -> pure 2 "3" -> pure 3 _ -> fail "invalid score value received" - _ <- updateState votesState (Acid.AddVote pkgname uid score) + _ <- addVote votesState pkgname uid score pkgScore <- pkgNumScore pkgname runHook_ votesUpdated (pkgname, pkgScore) ok . toResponse $ "Package voted for successfully" @@ -157,7 +170,7 @@ votesFeature ServerEnv{..} pkgname <- packageInPath dpath guardValidPackageName pkgname - success <- updateState votesState (Acid.RemoveVote pkgname uid) + success <- removeVote votesState pkgname uid pkgScore <- pkgNumScore pkgname when success $ runHook_ votesUpdated (pkgname, pkgScore) @@ -171,20 +184,20 @@ votesFeature ServerEnv{..} -- package in question. didUserVote :: MonadIO m => PackageName -> UserId -> m Bool didUserVote pkgname uid = - queryState votesState (Acid.GetPackageUserVoted pkgname uid) + getPackageUserVoted votesState pkgname uid -- Returns the number of votes a package has. pkgNumVotes :: MonadIO m => PackageName -> m Int pkgNumVotes pkgname = - queryState votesState (Acid.GetPackageVoteCount pkgname) + getPackageVoteCount votesState pkgname pkgNumScore :: MonadIO m => PackageName -> m Float pkgNumScore pkgname = - queryState votesState (Acid.GetPackageVoteScore pkgname) + getPackageVoteScore votesState pkgname pkgUserVote :: MonadIO m => PackageName -> UserId -> m (Maybe Score) pkgUserVote pkgname uid = - queryState votesState (Acid.GetPackageUserVote pkgname uid) + getPackageUserVote votesState pkgname uid -- Renders the HTML for the "Votes:" section on package pages. renderVotesHtml :: PackageName -> ServerPartE X.Html diff --git a/src/Distribution/Server/Features/Votes/Acid.hs b/src/Distribution/Server/Features/Votes/Acid.hs index 53bf0dd94..aa9ee0997 100644 --- a/src/Distribution/Server/Features/Votes/Acid.hs +++ b/src/Distribution/Server/Features/Votes/Acid.hs @@ -1,7 +1,9 @@ -module Distribution.Server.Framework.Votes.Acid - ( votesStateComponent +module Distribution.Server.Features.Votes.Acid + ( acidStore + , votesStateComponent ) where +import Distribution.Server.Features.Votes.Store import qualified Distribution.Server.Features.Votes.State as Acid import Distribution.Server.Framework @@ -9,6 +11,22 @@ import Distribution.Server.Framework.BackupRestore import qualified Data.Map as Map +acidStore :: FilePath -> IO Backend +acidStore stateDir = do + votesState <- votesStateComponent stateDir + return Backend { + backendStore = Store { + getAllPackageVoteSets = queryState votesState Acid.GetAllPackageVoteSets + , addVote = \pkgname uid score -> updateState votesState (Acid.AddVote pkgname uid score) + , removeVote = \pkgname uid -> updateState votesState (Acid.RemoveVote pkgname uid) + , getPackageVoteCount = \pkgname -> queryState votesState (Acid.GetPackageVoteCount pkgname) + , getPackageVoteScore = \pkgname -> queryState votesState (Acid.GetPackageVoteScore pkgname) + , getPackageUserVoted = \pkgname uid -> queryState votesState (Acid.GetPackageUserVoted pkgname uid) + , getPackageUserVote = \pkgname uid -> queryState votesState (Acid.GetPackageUserVote pkgname uid) + } + , backendState = [abstractAcidStateComponent votesState] + } + -- | Define the backing store (i.e. database component) votesStateComponent :: FilePath -> IO (StateComponent AcidState Acid.VotesState) votesStateComponent stateDir = do diff --git a/src/Distribution/Server/Features/Votes/Store.hs b/src/Distribution/Server/Features/Votes/Store.hs index 03ee1f0b5..5cc87fd61 100644 --- a/src/Distribution/Server/Features/Votes/Store.hs +++ b/src/Distribution/Server/Features/Votes/Store.hs @@ -1,15 +1,38 @@ +{-# LANGUAGE RankNTypes #-} + module Distribution.Server.Features.Votes.Store - ( votesScore + ( Backend(..) + , Store(..) + , votesScore ) where import Distribution.Server.Features.Votes.Types +import Distribution.Server.Framework.Feature (AbstractStateComponent) import Distribution.Server.Users.Types (UserId) +import Distribution.Package (PackageName) + import Control.Arrow ((&&&)) +import Control.Monad.Trans (MonadIO) import Data.List (group, sort) import Data.Map (Map) import qualified Data.Map as Map +data Backend = Backend { + backendStore :: Store + , backendState :: [AbstractStateComponent] + } + +data Store = Store { + getAllPackageVoteSets :: forall m. MonadIO m => m (Map.Map PackageName (Map.Map UserId Score)) + , addVote :: forall m. MonadIO m => PackageName -> UserId -> Score -> m Float + , removeVote :: forall m. MonadIO m => PackageName -> UserId -> m Bool + , getPackageVoteCount :: forall m. MonadIO m => PackageName -> m Int + , getPackageVoteScore :: forall m. MonadIO m => PackageName -> m Float + , getPackageUserVoted :: forall m. MonadIO m => PackageName -> UserId -> m Bool + , getPackageUserVote :: forall m. MonadIO m => PackageName -> UserId -> m (Maybe Score) + } + -- Using a Bayesian average (m=1.5, C=2) to calculate scoring votesScore :: Map UserId Score -> Float votesScore m = From 335d985248dbd2224da22bc87bc2e7dad20879c1 Mon Sep 17 00:00:00 2001 From: Tom Ellis Date: Sat, 11 Jul 2026 08:58:33 +0100 Subject: [PATCH 05/33] (refactor) eta reduce --- src/Distribution/Server/Features/Votes.hs | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/src/Distribution/Server/Features/Votes.hs b/src/Distribution/Server/Features/Votes.hs index df75a3acb..a296f8458 100644 --- a/src/Distribution/Server/Features/Votes.hs +++ b/src/Distribution/Server/Features/Votes.hs @@ -183,21 +183,21 @@ votesFeature ServerEnv{..} -- Returns true if a user has previously voted for the -- package in question. didUserVote :: MonadIO m => PackageName -> UserId -> m Bool - didUserVote pkgname uid = - getPackageUserVoted votesState pkgname uid + didUserVote = + getPackageUserVoted votesState -- Returns the number of votes a package has. pkgNumVotes :: MonadIO m => PackageName -> m Int - pkgNumVotes pkgname = - getPackageVoteCount votesState pkgname + pkgNumVotes = + getPackageVoteCount votesState pkgNumScore :: MonadIO m => PackageName -> m Float - pkgNumScore pkgname = - getPackageVoteScore votesState pkgname + pkgNumScore = + getPackageVoteScore votesState pkgUserVote :: MonadIO m => PackageName -> UserId -> m (Maybe Score) - pkgUserVote pkgname uid = - getPackageUserVote votesState pkgname uid + pkgUserVote = + getPackageUserVote votesState -- Renders the HTML for the "Votes:" section on package pages. renderVotesHtml :: PackageName -> ServerPartE X.Html From 84b9ed7f59eb9579b263adaba9d199303435c9ee Mon Sep 17 00:00:00 2001 From: Tom Ellis Date: Sat, 11 Jul 2026 11:40:27 +0100 Subject: [PATCH 06/33] (whitespace) Unwrap lines --- src/Distribution/Server/Features/Votes.hs | 12 ++++-------- 1 file changed, 4 insertions(+), 8 deletions(-) diff --git a/src/Distribution/Server/Features/Votes.hs b/src/Distribution/Server/Features/Votes.hs index a296f8458..b23761e8c 100644 --- a/src/Distribution/Server/Features/Votes.hs +++ b/src/Distribution/Server/Features/Votes.hs @@ -183,21 +183,17 @@ votesFeature ServerEnv{..} -- Returns true if a user has previously voted for the -- package in question. didUserVote :: MonadIO m => PackageName -> UserId -> m Bool - didUserVote = - getPackageUserVoted votesState + didUserVote = getPackageUserVoted votesState -- Returns the number of votes a package has. pkgNumVotes :: MonadIO m => PackageName -> m Int - pkgNumVotes = - getPackageVoteCount votesState + pkgNumVotes = getPackageVoteCount votesState pkgNumScore :: MonadIO m => PackageName -> m Float - pkgNumScore = - getPackageVoteScore votesState + pkgNumScore = getPackageVoteScore votesState pkgUserVote :: MonadIO m => PackageName -> UserId -> m (Maybe Score) - pkgUserVote = - getPackageUserVote votesState + pkgUserVote = getPackageUserVote votesState -- Renders the HTML for the "Votes:" section on package pages. renderVotesHtml :: PackageName -> ServerPartE X.Html From cda516fbbfb74b9ea9143e2e6bf22649d558d8f3 Mon Sep 17 00:00:00 2001 From: Tom Ellis Date: Sat, 11 Jul 2026 09:38:20 +0100 Subject: [PATCH 07/33] (refactor) Move platformStateComponent --- hackage-server.cabal | 1 + .../Server/Features/HaskellPlatform.hs | 21 +------------- .../Server/Features/HaskellPlatform/Acid.hs | 29 +++++++++++++++++++ 3 files changed, 31 insertions(+), 20 deletions(-) create mode 100644 src/Distribution/Server/Features/HaskellPlatform/Acid.hs diff --git a/hackage-server.cabal b/hackage-server.cabal index a92e07a2c..87d12b11a 100644 --- a/hackage-server.cabal +++ b/hackage-server.cabal @@ -370,6 +370,7 @@ library Distribution.Server.Features.Html.HtmlUtilities Distribution.Server.Features.HoogleData Distribution.Server.Features.HaskellPlatform + Distribution.Server.Features.HaskellPlatform.Acid Distribution.Server.Features.HaskellPlatform.State Distribution.Server.Features.PackageInfoJSON Distribution.Server.Features.Search diff --git a/src/Distribution/Server/Features/HaskellPlatform.hs b/src/Distribution/Server/Features/HaskellPlatform.hs index 90f5f241b..2e27c54ad 100644 --- a/src/Distribution/Server/Features/HaskellPlatform.hs +++ b/src/Distribution/Server/Features/HaskellPlatform.hs @@ -6,8 +6,8 @@ module Distribution.Server.Features.HaskellPlatform ( ) where import Distribution.Server.Framework -import Distribution.Server.Framework.BackupRestore +import Distribution.Server.Features.HaskellPlatform.Acid (platformStateComponent) import qualified Distribution.Server.Features.HaskellPlatform.State as Acid import Distribution.Package @@ -53,25 +53,6 @@ initPlatformFeature ServerEnv{serverStateDir} = do let feature = platformFeature platformState return feature -platformStateComponent :: FilePath -> IO (StateComponent AcidState Acid.PlatformPackages) -platformStateComponent stateDir = do - st <- openLocalStateFrom (stateDir "db" "Acid.PlatformPackages") Acid.initialPlatformPackages - return StateComponent { - stateDesc = "Platform packages" - , stateHandle = st - , getState = query st Acid.GetPlatformPackages - , putState = update st . Acid.ReplacePlatformPackages - , resetState = platformStateComponent - -- TODO: backup - -- For now backup is just empty, as this package is basically featureless - -- It defines state, but there is no way at all to modify this state - , backupState = \_ _ -> [] - , restoreState = RestoreBackup { - restoreEntry = error "Unexpected backup entry for platform" - , restoreFinalize = return Acid.initialPlatformPackages - } - } - platformFeature :: StateComponent AcidState Acid.PlatformPackages -> PlatformFeature platformFeature platformState diff --git a/src/Distribution/Server/Features/HaskellPlatform/Acid.hs b/src/Distribution/Server/Features/HaskellPlatform/Acid.hs new file mode 100644 index 000000000..f263a0b6d --- /dev/null +++ b/src/Distribution/Server/Features/HaskellPlatform/Acid.hs @@ -0,0 +1,29 @@ +{-# LANGUAGE NamedFieldPuns #-} + +module Distribution.Server.Features.HaskellPlatform.Acid + ( platformStateComponent + ) where + +import Distribution.Server.Framework +import Distribution.Server.Framework.BackupRestore + +import qualified Distribution.Server.Features.HaskellPlatform.State as Acid + +platformStateComponent :: FilePath -> IO (StateComponent AcidState Acid.PlatformPackages) +platformStateComponent stateDir = do + st <- openLocalStateFrom (stateDir "db" "Acid.PlatformPackages") Acid.initialPlatformPackages + return StateComponent { + stateDesc = "Platform packages" + , stateHandle = st + , getState = query st Acid.GetPlatformPackages + , putState = update st . Acid.ReplacePlatformPackages + , resetState = platformStateComponent + -- TODO: backup + -- For now backup is just empty, as this package is basically featureless + -- It defines state, but there is no way at all to modify this state + , backupState = \_ _ -> [] + , restoreState = RestoreBackup { + restoreEntry = error "Unexpected backup entry for platform" + , restoreFinalize = return Acid.initialPlatformPackages + } + } From 96c5d0e489fd97412961bbd54bf883bd884adefa Mon Sep 17 00:00:00 2001 From: Tom Ellis Date: Sat, 11 Jul 2026 09:41:09 +0100 Subject: [PATCH 08/33] (refactor) Introduce HaskellPlatform abstraction layer --- hackage-server.cabal | 1 + .../Server/Features/HaskellPlatform.hs | 23 ++++++++--------- .../Server/Features/HaskellPlatform/Acid.hs | 19 +++++++++++++- .../Server/Features/HaskellPlatform/Store.hs | 25 +++++++++++++++++++ 4 files changed, 54 insertions(+), 14 deletions(-) create mode 100644 src/Distribution/Server/Features/HaskellPlatform/Store.hs diff --git a/hackage-server.cabal b/hackage-server.cabal index 87d12b11a..3ab115d1b 100644 --- a/hackage-server.cabal +++ b/hackage-server.cabal @@ -372,6 +372,7 @@ library Distribution.Server.Features.HaskellPlatform Distribution.Server.Features.HaskellPlatform.Acid Distribution.Server.Features.HaskellPlatform.State + Distribution.Server.Features.HaskellPlatform.Store Distribution.Server.Features.PackageInfoJSON Distribution.Server.Features.Search Distribution.Server.Features.Search.BM25F diff --git a/src/Distribution/Server/Features/HaskellPlatform.hs b/src/Distribution/Server/Features/HaskellPlatform.hs index 2e27c54ad..12cf7093d 100644 --- a/src/Distribution/Server/Features/HaskellPlatform.hs +++ b/src/Distribution/Server/Features/HaskellPlatform.hs @@ -7,16 +7,14 @@ module Distribution.Server.Features.HaskellPlatform ( import Distribution.Server.Framework -import Distribution.Server.Features.HaskellPlatform.Acid (platformStateComponent) -import qualified Distribution.Server.Features.HaskellPlatform.State as Acid +import Distribution.Server.Features.HaskellPlatform.Acid (acidStore) +import qualified Distribution.Server.Features.HaskellPlatform.Store as Store import Distribution.Package import Distribution.Version import Distribution.Text import Data.Function -import qualified Data.Map as Map -import qualified Data.Set as Set -- Note: this can be generalized into dividing Hackage up into however many @@ -47,15 +45,15 @@ data PlatformResource = PlatformResource { initPlatformFeature :: ServerEnv -> IO (IO PlatformFeature) initPlatformFeature ServerEnv{serverStateDir} = do - platformState <- platformStateComponent serverStateDir + platformState <- acidStore serverStateDir return $ do let feature = platformFeature platformState return feature -platformFeature :: StateComponent AcidState Acid.PlatformPackages +platformFeature :: Store.Backend -> PlatformFeature -platformFeature platformState +platformFeature Store.Backend{..} = PlatformFeature{..} where platformFeatureInterface = (emptyHackageFeature "platform") { @@ -65,7 +63,7 @@ platformFeature platformState platformPackage , platformPackages ] - , featureState = [abstractAcidStateComponent platformState] + , featureState = backendState } platformResource = fix $ \r -> PlatformResource @@ -88,14 +86,13 @@ platformFeature platformState ------------------------------------------ -- functionality: showing status for a single package, and for all packages, adding a package, deleting a package platformVersions :: MonadIO m => PackageName -> m [Version] - platformVersions pkgname = liftM Set.toList $ queryState platformState $ Acid.GetPlatformPackage pkgname + platformVersions = Store.platformVersions backendStore platformPackageLatest :: MonadIO m => m [(PackageName, Version)] - platformPackageLatest = liftM (Map.toList . Map.map Set.findMax . Acid.blessedPackages) $ queryState platformState Acid.GetPlatformPackages + platformPackageLatest = Store.platformPackageLatest backendStore setPlatform :: MonadIO m => PackageName -> [Version] -> m () - setPlatform pkgname versions = updateState platformState $ Acid.SetPlatformPackage pkgname (Set.fromList versions) + setPlatform = Store.setPlatform backendStore removePlatform :: MonadIO m => PackageName -> m () - removePlatform pkgname = updateState platformState $ Acid.SetPlatformPackage pkgname Set.empty - + removePlatform = Store.removePlatform backendStore diff --git a/src/Distribution/Server/Features/HaskellPlatform/Acid.hs b/src/Distribution/Server/Features/HaskellPlatform/Acid.hs index f263a0b6d..7ae06d481 100644 --- a/src/Distribution/Server/Features/HaskellPlatform/Acid.hs +++ b/src/Distribution/Server/Features/HaskellPlatform/Acid.hs @@ -1,13 +1,30 @@ {-# LANGUAGE NamedFieldPuns #-} module Distribution.Server.Features.HaskellPlatform.Acid - ( platformStateComponent + ( acidStore ) where import Distribution.Server.Framework import Distribution.Server.Framework.BackupRestore import qualified Distribution.Server.Features.HaskellPlatform.State as Acid +import Distribution.Server.Features.HaskellPlatform.Store + +import qualified Data.Map as Map +import qualified Data.Set as Set + +acidStore :: FilePath -> IO Backend +acidStore stateDir = do + platformState <- platformStateComponent stateDir + pure Backend + { backendStore = Store + { platformVersions = \pkgname -> fmap Set.toList $ queryState platformState $ Acid.GetPlatformPackage pkgname + , platformPackageLatest = fmap (Map.toList . Map.map Set.findMax . Acid.blessedPackages) $ queryState platformState Acid.GetPlatformPackages + , setPlatform = \pkgname versions -> updateState platformState $ Acid.SetPlatformPackage pkgname (Set.fromList versions) + , removePlatform = \pkgname -> updateState platformState $ Acid.SetPlatformPackage pkgname Set.empty + } + , backendState = [abstractAcidStateComponent platformState] + } platformStateComponent :: FilePath -> IO (StateComponent AcidState Acid.PlatformPackages) platformStateComponent stateDir = do diff --git a/src/Distribution/Server/Features/HaskellPlatform/Store.hs b/src/Distribution/Server/Features/HaskellPlatform/Store.hs new file mode 100644 index 000000000..94c7a092c --- /dev/null +++ b/src/Distribution/Server/Features/HaskellPlatform/Store.hs @@ -0,0 +1,25 @@ +{-# LANGUAGE RankNTypes #-} + +module Distribution.Server.Features.HaskellPlatform.Store + ( Backend(..) + , Store(..) + ) where + +import Distribution.Server.Framework (AbstractStateComponent) + +import Distribution.Package (PackageName) +import Distribution.Version (Version) + +import Control.Monad.Trans (MonadIO) + +data Backend = Backend { + backendStore :: Store + , backendState :: [AbstractStateComponent] + } + +data Store = Store { + platformVersions :: forall m. MonadIO m => PackageName -> m [Version] + , platformPackageLatest :: forall m. MonadIO m => m [(PackageName, Version)] + , setPlatform :: forall m. MonadIO m => PackageName -> [Version] -> m () + , removePlatform :: forall m. MonadIO m => PackageName -> m () + } From 0bc50f6ddd6bbd08ba4c0b9cd3c0b03125ae9321 Mon Sep 17 00:00:00 2001 From: Tom Ellis Date: Sat, 11 Jul 2026 11:09:08 +0100 Subject: [PATCH 09/33] (refactor) Move analyticsPixelsStateComponent --- hackage-server.cabal | 1 + .../Server/Features/AnalyticsPixels.hs | 20 +--------------- .../Server/Features/AnalyticsPixels/Acid.hs | 24 +++++++++++++++++++ 3 files changed, 26 insertions(+), 19 deletions(-) create mode 100644 src/Distribution/Server/Features/AnalyticsPixels/Acid.hs diff --git a/hackage-server.cabal b/hackage-server.cabal index 3ab115d1b..3c14ef230 100644 --- a/hackage-server.cabal +++ b/hackage-server.cabal @@ -407,6 +407,7 @@ library Distribution.Server.Features.Tags.State Distribution.Server.Features.Tags.Types Distribution.Server.Features.AnalyticsPixels + Distribution.Server.Features.AnalyticsPixels.Acid Distribution.Server.Features.AnalyticsPixels.State Distribution.Server.Features.AnalyticsPixels.Types Distribution.Server.Features.UserDetails diff --git a/src/Distribution/Server/Features/AnalyticsPixels.hs b/src/Distribution/Server/Features/AnalyticsPixels.hs index fb211cda3..8c42381cf 100644 --- a/src/Distribution/Server/Features/AnalyticsPixels.hs +++ b/src/Distribution/Server/Features/AnalyticsPixels.hs @@ -10,11 +10,11 @@ module Distribution.Server.Features.AnalyticsPixels import Data.Set (Set) +import Distribution.Server.Features.AnalyticsPixels.Acid (analyticsPixelsStateComponent) import Distribution.Server.Features.AnalyticsPixels.Types import qualified Distribution.Server.Features.AnalyticsPixels.State as Acid import Distribution.Server.Framework -import Distribution.Server.Framework.BackupRestore import Distribution.Server.Features.Core import Distribution.Server.Features.Upload @@ -64,24 +64,6 @@ initAnalyticsPixelsFeature env@ServerEnv{serverStateDir} = do return feature --- | Define the backing store (i.e. database component) -analyticsPixelsStateComponent :: FilePath -> IO (StateComponent AcidState Acid.AnalyticsPixelsState) -analyticsPixelsStateComponent stateDir = do - st <- openLocalStateFrom (stateDir "db" "AnalyticsPixels") Acid.initialAnalyticsPixelsState - return StateComponent { - stateDesc = "Backing store for AnalyticsPixels feature" - , stateHandle = st - , getState = query st Acid.GetAnalyticsPixelsState - , putState = update st . Acid.ReplaceAnalyticsPixelsState - , resetState = analyticsPixelsStateComponent - , backupState = \_ _ -> [] - , restoreState = RestoreBackup { - restoreEntry = error "Unexpected backup entry" - , restoreFinalize = return Acid.initialAnalyticsPixelsState - } - } - - -- | Default constructor for building this feature. analyticsPixelsFeature :: ServerEnv -> StateComponent AcidState Acid.AnalyticsPixelsState diff --git a/src/Distribution/Server/Features/AnalyticsPixels/Acid.hs b/src/Distribution/Server/Features/AnalyticsPixels/Acid.hs new file mode 100644 index 000000000..ff8a5a6ad --- /dev/null +++ b/src/Distribution/Server/Features/AnalyticsPixels/Acid.hs @@ -0,0 +1,24 @@ +module Distribution.Server.Features.AnalyticsPixels.Acid + ( analyticsPixelsStateComponent + ) where + +import qualified Distribution.Server.Features.AnalyticsPixels.State as Acid +import Distribution.Server.Framework +import Distribution.Server.Framework.BackupRestore + +-- | Define the backing store (i.e. database component) +analyticsPixelsStateComponent :: FilePath -> IO (StateComponent AcidState Acid.AnalyticsPixelsState) +analyticsPixelsStateComponent stateDir = do + st <- openLocalStateFrom (stateDir "db" "AnalyticsPixels") Acid.initialAnalyticsPixelsState + return StateComponent { + stateDesc = "Backing store for AnalyticsPixels feature" + , stateHandle = st + , getState = query st Acid.GetAnalyticsPixelsState + , putState = update st . Acid.ReplaceAnalyticsPixelsState + , resetState = analyticsPixelsStateComponent + , backupState = \_ _ -> [] + , restoreState = RestoreBackup { + restoreEntry = error "Unexpected backup entry" + , restoreFinalize = return Acid.initialAnalyticsPixelsState + } + } From 003eb71686c91037d5921f6157063509e81d3971 Mon Sep 17 00:00:00 2001 From: Tom Ellis Date: Sat, 11 Jul 2026 11:11:10 +0100 Subject: [PATCH 10/33] (refactor) Introduce AnalyticsPixels abstraction layer --- hackage-server.cabal | 1 + .../Server/Features/AnalyticsPixels.hs | 18 ++++++------- .../Server/Features/AnalyticsPixels/Acid.hs | 15 ++++++++++- .../Server/Features/AnalyticsPixels/Store.hs | 25 +++++++++++++++++++ 4 files changed, 49 insertions(+), 10 deletions(-) create mode 100644 src/Distribution/Server/Features/AnalyticsPixels/Store.hs diff --git a/hackage-server.cabal b/hackage-server.cabal index 3c14ef230..898fa9add 100644 --- a/hackage-server.cabal +++ b/hackage-server.cabal @@ -409,6 +409,7 @@ library Distribution.Server.Features.AnalyticsPixels Distribution.Server.Features.AnalyticsPixels.Acid Distribution.Server.Features.AnalyticsPixels.State + Distribution.Server.Features.AnalyticsPixels.Store Distribution.Server.Features.AnalyticsPixels.Types Distribution.Server.Features.UserDetails Distribution.Server.Features.UserDetails.Acid diff --git a/src/Distribution/Server/Features/AnalyticsPixels.hs b/src/Distribution/Server/Features/AnalyticsPixels.hs index 8c42381cf..6182d1373 100644 --- a/src/Distribution/Server/Features/AnalyticsPixels.hs +++ b/src/Distribution/Server/Features/AnalyticsPixels.hs @@ -10,9 +10,9 @@ module Distribution.Server.Features.AnalyticsPixels import Data.Set (Set) -import Distribution.Server.Features.AnalyticsPixels.Acid (analyticsPixelsStateComponent) +import Distribution.Server.Features.AnalyticsPixels.Acid (acidStore) +import qualified Distribution.Server.Features.AnalyticsPixels.Store as Store import Distribution.Server.Features.AnalyticsPixels.Types -import qualified Distribution.Server.Features.AnalyticsPixels.State as Acid import Distribution.Server.Framework @@ -53,7 +53,7 @@ initAnalyticsPixelsFeature :: ServerEnv -> UploadFeature -> IO AnalyticsPixelsFeature) initAnalyticsPixelsFeature env@ServerEnv{serverStateDir} = do - dbAnalyticsPixelsState <- analyticsPixelsStateComponent serverStateDir + dbAnalyticsPixelsState <- acidStore serverStateDir analyticsPixelAdded <- newHook analyticsPixelRemoved <- newHook @@ -66,7 +66,7 @@ initAnalyticsPixelsFeature env@ServerEnv{serverStateDir} = do -- | Default constructor for building this feature. analyticsPixelsFeature :: ServerEnv - -> StateComponent AcidState Acid.AnalyticsPixelsState + -> Store.Backend -> CoreFeature -- To get site package list -> UserFeature -- To authenticate users -> UploadFeature -- For accessing package maintainers and trustees @@ -75,7 +75,7 @@ analyticsPixelsFeature :: ServerEnv -> AnalyticsPixelsFeature analyticsPixelsFeature ServerEnv{..} - analyticsPixelsState + Store.Backend{backendStore = analyticsPixelsState, backendState} CoreFeature { coreResource = CoreResource{..} } UserFeature{..} UploadFeature{..} @@ -86,7 +86,7 @@ analyticsPixelsFeature ServerEnv{..} analyticsPixelsFeatureInterface = (emptyHackageFeature "AnalyticsPixels") { featureDesc = "Allow users to attach analytics pixels to their packages", featureResources = [analyticsPixelsResource, userAnalyticsPixelsResource] - , featureState = [abstractAcidStateComponent analyticsPixelsState] + , featureState = backendState } analyticsPixelsResource :: Resource @@ -97,15 +97,15 @@ analyticsPixelsFeature ServerEnv{..} getPackageAnalyticsPixels :: MonadIO m => PackageName -> m (Set AnalyticsPixel) getPackageAnalyticsPixels name = - queryState analyticsPixelsState (Acid.AnalyticsPixelsForPackage name) + Store.getPackageAnalyticsPixels analyticsPixelsState name addPackageAnalyticsPixel :: MonadIO m => PackageName -> AnalyticsPixel -> m Bool addPackageAnalyticsPixel name pixel = do - added <- updateState analyticsPixelsState (Acid.AddPackageAnalyticsPixel name pixel) + added <- Store.addPackageAnalyticsPixel analyticsPixelsState name pixel when added $ runHook_ analyticsPixelAdded (name, pixel) pure added removePackageAnalyticsPixel :: MonadIO m => PackageName -> AnalyticsPixel -> m () removePackageAnalyticsPixel name pixel = do - updateState analyticsPixelsState (Acid.RemovePackageAnalyticsPixel name pixel) + Store.removePackageAnalyticsPixel analyticsPixelsState name pixel runHook_ analyticsPixelRemoved (name, pixel) diff --git a/src/Distribution/Server/Features/AnalyticsPixels/Acid.hs b/src/Distribution/Server/Features/AnalyticsPixels/Acid.hs index ff8a5a6ad..ce6cd7a4b 100644 --- a/src/Distribution/Server/Features/AnalyticsPixels/Acid.hs +++ b/src/Distribution/Server/Features/AnalyticsPixels/Acid.hs @@ -1,11 +1,24 @@ module Distribution.Server.Features.AnalyticsPixels.Acid - ( analyticsPixelsStateComponent + ( acidStore ) where import qualified Distribution.Server.Features.AnalyticsPixels.State as Acid +import Distribution.Server.Features.AnalyticsPixels.Store import Distribution.Server.Framework import Distribution.Server.Framework.BackupRestore +acidStore :: FilePath -> IO Backend +acidStore stateDir = do + analyticsPixelsState <- analyticsPixelsStateComponent stateDir + return Backend { + backendStore = Store { + getPackageAnalyticsPixels = \name -> queryState analyticsPixelsState (Acid.AnalyticsPixelsForPackage name) + , addPackageAnalyticsPixel = \name pixel -> updateState analyticsPixelsState (Acid.AddPackageAnalyticsPixel name pixel) + , removePackageAnalyticsPixel = \name pixel -> updateState analyticsPixelsState (Acid.RemovePackageAnalyticsPixel name pixel) + } + , backendState = [abstractAcidStateComponent analyticsPixelsState] + } + -- | Define the backing store (i.e. database component) analyticsPixelsStateComponent :: FilePath -> IO (StateComponent AcidState Acid.AnalyticsPixelsState) analyticsPixelsStateComponent stateDir = do diff --git a/src/Distribution/Server/Features/AnalyticsPixels/Store.hs b/src/Distribution/Server/Features/AnalyticsPixels/Store.hs new file mode 100644 index 000000000..cd287269f --- /dev/null +++ b/src/Distribution/Server/Features/AnalyticsPixels/Store.hs @@ -0,0 +1,25 @@ +{-# LANGUAGE RankNTypes #-} + +module Distribution.Server.Features.AnalyticsPixels.Store + ( Backend(..) + , Store(..) + ) where + +import Distribution.Server.Features.AnalyticsPixels.Types +import Distribution.Server.Framework (AbstractStateComponent) + +import Distribution.Package (PackageName) + +import Control.Monad.Trans (MonadIO) +import Data.Set (Set) + +data Backend = Backend { + backendStore :: Store + , backendState :: [AbstractStateComponent] + } + +data Store = Store { + getPackageAnalyticsPixels :: forall m. MonadIO m => PackageName -> m (Set AnalyticsPixel) + , addPackageAnalyticsPixel :: forall m. MonadIO m => PackageName -> AnalyticsPixel -> m Bool + , removePackageAnalyticsPixel :: forall m. MonadIO m => PackageName -> AnalyticsPixel -> m () + } From 3d7a9e114f35b18326f2e3cd820321d25cb69e58 Mon Sep 17 00:00:00 2001 From: Tom Ellis Date: Sat, 11 Jul 2026 11:30:55 +0100 Subject: [PATCH 11/33] (refactor) Eta reduce --- src/Distribution/Server/Features/AnalyticsPixels.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Distribution/Server/Features/AnalyticsPixels.hs b/src/Distribution/Server/Features/AnalyticsPixels.hs index 6182d1373..ca9c6d8d0 100644 --- a/src/Distribution/Server/Features/AnalyticsPixels.hs +++ b/src/Distribution/Server/Features/AnalyticsPixels.hs @@ -96,8 +96,8 @@ analyticsPixelsFeature ServerEnv{..} userAnalyticsPixelsResource = resourceAt "/user/:username/analytics-pixels.:format" getPackageAnalyticsPixels :: MonadIO m => PackageName -> m (Set AnalyticsPixel) - getPackageAnalyticsPixels name = - Store.getPackageAnalyticsPixels analyticsPixelsState name + getPackageAnalyticsPixels = + Store.getPackageAnalyticsPixels analyticsPixelsState addPackageAnalyticsPixel :: MonadIO m => PackageName -> AnalyticsPixel -> m Bool addPackageAnalyticsPixel name pixel = do From 7f77d62f2601b77cba1f31a7d33e606bf21ddd83 Mon Sep 17 00:00:00 2001 From: Tom Ellis Date: Sat, 11 Jul 2026 12:13:10 +0100 Subject: [PATCH 12/33] (refactor) Move mirrorersStateComponent --- hackage-server.cabal | 2 ++ src/Distribution/Server/Features/Mirror.hs | 15 +------------ .../Server/Features/Mirror/Acid.hs | 21 +++++++++++++++++++ 3 files changed, 24 insertions(+), 14 deletions(-) create mode 100644 src/Distribution/Server/Features/Mirror/Acid.hs diff --git a/hackage-server.cabal b/hackage-server.cabal index 898fa9add..19f6fa7e9 100644 --- a/hackage-server.cabal +++ b/hackage-server.cabal @@ -320,6 +320,8 @@ library Distribution.Server.Features.Security.SHA256 Distribution.Server.Features.Security.State Distribution.Server.Features.Mirror + Distribution.Server.Features.Mirror.Acid + Distribution.Server.Features.Mirror.Store Distribution.Server.Features.Upload Distribution.Server.Features.Upload.State Distribution.Server.Features.Upload.Backup diff --git a/src/Distribution/Server/Features/Mirror.hs b/src/Distribution/Server/Features/Mirror.hs index 0db7660cd..e5f1ae5ed 100644 --- a/src/Distribution/Server/Features/Mirror.hs +++ b/src/Distribution/Server/Features/Mirror.hs @@ -13,7 +13,7 @@ import Distribution.Server.Framework import Distribution.Server.Features.Core import Distribution.Server.Features.Users -import Distribution.Server.Users.State +import Distribution.Server.Features.Mirror.Acid (mirrorersStateComponent) import Distribution.Server.Packages.Types import Distribution.Server.Users.Backup import Distribution.Server.Users.Types @@ -73,19 +73,6 @@ initMirrorFeature env@ServerEnv{serverStateDir} = do return feature -mirrorersStateComponent :: FilePath -> IO (StateComponent AcidState MirrorClients) -mirrorersStateComponent stateDir = do - st <- openLocalStateFrom (stateDir "db" "MirrorClients") initialMirrorClients - return StateComponent { - stateDesc = "Mirror clients" - , stateHandle = st - , getState = query st GetMirrorClients - , putState = update st . ReplaceMirrorClients . mirrorClients - , backupState = \_ (MirrorClients clients) -> [csvToBackup ["clients.csv"] $ groupToCSV clients] - , restoreState = MirrorClients <$> groupBackup ["clients.csv"] - , resetState = mirrorersStateComponent - } - mirrorFeature :: ServerEnv -> CoreFeature -> UserFeature diff --git a/src/Distribution/Server/Features/Mirror/Acid.hs b/src/Distribution/Server/Features/Mirror/Acid.hs new file mode 100644 index 000000000..adec7e23b --- /dev/null +++ b/src/Distribution/Server/Features/Mirror/Acid.hs @@ -0,0 +1,21 @@ +module Distribution.Server.Features.Mirror.Acid + ( mirrorersStateComponent + ) where + +import Distribution.Server.Prelude + +import Distribution.Server.Framework +import Distribution.Server.Users.State + +mirrorersStateComponent :: FilePath -> IO (StateComponent AcidState MirrorClients) +mirrorersStateComponent stateDir = do + st <- openLocalStateFrom (stateDir "db" "MirrorClients") initialMirrorClients + return StateComponent { + stateDesc = "Mirror clients" + , stateHandle = st + , getState = query st GetMirrorClients + , putState = update st . ReplaceMirrorClients . mirrorClients + , backupState = \_ (MirrorClients clients) -> [csvToBackup ["clients.csv"] $ groupToCSV clients] + , restoreState = MirrorClients <$> groupBackup ["clients.csv"] + , resetState = mirrorersStateComponent + } From 9a09ec96248370acbf504c83c3bea30a9470a9bc Mon Sep 17 00:00:00 2001 From: Tom Ellis Date: Sat, 11 Jul 2026 12:26:43 +0100 Subject: [PATCH 13/33] (whitespace) Wrap lines --- src/Distribution/Server/Features/Mirror.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/Distribution/Server/Features/Mirror.hs b/src/Distribution/Server/Features/Mirror.hs index e5f1ae5ed..5cc246613 100644 --- a/src/Distribution/Server/Features/Mirror.hs +++ b/src/Distribution/Server/Features/Mirror.hs @@ -93,7 +93,8 @@ mirrorFeature ServerEnv{serverBlobStore = store} , updateSetPackageUploader } UserFeature{..} - mirrorersState mirrorGroup mirrorGroupResource + mirrorersState + mirrorGroup mirrorGroupResource = (MirrorFeature{..}, mirrorersGroupDesc) where mirrorFeatureInterface = (emptyHackageFeature "mirror") { From c42ae9f6ebea70cd085e73dac75bf75ba252f63e Mon Sep 17 00:00:00 2001 From: Tom Ellis Date: Sat, 11 Jul 2026 12:26:59 +0100 Subject: [PATCH 14/33] (refactor) Introduce Mirror abstraction layer --- src/Distribution/Server/Features/Mirror.hs | 19 +++++++------- .../Server/Features/Mirror/Acid.hs | 26 ++++++++++++++++++- .../Server/Features/Mirror/Store.hs | 23 ++++++++++++++++ 3 files changed, 57 insertions(+), 11 deletions(-) create mode 100644 src/Distribution/Server/Features/Mirror/Store.hs diff --git a/src/Distribution/Server/Features/Mirror.hs b/src/Distribution/Server/Features/Mirror.hs index 5cc246613..253c6a63e 100644 --- a/src/Distribution/Server/Features/Mirror.hs +++ b/src/Distribution/Server/Features/Mirror.hs @@ -13,15 +13,14 @@ import Distribution.Server.Framework import Distribution.Server.Features.Core import Distribution.Server.Features.Users -import Distribution.Server.Features.Mirror.Acid (mirrorersStateComponent) +import Distribution.Server.Features.Mirror.Acid (acidStore) +import qualified Distribution.Server.Features.Mirror.Store as Store import Distribution.Server.Packages.Types -import Distribution.Server.Users.Backup import Distribution.Server.Users.Types import Distribution.Server.Users.Users hiding (lookupUserName) import Distribution.Server.Users.Group (UserGroup(..), GroupDescription(..), nullDescription) import qualified Distribution.Server.Framework.BlobStorage as BlobStorage import qualified Distribution.Server.Packages.Unpack as Upload -import Distribution.Server.Framework.BackupDump import Distribution.Server.Util.Parse (unpackUTF8) import Distribution.PackageDescription.Parsec (parseGenericPackageDescription, runParseResult) @@ -61,7 +60,7 @@ initMirrorFeature :: ServerEnv -> IO MirrorFeature) initMirrorFeature env@ServerEnv{serverStateDir} = do -- Canonical state - mirrorersState <- mirrorersStateComponent serverStateDir + mirrorersState <- acidStore serverStateDir return $ \core user@UserFeature{..} -> do -- Tie the knot with a do-rec @@ -76,7 +75,7 @@ initMirrorFeature env@ServerEnv{serverStateDir} = do mirrorFeature :: ServerEnv -> CoreFeature -> UserFeature - -> StateComponent AcidState MirrorClients + -> Store.Backend -> UserGroup -> GroupResource -> (MirrorFeature, UserGroup) @@ -93,7 +92,7 @@ mirrorFeature ServerEnv{serverBlobStore = store} , updateSetPackageUploader } UserFeature{..} - mirrorersState + Store.Backend{backendStore = mirrorersState, backendState} mirrorGroup mirrorGroupResource = (MirrorFeature{..}, mirrorersGroupDesc) where @@ -109,7 +108,7 @@ mirrorFeature ServerEnv{serverBlobStore = store} [ groupResource mirrorGroupResource , groupUserResource mirrorGroupResource ] - , featureState = [abstractAcidStateComponent mirrorersState] + , featureState = backendState } mirrorResource = MirrorResource { @@ -140,9 +139,9 @@ mirrorFeature ServerEnv{serverBlobStore = store} mirrorersGroupDesc = UserGroup { groupDesc = nullDescription { groupTitle = "Mirror clients" }, - queryUserGroup = queryState mirrorersState GetMirrorClientsList, - addUserToGroup = updateState mirrorersState . AddMirrorClient, - removeUserFromGroup = updateState mirrorersState . RemoveMirrorClient, + queryUserGroup = Store.getMirrorClientsList mirrorersState, + addUserToGroup = Store.addMirrorClient mirrorersState, + removeUserFromGroup = Store.removeMirrorClient mirrorersState, groupsAllowedToDelete = [adminGroup], groupsAllowedToAdd = [adminGroup] } diff --git a/src/Distribution/Server/Features/Mirror/Acid.hs b/src/Distribution/Server/Features/Mirror/Acid.hs index adec7e23b..cfcad3f75 100644 --- a/src/Distribution/Server/Features/Mirror/Acid.hs +++ b/src/Distribution/Server/Features/Mirror/Acid.hs @@ -1,11 +1,35 @@ module Distribution.Server.Features.Mirror.Acid - ( mirrorersStateComponent + ( acidStore ) where import Distribution.Server.Prelude import Distribution.Server.Framework +import Distribution.Server.Framework.BackupDump +import Distribution.Server.Features.Mirror.Store import Distribution.Server.Users.State + ( MirrorClients(..) + , GetMirrorClients(..) + , GetMirrorClientsList(..) + , ReplaceMirrorClients(..) + , AddMirrorClient(..) + , RemoveMirrorClient(..) + , initialMirrorClients + , mirrorClients + ) +import Distribution.Server.Users.Backup (groupBackup, groupToCSV) + +acidStore :: FilePath -> IO Backend +acidStore stateDir = do + mirrorersState <- mirrorersStateComponent stateDir + pure Backend { + backendStore = Store { + getMirrorClientsList = queryState mirrorersState GetMirrorClientsList + , addMirrorClient = \uid -> updateState mirrorersState (AddMirrorClient uid) + , removeMirrorClient = \uid -> updateState mirrorersState (RemoveMirrorClient uid) + } + , backendState = [abstractAcidStateComponent mirrorersState] + } mirrorersStateComponent :: FilePath -> IO (StateComponent AcidState MirrorClients) mirrorersStateComponent stateDir = do diff --git a/src/Distribution/Server/Features/Mirror/Store.hs b/src/Distribution/Server/Features/Mirror/Store.hs new file mode 100644 index 000000000..93b338691 --- /dev/null +++ b/src/Distribution/Server/Features/Mirror/Store.hs @@ -0,0 +1,23 @@ +{-# LANGUAGE RankNTypes #-} + +module Distribution.Server.Features.Mirror.Store + ( Backend(..) + , Store(..) + ) where + +import Distribution.Server.Framework (AbstractStateComponent) +import Distribution.Server.Users.UserIdSet (UserIdSet) +import Distribution.Server.Users.Types (UserId) + +import Control.Monad.Trans (MonadIO) + +data Backend = Backend { + backendStore :: Store + , backendState :: [AbstractStateComponent] + } + +data Store = Store { + getMirrorClientsList :: forall m. MonadIO m => m UserIdSet + , addMirrorClient :: forall m. MonadIO m => UserId -> m () + , removeMirrorClient :: forall m. MonadIO m => UserId -> m () + } From cfefe83797d4afcb36ce51c6954458ada5318fe1 Mon Sep 17 00:00:00 2001 From: Tom Ellis Date: Sat, 11 Jul 2026 12:58:18 +0100 Subject: [PATCH 15/33] (refactor) Introduce Core abstraction layer --- hackage-server.cabal | 1 + .../Server/Features/TarIndexCache.hs | 18 +------------ .../Server/Features/TarIndexCache/Acid.hs | 26 +++++++++++++++++++ 3 files changed, 28 insertions(+), 17 deletions(-) create mode 100644 src/Distribution/Server/Features/TarIndexCache/Acid.hs diff --git a/hackage-server.cabal b/hackage-server.cabal index 19f6fa7e9..f7cdd7623 100644 --- a/hackage-server.cabal +++ b/hackage-server.cabal @@ -322,6 +322,7 @@ library Distribution.Server.Features.Mirror Distribution.Server.Features.Mirror.Acid Distribution.Server.Features.Mirror.Store + Distribution.Server.Features.TarIndexCache.Acid Distribution.Server.Features.Upload Distribution.Server.Features.Upload.State Distribution.Server.Features.Upload.Backup diff --git a/src/Distribution/Server/Features/TarIndexCache.hs b/src/Distribution/Server/Features/TarIndexCache.hs index e075d1b8c..4afe9a556 100644 --- a/src/Distribution/Server/Features/TarIndexCache.hs +++ b/src/Distribution/Server/Features/TarIndexCache.hs @@ -17,6 +17,7 @@ import Distribution.Server.Framework import Distribution.Server.Framework.BlobStorage import qualified Distribution.Server.Framework.BlobStorage as BlobStorage import Distribution.Server.Framework.BackupRestore +import Distribution.Server.Features.TarIndexCache.Acid (tarIndexCacheStateComponent) import qualified Distribution.Server.Features.TarIndexCache.State as Acid import Distribution.Server.Features.Users import Distribution.Server.Packages.Types @@ -51,23 +52,6 @@ initTarIndexCacheFeature env@ServerEnv{serverStateDir} = do let feature = tarIndexCacheFeature env users tarIndexCache return feature -tarIndexCacheStateComponent :: FilePath -> IO (StateComponent AcidState Acid.TarIndexCache) -tarIndexCacheStateComponent stateDir = do - st <- openLocalStateFrom (stateDir "db" "TarIndexCache") Acid.initialTarIndexCache - return StateComponent { - stateDesc = "Mapping from tarball blob IDs to tarindex blob IDs" - , stateHandle = st - , getState = query st Acid.GetTarIndexCache - , putState = update st . Acid.ReplaceTarIndexCache - , resetState = tarIndexCacheStateComponent - -- We don't backup the tar indices, but reconstruct them on demand - , backupState = \_ _ -> [] - , restoreState = RestoreBackup { - restoreEntry = error "The impossible happened" - , restoreFinalize = return Acid.initialTarIndexCache - } - } - tarIndexCacheFeature :: ServerEnv -> UserFeature -> StateComponent AcidState Acid.TarIndexCache diff --git a/src/Distribution/Server/Features/TarIndexCache/Acid.hs b/src/Distribution/Server/Features/TarIndexCache/Acid.hs new file mode 100644 index 000000000..fcd58326c --- /dev/null +++ b/src/Distribution/Server/Features/TarIndexCache/Acid.hs @@ -0,0 +1,26 @@ +module Distribution.Server.Features.TarIndexCache.Acid + ( tarIndexCacheStateComponent + ) where + +import Distribution.Server.Prelude + +import Distribution.Server.Framework +import Distribution.Server.Framework.BackupRestore +import Distribution.Server.Features.TarIndexCache.State as Acid + +tarIndexCacheStateComponent :: FilePath -> IO (StateComponent AcidState Acid.TarIndexCache) +tarIndexCacheStateComponent stateDir = do + st <- openLocalStateFrom (stateDir "db" "TarIndexCache") Acid.initialTarIndexCache + return StateComponent { + stateDesc = "Mapping from tarball blob IDs to tarindex blob IDs" + , stateHandle = st + , getState = query st Acid.GetTarIndexCache + , putState = update st . Acid.ReplaceTarIndexCache + , resetState = tarIndexCacheStateComponent + -- We don't backup the tar indices, but reconstruct them on demand + , backupState = \_ _ -> [] + , restoreState = RestoreBackup { + restoreEntry = error "The impossible happened" + , restoreFinalize = return Acid.initialTarIndexCache + } + } From c24e23898528e3ba9451e609e46e34b8a417be0c Mon Sep 17 00:00:00 2001 From: Tom Ellis Date: Sat, 11 Jul 2026 13:03:46 +0100 Subject: [PATCH 16/33] (refactor) Introduce TarIndexCache abstraction layer --- hackage-server.cabal | 1 + .../Server/Features/TarIndexCache.hs | 21 +++++++++--------- .../Server/Features/TarIndexCache/Acid.hs | 17 +++++++++++++- .../Server/Features/TarIndexCache/Store.hs | 22 +++++++++++++++++++ 4 files changed, 50 insertions(+), 11 deletions(-) create mode 100644 src/Distribution/Server/Features/TarIndexCache/Store.hs diff --git a/hackage-server.cabal b/hackage-server.cabal index f7cdd7623..4d413a6c3 100644 --- a/hackage-server.cabal +++ b/hackage-server.cabal @@ -323,6 +323,7 @@ library Distribution.Server.Features.Mirror.Acid Distribution.Server.Features.Mirror.Store Distribution.Server.Features.TarIndexCache.Acid + Distribution.Server.Features.TarIndexCache.Store Distribution.Server.Features.Upload Distribution.Server.Features.Upload.State Distribution.Server.Features.Upload.Backup diff --git a/src/Distribution/Server/Features/TarIndexCache.hs b/src/Distribution/Server/Features/TarIndexCache.hs index 4afe9a556..83bbda3a0 100644 --- a/src/Distribution/Server/Features/TarIndexCache.hs +++ b/src/Distribution/Server/Features/TarIndexCache.hs @@ -17,7 +17,8 @@ import Distribution.Server.Framework import Distribution.Server.Framework.BlobStorage import qualified Distribution.Server.Framework.BlobStorage as BlobStorage import Distribution.Server.Framework.BackupRestore -import Distribution.Server.Features.TarIndexCache.Acid (tarIndexCacheStateComponent) +import Distribution.Server.Features.TarIndexCache.Acid (acidStore) +import qualified Distribution.Server.Features.TarIndexCache.Store as Store import qualified Distribution.Server.Features.TarIndexCache.State as Acid import Distribution.Server.Features.Users import Distribution.Server.Packages.Types @@ -46,19 +47,19 @@ initTarIndexCacheFeature :: ServerEnv -> IO (UserFeature -> IO TarIndexCacheFeature) initTarIndexCacheFeature env@ServerEnv{serverStateDir} = do - tarIndexCache <- tarIndexCacheStateComponent serverStateDir + tarIndexCacheBackend <- acidStore serverStateDir return $ \users -> do - let feature = tarIndexCacheFeature env users tarIndexCache + let feature = tarIndexCacheFeature env users tarIndexCacheBackend return feature tarIndexCacheFeature :: ServerEnv -> UserFeature - -> StateComponent AcidState Acid.TarIndexCache + -> Store.Backend -> TarIndexCacheFeature tarIndexCacheFeature ServerEnv{serverBlobStore = store} UserFeature{..} - tarIndexCache = + Store.Backend{backendStore = tarIndexCache, backendState} = TarIndexCacheFeature{..} where tarIndexCacheFeatureInterface :: HackageFeature @@ -68,7 +69,7 @@ tarIndexCacheFeature ServerEnv{serverBlobStore = store} -- (TODO: We could potentially check that if a package occurs in both -- packages then both caches point to identical tar indices, but for -- that we would need to be in IO) - , featureState = [abstractAcidStateComponent' (\_ _ -> []) tarIndexCache] + , featureState = backendState , featureResources = [ (resourceAt "/server-status/tarindices.:format") { resourceDesc = [ (GET, "Which tar indices have been generated?") @@ -83,7 +84,7 @@ tarIndexCacheFeature ServerEnv{serverBlobStore = store} -- This is the heart of this feature cachedTarIndex :: BlobId -> IO TarIndex cachedTarIndex tarBallBlobId = do - mTarIndexBlobId <- queryState tarIndexCache (Acid.FindTarIndex tarBallBlobId) + mTarIndexBlobId <- Store.findTarIndex tarIndexCache tarBallBlobId case mTarIndexBlobId of Just tarIndexBlobId -> do serializedTarIndex <- fetch store tarIndexBlobId @@ -96,7 +97,7 @@ tarIndexCacheFeature ServerEnv{serverBlobStore = store} Left err -> throwIO (userError err) Right tarIndex -> return tarIndex tarIndexBlobId <- add store (runPutLazy (safePut tarIndex)) - updateState tarIndexCache (Acid.SetTarIndex tarBallBlobId tarIndexBlobId) + Store.setTarIndex tarIndexCache tarBallBlobId tarIndexBlobId return tarIndex cachedPackageTarIndex :: PkgTarball -> IO TarIndex @@ -104,7 +105,7 @@ tarIndexCacheFeature ServerEnv{serverBlobStore = store} serveTarIndicesStatus :: ServerPartE Response serveTarIndicesStatus = do - Acid.TarIndexCache state <- liftIO $ getState tarIndexCache + Acid.TarIndexCache state <- liftIO $ Store.getTarIndexCache tarIndexCache return . toResponse . toJSON . Map.toList $ state -- | With curl: @@ -115,7 +116,7 @@ tarIndexCacheFeature ServerEnv{serverBlobStore = store} guardAuthorised_ [InGroup adminGroup] -- TODO: This resets the tar indices _state_ only, we don't actually -- remove any blobs - liftIO $ putState tarIndexCache Acid.initialTarIndexCache + liftIO $ Store.replaceTarIndexCache tarIndexCache Acid.initialTarIndexCache ok $ toResponse "Ok!" -- Functions to access specific files in a tarball diff --git a/src/Distribution/Server/Features/TarIndexCache/Acid.hs b/src/Distribution/Server/Features/TarIndexCache/Acid.hs index fcd58326c..75b58d49f 100644 --- a/src/Distribution/Server/Features/TarIndexCache/Acid.hs +++ b/src/Distribution/Server/Features/TarIndexCache/Acid.hs @@ -1,13 +1,28 @@ module Distribution.Server.Features.TarIndexCache.Acid - ( tarIndexCacheStateComponent + ( acidStore ) where import Distribution.Server.Prelude import Distribution.Server.Framework import Distribution.Server.Framework.BackupRestore +import Distribution.Server.Features.TarIndexCache.Store import Distribution.Server.Features.TarIndexCache.State as Acid +acidStore :: FilePath -> IO Backend +acidStore stateDir = do + st <- openLocalStateFrom (stateDir "db" "TarIndexCache") Acid.initialTarIndexCache + state <- tarIndexCacheStateComponent stateDir + pure Backend { + backendStore = Store { + getTarIndexCache = query st Acid.GetTarIndexCache + , replaceTarIndexCache = update st . Acid.ReplaceTarIndexCache + , findTarIndex = query st . Acid.FindTarIndex + , setTarIndex = \tar index -> update st (Acid.SetTarIndex tar index) + } + , backendState = [abstractAcidStateComponent' (\_ _ -> []) state] + } + tarIndexCacheStateComponent :: FilePath -> IO (StateComponent AcidState Acid.TarIndexCache) tarIndexCacheStateComponent stateDir = do st <- openLocalStateFrom (stateDir "db" "TarIndexCache") Acid.initialTarIndexCache diff --git a/src/Distribution/Server/Features/TarIndexCache/Store.hs b/src/Distribution/Server/Features/TarIndexCache/Store.hs new file mode 100644 index 000000000..7f618ef1a --- /dev/null +++ b/src/Distribution/Server/Features/TarIndexCache/Store.hs @@ -0,0 +1,22 @@ +{-# LANGUAGE RankNTypes #-} + +module Distribution.Server.Features.TarIndexCache.Store + ( Backend(..) + , Store(..) + ) where + +import Distribution.Server.Framework (AbstractStateComponent) +import Distribution.Server.Features.TarIndexCache.State (TarIndexCache) +import Distribution.Server.Framework.BlobStorage (BlobId) + +data Backend = Backend { + backendStore :: Store + , backendState :: [AbstractStateComponent] + } + +data Store = Store { + getTarIndexCache :: IO TarIndexCache + , replaceTarIndexCache :: TarIndexCache -> IO () + , findTarIndex :: BlobId -> IO (Maybe BlobId) + , setTarIndex :: BlobId -> BlobId -> IO () + } From fd6a90c0354a0c0177b7fa747e671bb70b9535f3 Mon Sep 17 00:00:00 2001 From: Tom Ellis Date: Sat, 11 Jul 2026 13:27:33 +0100 Subject: [PATCH 17/33] (refactor) Move packagesStateComponent --- hackage-server.cabal | 1 + src/Distribution/Server/Features/Core.hs | 19 +-------------- src/Distribution/Server/Features/Core/Acid.hs | 24 +++++++++++++++++++ 3 files changed, 26 insertions(+), 18 deletions(-) create mode 100644 src/Distribution/Server/Features/Core/Acid.hs diff --git a/hackage-server.cabal b/hackage-server.cabal index 4d413a6c3..3fce099bd 100644 --- a/hackage-server.cabal +++ b/hackage-server.cabal @@ -307,6 +307,7 @@ library Distribution.Server.Features.Browse.Options Distribution.Server.Features.Browse.Parsers Distribution.Server.Features.Core + Distribution.Server.Features.Core.Acid Distribution.Server.Features.Core.State Distribution.Server.Features.Core.Backup Distribution.Server.Features.Security diff --git a/src/Distribution/Server/Features/Core.hs b/src/Distribution/Server/Features/Core.hs index 2bc6ff059..e64fbf9dd 100644 --- a/src/Distribution/Server/Features/Core.hs +++ b/src/Distribution/Server/Features/Core.hs @@ -18,8 +18,6 @@ module Distribution.Server.Features.Core ( -- * Misc other utils packageExists, packageIdExists, - - packagesStateComponent, ) where -- stdlib @@ -37,7 +35,7 @@ import qualified Data.Vector as Vec -- hackage import Distribution.Server.Prelude -import Distribution.Server.Features.Core.Backup +import Distribution.Server.Features.Core.Acid (packagesStateComponent) import qualified Distribution.Server.Features.Core.State as Acid import Distribution.Server.Features.Security.Migration import Distribution.Server.Features.Security.SHA256 (sha256) @@ -359,21 +357,6 @@ initCoreFeature env@ServerEnv{serverStateDir, serverCacheDelay, return feature -packagesStateComponent :: Verbosity -> Bool -> FilePath -> IO (StateComponent AcidState Acid.PackagesState) -packagesStateComponent verbosity freshDB stateDir = do - let stateFile = stateDir "db" "PackagesState" - st <- logTiming verbosity "Loaded PackagesState" $ - openLocalStateFrom stateFile (Acid.initialPackagesState freshDB) - return StateComponent { - stateDesc = "Main package database" - , stateHandle = st - , getState = query st Acid.GetPackagesState - , putState = update st . Acid.ReplacePackagesState - , backupState = \_ -> indexToAllVersions - , restoreState = packagesBackup - , resetState = packagesStateComponent verbosity True - } - coreFeature :: ServerEnv -> UserFeature -> StateComponent AcidState Acid.PackagesState diff --git a/src/Distribution/Server/Features/Core/Acid.hs b/src/Distribution/Server/Features/Core/Acid.hs new file mode 100644 index 000000000..8044ddde8 --- /dev/null +++ b/src/Distribution/Server/Features/Core/Acid.hs @@ -0,0 +1,24 @@ +module Distribution.Server.Features.Core.Acid + ( packagesStateComponent + ) where + +import Distribution.Server.Prelude + +import Distribution.Server.Features.Core.Backup +import qualified Distribution.Server.Features.Core.State as Acid +import Distribution.Server.Framework + +packagesStateComponent :: Verbosity -> Bool -> FilePath -> IO (StateComponent AcidState Acid.PackagesState) +packagesStateComponent verbosity freshDB stateDir = do + let stateFile = stateDir "db" "PackagesState" + st <- logTiming verbosity "Loaded PackagesState" $ + openLocalStateFrom stateFile (Acid.initialPackagesState freshDB) + return StateComponent { + stateDesc = "Main package database" + , stateHandle = st + , getState = query st Acid.GetPackagesState + , putState = update st . Acid.ReplacePackagesState + , backupState = \_ -> indexToAllVersions + , restoreState = packagesBackup + , resetState = packagesStateComponent verbosity True + } From cc27e633017361e8bb468a56a8b6c9e674e81554 Mon Sep 17 00:00:00 2001 From: Tom Ellis Date: Sat, 11 Jul 2026 13:29:55 +0100 Subject: [PATCH 18/33] (refactor) Introduce Core abstraction layer --- hackage-server.cabal | 1 + src/Distribution/Server/Features/Core.hs | 63 +++++++++---------- src/Distribution/Server/Features/Core/Acid.hs | 35 ++++++++++- .../Server/Features/Core/Store.hs | 37 +++++++++++ 4 files changed, 100 insertions(+), 36 deletions(-) create mode 100644 src/Distribution/Server/Features/Core/Store.hs diff --git a/hackage-server.cabal b/hackage-server.cabal index 3fce099bd..89d4badd4 100644 --- a/hackage-server.cabal +++ b/hackage-server.cabal @@ -309,6 +309,7 @@ library Distribution.Server.Features.Core Distribution.Server.Features.Core.Acid Distribution.Server.Features.Core.State + Distribution.Server.Features.Core.Store Distribution.Server.Features.Core.Backup Distribution.Server.Features.Security Distribution.Server.Features.Security.Backup diff --git a/src/Distribution/Server/Features/Core.hs b/src/Distribution/Server/Features/Core.hs index e64fbf9dd..2c0943ce4 100644 --- a/src/Distribution/Server/Features/Core.hs +++ b/src/Distribution/Server/Features/Core.hs @@ -35,9 +35,9 @@ import qualified Data.Vector as Vec -- hackage import Distribution.Server.Prelude -import Distribution.Server.Features.Core.Acid (packagesStateComponent) +import Distribution.Server.Features.Core.Acid (acidStore) +import qualified Distribution.Server.Features.Core.Store as Store import qualified Distribution.Server.Features.Core.State as Acid -import Distribution.Server.Features.Security.Migration import Distribution.Server.Features.Security.SHA256 (sha256) import Distribution.Server.Features.Users import Distribution.Server.Framework @@ -267,8 +267,8 @@ data CoreResource = CoreResource { initCoreFeature :: ServerEnv -> IO (UserFeature -> IO CoreFeature) initCoreFeature env@ServerEnv{serverStateDir, serverCacheDelay, serverVerbosity = verbosity} = do - -- Canonical state - packagesState <- packagesStateComponent verbosity False serverStateDir + packagesBackend <- acidStore env verbosity False serverStateDir + let packagesStore = Store.backendStore packagesBackend -- Hooks packageChangeHook <- newHook @@ -298,16 +298,16 @@ initCoreFeature env@ServerEnv{serverStateDir, serverCacheDelay, -- need any other kind of migration. migrateUpdateLog <- (isLeft . Acid.packageUpdateLog) <$> - queryState packagesState Acid.GetPackagesState + Store.getPackagesState packagesStore when migrateUpdateLog $ do -- Migrate Acid.PackagesState (introduce package update log) logTiming verbosity "migrating package update log" $ do userdb <- queryGetUserDb users - updateState packagesState (Acid.MigrateAddUpdateLog userdb) + Store.migrateAddUpdateLog packagesStore userdb -- Migrate PkgTarball logTiming verbosity "migrating PkgTarball" $ - migratePkgTarball_v1_to_v2 env packagesState + Store.migratePackageTarballs packagesStore -- Create a checkpoint -- @@ -323,11 +323,11 @@ initCoreFeature env@ServerEnv{serverStateDir, serverCacheDelay, -- reconstruct the package log rather than use the package log as it was -- constructed in the first place, and we might potentially lose -- information. - createCheckpoint (stateHandle packagesState) + Store.createStoreCheckpoint packagesStore rec let (feature, getIndexTarball) = coreFeature env users - packagesState indexTar + packagesBackend indexTar packageChangeHook preIndexUpdateHook packageDownloadHook @@ -352,14 +352,14 @@ initCoreFeature env@ServerEnv{serverStateDir, serverCacheDelay, PackageChangeAdd _ -> return () _ -> do additionalEntries <- concat <$> runHook preIndexUpdateHook packageChange - forM_ additionalEntries $ updateState packagesState . Acid.AddOtherIndexEntry + forM_ additionalEntries $ Store.addOtherIndexEntry packagesStore prodAsyncCache indexTar "package change" return feature coreFeature :: ServerEnv -> UserFeature - -> StateComponent AcidState Acid.PackagesState + -> Store.Backend -> AsyncCache IndexTarballInfo -> Hook PackageChange () -> Hook PackageChange [TarIndexEntry] @@ -368,7 +368,7 @@ coreFeature :: ServerEnv , IO IndexTarballInfo ) coreFeature ServerEnv{serverBlobStore = store} UserFeature{..} - packagesState cacheIndexTarball + Store.Backend{backendStore = packagesStore, backendState} cacheIndexTarball packageChangeHook preIndexUpdateHook packageDownloadHook @@ -391,7 +391,7 @@ coreFeature ServerEnv{serverBlobStore = store} UserFeature{..} , coreAdminDeauth , corePackUserDeauth ] - , featureState = [abstractAcidStateComponent packagesState] + , featureState = backendState , featureCaches = [ CacheComponent { cacheDesc = "main package index tarball", @@ -488,7 +488,7 @@ coreFeature ServerEnv{serverBlobStore = store} UserFeature{..} -- Queries -- queryGetPackageIndex :: MonadIO m => m (PackageIndex PkgInfo) - queryGetPackageIndex = Acid.packageIndex <$> queryState packagesState Acid.GetPackagesState + queryGetPackageIndex = Acid.packageIndex <$> Store.getPackagesState packagesStore queryGetIndexTarballInfo :: MonadIO m => m IndexTarballInfo queryGetIndexTarballInfo = readAsyncCache cacheIndexTarball @@ -509,12 +509,11 @@ coreFeature ServerEnv{serverBlobStore = store} UserFeature{..} let pkginfo = Acid.mkPackageInfo pkgid cabalFile uploadinfo mtarball additionalEntries <- concat `liftM` runHook preIndexUpdateHook (PackageChangeAdd pkginfo) - successFlag <- updateState packagesState $ - Acid.AddPackage3 - pkginfo - uploadinfo - (userName userInfo) - additionalEntries + successFlag <- Store.addPackage packagesStore + pkginfo + uploadinfo + (userName userInfo) + additionalEntries loginfo maxBound ("updateState(AddPackage3," ++ display pkgid ++ ") -> " ++ show successFlag) if successFlag @@ -524,7 +523,7 @@ coreFeature ServerEnv{serverBlobStore = store} UserFeature{..} updateDeletePackage :: MonadIO m => PackageId -> m Bool updateDeletePackage pkgid = logTiming maxBound ("updateDeletePackage " ++ display pkgid) $ do - mpkginfo <- updateState packagesState (Acid.DeletePackage pkgid) + mpkginfo <- Store.deletePackage packagesStore pkgid case mpkginfo of Nothing -> return False Just pkginfo -> do @@ -535,12 +534,11 @@ coreFeature ServerEnv{serverBlobStore = store} UserFeature{..} updateAddPackageRevision pkgid cabalfile uploadinfo@(_, uid) = logTiming maxBound ("updateAddPackageRevision " ++ display pkgid) $ do usersdb <- queryGetUserDb let Just userInfo = lookupUserId uid usersdb - (moldpkginfo, newpkginfo) <- updateState packagesState $ - Acid.AddPackageRevision2 - pkgid - cabalfile - uploadinfo - (userName userInfo) + (moldpkginfo, newpkginfo) <- Store.addPackageRevision packagesStore + pkgid + cabalfile + uploadinfo + (userName userInfo) loginfo maxBound ("updateState(AddPackageRevision2," ++ display pkgid ++ ") -> " ++ maybe "Nothing" (const "Just _") moldpkginfo) case moldpkginfo of Nothing -> @@ -550,7 +548,7 @@ coreFeature ServerEnv{serverBlobStore = store} UserFeature{..} updateAddPackageTarball :: MonadIO m => PackageId -> PkgTarball -> UploadInfo -> m Bool updateAddPackageTarball pkgid tarball uploadinfo = logTiming maxBound ("updateAddPackageTarball " ++ display pkgid) $ do - mpkginfo <- updateState packagesState (Acid.AddPackageTarball pkgid tarball uploadinfo) + mpkginfo <- Store.addPackageTarball packagesStore pkgid tarball uploadinfo case mpkginfo of Nothing -> return False @@ -559,7 +557,7 @@ coreFeature ServerEnv{serverBlobStore = store} UserFeature{..} return True updateSetPackageUploader pkgid userid = do - mpkginfo <- updateState packagesState (Acid.SetPackageUploader pkgid userid) + mpkginfo <- Store.setPackageUploader packagesStore pkgid userid case mpkginfo of Nothing -> return False Just (oldpkginfo, newpkginfo) -> do @@ -567,7 +565,7 @@ coreFeature ServerEnv{serverBlobStore = store} UserFeature{..} return True updateSetPackageUploadTime pkgid time = do - mpkginfo <- updateState packagesState (Acid.SetPackageUploadTime pkgid time) + mpkginfo <- Store.setPackageUploadTime packagesStore pkgid time case mpkginfo of Nothing -> return False Just (oldpkginfo, newpkginfo) -> do @@ -576,8 +574,7 @@ coreFeature ServerEnv{serverBlobStore = store} UserFeature{..} updateArchiveIndexEntry :: MonadIO m => FilePath -> LazyByteString -> UTCTime -> m () updateArchiveIndexEntry entryName entryData entryTime = logTiming maxBound ("updateArchiveIndexEntry " ++ show entryName) $ do - updateState packagesState $ - Acid.AddOtherIndexEntry $ ExtraEntry entryName entryData entryTime + Store.addOtherIndexEntry packagesStore $ ExtraEntry entryName entryData entryTime runHook_ packageChangeHook (PackageChangeIndexExtra entryName entryData entryTime) -- Cache updates @@ -586,7 +583,7 @@ coreFeature ServerEnv{serverBlobStore = store} UserFeature{..} getIndexTarball = do users <- queryGetUserDb -- note, changes here don't automatically propagate time <- getCurrentTime - Acid.PackagesState index (Right updateSeq) <- queryState packagesState Acid.GetPackagesState + Acid.PackagesState index (Right updateSeq) <- Store.getPackagesState packagesStore let updateLog = Foldable.toList updateSeq legacyTarball = Packages.Index.writeLegacy users diff --git a/src/Distribution/Server/Features/Core/Acid.hs b/src/Distribution/Server/Features/Core/Acid.hs index 8044ddde8..e38301557 100644 --- a/src/Distribution/Server/Features/Core/Acid.hs +++ b/src/Distribution/Server/Features/Core/Acid.hs @@ -1,13 +1,42 @@ module Distribution.Server.Features.Core.Acid - ( packagesStateComponent + ( acidStore + , packagesStateComponent ) where -import Distribution.Server.Prelude - import Distribution.Server.Features.Core.Backup +import Distribution.Server.Features.Core.Store import qualified Distribution.Server.Features.Core.State as Acid +import Distribution.Server.Features.Security.Migration import Distribution.Server.Framework +acidStore :: ServerEnv -> Verbosity -> Bool -> FilePath -> IO Backend +acidStore env verbosity freshDB stateDir = do + packagesState <- packagesStateComponent verbosity freshDB stateDir + pure Backend { + backendStore = Store { + getPackagesState = queryState packagesState Acid.GetPackagesState + , addPackage = \pkginfo uploadinfo username entries -> + updateState packagesState (Acid.AddPackage3 pkginfo uploadinfo username entries) + , deletePackage = \pkgid -> + updateState packagesState (Acid.DeletePackage pkgid) + , addPackageRevision = \pkgid cabalfile uploadinfo username -> + updateState packagesState (Acid.AddPackageRevision2 pkgid cabalfile uploadinfo username) + , addPackageTarball = \pkgid tarball uploadinfo -> + updateState packagesState (Acid.AddPackageTarball pkgid tarball uploadinfo) + , setPackageUploader = \pkgid userid -> + updateState packagesState (Acid.SetPackageUploader pkgid userid) + , setPackageUploadTime = \pkgid time -> + updateState packagesState (Acid.SetPackageUploadTime pkgid time) + , addOtherIndexEntry = \entry -> + updateState packagesState (Acid.AddOtherIndexEntry entry) + , migrateAddUpdateLog = \userdb -> + updateState packagesState (Acid.MigrateAddUpdateLog userdb) + , migratePackageTarballs = migratePkgTarball_v1_to_v2 env packagesState + , createStoreCheckpoint = createCheckpoint (stateHandle packagesState) + } + , backendState = [abstractAcidStateComponent packagesState] + } + packagesStateComponent :: Verbosity -> Bool -> FilePath -> IO (StateComponent AcidState Acid.PackagesState) packagesStateComponent verbosity freshDB stateDir = do let stateFile = stateDir "db" "PackagesState" diff --git a/src/Distribution/Server/Features/Core/Store.hs b/src/Distribution/Server/Features/Core/Store.hs new file mode 100644 index 000000000..a366f0f52 --- /dev/null +++ b/src/Distribution/Server/Features/Core/Store.hs @@ -0,0 +1,37 @@ +{-# LANGUAGE RankNTypes #-} + +module Distribution.Server.Features.Core.Store + ( Backend(..) + , Store(..) + ) where + +import Distribution.Server.Framework (AbstractStateComponent) +import Distribution.Server.Features.Core.State (PackagesState) +import Distribution.Server.Packages.Index (TarIndexEntry) +import Distribution.Server.Packages.Types +import Distribution.Server.Users.Types (UserId, UserName) +import Distribution.Server.Users.Users (Users) + +import Distribution.Package (PackageId) + +import Control.Monad.Trans (MonadIO) +import Data.Time.Clock (UTCTime) + +data Backend = Backend { + backendStore :: Store + , backendState :: [AbstractStateComponent] + } + +data Store = Store { + getPackagesState :: forall m. MonadIO m => m PackagesState + , addPackage :: forall m. MonadIO m => PkgInfo -> UploadInfo -> UserName -> [TarIndexEntry] -> m Bool + , deletePackage :: forall m. MonadIO m => PackageId -> m (Maybe PkgInfo) + , addPackageRevision :: forall m. MonadIO m => PackageId -> CabalFileText -> UploadInfo -> UserName -> m (Maybe PkgInfo, PkgInfo) + , addPackageTarball :: forall m. MonadIO m => PackageId -> PkgTarball -> UploadInfo -> m (Maybe (PkgInfo, PkgInfo)) + , setPackageUploader :: forall m. MonadIO m => PackageId -> UserId -> m (Maybe (PkgInfo, PkgInfo)) + , setPackageUploadTime :: forall m. MonadIO m => PackageId -> UTCTime -> m (Maybe (PkgInfo, PkgInfo)) + , addOtherIndexEntry :: forall m. MonadIO m => TarIndexEntry -> m () + , migrateAddUpdateLog :: forall m. MonadIO m => Users -> m () + , migratePackageTarballs :: IO () + , createStoreCheckpoint :: IO () + } From c8a2bad1a15c79cfa2bcc3b0233ce41d8f365936 Mon Sep 17 00:00:00 2001 From: Tom Ellis Date: Tue, 14 Jul 2026 18:10:51 +0100 Subject: [PATCH 19/33] (refactor) Pull out pkgs --- src/Distribution/Server/Features/Core.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/Distribution/Server/Features/Core.hs b/src/Distribution/Server/Features/Core.hs index 2c0943ce4..5089064df 100644 --- a/src/Distribution/Server/Features/Core.hs +++ b/src/Distribution/Server/Features/Core.hs @@ -619,7 +619,8 @@ coreFeature ServerEnv{serverBlobStore = store} UserFeature{..} lookupPackageName :: PackageName -> ServerPartE [PkgInfo] lookupPackageName pkgname = do pkgsIndex <- queryGetPackageIndex - case PackageIndex.lookupPackageName pkgsIndex pkgname of + let pkgs = PackageIndex.lookupPackageName pkgsIndex pkgname + case pkgs of [] -> packageError [MText "No such package in package index"] pkgs -> return pkgs From ddfa57c221af944b8e9a13bf8cd0c5c4fddaaa5a Mon Sep 17 00:00:00 2001 From: Tom Ellis Date: Tue, 14 Jul 2026 18:10:55 +0100 Subject: [PATCH 20/33] Add package name lookup store query --- src/Distribution/Server/Features/Core.hs | 9 +++++++-- src/Distribution/Server/Features/Core/Acid.hs | 4 ++++ src/Distribution/Server/Features/Core/Store.hs | 3 ++- 3 files changed, 13 insertions(+), 3 deletions(-) diff --git a/src/Distribution/Server/Features/Core.hs b/src/Distribution/Server/Features/Core.hs index 5089064df..53be3e1c0 100644 --- a/src/Distribution/Server/Features/Core.hs +++ b/src/Distribution/Server/Features/Core.hs @@ -74,6 +74,9 @@ data CoreFeature = CoreFeature { -- | Retrieves the entire main package index. queryGetPackageIndex :: forall m. MonadIO m => m (PackageIndex PkgInfo), + -- | Retrieves all versions of a package. + queryLookupPackageName :: forall m. MonadIO m => PackageName -> m [PkgInfo], + -- | Retrieve the raw tarball info queryGetIndexTarballInfo :: forall m. MonadIO m => m IndexTarballInfo, @@ -490,6 +493,9 @@ coreFeature ServerEnv{serverBlobStore = store} UserFeature{..} queryGetPackageIndex :: MonadIO m => m (PackageIndex PkgInfo) queryGetPackageIndex = Acid.packageIndex <$> Store.getPackagesState packagesStore + queryLookupPackageName :: MonadIO m => PackageName -> m [PkgInfo] + queryLookupPackageName = Store.lookupPackageName packagesStore + queryGetIndexTarballInfo :: MonadIO m => m IndexTarballInfo queryGetIndexTarballInfo = readAsyncCache cacheIndexTarball @@ -618,8 +624,7 @@ coreFeature ServerEnv{serverBlobStore = store} UserFeature{..} lookupPackageName :: PackageName -> ServerPartE [PkgInfo] lookupPackageName pkgname = do - pkgsIndex <- queryGetPackageIndex - let pkgs = PackageIndex.lookupPackageName pkgsIndex pkgname + pkgs <- queryLookupPackageName pkgname case pkgs of [] -> packageError [MText "No such package in package index"] pkgs -> return pkgs diff --git a/src/Distribution/Server/Features/Core/Acid.hs b/src/Distribution/Server/Features/Core/Acid.hs index e38301557..a5245ae07 100644 --- a/src/Distribution/Server/Features/Core/Acid.hs +++ b/src/Distribution/Server/Features/Core/Acid.hs @@ -8,6 +8,7 @@ import Distribution.Server.Features.Core.Store import qualified Distribution.Server.Features.Core.State as Acid import Distribution.Server.Features.Security.Migration import Distribution.Server.Framework +import qualified Distribution.Server.Packages.PackageIndex as PackageIndex acidStore :: ServerEnv -> Verbosity -> Bool -> FilePath -> IO Backend acidStore env verbosity freshDB stateDir = do @@ -15,6 +16,9 @@ acidStore env verbosity freshDB stateDir = do pure Backend { backendStore = Store { getPackagesState = queryState packagesState Acid.GetPackagesState + , lookupPackageName = \pkgname -> do + packages <- queryState packagesState Acid.GetPackagesState + pure (PackageIndex.lookupPackageName (Acid.packageIndex packages) pkgname) , addPackage = \pkginfo uploadinfo username entries -> updateState packagesState (Acid.AddPackage3 pkginfo uploadinfo username entries) , deletePackage = \pkgid -> diff --git a/src/Distribution/Server/Features/Core/Store.hs b/src/Distribution/Server/Features/Core/Store.hs index a366f0f52..5cb956580 100644 --- a/src/Distribution/Server/Features/Core/Store.hs +++ b/src/Distribution/Server/Features/Core/Store.hs @@ -12,7 +12,7 @@ import Distribution.Server.Packages.Types import Distribution.Server.Users.Types (UserId, UserName) import Distribution.Server.Users.Users (Users) -import Distribution.Package (PackageId) +import Distribution.Package (PackageId, PackageName) import Control.Monad.Trans (MonadIO) import Data.Time.Clock (UTCTime) @@ -24,6 +24,7 @@ data Backend = Backend { data Store = Store { getPackagesState :: forall m. MonadIO m => m PackagesState + , lookupPackageName :: forall m. MonadIO m => PackageName -> m [PkgInfo] , addPackage :: forall m. MonadIO m => PkgInfo -> UploadInfo -> UserName -> [TarIndexEntry] -> m Bool , deletePackage :: forall m. MonadIO m => PackageId -> m (Maybe PkgInfo) , addPackageRevision :: forall m. MonadIO m => PackageId -> CabalFileText -> UploadInfo -> UserName -> m (Maybe PkgInfo, PkgInfo) From 11eaf627461a24407a8fb236c8677a099b27079a Mon Sep 17 00:00:00 2001 From: Tom Ellis Date: Tue, 14 Jul 2026 18:08:05 +0100 Subject: [PATCH 21/33] (refactor) Pull out mpkg --- src/Distribution/Server/Features/Core.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/Distribution/Server/Features/Core.hs b/src/Distribution/Server/Features/Core.hs index 53be3e1c0..01b327b46 100644 --- a/src/Distribution/Server/Features/Core.hs +++ b/src/Distribution/Server/Features/Core.hs @@ -636,7 +636,8 @@ coreFeature ServerEnv{serverBlobStore = store} UserFeature{..} return (last pkgs) lookupPackageId pkgid = do pkgsIndex <- queryGetPackageIndex - case PackageIndex.lookupPackageId pkgsIndex pkgid of + let mpkg = PackageIndex.lookupPackageId pkgsIndex pkgid + case mpkg of Just pkg -> return pkg _ -> packageError [MText $ "No such package version for " ++ display (packageName pkgid)] From bd6c29bac1227a1458b22001bd32604f8a12dd26 Mon Sep 17 00:00:00 2001 From: Tom Ellis Date: Tue, 14 Jul 2026 18:08:15 +0100 Subject: [PATCH 22/33] Add package ID lookup store query --- src/Distribution/Server/Features/Core.hs | 9 +++++++-- src/Distribution/Server/Features/Core/Acid.hs | 3 +++ src/Distribution/Server/Features/Core/Store.hs | 1 + 3 files changed, 11 insertions(+), 2 deletions(-) diff --git a/src/Distribution/Server/Features/Core.hs b/src/Distribution/Server/Features/Core.hs index 01b327b46..b22cc5039 100644 --- a/src/Distribution/Server/Features/Core.hs +++ b/src/Distribution/Server/Features/Core.hs @@ -77,6 +77,9 @@ data CoreFeature = CoreFeature { -- | Retrieves all versions of a package. queryLookupPackageName :: forall m. MonadIO m => PackageName -> m [PkgInfo], + -- | Retrieves a specific package version. + queryLookupPackageId :: forall m. MonadIO m => PackageId -> m (Maybe PkgInfo), + -- | Retrieve the raw tarball info queryGetIndexTarballInfo :: forall m. MonadIO m => m IndexTarballInfo, @@ -496,6 +499,9 @@ coreFeature ServerEnv{serverBlobStore = store} UserFeature{..} queryLookupPackageName :: MonadIO m => PackageName -> m [PkgInfo] queryLookupPackageName = Store.lookupPackageName packagesStore + queryLookupPackageId :: MonadIO m => PackageId -> m (Maybe PkgInfo) + queryLookupPackageId = Store.lookupPackageId packagesStore + queryGetIndexTarballInfo :: MonadIO m => m IndexTarballInfo queryGetIndexTarballInfo = readAsyncCache cacheIndexTarball @@ -635,8 +641,7 @@ coreFeature ServerEnv{serverBlobStore = store} UserFeature{..} -- pkgs is sorted by version number and non-empty return (last pkgs) lookupPackageId pkgid = do - pkgsIndex <- queryGetPackageIndex - let mpkg = PackageIndex.lookupPackageId pkgsIndex pkgid + mpkg <- queryLookupPackageId pkgid case mpkg of Just pkg -> return pkg _ -> packageError [MText $ "No such package version for " ++ display (packageName pkgid)] diff --git a/src/Distribution/Server/Features/Core/Acid.hs b/src/Distribution/Server/Features/Core/Acid.hs index a5245ae07..da8d70fa3 100644 --- a/src/Distribution/Server/Features/Core/Acid.hs +++ b/src/Distribution/Server/Features/Core/Acid.hs @@ -19,6 +19,9 @@ acidStore env verbosity freshDB stateDir = do , lookupPackageName = \pkgname -> do packages <- queryState packagesState Acid.GetPackagesState pure (PackageIndex.lookupPackageName (Acid.packageIndex packages) pkgname) + , lookupPackageId = \pkgid -> do + packages <- queryState packagesState Acid.GetPackagesState + pure (PackageIndex.lookupPackageId (Acid.packageIndex packages) pkgid) , addPackage = \pkginfo uploadinfo username entries -> updateState packagesState (Acid.AddPackage3 pkginfo uploadinfo username entries) , deletePackage = \pkgid -> diff --git a/src/Distribution/Server/Features/Core/Store.hs b/src/Distribution/Server/Features/Core/Store.hs index 5cb956580..0234aa04e 100644 --- a/src/Distribution/Server/Features/Core/Store.hs +++ b/src/Distribution/Server/Features/Core/Store.hs @@ -25,6 +25,7 @@ data Backend = Backend { data Store = Store { getPackagesState :: forall m. MonadIO m => m PackagesState , lookupPackageName :: forall m. MonadIO m => PackageName -> m [PkgInfo] + , lookupPackageId :: forall m. MonadIO m => PackageId -> m (Maybe PkgInfo) , addPackage :: forall m. MonadIO m => PkgInfo -> UploadInfo -> UserName -> [TarIndexEntry] -> m Bool , deletePackage :: forall m. MonadIO m => PackageId -> m (Maybe PkgInfo) , addPackageRevision :: forall m. MonadIO m => PackageId -> CabalFileText -> UploadInfo -> UserName -> m (Maybe PkgInfo, PkgInfo) From 77925216816106aaa883291d771410eb06c532bf Mon Sep 17 00:00:00 2001 From: Tom Ellis Date: Tue, 14 Jul 2026 18:26:29 +0100 Subject: [PATCH 23/33] (refactor) Pull out PackageList add-hook pkgs --- src/Distribution/Server/Features/PackageList.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/Distribution/Server/Features/PackageList.hs b/src/Distribution/Server/Features/PackageList.hs index d2b063c29..2346239da 100644 --- a/src/Distribution/Server/Features/PackageList.hs +++ b/src/Distribution/Server/Features/PackageList.hs @@ -153,7 +153,8 @@ initListFeature _env = do let pkgname = packageName . packageId $ pkg prefsinfo <- queryGetPreferredInfo pkgname index <- queryGetPackageIndex - let allVersions = packageVersion <$> PackageIndex.lookupPackageName index pkgname + let pkgs = PackageIndex.lookupPackageName index pkgname + let allVersions = packageVersion <$> pkgs modifyItem pkgname $ \x -> updateReferenceVersion prefsinfo allVersions $ x From ac4531b3fdf381c4bb90bb51ecd516f6ce13cfae Mon Sep 17 00:00:00 2001 From: Tom Ellis Date: Tue, 14 Jul 2026 18:26:45 +0100 Subject: [PATCH 24/33] (refactor) Pull out PackageList preferred-hook pkgs --- src/Distribution/Server/Features/PackageList.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/Distribution/Server/Features/PackageList.hs b/src/Distribution/Server/Features/PackageList.hs index 2346239da..96fba93f4 100644 --- a/src/Distribution/Server/Features/PackageList.hs +++ b/src/Distribution/Server/Features/PackageList.hs @@ -198,7 +198,8 @@ initListFeature _env = do registerHook updatePreferredHook $ \(pkgname, prefsinfo) -> do index <- queryGetPackageIndex - let allVersions = packageVersion <$> PackageIndex.lookupPackageName index pkgname + let pkgs = PackageIndex.lookupPackageName index pkgname + let allVersions = packageVersion <$> pkgs modifyItem pkgname $ updateReferenceVersion prefsinfo allVersions return feature From cc24df6aabd4b0f98146cda6d525fab8a9d3a3fa Mon Sep 17 00:00:00 2001 From: Tom Ellis Date: Tue, 14 Jul 2026 18:28:52 +0100 Subject: [PATCH 25/33] Use package name lookup query in list and search --- src/Distribution/Server/Features/PackageList.hs | 12 ++++-------- src/Distribution/Server/Features/Search.hs | 3 +-- 2 files changed, 5 insertions(+), 10 deletions(-) diff --git a/src/Distribution/Server/Features/PackageList.hs b/src/Distribution/Server/Features/PackageList.hs index 96fba93f4..f4aa8b08a 100644 --- a/src/Distribution/Server/Features/PackageList.hs +++ b/src/Distribution/Server/Features/PackageList.hs @@ -152,8 +152,7 @@ initListFeature _env = do registerHookJust packageChangeHook isPackageAdd $ \pkg -> do let pkgname = packageName . packageId $ pkg prefsinfo <- queryGetPreferredInfo pkgname - index <- queryGetPackageIndex - let pkgs = PackageIndex.lookupPackageName index pkgname + pkgs <- queryLookupPackageName pkgname let allVersions = packageVersion <$> pkgs modifyItem pkgname $ \x -> updateReferenceVersion prefsinfo allVersions $ @@ -197,8 +196,7 @@ initListFeature _env = do runHook_ itemUpdate (Set.singleton pkgname) registerHook updatePreferredHook $ \(pkgname, prefsinfo) -> do - index <- queryGetPackageIndex - let pkgs = PackageIndex.lookupPackageName index pkgname + pkgs <- queryLookupPackageName pkgname let allVersions = packageVersion <$> pkgs modifyItem pkgname $ updateReferenceVersion prefsinfo allVersions @@ -254,15 +252,13 @@ listFeature CoreFeature{..} case hasItem of True -> modifyMemState itemCache $ Map.adjust token pkgname False -> do - index <- queryGetPackageIndex - let pkgs = PackageIndex.lookupPackageName index pkgname + pkgs <- queryLookupPackageName pkgname case pkgs of [] -> return () --this shouldn't happen _ -> modifyMemState itemCache . uncurry Map.insert =<< constructItem (last pkgs) updateDesc pkgname = do - index <- queryGetPackageIndex - let pkgs = PackageIndex.lookupPackageName index pkgname + pkgs <- queryLookupPackageName pkgname case pkgs of [] -> modifyMemState itemCache (Map.delete pkgname) _ -> modifyItem pkgname (updateDescriptionItem $ pkgDesc $ last pkgs) diff --git a/src/Distribution/Server/Features/Search.hs b/src/Distribution/Server/Features/Search.hs index 9bae0e2f3..315e77b7f 100644 --- a/src/Distribution/Server/Features/Search.hs +++ b/src/Distribution/Server/Features/Search.hs @@ -117,8 +117,7 @@ searchFeature ServerEnv{serverBaseURI} CoreFeature{..} ListFeature{getAllLists} --TODO: update periodically for download count changes updatePackage :: PackageName -> IO () updatePackage pkgname = do - index <- queryGetPackageIndex - let pkgs = PackageIndex.lookupPackageName index pkgname + pkgs <- queryLookupPackageName pkgname case reverse pkgs of [] -> modifyMemState searchEngineState (SearchEngine.deleteDoc pkgname) From ff504c232e7d7c9b02acf9adb717aa18832f437a Mon Sep 17 00:00:00 2001 From: Tom Ellis Date: Tue, 14 Jul 2026 18:53:08 +0100 Subject: [PATCH 26/33] (refactor) Add Search pkgname let --- src/Distribution/Server/Features/Search.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Distribution/Server/Features/Search.hs b/src/Distribution/Server/Features/Search.hs index 315e77b7f..c151f794c 100644 --- a/src/Distribution/Server/Features/Search.hs +++ b/src/Distribution/Server/Features/Search.hs @@ -107,7 +107,7 @@ searchFeature ServerEnv{serverBaseURI} CoreFeature{..} ListFeature{getAllLists} let pkgs = [ (getSearchDoc pkgLatestVer, pkgdownloads pkgname) | pkgVers <- PackageIndex.allPackagesByName pkgindex , let pkgLatestVer = last pkgVers - pkgname = packageName pkgLatestVer ] + , let pkgname = packageName pkgLatestVer ] se = SearchEngine.insertDocs pkgs initialPkgSearchEngine writeMemState searchEngineState se From d5184c117a892fcdb7e0a6d1c658868bc5416ef4 Mon Sep 17 00:00:00 2001 From: Tom Ellis Date: Tue, 14 Jul 2026 19:13:48 +0100 Subject: [PATCH 27/33] (refactor) Apply last earlier --- src/Distribution/Server/Features/Tags.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/Distribution/Server/Features/Tags.hs b/src/Distribution/Server/Features/Tags.hs index 09b4723e8..255e8465e 100644 --- a/src/Distribution/Server/Features/Tags.hs +++ b/src/Distribution/Server/Features/Tags.hs @@ -313,9 +313,9 @@ constructTagIndex = foldl' addToTags Acid.emptyPackageTags . PackageIndex.allPac -- tags on startup constructImmutableTagIndex :: PackageIndex PkgInfo -> Acid.PackageTags -constructImmutableTagIndex = foldl' addToTags Acid.emptyPackageTags . PackageIndex.allPackagesByName - where addToTags calcTags pkgList = - let info = pkgDesc $ last pkgList +constructImmutableTagIndex = foldl' addToTags Acid.emptyPackageTags . fmap last . PackageIndex.allPackagesByName + where addToTags calcTags pkg = + let info = pkgDesc pkg !pn = packageName info !tags = constructImmutableTags info in Acid.setTags pn (Set.fromList tags) calcTags From edaa9700fcbbe260e22e51f50be38de4d241cc9d Mon Sep 17 00:00:00 2001 From: Tom Ellis Date: Tue, 14 Jul 2026 19:17:11 +0100 Subject: [PATCH 28/33] (refactor) Extract latest package earlier --- src/Distribution/Server/Features/Tags.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/Distribution/Server/Features/Tags.hs b/src/Distribution/Server/Features/Tags.hs index 255e8465e..307548ce7 100644 --- a/src/Distribution/Server/Features/Tags.hs +++ b/src/Distribution/Server/Features/Tags.hs @@ -201,7 +201,7 @@ tagsFeature CoreFeature{ queryGetPackageIndex } initImmutableTags :: IO () initImmutableTags = do index <- queryGetPackageIndex - let calcTags = Acid.tagPackages $ constructImmutableTagIndex index + let calcTags = Acid.tagPackages $ constructImmutableTagIndex ((fmap last . PackageIndex.allPackagesByName) index) aliases <- mapM (queryState tagsAlias . Acid.GetTagAlias) $ Map.keys calcTags let calcTags' = Map.toList . Map.fromListWith Set.union $ zip aliases (Map.elems calcTags) forM_ calcTags' $ uncurry setCalculatedTag @@ -312,8 +312,8 @@ constructTagIndex = foldl' addToTags Acid.emptyPackageTags . PackageIndex.allPac in Acid.setTags pkgname (Set.union categoryTags immutableTags) pkgTags -- tags on startup -constructImmutableTagIndex :: PackageIndex PkgInfo -> Acid.PackageTags -constructImmutableTagIndex = foldl' addToTags Acid.emptyPackageTags . fmap last . PackageIndex.allPackagesByName +constructImmutableTagIndex :: [PkgInfo] -> Acid.PackageTags +constructImmutableTagIndex = foldl' addToTags Acid.emptyPackageTags where addToTags calcTags pkg = let info = pkgDesc pkg !pn = packageName info From baba6669c12ff084e2b06f4be6edf65846b110a7 Mon Sep 17 00:00:00 2001 From: Tom Ellis Date: Tue, 14 Jul 2026 19:20:39 +0100 Subject: [PATCH 29/33] (refactor) Pull out latestPackages --- src/Distribution/Server/Features/Tags.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/Distribution/Server/Features/Tags.hs b/src/Distribution/Server/Features/Tags.hs index 307548ce7..e9752d93c 100644 --- a/src/Distribution/Server/Features/Tags.hs +++ b/src/Distribution/Server/Features/Tags.hs @@ -201,7 +201,8 @@ tagsFeature CoreFeature{ queryGetPackageIndex } initImmutableTags :: IO () initImmutableTags = do index <- queryGetPackageIndex - let calcTags = Acid.tagPackages $ constructImmutableTagIndex ((fmap last . PackageIndex.allPackagesByName) index) + let latestPackages = (fmap last . PackageIndex.allPackagesByName) index + let calcTags = Acid.tagPackages $ constructImmutableTagIndex latestPackages aliases <- mapM (queryState tagsAlias . Acid.GetTagAlias) $ Map.keys calcTags let calcTags' = Map.toList . Map.fromListWith Set.union $ zip aliases (Map.elems calcTags) forM_ calcTags' $ uncurry setCalculatedTag From 85ab3aa46108914450706ecdc2159bb182ab4052 Mon Sep 17 00:00:00 2001 From: Tom Ellis Date: Tue, 14 Jul 2026 18:54:27 +0100 Subject: [PATCH 30/33] Add latest package versions query --- src/Distribution/Server/Features/Core.hs | 6 ++++++ src/Distribution/Server/Features/Core/Acid.hs | 5 +++++ src/Distribution/Server/Features/Core/Store.hs | 1 + src/Distribution/Server/Features/PackageList.hs | 5 ++--- src/Distribution/Server/Features/Search.hs | 8 +++----- src/Distribution/Server/Features/Tags.hs | 5 ++--- 6 files changed, 19 insertions(+), 11 deletions(-) diff --git a/src/Distribution/Server/Features/Core.hs b/src/Distribution/Server/Features/Core.hs index b22cc5039..f30dc86dd 100644 --- a/src/Distribution/Server/Features/Core.hs +++ b/src/Distribution/Server/Features/Core.hs @@ -80,6 +80,9 @@ data CoreFeature = CoreFeature { -- | Retrieves a specific package version. queryLookupPackageId :: forall m. MonadIO m => PackageId -> m (Maybe PkgInfo), + -- | Retrieves the latest version of every package. + queryLatestPackages :: forall m. MonadIO m => m [PkgInfo], + -- | Retrieve the raw tarball info queryGetIndexTarballInfo :: forall m. MonadIO m => m IndexTarballInfo, @@ -502,6 +505,9 @@ coreFeature ServerEnv{serverBlobStore = store} UserFeature{..} queryLookupPackageId :: MonadIO m => PackageId -> m (Maybe PkgInfo) queryLookupPackageId = Store.lookupPackageId packagesStore + queryLatestPackages :: MonadIO m => m [PkgInfo] + queryLatestPackages = Store.latestPackages packagesStore + queryGetIndexTarballInfo :: MonadIO m => m IndexTarballInfo queryGetIndexTarballInfo = readAsyncCache cacheIndexTarball diff --git a/src/Distribution/Server/Features/Core/Acid.hs b/src/Distribution/Server/Features/Core/Acid.hs index da8d70fa3..9cbf31095 100644 --- a/src/Distribution/Server/Features/Core/Acid.hs +++ b/src/Distribution/Server/Features/Core/Acid.hs @@ -10,6 +10,8 @@ import Distribution.Server.Features.Security.Migration import Distribution.Server.Framework import qualified Distribution.Server.Packages.PackageIndex as PackageIndex +import qualified Data.List.NonEmpty as NE + acidStore :: ServerEnv -> Verbosity -> Bool -> FilePath -> IO Backend acidStore env verbosity freshDB stateDir = do packagesState <- packagesStateComponent verbosity freshDB stateDir @@ -22,6 +24,9 @@ acidStore env verbosity freshDB stateDir = do , lookupPackageId = \pkgid -> do packages <- queryState packagesState Acid.GetPackagesState pure (PackageIndex.lookupPackageId (Acid.packageIndex packages) pkgid) + , latestPackages = do + packages <- queryState packagesState Acid.GetPackagesState + pure (NE.last <$> PackageIndex.allPackagesByNameNE (Acid.packageIndex packages)) , addPackage = \pkginfo uploadinfo username entries -> updateState packagesState (Acid.AddPackage3 pkginfo uploadinfo username entries) , deletePackage = \pkgid -> diff --git a/src/Distribution/Server/Features/Core/Store.hs b/src/Distribution/Server/Features/Core/Store.hs index 0234aa04e..23856468a 100644 --- a/src/Distribution/Server/Features/Core/Store.hs +++ b/src/Distribution/Server/Features/Core/Store.hs @@ -26,6 +26,7 @@ data Store = Store { getPackagesState :: forall m. MonadIO m => m PackagesState , lookupPackageName :: forall m. MonadIO m => PackageName -> m [PkgInfo] , lookupPackageId :: forall m. MonadIO m => PackageId -> m (Maybe PkgInfo) + , latestPackages :: forall m. MonadIO m => m [PkgInfo] , addPackage :: forall m. MonadIO m => PkgInfo -> UploadInfo -> UserName -> [TarIndexEntry] -> m Bool , deletePackage :: forall m. MonadIO m => PackageId -> m (Maybe PkgInfo) , addPackageRevision :: forall m. MonadIO m => PackageId -> CabalFileText -> UploadInfo -> UserName -> m (Maybe PkgInfo, PkgInfo) diff --git a/src/Distribution/Server/Features/PackageList.hs b/src/Distribution/Server/Features/PackageList.hs index f4aa8b08a..5f03931cd 100644 --- a/src/Distribution/Server/Features/PackageList.hs +++ b/src/Distribution/Server/Features/PackageList.hs @@ -19,7 +19,6 @@ import Distribution.Server.Users.Users (userIdToName) import qualified Distribution.Server.Users.UserIdSet as UserIdSet import Distribution.Server.Users.Group(UserGroup(..), GroupDescription(..)) import Distribution.Server.Features.PreferredVersions -import qualified Distribution.Server.Packages.PackageIndex as PackageIndex import Distribution.Server.Util.CountingMap (cmFind) import Distribution.Server.Packages.Types @@ -274,8 +273,8 @@ listFeature CoreFeature{..} constructItemIndex :: IO (Map PackageName PackageItem) constructItemIndex = do - index <- queryGetPackageIndex - items <- mapM (constructItem . last) $ PackageIndex.allPackagesByName index + latestPackages <- queryLatestPackages + items <- mapM constructItem latestPackages return $ Map.fromList items constructItem :: PkgInfo -> IO (PackageName, PackageItem) diff --git a/src/Distribution/Server/Features/Search.hs b/src/Distribution/Server/Features/Search.hs index c151f794c..6d57f9513 100644 --- a/src/Distribution/Server/Features/Search.hs +++ b/src/Distribution/Server/Features/Search.hs @@ -12,7 +12,6 @@ import Distribution.Server.Features.PackageList 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 @@ -102,12 +101,11 @@ searchFeature ServerEnv{serverBaseURI} CoreFeature{..} ListFeature{getAllLists} getSearchDoc = flattenPackageDescription . pkgDesc postInit = do - pkgindex <- queryGetPackageIndex + latestPackages <- queryLatestPackages pkgdownloads <- getDownloadCounts let pkgs = [ (getSearchDoc pkgLatestVer, pkgdownloads pkgname) - | pkgVers <- PackageIndex.allPackagesByName pkgindex - , let pkgLatestVer = last pkgVers - , let pkgname = packageName pkgLatestVer ] + | pkgLatestVer <- latestPackages + , let pkgname = packageName pkgLatestVer ] se = SearchEngine.insertDocs pkgs initialPkgSearchEngine writeMemState searchEngineState se diff --git a/src/Distribution/Server/Features/Tags.hs b/src/Distribution/Server/Features/Tags.hs index e9752d93c..cdd8ac507 100644 --- a/src/Distribution/Server/Features/Tags.hs +++ b/src/Distribution/Server/Features/Tags.hs @@ -154,7 +154,7 @@ tagsFeature :: CoreFeature -> MemState (Map PackageName (Set Tag, Set Tag)) -> TagsFeature -tagsFeature CoreFeature{ queryGetPackageIndex } +tagsFeature CoreFeature{ queryGetPackageIndex, queryLatestPackages } UploadFeature{ maintainersGroup, trusteesGroup } UserFeature{ guardAuthorised' } tagsState @@ -200,8 +200,7 @@ tagsFeature CoreFeature{ queryGetPackageIndex } initImmutableTags :: IO () initImmutableTags = do - index <- queryGetPackageIndex - let latestPackages = (fmap last . PackageIndex.allPackagesByName) index + latestPackages <- queryLatestPackages let calcTags = Acid.tagPackages $ constructImmutableTagIndex latestPackages aliases <- mapM (queryState tagsAlias . Acid.GetTagAlias) $ Map.keys calcTags let calcTags' = Map.toList . Map.fromListWith Set.union $ zip aliases (Map.elems calcTags) From cc82bb10b97c68ceab718a1fbd9b61854101dd2c Mon Sep 17 00:00:00 2001 From: Tom Ellis Date: Wed, 15 Jul 2026 07:30:34 +0100 Subject: [PATCH 31/33] (refactor) Run allPackageNames earlier --- src/Distribution/Server/Features/Tags.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/Distribution/Server/Features/Tags.hs b/src/Distribution/Server/Features/Tags.hs index cdd8ac507..ae740f44e 100644 --- a/src/Distribution/Server/Features/Tags.hs +++ b/src/Distribution/Server/Features/Tags.hs @@ -242,12 +242,12 @@ tagsFeature CoreFeature{ queryGetPackageIndex, queryLatestPackages } Just (Tag orig) -> do index <- queryGetPackageIndex void $ updateState tagsAlias $ Acid.AddTagAlias (Tag orig) deprTag - void $ constructMergedTagIndex (Tag orig) deprTag index + void $ constructMergedTagIndex (Tag orig) deprTag (PackageIndex.allPackageNames index) _ -> errBadRequest "Tag not recognised" [MText "Couldn't parse tag. It should be a single tag."] -- tags on merging - constructMergedTagIndex :: forall m. (Functor m, MonadIO m) => Tag -> Tag -> PackageIndex PkgInfo -> m Acid.PackageTags - constructMergedTagIndex orig depr = foldM addToTags Acid.emptyPackageTags . PackageIndex.allPackageNames + constructMergedTagIndex :: forall m. (Functor m, MonadIO m) => Tag -> Tag -> [PackageName] -> m Acid.PackageTags + constructMergedTagIndex orig depr = foldM addToTags Acid.emptyPackageTags where addToTags calcTags pn = do pkgTags <- queryTagsForPackage pn if Set.member depr pkgTags From 6f3941132ff9188744c368c21f99b02dfe24b2f6 Mon Sep 17 00:00:00 2001 From: Tom Ellis Date: Wed, 15 Jul 2026 07:30:59 +0100 Subject: [PATCH 32/33] (refactor) Pull out pkgNames --- src/Distribution/Server/Features/Tags.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/Distribution/Server/Features/Tags.hs b/src/Distribution/Server/Features/Tags.hs index ae740f44e..7ad5df74c 100644 --- a/src/Distribution/Server/Features/Tags.hs +++ b/src/Distribution/Server/Features/Tags.hs @@ -241,8 +241,9 @@ tagsFeature CoreFeature{ queryGetPackageIndex, queryLatestPackages } case simpleParse =<< targetTag of Just (Tag orig) -> do index <- queryGetPackageIndex + let pkgNames = PackageIndex.allPackageNames index void $ updateState tagsAlias $ Acid.AddTagAlias (Tag orig) deprTag - void $ constructMergedTagIndex (Tag orig) deprTag (PackageIndex.allPackageNames index) + void $ constructMergedTagIndex (Tag orig) deprTag pkgNames _ -> errBadRequest "Tag not recognised" [MText "Couldn't parse tag. It should be a single tag."] -- tags on merging From c1c740fe3d9df5c52b152057b6d49f05682f7529 Mon Sep 17 00:00:00 2001 From: Tom Ellis Date: Wed, 15 Jul 2026 07:33:57 +0100 Subject: [PATCH 33/33] (refactor) Use queryLatestPackages instead of queryGetPackageIndex The former returns a smaller result. --- src/Distribution/Server/Features/Tags.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/Distribution/Server/Features/Tags.hs b/src/Distribution/Server/Features/Tags.hs index 7ad5df74c..ae51e24a4 100644 --- a/src/Distribution/Server/Features/Tags.hs +++ b/src/Distribution/Server/Features/Tags.hs @@ -154,7 +154,7 @@ tagsFeature :: CoreFeature -> MemState (Map PackageName (Set Tag, Set Tag)) -> TagsFeature -tagsFeature CoreFeature{ queryGetPackageIndex, queryLatestPackages } +tagsFeature CoreFeature{ queryLatestPackages } UploadFeature{ maintainersGroup, trusteesGroup } UserFeature{ guardAuthorised' } tagsState @@ -240,8 +240,8 @@ tagsFeature CoreFeature{ queryGetPackageIndex, queryLatestPackages } mergeTags targetTag deprTag = case simpleParse =<< targetTag of Just (Tag orig) -> do - index <- queryGetPackageIndex - let pkgNames = PackageIndex.allPackageNames index + latestPkgs <- queryLatestPackages + let pkgNames = packageName <$> latestPkgs void $ updateState tagsAlias $ Acid.AddTagAlias (Tag orig) deprTag void $ constructMergedTagIndex (Tag orig) deprTag pkgNames _ -> errBadRequest "Tag not recognised" [MText "Couldn't parse tag. It should be a single tag."]