From d44cfd3cd8bafbdaf8d6d8879bb6bd62d9cb1897 Mon Sep 17 00:00:00 2001 From: Tom Ellis Date: Sat, 11 Jul 2026 11:36:55 +0100 Subject: [PATCH 01/68] (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 53beefc23f3df6bf74168c23c5beceaddc08da19 Mon Sep 17 00:00:00 2001 From: Tom Ellis Date: Sat, 11 Jul 2026 11:37:07 +0100 Subject: [PATCH 02/68] (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 033d2c381d9ccc7da31935ccad8cd3b1aaa1c6fd Mon Sep 17 00:00:00 2001 From: Tom Ellis Date: Sat, 11 Jul 2026 08:11:52 +0100 Subject: [PATCH 03/68] (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 abbe19f325c896972701d4c1ba637f800db17c46 Mon Sep 17 00:00:00 2001 From: Tom Ellis Date: Sat, 11 Jul 2026 08:38:58 +0100 Subject: [PATCH 04/68] (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 bac2187c753bc90826493b7f76fb801a48a7e0dc Mon Sep 17 00:00:00 2001 From: Tom Ellis Date: Sat, 11 Jul 2026 08:58:33 +0100 Subject: [PATCH 05/68] (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 518a680c1eedf29533ec5acef2fecc8a026733b0 Mon Sep 17 00:00:00 2001 From: Tom Ellis Date: Sat, 11 Jul 2026 11:40:27 +0100 Subject: [PATCH 06/68] (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 20338510ce1226f97f4b2f8039de1d41524975ac Mon Sep 17 00:00:00 2001 From: Tom Ellis Date: Sat, 11 Jul 2026 09:38:20 +0100 Subject: [PATCH 07/68] (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 64b4356b6a7750b44c60a65a0684a0c0bb133e02 Mon Sep 17 00:00:00 2001 From: Tom Ellis Date: Sat, 11 Jul 2026 09:41:09 +0100 Subject: [PATCH 08/68] (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 02539917961a7887df30b5e8d42bfee8de4898e5 Mon Sep 17 00:00:00 2001 From: Tom Ellis Date: Sat, 11 Jul 2026 11:09:08 +0100 Subject: [PATCH 09/68] (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 3d84d24d080b2b325a8f7ece769434a4ea06092c Mon Sep 17 00:00:00 2001 From: Tom Ellis Date: Sat, 11 Jul 2026 11:11:10 +0100 Subject: [PATCH 10/68] (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 6332197f7edd1aa2c0610d6b62c2b6125209c2b9 Mon Sep 17 00:00:00 2001 From: Tom Ellis Date: Sat, 11 Jul 2026 11:30:55 +0100 Subject: [PATCH 11/68] (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 1a77e9fc442d135e91278ce5972fddb18c22d870 Mon Sep 17 00:00:00 2001 From: Tom Ellis Date: Sat, 11 Jul 2026 12:13:10 +0100 Subject: [PATCH 12/68] (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 b7d16944c61e6ca951d34d409ce3a546bdbc7359 Mon Sep 17 00:00:00 2001 From: Tom Ellis Date: Sat, 11 Jul 2026 12:26:43 +0100 Subject: [PATCH 13/68] (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 f516070452c076a90fd31c86a51caa3b48a0b38a Mon Sep 17 00:00:00 2001 From: Tom Ellis Date: Sat, 11 Jul 2026 12:26:59 +0100 Subject: [PATCH 14/68] (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 39dc4b6b2c00aae133c7a7104c5c472f505e2624 Mon Sep 17 00:00:00 2001 From: Tom Ellis Date: Sat, 11 Jul 2026 12:58:18 +0100 Subject: [PATCH 15/68] (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 776d99ba262008f95b8e6b5ce6b93d808877bc46 Mon Sep 17 00:00:00 2001 From: Tom Ellis Date: Sat, 11 Jul 2026 13:03:46 +0100 Subject: [PATCH 16/68] (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..458424a3c 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 + state <- tarIndexCacheStateComponent stateDir + let st = stateHandle state + 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 7fddce481d70d6bdfd76ce7a43e95a6cd99a52f7 Mon Sep 17 00:00:00 2001 From: Tom Ellis Date: Sat, 11 Jul 2026 13:27:33 +0100 Subject: [PATCH 17/68] (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 e328e0c12a7d423b2736a4d1b698b1f34ee39155 Mon Sep 17 00:00:00 2001 From: Tom Ellis Date: Sat, 11 Jul 2026 13:29:55 +0100 Subject: [PATCH 18/68] (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 9d717e7409e1348d7b2389256c9c36c1f2b60eea Mon Sep 17 00:00:00 2001 From: Tom Ellis Date: Tue, 14 Jul 2026 18:10:51 +0100 Subject: [PATCH 19/68] (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 ecfafb2469700b5ce9b255521729bc973b1ad04e Mon Sep 17 00:00:00 2001 From: Tom Ellis Date: Tue, 14 Jul 2026 18:10:55 +0100 Subject: [PATCH 20/68] 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 19fd228417c6cd77660a9b8d84e5517619a8c07d Mon Sep 17 00:00:00 2001 From: Tom Ellis Date: Tue, 14 Jul 2026 18:08:05 +0100 Subject: [PATCH 21/68] (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 7835139b602276bf6f53f99e6d66bb3cc5a2f807 Mon Sep 17 00:00:00 2001 From: Tom Ellis Date: Tue, 14 Jul 2026 18:08:15 +0100 Subject: [PATCH 22/68] 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 4109e33fd082da0c3bf1a55b47472b89c20f0fc1 Mon Sep 17 00:00:00 2001 From: Tom Ellis Date: Tue, 14 Jul 2026 18:26:29 +0100 Subject: [PATCH 23/68] (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 c35926829aa7ad7a97348a46be13f75748d594c6 Mon Sep 17 00:00:00 2001 From: Tom Ellis Date: Tue, 14 Jul 2026 18:26:45 +0100 Subject: [PATCH 24/68] (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 a15f8c324b7ee2487c2379e27c0868844f61ce93 Mon Sep 17 00:00:00 2001 From: Tom Ellis Date: Tue, 14 Jul 2026 18:28:52 +0100 Subject: [PATCH 25/68] 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 b61dc16fa38350ca1cbde9fd86f6f4802ac3c375 Mon Sep 17 00:00:00 2001 From: Tom Ellis Date: Tue, 14 Jul 2026 18:53:08 +0100 Subject: [PATCH 26/68] (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 e49d07a0de31092f8b2037f5f3d82612880abddb Mon Sep 17 00:00:00 2001 From: Tom Ellis Date: Tue, 14 Jul 2026 19:13:48 +0100 Subject: [PATCH 27/68] (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 e28ae20dca1b6f064dd040e2cae031b6ad458853 Mon Sep 17 00:00:00 2001 From: Tom Ellis Date: Tue, 14 Jul 2026 19:17:11 +0100 Subject: [PATCH 28/68] (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 06426210e7737beb8e6bf5350b8305a98e942460 Mon Sep 17 00:00:00 2001 From: Tom Ellis Date: Tue, 14 Jul 2026 19:20:39 +0100 Subject: [PATCH 29/68] (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 f6955cf2ba283e9d20cec1afaef6ccec4681ef08 Mon Sep 17 00:00:00 2001 From: Tom Ellis Date: Tue, 14 Jul 2026 18:54:27 +0100 Subject: [PATCH 30/68] 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 6e52ca15d46a32d45e56bab05e1debf551902bc6 Mon Sep 17 00:00:00 2001 From: Tom Ellis Date: Wed, 15 Jul 2026 07:30:34 +0100 Subject: [PATCH 31/68] (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 6a7bd8e57a703680f6aededa3293a8708b074516 Mon Sep 17 00:00:00 2001 From: Tom Ellis Date: Wed, 15 Jul 2026 07:30:59 +0100 Subject: [PATCH 32/68] (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 46da15840f6ae62d202ab19c0991653fc9ae62bc Mon Sep 17 00:00:00 2001 From: Tom Ellis Date: Wed, 15 Jul 2026 07:33:57 +0100 Subject: [PATCH 33/68] (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."] From ceb2ba2f9a8596b3e9e70c143a07d6136188118a Mon Sep 17 00:00:00 2001 From: Tom Ellis Date: Fri, 25 Sep 2026 13:39:03 +0100 Subject: [PATCH 34/68] (refactor) Move AdminLog into new module --- hackage-server.cabal | 1 + .../Server/Features/AdminLog/Acid.hs | 99 +------------------ .../Server/Features/AdminLog/Backup.hs | 17 ++-- .../Server/Features/AdminLog/State.hs | 96 ++++++++++++++++++ 4 files changed, 109 insertions(+), 104 deletions(-) create mode 100644 src/Distribution/Server/Features/AdminLog/State.hs diff --git a/hackage-server.cabal b/hackage-server.cabal index 89d4badd4..01d4a0764 100644 --- a/hackage-server.cabal +++ b/hackage-server.cabal @@ -348,6 +348,7 @@ library Distribution.Server.Features.AdminLog Distribution.Server.Features.AdminLog.Acid Distribution.Server.Features.AdminLog.Backup + Distribution.Server.Features.AdminLog.State Distribution.Server.Features.AdminLog.Types Distribution.Server.Features.BuildReports Distribution.Server.Features.BuildReports.BuildReport diff --git a/src/Distribution/Server/Features/AdminLog/Acid.hs b/src/Distribution/Server/Features/AdminLog/Acid.hs index 4c03477fb..67fb126a2 100644 --- a/src/Distribution/Server/Features/AdminLog/Acid.hs +++ b/src/Distribution/Server/Features/AdminLog/Acid.hs @@ -1,96 +1,5 @@ -{-# LANGUAGE DeriveDataTypeable, TypeFamilies, TemplateHaskell, BangPatterns, - GeneralizedNewtypeDeriving, NamedFieldPuns, RecordWildCards, - PatternGuards, RankNTypes #-} +module Distribution.Server.Features.AdminLog.Acid + ( module Distribution.Server.Features.AdminLog.State + ) where -module Distribution.Server.Features.AdminLog.Acid where - -import Distribution.Server.Features.AdminLog.Types -import Distribution.Server.Users.Types (UserId) -import Distribution.Server.Framework - -import Control.Monad.Reader -import qualified Control.Monad.State as State -import Data.Time (UTCTime) -import qualified Data.ByteString.Lazy.Char8 as BS -import Data.Acid.Compat - -newtype AdminLog = AdminLog { - adminLog :: [(UTCTime,UserId,AdminAction,BS.ByteString)] -} deriving (Show, MemSize) - -deriveSafeCopy 0 'base ''AdminLog - -initialAdminLog :: AdminLog -initialAdminLog = AdminLog [] - -getAdminLog :: Query AdminLog AdminLog -getAdminLog = ask - -addAdminLog :: (UTCTime, UserId, AdminAction, BS.ByteString) -> Update AdminLog () -addAdminLog x = State.modify (\(AdminLog xs) -> AdminLog (x : xs)) - -instance Eq AdminLog where - (AdminLog (x:_)) == (AdminLog (y:_)) = x == y - (AdminLog []) == (AdminLog []) = True - _ == _ = False - -replaceAdminLog :: AdminLog -> Update AdminLog () -replaceAdminLog = State.put - ------------------------------- --- IsAcidic machinery --- --- See Note [Acid Migration] in "Data.Acid.Compat" --- original module name was Distribution.Server.Features.AdminLog" - --- makeAcidic ''AdminLog ['getAdminLog --- ,'replaceAdminLog --- ,'addAdminLog] - -instance IsAcidic AdminLog where - acidEvents - = [QueryEvent - (\ GetAdminLog -> getAdminLog) safeCopyMethodSerialiser, - UpdateEvent - (\ (ReplaceAdminLog arg_aDn6) -> replaceAdminLog arg_aDn6) - safeCopyMethodSerialiser, - UpdateEvent - (\ (AddAdminLog arg_aDn7) -> addAdminLog arg_aDn7) - safeCopyMethodSerialiser] -data GetAdminLog = GetAdminLog -instance SafeCopy GetAdminLog where - putCopy GetAdminLog = contain (do return ()) - getCopy = contain (return GetAdminLog) - errorTypeName _ = "Data.SafeCopy.SafeCopy.SafeCopy GetAdminLog" -instance Data.Acid.Compat.Method GetAdminLog where - type MethodResult GetAdminLog = AdminLog - type MethodState GetAdminLog = AdminLog - methodTag = movedMethodTag "Distribution.Server.Features.AdminLog" -instance QueryEvent GetAdminLog -newtype ReplaceAdminLog = ReplaceAdminLog AdminLog -instance SafeCopy ReplaceAdminLog where - putCopy (ReplaceAdminLog arg_aDmO) - = contain - (do safePut arg_aDmO - return ()) - getCopy = contain (return ReplaceAdminLog <*> safeGet) - errorTypeName _ = "Data.SafeCopy.SafeCopy.SafeCopy ReplaceAdminLog" -instance Data.Acid.Compat.Method ReplaceAdminLog where - type MethodResult ReplaceAdminLog = () - type MethodState ReplaceAdminLog = AdminLog - methodTag = movedMethodTag "Distribution.Server.Features.AdminLog" -instance UpdateEvent ReplaceAdminLog -newtype AddAdminLog - = AddAdminLog (UTCTime, UserId, AdminAction, BS.ByteString) -instance SafeCopy AddAdminLog where - putCopy (AddAdminLog arg_aDmT) - = contain - (do safePut arg_aDmT - return ()) - getCopy = contain (return AddAdminLog <*> safeGet) - errorTypeName _ = "Data.SafeCopy.SafeCopy.SafeCopy AddAdminLog" -instance Data.Acid.Compat.Method AddAdminLog where - type MethodResult AddAdminLog = () - type MethodState AddAdminLog = AdminLog - methodTag = movedMethodTag "Distribution.Server.Features.AdminLog" -instance UpdateEvent AddAdminLog +import Distribution.Server.Features.AdminLog.State diff --git a/src/Distribution/Server/Features/AdminLog/Backup.hs b/src/Distribution/Server/Features/AdminLog/Backup.hs index 6713c3cd6..56fd4fb90 100644 --- a/src/Distribution/Server/Features/AdminLog/Backup.hs +++ b/src/Distribution/Server/Features/AdminLog/Backup.hs @@ -1,19 +1,19 @@ module Distribution.Server.Features.AdminLog.Backup where -import qualified Distribution.Server.Features.AdminLog.Acid as Acid import Distribution.Server.Features.AdminLog.Types -import Distribution.Server.Users.Types (UserId) +import qualified Distribution.Server.Features.AdminLog.State as State import Distribution.Server.Framework.BackupRestore +import Distribution.Server.Users.Types (UserId) import Data.Maybe(mapMaybe) -import Data.Time (UTCTime) import qualified Data.ByteString.Lazy.Char8 as BS +import Data.Time (UTCTime) import Text.Read (readMaybe) import Distribution.Server.Util.Parse -restoreAdminLogBackup :: RestoreBackup Acid.AdminLog +restoreAdminLogBackup :: RestoreBackup State.AdminLog restoreAdminLogBackup = - go (Acid.AdminLog []) + go (State.AdminLog []) where go logs = RestoreBackup { @@ -24,13 +24,12 @@ restoreAdminLogBackup = , restoreFinalize = return logs } -importLogs :: Acid.AdminLog -> BS.ByteString -> Acid.AdminLog -importLogs (Acid.AdminLog ls) = - Acid.AdminLog . (++ls) . mapMaybe fromRecord . lines . unpackUTF8 +importLogs :: State.AdminLog -> BS.ByteString -> State.AdminLog +importLogs (State.AdminLog ls) = + State.AdminLog . (++ls) . mapMaybe fromRecord . lines . unpackUTF8 where fromRecord :: String -> Maybe (UTCTime,UserId,AdminAction,BS.ByteString) fromRecord = readMaybe backupLogEntries :: [(UTCTime,UserId,AdminAction,BS.ByteString)] -> BS.ByteString backupLogEntries = packUTF8 . unlines . map show - diff --git a/src/Distribution/Server/Features/AdminLog/State.hs b/src/Distribution/Server/Features/AdminLog/State.hs new file mode 100644 index 000000000..259c79e7a --- /dev/null +++ b/src/Distribution/Server/Features/AdminLog/State.hs @@ -0,0 +1,96 @@ +{-# LANGUAGE DeriveDataTypeable, TypeFamilies, TemplateHaskell, BangPatterns, + GeneralizedNewtypeDeriving, NamedFieldPuns, RecordWildCards, + PatternGuards, RankNTypes #-} + +module Distribution.Server.Features.AdminLog.State where + +import Distribution.Server.Features.AdminLog.Types +import Distribution.Server.Framework +import Distribution.Server.Users.Types (UserId) + +import Control.Monad.Reader +import qualified Control.Monad.State as State +import Data.Acid.Compat +import Data.Time (UTCTime) +import qualified Data.ByteString.Lazy.Char8 as BS + +newtype AdminLog = AdminLog { + adminLog :: [(UTCTime,UserId,AdminAction,BS.ByteString)] +} deriving (Show, MemSize) + +deriveSafeCopy 0 'base ''AdminLog + +initialAdminLog :: AdminLog +initialAdminLog = AdminLog [] + +getAdminLog :: Query AdminLog AdminLog +getAdminLog = ask + +addAdminLog :: (UTCTime, UserId, AdminAction, BS.ByteString) -> Update AdminLog () +addAdminLog x = State.modify (\(AdminLog xs) -> AdminLog (x : xs)) + +instance Eq AdminLog where + (AdminLog (x:_)) == (AdminLog (y:_)) = x == y + (AdminLog []) == (AdminLog []) = True + _ == _ = False + +replaceAdminLog :: AdminLog -> Update AdminLog () +replaceAdminLog = State.put + +------------------------------ +-- IsAcidic machinery +-- +-- See Note [Acid Migration] in "Data.Acid.Compat" +-- original module name was Distribution.Server.Features.AdminLog" + +-- makeAcidic ''AdminLog ['getAdminLog +-- ,'replaceAdminLog +-- ,'addAdminLog] + +instance IsAcidic AdminLog where + acidEvents + = [QueryEvent + (\ GetAdminLog -> getAdminLog) safeCopyMethodSerialiser, + UpdateEvent + (\ (ReplaceAdminLog arg_aDn6) -> replaceAdminLog arg_aDn6) + safeCopyMethodSerialiser, + UpdateEvent + (\ (AddAdminLog arg_aDn7) -> addAdminLog arg_aDn7) + safeCopyMethodSerialiser] +data GetAdminLog = GetAdminLog +instance SafeCopy GetAdminLog where + putCopy GetAdminLog = contain (do return ()) + getCopy = contain (return GetAdminLog) + errorTypeName _ = "Data.SafeCopy.SafeCopy.SafeCopy GetAdminLog" +instance Data.Acid.Compat.Method GetAdminLog where + type MethodResult GetAdminLog = AdminLog + type MethodState GetAdminLog = AdminLog + methodTag = movedMethodTag "Distribution.Server.Features.AdminLog" +instance QueryEvent GetAdminLog +newtype ReplaceAdminLog = ReplaceAdminLog AdminLog +instance SafeCopy ReplaceAdminLog where + putCopy (ReplaceAdminLog arg_aDmO) + = contain + (do safePut arg_aDmO + return ()) + getCopy = contain (return ReplaceAdminLog <*> safeGet) + errorTypeName _ = "Data.SafeCopy.SafeCopy.SafeCopy ReplaceAdminLog" +instance Data.Acid.Compat.Method ReplaceAdminLog where + type MethodResult ReplaceAdminLog = () + type MethodState ReplaceAdminLog = AdminLog + methodTag = movedMethodTag "Distribution.Server.Features.AdminLog" +instance UpdateEvent ReplaceAdminLog +newtype AddAdminLog + = AddAdminLog (UTCTime, UserId, AdminAction, BS.ByteString) +instance SafeCopy AddAdminLog where + putCopy (AddAdminLog arg_aDmT) + = contain + (do safePut arg_aDmT + return ()) + getCopy = contain (return AddAdminLog <*> safeGet) + errorTypeName _ = "Data.SafeCopy.SafeCopy.SafeCopy AddAdminLog" +instance Data.Acid.Compat.Method AddAdminLog where + type MethodResult AddAdminLog = () + type MethodState AddAdminLog = AdminLog + methodTag = movedMethodTag "Distribution.Server.Features.AdminLog" +instance UpdateEvent AddAdminLog From c4c635819fea37664f1f2b9f9d86bb5244c665de Mon Sep 17 00:00:00 2001 From: Tom Ellis Date: Fri, 25 Sep 2026 13:40:23 +0100 Subject: [PATCH 35/68] (refactor) Move adminLogStateComponent to AdminLog.Acid --- src/Distribution/Server/Features/AdminLog.hs | 20 ++---------------- .../Server/Features/AdminLog/Acid.hs | 21 ++++++++++++++++++- 2 files changed, 22 insertions(+), 19 deletions(-) diff --git a/src/Distribution/Server/Features/AdminLog.hs b/src/Distribution/Server/Features/AdminLog.hs index 8c6a39330..53bee55fd 100755 --- a/src/Distribution/Server/Features/AdminLog.hs +++ b/src/Distribution/Server/Features/AdminLog.hs @@ -4,13 +4,12 @@ module Distribution.Server.Features.AdminLog where -import qualified Distribution.Server.Features.AdminLog.Acid as Acid -import Distribution.Server.Features.AdminLog.Backup +import Distribution.Server.Features.AdminLog.Acid (adminLogStateComponent) +import qualified Distribution.Server.Features.AdminLog.State as Acid import Distribution.Server.Features.AdminLog.Types import Distribution.Server.Users.Types (UserId) import Distribution.Server.Users.Group import Distribution.Server.Framework -import Distribution.Server.Framework.BackupRestore import Distribution.Server.Pages.AdminLog import Distribution.Server.Features.Users @@ -87,18 +86,3 @@ adminLogFeature UserFeature{..} adminLogState nameIt AdminGroup = "Administrators" nameIt TrusteeGroup = "Trustees" nameIt (OtherGroup s) = unpackUTF8 s - -adminLogStateComponent :: FilePath -> IO (StateComponent AcidState Acid.AdminLog) -adminLogStateComponent stateDir = do - st <- openLocalStateFrom (stateDir "db" "AdminLog") Acid.initialAdminLog - return StateComponent { - stateDesc = "AdminLog" - , stateHandle = st - , getState = query st Acid.GetAdminLog - , putState = update st . Acid.ReplaceAdminLog - , backupState = \_ (Acid.AdminLog xs) -> - [BackupByteString ["adminLog.txt"] . backupLogEntries $ xs] - , restoreState = restoreAdminLogBackup - , resetState = adminLogStateComponent - } - diff --git a/src/Distribution/Server/Features/AdminLog/Acid.hs b/src/Distribution/Server/Features/AdminLog/Acid.hs index 67fb126a2..1ca5b35db 100644 --- a/src/Distribution/Server/Features/AdminLog/Acid.hs +++ b/src/Distribution/Server/Features/AdminLog/Acid.hs @@ -1,5 +1,24 @@ module Distribution.Server.Features.AdminLog.Acid - ( module Distribution.Server.Features.AdminLog.State + ( adminLogStateComponent + , module Distribution.Server.Features.AdminLog.State ) where +import Distribution.Server.Features.AdminLog.Backup import Distribution.Server.Features.AdminLog.State +import qualified Distribution.Server.Features.AdminLog.State as State +import Distribution.Server.Framework +import Distribution.Server.Framework.BackupRestore + +adminLogStateComponent :: FilePath -> IO (StateComponent AcidState State.AdminLog) +adminLogStateComponent stateDir = do + st <- openLocalStateFrom (stateDir "db" "AdminLog") State.initialAdminLog + return StateComponent { + stateDesc = "AdminLog" + , stateHandle = st + , getState = query st State.GetAdminLog + , putState = update st . State.ReplaceAdminLog + , backupState = \_ (State.AdminLog xs) -> + [BackupByteString ["adminLog.txt"] . backupLogEntries $ xs] + , restoreState = restoreAdminLogBackup + , resetState = adminLogStateComponent + } From b1d6a5590aa97169359044a071cca0c17910c2ab Mon Sep 17 00:00:00 2001 From: Tom Ellis Date: Fri, 25 Sep 2026 13:42:27 +0100 Subject: [PATCH 36/68] (refactor) Introduce AdminLog abstraction layer --- hackage-server.cabal | 1 + src/Distribution/Server/Features/AdminLog.hs | 29 ++++++++++--------- .../Server/Features/AdminLog/Acid.hs | 16 ++++++++-- .../Server/Features/AdminLog/Store.hs | 24 +++++++++++++++ .../Server/Features/UserNotify.hs | 3 +- 5 files changed, 54 insertions(+), 19 deletions(-) create mode 100644 src/Distribution/Server/Features/AdminLog/Store.hs diff --git a/hackage-server.cabal b/hackage-server.cabal index 01d4a0764..d887ba192 100644 --- a/hackage-server.cabal +++ b/hackage-server.cabal @@ -349,6 +349,7 @@ library Distribution.Server.Features.AdminLog.Acid Distribution.Server.Features.AdminLog.Backup Distribution.Server.Features.AdminLog.State + Distribution.Server.Features.AdminLog.Store Distribution.Server.Features.AdminLog.Types Distribution.Server.Features.BuildReports Distribution.Server.Features.BuildReports.BuildReport diff --git a/src/Distribution/Server/Features/AdminLog.hs b/src/Distribution/Server/Features/AdminLog.hs index 53bee55fd..a14392f24 100755 --- a/src/Distribution/Server/Features/AdminLog.hs +++ b/src/Distribution/Server/Features/AdminLog.hs @@ -4,8 +4,8 @@ module Distribution.Server.Features.AdminLog where -import Distribution.Server.Features.AdminLog.Acid (adminLogStateComponent) -import qualified Distribution.Server.Features.AdminLog.State as Acid +import Distribution.Server.Features.AdminLog.Acid (acidStore) +import qualified Distribution.Server.Features.AdminLog.Store as Store import Distribution.Server.Features.AdminLog.Types import Distribution.Server.Users.Types (UserId) import Distribution.Server.Users.Group @@ -14,7 +14,8 @@ import Distribution.Server.Framework import Distribution.Server.Pages.AdminLog import Distribution.Server.Features.Users -import Data.Time.Clock (getCurrentTime) +import Data.Time.Clock (getCurrentTime, UTCTime) +import qualified Data.ByteString.Lazy.Char8 as BS import Distribution.Server.Util.Parse --TODO Maybe Reason @@ -28,7 +29,7 @@ mkAdminAction gd isAdd uid = (if isAdd then Admin_GroupAddUser else Admin_GroupD data AdminLogFeature = AdminLogFeature { adminLogFeatureInterface :: HackageFeature - , queryGetAdminLog :: forall m. MonadIO m => m Acid.AdminLog + , queryGetAdminLog :: forall m. MonadIO m => m [(UTCTime,UserId,AdminAction,BS.ByteString)] } instance IsHackageFeature AdminLogFeature where @@ -36,22 +37,22 @@ instance IsHackageFeature AdminLogFeature where initAdminLogFeature :: ServerEnv -> IO (UserFeature -> IO AdminLogFeature) initAdminLogFeature ServerEnv{serverStateDir} = do - adminLogState <- adminLogStateComponent serverStateDir + adminLogBackend <- acidStore serverStateDir return $ \users@UserFeature{groupChangedHook} -> do - let feature = adminLogFeature users adminLogState + let feature = adminLogFeature users adminLogBackend registerHook groupChangedHook $ \(gd,addOrDel,actorUid,targetUid,reason) -> do now <- getCurrentTime - updateState adminLogState $ Acid.AddAdminLog + Store.addAdminLog (Store.backendStore adminLogBackend) (now, actorUid, mkAdminAction gd addOrDel targetUid, packUTF8 reason) return feature adminLogFeature :: UserFeature - -> StateComponent AcidState Acid.AdminLog + -> Store.Backend -> AdminLogFeature -adminLogFeature UserFeature{..} adminLogState +adminLogFeature UserFeature{..} Store.Backend{backendStore = adminLogStore, backendState} = AdminLogFeature {..} where @@ -59,7 +60,7 @@ adminLogFeature UserFeature{..} adminLogState (emptyHackageFeature "admin-actions-log") { featureDesc = "Log of additions and removals of users from groups.", featureResources = [adminLogResource], - featureState = [abstractAcidStateComponent adminLogState] + featureState = backendState } adminLogResource :: Resource @@ -69,13 +70,13 @@ adminLogFeature UserFeature{..} adminLogState resourceGet = [("html", serveAdminLogGet)] } - queryGetAdminLog :: MonadIO m => m Acid.AdminLog - queryGetAdminLog = queryState adminLogState Acid.GetAdminLog + queryGetAdminLog :: MonadIO m => m [(UTCTime,UserId,AdminAction,BS.ByteString)] + queryGetAdminLog = Store.getAdminLog adminLogStore serveAdminLogGet _ = do - aLog <- queryState adminLogState Acid.GetAdminLog + aLog <- queryGetAdminLog users <- queryGetUserDb - return . toResponse . adminLogPage users . map mkRow . Acid.adminLog $ aLog + return . toResponse . adminLogPage users . map mkRow $ aLog mkRow (time, actorId, Admin_GroupDelUser targetId group, reason) = (time, actorId, "Acid.Delete", targetId, nameIt group, unpackUTF8 reason) diff --git a/src/Distribution/Server/Features/AdminLog/Acid.hs b/src/Distribution/Server/Features/AdminLog/Acid.hs index 1ca5b35db..9aca94195 100644 --- a/src/Distribution/Server/Features/AdminLog/Acid.hs +++ b/src/Distribution/Server/Features/AdminLog/Acid.hs @@ -1,14 +1,24 @@ module Distribution.Server.Features.AdminLog.Acid - ( adminLogStateComponent - , module Distribution.Server.Features.AdminLog.State + ( acidStore ) where import Distribution.Server.Features.AdminLog.Backup -import Distribution.Server.Features.AdminLog.State import qualified Distribution.Server.Features.AdminLog.State as State +import Distribution.Server.Features.AdminLog.Store import Distribution.Server.Framework import Distribution.Server.Framework.BackupRestore +acidStore :: FilePath -> IO Backend +acidStore stateDir = do + adminLogState <- adminLogStateComponent stateDir + pure Backend { + backendStore = Store { + getAdminLog = State.adminLog <$> queryState adminLogState State.GetAdminLog + , addAdminLog = \entry -> updateState adminLogState (State.AddAdminLog entry) + } + , backendState = [abstractAcidStateComponent adminLogState] + } + adminLogStateComponent :: FilePath -> IO (StateComponent AcidState State.AdminLog) adminLogStateComponent stateDir = do st <- openLocalStateFrom (stateDir "db" "AdminLog") State.initialAdminLog diff --git a/src/Distribution/Server/Features/AdminLog/Store.hs b/src/Distribution/Server/Features/AdminLog/Store.hs new file mode 100644 index 000000000..5caf391ce --- /dev/null +++ b/src/Distribution/Server/Features/AdminLog/Store.hs @@ -0,0 +1,24 @@ +{-# LANGUAGE RankNTypes #-} + +module Distribution.Server.Features.AdminLog.Store + ( Backend(..) + , Store(..) + ) where + +import Distribution.Server.Features.AdminLog.Types (AdminAction) +import Distribution.Server.Framework (AbstractStateComponent) +import Distribution.Server.Users.Types (UserId) + +import Control.Monad.Trans (MonadIO) +import Data.Time (UTCTime) +import qualified Data.ByteString.Lazy.Char8 as BS + +data Backend = Backend { + backendStore :: Store + , backendState :: [AbstractStateComponent] + } + +data Store = Store { + getAdminLog :: forall m. MonadIO m => m [(UTCTime,UserId,AdminAction,BS.ByteString)] + , addAdminLog :: forall m. MonadIO m => (UTCTime, UserId, AdminAction, BS.ByteString) -> m () + } diff --git a/src/Distribution/Server/Features/UserNotify.hs b/src/Distribution/Server/Features/UserNotify.hs index 9f753fc31..15025f1cc 100644 --- a/src/Distribution/Server/Features/UserNotify.hs +++ b/src/Distribution/Server/Features/UserNotify.hs @@ -40,7 +40,6 @@ import Distribution.Server.Framework.BackupDump import Distribution.Server.Framework.Templating import Distribution.Server.Features.AdminLog -import qualified Distribution.Server.Features.AdminLog.Acid as Acid import Distribution.Server.Features.AdminLog.Types import Distribution.Server.Features.BuildReports import qualified Distribution.Server.Features.BuildReports.BuildReport as BuildReport @@ -536,7 +535,7 @@ userNotifyFeature UserFeature{..} return $ filter isRecent $ (PackageIndex.allPackages pkgIndex) collectAdminActions earlier now = do - aLog <- Acid.adminLog <$> queryGetAdminLog + aLog <- queryGetAdminLog let isRecent (t,_,_,_) = t > earlier && t <= now return $ filter isRecent $ aLog From 7c863539266760fb322b83dbb36493beeaac3bc3 Mon Sep 17 00:00:00 2001 From: Tom Ellis Date: Fri, 25 Sep 2026 13:53:41 +0100 Subject: [PATCH 37/68] (refactor) Move UserDetails state into UserDetails.State --- hackage-server.cabal | 1 + .../Server/Features/UserDetails.hs | 7 +- .../Server/Features/UserDetails/Acid.hs | 102 +++++------------- .../Server/Features/UserDetails/Backup.hs | 2 +- .../Server/Features/UserDetails/State.hs | 80 ++++++++++++++ 5 files changed, 110 insertions(+), 82 deletions(-) create mode 100644 src/Distribution/Server/Features/UserDetails/State.hs diff --git a/hackage-server.cabal b/hackage-server.cabal index d887ba192..ae8424e44 100644 --- a/hackage-server.cabal +++ b/hackage-server.cabal @@ -422,6 +422,7 @@ library Distribution.Server.Features.UserDetails Distribution.Server.Features.UserDetails.Acid Distribution.Server.Features.UserDetails.Backup + Distribution.Server.Features.UserDetails.State Distribution.Server.Features.UserDetails.Types Distribution.Server.Features.UserSignup Distribution.Server.Features.UserSignup.Acid diff --git a/src/Distribution/Server/Features/UserDetails.hs b/src/Distribution/Server/Features/UserDetails.hs index 6d67d44c6..36914305b 100644 --- a/src/Distribution/Server/Features/UserDetails.hs +++ b/src/Distribution/Server/Features/UserDetails.hs @@ -9,6 +9,7 @@ module Distribution.Server.Features.UserDetails ( ) where import qualified Distribution.Server.Features.UserDetails.Acid as Acid +import qualified Distribution.Server.Features.UserDetails.State as State import Distribution.Server.Features.UserDetails.Backup import Distribution.Server.Features.UserDetails.Types import Distribution.Server.Framework @@ -45,9 +46,9 @@ instance IsHackageFeature UserDetailsFeature where -- State components -- -userDetailsStateComponent :: FilePath -> IO (StateComponent AcidState Acid.UserDetailsTable) +userDetailsStateComponent :: FilePath -> IO (StateComponent AcidState State.UserDetailsTable) userDetailsStateComponent stateDir = do - st <- openLocalStateFrom (stateDir "db" "UserDetails") Acid.emptyUserDetailsTable + st <- openLocalStateFrom (stateDir "db" "UserDetails") State.emptyUserDetailsTable return StateComponent { stateDesc = "Extra details associated with user accounts, email addresses etc" , stateHandle = st @@ -85,7 +86,7 @@ initUserDetailsFeature ServerEnv{serverStateDir, serverTemplatesDir, serverTempl userDetailsFeature :: Templates - -> StateComponent AcidState Acid.UserDetailsTable + -> StateComponent AcidState State.UserDetailsTable -> UserFeature -> CoreFeature -> UploadFeature diff --git a/src/Distribution/Server/Features/UserDetails/Acid.hs b/src/Distribution/Server/Features/UserDetails/Acid.hs index 9d218805f..2404f0b68 100644 --- a/src/Distribution/Server/Features/UserDetails/Acid.hs +++ b/src/Distribution/Server/Features/UserDetails/Acid.hs @@ -1,86 +1,32 @@ -{-# LANGUAGE DeriveDataTypeable, TypeFamilies, TemplateHaskell, - NamedFieldPuns, RecordWildCards #-} -module Distribution.Server.Features.UserDetails.Acid where - -import Distribution.Server.Features.UserDetails.Types +{-# LANGUAGE TemplateHaskell, TypeFamilies #-} + +module Distribution.Server.Features.UserDetails.Acid + ( module State + , GetUserDetailsTable(..) + , LookupUserDetails(..) + , ReplaceUserDetailsTable(..) + , SetUserDetails(..) + , SetUserNameContact(..) + , SetUserAdminInfo(..) + , DeleteUserDetails(..) + ) where + +import Distribution.Server.Features.UserDetails.State as State import Distribution.Server.Framework -import Distribution.Server.Users.Types - -import Data.SafeCopy (base, deriveSafeCopy) - -import Data.IntMap (IntMap) -import qualified Data.IntMap as IntMap -import Data.Text (Text) -import qualified Data.Text as T - -import Control.Monad.Reader (ask) -import Control.Monad.State (get, put) - - -------------------------- --- Types of stored data --- - -newtype UserDetailsTable = UserDetailsTable (IntMap AccountDetails) - deriving (Eq, Show) - -emptyAccountDetails :: AccountDetails -emptyAccountDetails = AccountDetails T.empty T.empty Nothing T.empty - -emptyUserDetailsTable :: UserDetailsTable -emptyUserDetailsTable = UserDetailsTable IntMap.empty - -$(deriveSafeCopy 0 'base ''UserDetailsTable) - -instance MemSize UserDetailsTable where - memSize (UserDetailsTable a) = memSize1 a - - ------------------------------ --- State queries and updates +-- Acid event types -- -getUserDetailsTable :: Query UserDetailsTable UserDetailsTable -getUserDetailsTable = ask - -replaceUserDetailsTable :: UserDetailsTable -> Update UserDetailsTable () -replaceUserDetailsTable = put - -lookupUserDetails :: UserId -> Query UserDetailsTable (Maybe AccountDetails) -lookupUserDetails (UserId uid) = do - UserDetailsTable tbl <- ask - return $! IntMap.lookup uid tbl - -setUserDetails :: UserId -> AccountDetails -> Update UserDetailsTable () -setUserDetails (UserId uid) udetails = do - UserDetailsTable tbl <- get - put $! UserDetailsTable (IntMap.insert uid udetails tbl) - -deleteUserDetails :: UserId -> Update UserDetailsTable Bool -deleteUserDetails (UserId uid) = do - UserDetailsTable tbl <- get - if IntMap.member uid tbl - then do put $! UserDetailsTable (IntMap.delete uid tbl) - return True - else return False - -setUserNameContact :: UserId -> Text -> Text -> Update UserDetailsTable () -setUserNameContact (UserId uid) name email = do - UserDetailsTable tbl <- get - put $! UserDetailsTable (IntMap.alter upd uid tbl) - where - upd Nothing = Just emptyAccountDetails { accountName = name, accountContactEmail = email } - upd (Just udetails) = Just udetails { accountName = name, accountContactEmail = email } - -setUserAdminInfo :: UserId -> Maybe AccountKind -> Text -> Update UserDetailsTable () -setUserAdminInfo (UserId uid) akind notes = do - UserDetailsTable tbl <- get - put $! UserDetailsTable (IntMap.alter upd uid tbl) - where - upd Nothing = Just emptyAccountDetails { accountKind = akind, accountAdminNotes = notes } - upd (Just udetails) = Just udetails { accountKind = akind, accountAdminNotes = notes } - +-- This splice generates an orphan IsAcidic UserDetailsTable instance: +-- IsAcidic comes from acid-state, and UserDetailsTable is defined in +-- State. +-- +-- makeAcidic generates the instance together with the event +-- types. The serialized event tags of the event types depend on the +-- name of the module where the splice is run, so for simplicity we +-- continue to run the splice here, despite UserDetailsTable no longer +-- being defined here. makeAcidic ''UserDetailsTable [ --queries 'getUserDetailsTable, diff --git a/src/Distribution/Server/Features/UserDetails/Backup.hs b/src/Distribution/Server/Features/UserDetails/Backup.hs index d759fce78..648d64483 100644 --- a/src/Distribution/Server/Features/UserDetails/Backup.hs +++ b/src/Distribution/Server/Features/UserDetails/Backup.hs @@ -1,6 +1,6 @@ module Distribution.Server.Features.UserDetails.Backup where -import qualified Distribution.Server.Features.UserDetails.Acid as Acid +import qualified Distribution.Server.Features.UserDetails.State as Acid import Distribution.Server.Features.UserDetails.Types import Distribution.Server.Framework.BackupDump import Distribution.Server.Framework.BackupRestore diff --git a/src/Distribution/Server/Features/UserDetails/State.hs b/src/Distribution/Server/Features/UserDetails/State.hs new file mode 100644 index 000000000..e5bbfe49a --- /dev/null +++ b/src/Distribution/Server/Features/UserDetails/State.hs @@ -0,0 +1,80 @@ +{-# LANGUAGE DeriveDataTypeable, TypeFamilies, TemplateHaskell #-} + +module Distribution.Server.Features.UserDetails.State where + +import Distribution.Server.Features.UserDetails.Types +import Distribution.Server.Users.Types + +import Data.SafeCopy (base, deriveSafeCopy) +import Data.IntMap (IntMap) +import qualified Data.IntMap as IntMap +import qualified Data.Text as T +import Data.Text (Text) + +import Control.Monad.Reader (ask) +import Control.Monad.State (get, put) + +import Distribution.Server.Framework + +------------------------- +-- Types of stored data +-- + +newtype UserDetailsTable = UserDetailsTable (IntMap AccountDetails) + deriving (Eq, Show) + +emptyAccountDetails :: AccountDetails +emptyAccountDetails = AccountDetails T.empty T.empty Nothing T.empty + +emptyUserDetailsTable :: UserDetailsTable +emptyUserDetailsTable = UserDetailsTable IntMap.empty + +$(deriveSafeCopy 0 'base ''UserDetailsTable) + +instance MemSize UserDetailsTable where + memSize (UserDetailsTable a) = memSize1 a + + +------------------------------ +-- State queries and updates +-- + +getUserDetailsTable :: Query UserDetailsTable UserDetailsTable +getUserDetailsTable = ask + +replaceUserDetailsTable :: UserDetailsTable -> Update UserDetailsTable () +replaceUserDetailsTable = put + +lookupUserDetails :: UserId -> Query UserDetailsTable (Maybe AccountDetails) +lookupUserDetails (UserId uid) = do + UserDetailsTable tbl <- ask + return $! IntMap.lookup uid tbl + +setUserDetails :: UserId -> AccountDetails -> Update UserDetailsTable () +setUserDetails (UserId uid) udetails = do + UserDetailsTable tbl <- get + put $! UserDetailsTable (IntMap.insert uid udetails tbl) + +deleteUserDetails :: UserId -> Update UserDetailsTable Bool +deleteUserDetails (UserId uid) = do + UserDetailsTable tbl <- get + if IntMap.member uid tbl + then do put $! UserDetailsTable (IntMap.delete uid tbl) + return True + else return False + +setUserNameContact :: UserId -> Text -> Text -> Update UserDetailsTable () +setUserNameContact (UserId uid) name email = do + UserDetailsTable tbl <- get + put $! UserDetailsTable (IntMap.alter upd uid tbl) + where + upd Nothing = Just emptyAccountDetails { accountName = name, accountContactEmail = email } + upd (Just udetails) = Just udetails { accountName = name, accountContactEmail = email } + +setUserAdminInfo :: UserId -> Maybe AccountKind -> Text -> Update UserDetailsTable () +setUserAdminInfo (UserId uid) akind notes = do + UserDetailsTable tbl <- get + put $! UserDetailsTable (IntMap.alter upd uid tbl) + where + upd Nothing = Just emptyAccountDetails { accountKind = akind, accountAdminNotes = notes } + upd (Just udetails) = Just udetails { accountKind = akind, accountAdminNotes = notes } From c086f2df2c73722e1b114e95dc0b81bb502354d6 Mon Sep 17 00:00:00 2001 From: Tom Ellis Date: Fri, 25 Sep 2026 13:55:56 +0100 Subject: [PATCH 38/68] (refactor) Move userDetailsStateComponent to UserDetails.Acid --- .../Server/Features/UserDetails.hs | 22 +------------------ .../Server/Features/UserDetails/Acid.hs | 20 +++++++++++++++++ 2 files changed, 21 insertions(+), 21 deletions(-) diff --git a/src/Distribution/Server/Features/UserDetails.hs b/src/Distribution/Server/Features/UserDetails.hs index 36914305b..a614333e3 100644 --- a/src/Distribution/Server/Features/UserDetails.hs +++ b/src/Distribution/Server/Features/UserDetails.hs @@ -10,10 +10,8 @@ module Distribution.Server.Features.UserDetails ( import qualified Distribution.Server.Features.UserDetails.Acid as Acid import qualified Distribution.Server.Features.UserDetails.State as State -import Distribution.Server.Features.UserDetails.Backup import Distribution.Server.Features.UserDetails.Types import Distribution.Server.Framework -import Distribution.Server.Framework.BackupDump import Distribution.Server.Framework.Templating import Distribution.Server.Features.Users @@ -42,24 +40,6 @@ instance IsHackageFeature UserDetailsFeature where getFeatureInterface = userDetailsFeatureInterface ---------------------- --- State components --- - -userDetailsStateComponent :: FilePath -> IO (StateComponent AcidState State.UserDetailsTable) -userDetailsStateComponent stateDir = do - st <- openLocalStateFrom (stateDir "db" "UserDetails") State.emptyUserDetailsTable - return StateComponent { - stateDesc = "Extra details associated with user accounts, email addresses etc" - , stateHandle = st - , getState = query st Acid.GetUserDetailsTable - , putState = update st . Acid.ReplaceUserDetailsTable - , backupState = \backuptype users -> - [csvToBackup ["users.csv"] (userDetailsToCSV backuptype users)] - , restoreState = userDetailsBackup - , resetState = userDetailsStateComponent - } - ---------------------------------------- -- Feature definition & initialisation -- @@ -71,7 +51,7 @@ initUserDetailsFeature :: ServerEnv -> IO UserDetailsFeature) initUserDetailsFeature ServerEnv{serverStateDir, serverTemplatesDir, serverTemplatesMode} = do -- Canonical state - usersDetailsState <- userDetailsStateComponent serverStateDir + usersDetailsState <- Acid.userDetailsStateComponent serverStateDir --TODO: link up to user feature to delete diff --git a/src/Distribution/Server/Features/UserDetails/Acid.hs b/src/Distribution/Server/Features/UserDetails/Acid.hs index 2404f0b68..45db20135 100644 --- a/src/Distribution/Server/Features/UserDetails/Acid.hs +++ b/src/Distribution/Server/Features/UserDetails/Acid.hs @@ -9,10 +9,13 @@ module Distribution.Server.Features.UserDetails.Acid , SetUserNameContact(..) , SetUserAdminInfo(..) , DeleteUserDetails(..) + , userDetailsStateComponent ) where import Distribution.Server.Features.UserDetails.State as State import Distribution.Server.Framework +import Distribution.Server.Framework.BackupDump +import Distribution.Server.Features.UserDetails.Backup ------------------------------ -- Acid event types @@ -40,3 +43,20 @@ makeAcidic ''UserDetailsTable [ ] +--------------------- +-- State components +-- + +userDetailsStateComponent :: FilePath -> IO (StateComponent AcidState State.UserDetailsTable) +userDetailsStateComponent stateDir = do + st <- openLocalStateFrom (stateDir "db" "UserDetails") State.emptyUserDetailsTable + return StateComponent { + stateDesc = "Extra details associated with user accounts, email addresses etc" + , stateHandle = st + , getState = query st GetUserDetailsTable + , putState = update st . ReplaceUserDetailsTable + , backupState = \backuptype users -> + [csvToBackup ["users.csv"] (userDetailsToCSV backuptype users)] + , restoreState = userDetailsBackup + , resetState = userDetailsStateComponent + } From 56afb385b75933cef4596876032b87f078b4fbdc Mon Sep 17 00:00:00 2001 From: Tom Ellis Date: Fri, 25 Sep 2026 13:59:50 +0100 Subject: [PATCH 39/68] (refactor) Introduce UserDetails abstraction layer --- hackage-server.cabal | 1 + .../Server/Features/UserDetails.hs | 27 ++++++++--------- .../Server/Features/UserDetails/Acid.hs | 30 +++++++++++-------- .../Server/Features/UserDetails/Backup.hs | 20 ++++++------- .../Server/Features/UserDetails/Store.hs | 25 ++++++++++++++++ 5 files changed, 67 insertions(+), 36 deletions(-) create mode 100644 src/Distribution/Server/Features/UserDetails/Store.hs diff --git a/hackage-server.cabal b/hackage-server.cabal index ae8424e44..760f03acc 100644 --- a/hackage-server.cabal +++ b/hackage-server.cabal @@ -423,6 +423,7 @@ library Distribution.Server.Features.UserDetails.Acid Distribution.Server.Features.UserDetails.Backup Distribution.Server.Features.UserDetails.State + Distribution.Server.Features.UserDetails.Store Distribution.Server.Features.UserDetails.Types Distribution.Server.Features.UserSignup Distribution.Server.Features.UserSignup.Acid diff --git a/src/Distribution/Server/Features/UserDetails.hs b/src/Distribution/Server/Features/UserDetails.hs index a614333e3..833c98998 100644 --- a/src/Distribution/Server/Features/UserDetails.hs +++ b/src/Distribution/Server/Features/UserDetails.hs @@ -8,8 +8,8 @@ module Distribution.Server.Features.UserDetails ( UserDetailsFeature(..), ) where -import qualified Distribution.Server.Features.UserDetails.Acid as Acid -import qualified Distribution.Server.Features.UserDetails.State as State +import Distribution.Server.Features.UserDetails.Acid (acidStore) +import qualified Distribution.Server.Features.UserDetails.Store as Store import Distribution.Server.Features.UserDetails.Types import Distribution.Server.Framework import Distribution.Server.Framework.Templating @@ -50,8 +50,7 @@ initUserDetailsFeature :: ServerEnv -> UploadFeature -> IO UserDetailsFeature) initUserDetailsFeature ServerEnv{serverStateDir, serverTemplatesDir, serverTemplatesMode} = do - -- Canonical state - usersDetailsState <- Acid.userDetailsStateComponent serverStateDir + userDetailsBackend <- acidStore serverStateDir --TODO: link up to user feature to delete @@ -61,24 +60,24 @@ initUserDetailsFeature ServerEnv{serverStateDir, serverTemplatesDir, serverTempl [ "user-details-form.html" ] return $ \users core upload -> do - let feature = userDetailsFeature templates usersDetailsState users core upload + let feature = userDetailsFeature templates userDetailsBackend users core upload return feature userDetailsFeature :: Templates - -> StateComponent AcidState State.UserDetailsTable + -> Store.Backend -> UserFeature -> CoreFeature -> UploadFeature -> UserDetailsFeature -userDetailsFeature templates userDetailsState UserFeature{..} CoreFeature{..} UploadFeature{uploadersGroup} +userDetailsFeature templates Store.Backend{backendStore = userDetailsStore, backendState} UserFeature{..} CoreFeature{..} UploadFeature{uploadersGroup} = UserDetailsFeature {..} where userDetailsFeatureInterface = (emptyHackageFeature "user-details") { featureDesc = "Extra information about user accounts, email addresses etc." , featureResources = [userNameContactResource, userAdminInfoResource] - , featureState = [abstractAcidStateComponent userDetailsState] + , featureState = backendState , featureCaches = [] } @@ -113,11 +112,11 @@ userDetailsFeature templates userDetailsState UserFeature{..} CoreFeature{..} Up -- queryUserDetails :: MonadIO m => UserId -> m (Maybe AccountDetails) - queryUserDetails uid = queryState userDetailsState (Acid.LookupUserDetails uid) + queryUserDetails = Store.lookupUserDetails userDetailsStore updateUserDetails :: MonadIO m => UserId -> AccountDetails -> m () updateUserDetails uid udetails = do - updateState userDetailsState (Acid.SetUserDetails uid udetails) + Store.setUserDetails userDetailsStore uid udetails -- Request handlers -- @@ -169,14 +168,14 @@ userDetailsFeature templates userDetailsState UserFeature{..} CoreFeature{..} Up NameAndContact name email <- expectAesonContent guardValidLookingName name guardValidLookingEmail email - updateState userDetailsState (Acid.SetUserNameContact uid name email) + Store.setUserNameContact userDetailsStore uid name email noContent $ toResponse () handlerDeleteUserNameContact :: DynamicPath -> ServerPartE Response handlerDeleteUserNameContact dpath = do uid <- lookupUserName =<< userNameInPath dpath guardAuthorised_ [IsUserId uid, InGroup adminGroup] - updateState userDetailsState (Acid.SetUserNameContact uid T.empty T.empty) + Store.setUserNameContact userDetailsStore uid T.empty T.empty noContent $ toResponse () handlerGetAdminInfo :: DynamicPath -> ServerPartE Response @@ -198,12 +197,12 @@ userDetailsFeature templates userDetailsState UserFeature{..} CoreFeature{..} Up guardAuthorised_ [InGroup adminGroup] uid <- lookupUserName =<< userNameInPath dpath AdminInfo akind notes <- expectAesonContent - updateState userDetailsState (Acid.SetUserAdminInfo uid akind notes) + Store.setUserAdminInfo userDetailsStore uid akind notes noContent $ toResponse () handlerDeleteAdminInfo :: DynamicPath -> ServerPartE Response handlerDeleteAdminInfo dpath = do guardAuthorised_ [InGroup adminGroup] uid <- lookupUserName =<< userNameInPath dpath - updateState userDetailsState (Acid.SetUserAdminInfo uid Nothing T.empty) + Store.setUserAdminInfo userDetailsStore uid Nothing T.empty noContent $ toResponse () diff --git a/src/Distribution/Server/Features/UserDetails/Acid.hs b/src/Distribution/Server/Features/UserDetails/Acid.hs index 45db20135..c4d113cc2 100644 --- a/src/Distribution/Server/Features/UserDetails/Acid.hs +++ b/src/Distribution/Server/Features/UserDetails/Acid.hs @@ -1,18 +1,11 @@ {-# LANGUAGE TemplateHaskell, TypeFamilies #-} module Distribution.Server.Features.UserDetails.Acid - ( module State - , GetUserDetailsTable(..) - , LookupUserDetails(..) - , ReplaceUserDetailsTable(..) - , SetUserDetails(..) - , SetUserNameContact(..) - , SetUserAdminInfo(..) - , DeleteUserDetails(..) - , userDetailsStateComponent + ( acidStore ) where -import Distribution.Server.Features.UserDetails.State as State +import Distribution.Server.Features.UserDetails.State +import qualified Distribution.Server.Features.UserDetails.Store as Store import Distribution.Server.Framework import Distribution.Server.Framework.BackupDump import Distribution.Server.Features.UserDetails.Backup @@ -43,13 +36,26 @@ makeAcidic ''UserDetailsTable [ ] +acidStore :: FilePath -> IO Store.Backend +acidStore stateDir = do + userDetailsState <- userDetailsStateComponent stateDir + pure Store.Backend { + Store.backendStore = Store.Store { + Store.lookupUserDetails = \uid -> queryState userDetailsState (LookupUserDetails uid) + , Store.setUserDetails = \uid details -> updateState userDetailsState (SetUserDetails uid details) + , Store.setUserNameContact = \uid name email -> updateState userDetailsState (SetUserNameContact uid name email) + , Store.setUserAdminInfo = \uid kind notes -> updateState userDetailsState (SetUserAdminInfo uid kind notes) + } + , Store.backendState = [abstractAcidStateComponent userDetailsState] + } + --------------------- -- State components -- -userDetailsStateComponent :: FilePath -> IO (StateComponent AcidState State.UserDetailsTable) +userDetailsStateComponent :: FilePath -> IO (StateComponent AcidState UserDetailsTable) userDetailsStateComponent stateDir = do - st <- openLocalStateFrom (stateDir "db" "UserDetails") State.emptyUserDetailsTable + st <- openLocalStateFrom (stateDir "db" "UserDetails") emptyUserDetailsTable return StateComponent { stateDesc = "Extra details associated with user accounts, email addresses etc" , stateHandle = st diff --git a/src/Distribution/Server/Features/UserDetails/Backup.hs b/src/Distribution/Server/Features/UserDetails/Backup.hs index 648d64483..4d6484823 100644 --- a/src/Distribution/Server/Features/UserDetails/Backup.hs +++ b/src/Distribution/Server/Features/UserDetails/Backup.hs @@ -1,6 +1,6 @@ module Distribution.Server.Features.UserDetails.Backup where -import qualified Distribution.Server.Features.UserDetails.State as Acid +import qualified Distribution.Server.Features.UserDetails.State as State import Distribution.Server.Features.UserDetails.Types import Distribution.Server.Framework.BackupDump import Distribution.Server.Framework.BackupRestore @@ -18,10 +18,10 @@ import Text.CSV (CSV, Record) -- Data backup and restore -- -userDetailsBackup :: RestoreBackup Acid.UserDetailsTable -userDetailsBackup = updateUserBackup Acid.emptyUserDetailsTable +userDetailsBackup :: RestoreBackup State.UserDetailsTable +userDetailsBackup = updateUserBackup State.emptyUserDetailsTable -updateUserBackup :: Acid.UserDetailsTable -> RestoreBackup Acid.UserDetailsTable +updateUserBackup :: State.UserDetailsTable -> RestoreBackup State.UserDetailsTable updateUserBackup users = RestoreBackup { restoreEntry = \entry -> case entry of BackupByteString ["users.csv"] bs -> do @@ -34,11 +34,11 @@ updateUserBackup users = RestoreBackup { return users } -importUserDetails :: CSV -> Acid.UserDetailsTable -> Restore Acid.UserDetailsTable +importUserDetails :: CSV -> State.UserDetailsTable -> Restore State.UserDetailsTable importUserDetails = concatM . map fromRecord . drop 2 where - fromRecord :: Record -> Acid.UserDetailsTable -> Restore Acid.UserDetailsTable - fromRecord [idStr, nameStr, emailStr, kindStr, notesStr] (Acid.UserDetailsTable tbl) = do + fromRecord :: Record -> State.UserDetailsTable -> Restore State.UserDetailsTable + fromRecord [idStr, nameStr, emailStr, kindStr, notesStr] (State.UserDetailsTable tbl) = do UserId uid <- parseText "user id" idStr akind <- parseKind kindStr let udetails = AccountDetails { @@ -47,7 +47,7 @@ importUserDetails = concatM . map fromRecord . drop 2 accountKind = akind, accountAdminNotes = T.pack notesStr } - return $! Acid.UserDetailsTable (IntMap.insert uid udetails tbl) + return $! State.UserDetailsTable (IntMap.insert uid udetails tbl) fromRecord x _ = fail $ "Error processing user details record: " ++ show x @@ -56,8 +56,8 @@ importUserDetails = concatM . map fromRecord . drop 2 parseKind "special" = return (Just AccountKindSpecial) parseKind sts = fail $ "unable to parse account kind: " ++ sts -userDetailsToCSV :: BackupType -> Acid.UserDetailsTable -> CSV -userDetailsToCSV backuptype (Acid.UserDetailsTable tbl) +userDetailsToCSV :: BackupType -> State.UserDetailsTable -> CSV +userDetailsToCSV backuptype (State.UserDetailsTable tbl) = ([showVersion userCSVVer]:) $ (userdetailsCSVKey:) $ diff --git a/src/Distribution/Server/Features/UserDetails/Store.hs b/src/Distribution/Server/Features/UserDetails/Store.hs new file mode 100644 index 000000000..9e265a06d --- /dev/null +++ b/src/Distribution/Server/Features/UserDetails/Store.hs @@ -0,0 +1,25 @@ +{-# LANGUAGE RankNTypes #-} + +module Distribution.Server.Features.UserDetails.Store + ( Backend(..) + , Store(..) + ) where + +import Distribution.Server.Features.UserDetails.Types +import Distribution.Server.Framework (AbstractStateComponent) +import Distribution.Server.Users.Types (UserId) + +import Control.Monad.Trans (MonadIO) +import Data.Text (Text) + +data Backend = Backend { + backendStore :: Store + , backendState :: [AbstractStateComponent] + } + +data Store = Store { + lookupUserDetails :: forall m. MonadIO m => UserId -> m (Maybe AccountDetails) + , setUserDetails :: forall m. MonadIO m => UserId -> AccountDetails -> m () + , setUserNameContact :: forall m. MonadIO m => UserId -> Text -> Text -> m () + , setUserAdminInfo :: forall m. MonadIO m => UserId -> Maybe AccountKind -> Text -> m () + } From 08b14c09b25a526bf2cfa0a2eccc3f915b85b132 Mon Sep 17 00:00:00 2001 From: Tom Ellis Date: Fri, 25 Sep 2026 14:18:03 +0100 Subject: [PATCH 40/68] (refactor) Move vouchStateComponent to Vouch.Acid --- hackage-server.cabal | 1 + src/Distribution/Server/Features/Vouch.hs | 29 ++++--------------- .../Server/Features/Vouch/Acid.hs | 26 +++++++++++++++++ 3 files changed, 32 insertions(+), 24 deletions(-) create mode 100644 src/Distribution/Server/Features/Vouch/Acid.hs diff --git a/hackage-server.cabal b/hackage-server.cabal index 760f03acc..1d9bb7536 100644 --- a/hackage-server.cabal +++ b/hackage-server.cabal @@ -401,6 +401,7 @@ library Distribution.Server.Features.Votes.Store Distribution.Server.Features.Votes.Types Distribution.Server.Features.Vouch + Distribution.Server.Features.Vouch.Acid Distribution.Server.Features.Vouch.State Distribution.Server.Features.Vouch.Types Distribution.Server.Features.RecentPackages diff --git a/src/Distribution/Server/Features/Vouch.hs b/src/Distribution/Server/Features/Vouch.hs index af4b99fff..f58115447 100644 --- a/src/Distribution/Server/Features/Vouch.hs +++ b/src/Distribution/Server/Features/Vouch.hs @@ -4,6 +4,7 @@ module Distribution.Server.Features.Vouch (VouchFeature(..), initVouchFeature, judgeVouch) where import qualified Distribution.Server.Features.Vouch.State as Acid +import Distribution.Server.Features.Vouch.Acid (vouchStateComponent) import Distribution.Server.Features.Vouch.Types import Control.Monad (when, join) import Control.Monad.Except (runExceptT, throwError) @@ -14,13 +15,12 @@ import Data.Time (UTCTime(..), addUTCTime, getCurrentTime, nominalDay, secondsTo import Data.Time.Format.ISO8601 (formatShow, iso8601Format) import Text.XHtml.Strict (prettyHtmlFragment, stringToHtml, li) -import Distribution.Server.Framework ((), AcidState, DynamicPath, HackageFeature, IsHackageFeature, IsHackageFeature(..)) -import Distribution.Server.Framework (MessageSpan(MText), Method(..), Response, ServerEnv(..), ServerPartE, StateComponent(..)) +import Distribution.Server.Framework ((), DynamicPath, HackageFeature, IsHackageFeature, IsHackageFeature(..)) +import Distribution.Server.Framework (MessageSpan(MText), Method(..), Response, ServerEnv(..), ServerPartE) import Distribution.Server.Framework (abstractAcidStateComponent, emptyHackageFeature, errBadRequest) import Distribution.Server.Framework (featureDesc, featureReloadFiles, featureResources, featureState) -import Distribution.Server.Framework (liftIO, openLocalStateFrom, query, queryState, resourceAt, resourceDesc, resourceGet) -import Distribution.Server.Framework (resourcePost, toResponse, update, updateState) -import Distribution.Server.Framework.BackupRestore (RestoreBackup(..)) +import Distribution.Server.Framework (liftIO, queryState, resourceAt, resourceDesc, resourceGet) +import Distribution.Server.Framework (resourcePost, toResponse, updateState) import Distribution.Server.Framework.Templating (($=), TemplateAttr, getTemplate, loadTemplates, reloadTemplates, templateUnescaped) import qualified Distribution.Server.Users.Group as Group import Distribution.Server.Users.Types (UserId(..), UserInfo, UserName(..), userName) @@ -28,25 +28,6 @@ import Distribution.Server.Features.Upload(UploadFeature(..)) import Distribution.Server.Features.Users (UserFeature(..)) import Distribution.Simple.Utils (toUTF8LBS) -vouchStateComponent :: FilePath -> IO (StateComponent AcidState Acid.VouchData) -vouchStateComponent stateDir = do - st <- openLocalStateFrom (stateDir "db" "Vouch") (Acid.VouchData mempty mempty) - let initialVouchData = Acid.VouchData mempty mempty - restore = - RestoreBackup - { restoreEntry = error "Unexpected backup entry" - , restoreFinalize = return initialVouchData - } - pure StateComponent - { stateDesc = "Keeps track of vouches" - , stateHandle = st - , getState = query st Acid.GetVouchesData - , putState = update st . Acid.ReplaceVouchesData - , backupState = \_ _ -> [] - , restoreState = restore - , resetState = vouchStateComponent - } - data VouchFeature = VouchFeature { vouchFeatureInterface :: HackageFeature diff --git a/src/Distribution/Server/Features/Vouch/Acid.hs b/src/Distribution/Server/Features/Vouch/Acid.hs new file mode 100644 index 000000000..af9cac84f --- /dev/null +++ b/src/Distribution/Server/Features/Vouch/Acid.hs @@ -0,0 +1,26 @@ +module Distribution.Server.Features.Vouch.Acid + ( vouchStateComponent + ) where + +import qualified Distribution.Server.Features.Vouch.State as Acid +import Distribution.Server.Framework +import Distribution.Server.Framework.BackupRestore (RestoreBackup(..)) + +vouchStateComponent :: FilePath -> IO (StateComponent AcidState Acid.VouchData) +vouchStateComponent stateDir = do + st <- openLocalStateFrom (stateDir "db" "Vouch") (Acid.VouchData mempty mempty) + let initialVouchData = Acid.VouchData mempty mempty + restore = + RestoreBackup + { restoreEntry = error "Unexpected backup entry" + , restoreFinalize = return initialVouchData + } + pure StateComponent + { stateDesc = "Keeps track of vouches" + , stateHandle = st + , getState = query st Acid.GetVouchesData + , putState = update st . Acid.ReplaceVouchesData + , backupState = \_ _ -> [] + , restoreState = restore + , resetState = vouchStateComponent + } From b7eeadbcf1bd49eb275d5ed23332e023dbbf0f2e Mon Sep 17 00:00:00 2001 From: Tom Ellis Date: Fri, 25 Sep 2026 14:21:10 +0100 Subject: [PATCH 41/68] (refactor) Introduce Vouch abstraction layer --- hackage-server.cabal | 1 + src/Distribution/Server/Features/Vouch.hs | 36 ++++++++----------- .../Server/Features/Vouch/Acid.hs | 23 +++++++++++- .../Server/Features/Vouch/Store.hs | 24 +++++++++++++ 4 files changed, 61 insertions(+), 23 deletions(-) create mode 100644 src/Distribution/Server/Features/Vouch/Store.hs diff --git a/hackage-server.cabal b/hackage-server.cabal index 1d9bb7536..3f00d0753 100644 --- a/hackage-server.cabal +++ b/hackage-server.cabal @@ -403,6 +403,7 @@ library Distribution.Server.Features.Vouch Distribution.Server.Features.Vouch.Acid Distribution.Server.Features.Vouch.State + Distribution.Server.Features.Vouch.Store Distribution.Server.Features.Vouch.Types Distribution.Server.Features.RecentPackages Distribution.Server.Features.PreferredVersions diff --git a/src/Distribution/Server/Features/Vouch.hs b/src/Distribution/Server/Features/Vouch.hs index f58115447..7337f43e9 100644 --- a/src/Distribution/Server/Features/Vouch.hs +++ b/src/Distribution/Server/Features/Vouch.hs @@ -3,24 +3,23 @@ module Distribution.Server.Features.Vouch (VouchFeature(..), initVouchFeature, judgeVouch) where -import qualified Distribution.Server.Features.Vouch.State as Acid -import Distribution.Server.Features.Vouch.Acid (vouchStateComponent) +import Distribution.Server.Features.Vouch.Acid (acidStore) +import qualified Distribution.Server.Features.Vouch.Store as Store import Distribution.Server.Features.Vouch.Types import Control.Monad (when, join) import Control.Monad.Except (runExceptT, throwError) import Control.Monad.IO.Class (MonadIO) import qualified Data.ByteString.Lazy.Char8 as LBS -import qualified Data.Set as Set import Data.Time (UTCTime(..), addUTCTime, getCurrentTime, nominalDay, secondsToDiffTime) import Data.Time.Format.ISO8601 (formatShow, iso8601Format) import Text.XHtml.Strict (prettyHtmlFragment, stringToHtml, li) import Distribution.Server.Framework ((), DynamicPath, HackageFeature, IsHackageFeature, IsHackageFeature(..)) import Distribution.Server.Framework (MessageSpan(MText), Method(..), Response, ServerEnv(..), ServerPartE) -import Distribution.Server.Framework (abstractAcidStateComponent, emptyHackageFeature, errBadRequest) +import Distribution.Server.Framework (emptyHackageFeature, errBadRequest) import Distribution.Server.Framework (featureDesc, featureReloadFiles, featureResources, featureState) -import Distribution.Server.Framework (liftIO, queryState, resourceAt, resourceDesc, resourceGet) -import Distribution.Server.Framework (resourcePost, toResponse, updateState) +import Distribution.Server.Framework (liftIO, resourceAt, resourceDesc, resourceGet) +import Distribution.Server.Framework (resourcePost, toResponse) import Distribution.Server.Framework.Templating (($=), TemplateAttr, getTemplate, loadTemplates, reloadTemplates, templateUnescaped) import qualified Distribution.Server.Users.Group as Group import Distribution.Server.Users.Types (UserId(..), UserInfo, UserName(..), userName) @@ -93,17 +92,18 @@ renderVouchers lookupUserInfo (uid, timestamp) = do initVouchFeature :: ServerEnv -> IO (UserFeature -> UploadFeature -> IO VouchFeature) initVouchFeature ServerEnv{serverStateDir, serverTemplatesDir, serverTemplatesMode} = do - vouchState <- vouchStateComponent serverStateDir + vouchBackend <- acidStore serverStateDir templates <- loadTemplates serverTemplatesMode [ serverTemplatesDir, serverTemplatesDir "Html"] ["vouch.html"] vouchTemplate <- getTemplate templates "vouch.html" return $ \UserFeature{userNameInPath, lookupUserName, lookupUserInfo, guardAuthenticated} UploadFeature{uploadersGroup} -> do let + vouchStore = Store.backendStore vouchBackend handleGetVouches :: DynamicPath -> ServerPartE Response handleGetVouches dpath = do uid <- lookupUserName =<< userNameInPath dpath - vouches <- queryState vouchState $ Acid.GetVouchesFor uid + vouches <- Store.getVouchesFor vouchStore uid param <- renderToLBS lookupUserInfo vouches pure . toResponse $ vouchTemplate [ "msg" $= "" @@ -116,8 +116,8 @@ initVouchFeature ServerEnv{serverStateDir, serverTemplatesDir, serverTemplatesMo ugroup <- liftIO $ Group.queryUserGroup uploadersGroup now <- liftIO getCurrentTime vouchee <- lookupUserName =<< userNameInPath dpath - vouchersForVoucher <- queryState vouchState $ Acid.GetVouchesFor voucher - existingVouchers <- queryState vouchState $ Acid.GetVouchesFor vouchee + vouchersForVoucher <- Store.getVouchesFor vouchStore voucher + existingVouchers <- Store.getVouchesFor vouchStore vouchee case judgeVouch ugroup now vouchee vouchersForVoucher existingVouchers voucher of Left NotAnUploader -> errBadRequest "Not an uploader" [MText "You must be an uploader yourself to endorse other users."] @@ -130,16 +130,13 @@ initVouchFeature ServerEnv{serverStateDir, serverTemplatesDir, serverTemplatesMo Left YouAlreadyVouched -> errBadRequest "Already endorsed" [MText "You have already endorsed this user."] Right result -> do - updateState vouchState $ Acid.PutVouch vouchee (voucher, now) + Store.addVouch vouchStore vouchee (voucher, now) param <- renderToLBS lookupUserInfo $ existingVouchers ++ [(voucher, now)] case result of AddVouchComplete -> do -- enqueue vouching completed notification -- which will be read using drainQueuedNotifications - Acid.VouchData vouches notNotified <- - queryState vouchState Acid.GetVouchesData - let newState = Acid.VouchData vouches (Set.insert vouchee notNotified) - updateState vouchState $ Acid.ReplaceVouchesData newState + Store.queueVouchCompleteNotification vouchStore vouchee liftIO $ Group.addUserToGroup uploadersGroup vouchee pure . toResponse $ vouchTemplate @@ -169,13 +166,8 @@ initVouchFeature ServerEnv{serverStateDir, serverTemplatesDir, serverTemplatesMo , resourcePost = [("html", handlePostVouch)] } ] - , featureState = [ abstractAcidStateComponent vouchState ] + , featureState = Store.backendState vouchBackend , featureReloadFiles = reloadTemplates templates }, - drainQueuedNotifications = do - Acid.VouchData vouches notNotified <- - queryState vouchState Acid.GetVouchesData - let newState = Acid.VouchData vouches mempty - updateState vouchState $ Acid.ReplaceVouchesData newState - pure $ Set.toList notNotified + drainQueuedNotifications = Store.drainQueuedNotifications vouchStore } diff --git a/src/Distribution/Server/Features/Vouch/Acid.hs b/src/Distribution/Server/Features/Vouch/Acid.hs index af9cac84f..92fc83e42 100644 --- a/src/Distribution/Server/Features/Vouch/Acid.hs +++ b/src/Distribution/Server/Features/Vouch/Acid.hs @@ -1,11 +1,32 @@ module Distribution.Server.Features.Vouch.Acid - ( vouchStateComponent + ( acidStore ) where import qualified Distribution.Server.Features.Vouch.State as Acid +import qualified Distribution.Server.Features.Vouch.Store as Store import Distribution.Server.Framework import Distribution.Server.Framework.BackupRestore (RestoreBackup(..)) +import qualified Data.Set as Set + +acidStore :: FilePath -> IO Store.Backend +acidStore stateDir = do + vouchState <- vouchStateComponent stateDir + pure Store.Backend { + Store.backendStore = Store.Store { + Store.getVouchesFor = \uid -> queryState vouchState (Acid.GetVouchesFor uid) + , Store.addVouch = \uid entry -> updateState vouchState (Acid.PutVouch uid entry) + , Store.queueVouchCompleteNotification = \uid -> do + Acid.VouchData vouches notNotified <- queryState vouchState Acid.GetVouchesData + updateState vouchState (Acid.ReplaceVouchesData (Acid.VouchData vouches (Set.insert uid notNotified))) + , Store.drainQueuedNotifications = do + Acid.VouchData vouches notNotified <- queryState vouchState Acid.GetVouchesData + updateState vouchState (Acid.ReplaceVouchesData (Acid.VouchData vouches mempty)) + pure (Set.toList notNotified) + } + , Store.backendState = [abstractAcidStateComponent vouchState] + } + vouchStateComponent :: FilePath -> IO (StateComponent AcidState Acid.VouchData) vouchStateComponent stateDir = do st <- openLocalStateFrom (stateDir "db" "Vouch") (Acid.VouchData mempty mempty) diff --git a/src/Distribution/Server/Features/Vouch/Store.hs b/src/Distribution/Server/Features/Vouch/Store.hs new file mode 100644 index 000000000..3dc6bb648 --- /dev/null +++ b/src/Distribution/Server/Features/Vouch/Store.hs @@ -0,0 +1,24 @@ +{-# LANGUAGE RankNTypes #-} + +module Distribution.Server.Features.Vouch.Store + ( Backend(..) + , Store(..) + ) where + +import Distribution.Server.Framework (AbstractStateComponent) +import Distribution.Server.Users.Types (UserId) + +import Control.Monad.Trans (MonadIO) +import Data.Time (UTCTime) + +data Backend = Backend { + backendStore :: Store + , backendState :: [AbstractStateComponent] + } + +data Store = Store { + getVouchesFor :: forall m. MonadIO m => UserId -> m [(UserId, UTCTime)] + , addVouch :: forall m. MonadIO m => UserId -> (UserId, UTCTime) -> m () + , queueVouchCompleteNotification :: forall m. MonadIO m => UserId -> m () + , drainQueuedNotifications :: forall m. MonadIO m => m [UserId] + } From 3190bea212cc6c56ded95ab0486db79738b29d33 Mon Sep 17 00:00:00 2001 From: Tom Ellis Date: Fri, 25 Sep 2026 15:51:55 +0100 Subject: [PATCH 42/68] (refactor) Move SignupResetTable into UserSignup.State --- hackage-server.cabal | 1 + .../Server/Features/UserSignup.hs | 9 ++++---- .../Server/Features/UserSignup/Acid.hs | 16 ++----------- .../Server/Features/UserSignup/Backup.hs | 17 +++++++------- .../Server/Features/UserSignup/State.hs | 23 +++++++++++++++++++ 5 files changed, 39 insertions(+), 27 deletions(-) create mode 100644 src/Distribution/Server/Features/UserSignup/State.hs diff --git a/hackage-server.cabal b/hackage-server.cabal index 3f00d0753..160033bfb 100644 --- a/hackage-server.cabal +++ b/hackage-server.cabal @@ -430,6 +430,7 @@ library Distribution.Server.Features.UserSignup Distribution.Server.Features.UserSignup.Acid Distribution.Server.Features.UserSignup.Backup + Distribution.Server.Features.UserSignup.State Distribution.Server.Features.UserSignup.Types Distribution.Server.Features.StaticFiles Distribution.Server.Features.ServerIntrospect diff --git a/src/Distribution/Server/Features/UserSignup.hs b/src/Distribution/Server/Features/UserSignup.hs index fb771c078..fc8800149 100644 --- a/src/Distribution/Server/Features/UserSignup.hs +++ b/src/Distribution/Server/Features/UserSignup.hs @@ -12,6 +12,7 @@ module Distribution.Server.Features.UserSignup ( ) where import qualified Distribution.Server.Features.UserSignup.Acid as Acid +import qualified Distribution.Server.Features.UserSignup.State as State import Distribution.Server.Features.UserSignup.Backup import Distribution.Server.Features.UserSignup.Types @@ -94,9 +95,9 @@ instance IsHackageFeature UserSignupFeature where -- State components -- -signupResetStateComponent :: FilePath -> IO (StateComponent AcidState Acid.SignupResetTable) +signupResetStateComponent :: FilePath -> IO (StateComponent AcidState State.SignupResetTable) signupResetStateComponent stateDir = do - st <- openLocalStateFrom (stateDir "db" "UserSignupReset") Acid.emptySignupResetTable + st <- openLocalStateFrom (stateDir "db" "UserSignupReset") State.emptySignupResetTable return StateComponent { stateDesc = "State to keep track of outstanding requests for user signup and password resets" , stateHandle = st @@ -143,7 +144,7 @@ userSignupFeature :: ServerEnv -> UserFeature -> UserDetailsFeature -> UploadFeature - -> StateComponent AcidState Acid.SignupResetTable + -> StateComponent AcidState State.SignupResetTable -> Templates -> UserSignupFeature userSignupFeature ServerEnv{serverBaseURI, serverCron} @@ -213,7 +214,7 @@ userSignupFeature ServerEnv{serverBaseURI, serverCron} queryAllSignupResetInfo :: MonadIO m => m [SignupResetInfo] queryAllSignupResetInfo = queryState signupResetState Acid.GetSignupResetTable - >>= \(Acid.SignupResetTable tbl) -> return (Map.elems tbl) + >>= \(State.SignupResetTable tbl) -> return (Map.elems tbl) querySignupInfo :: Nonce -> MonadIO m => m (Maybe SignupResetInfo) querySignupInfo nonce = diff --git a/src/Distribution/Server/Features/UserSignup/Acid.hs b/src/Distribution/Server/Features/UserSignup/Acid.hs index cdd9badae..0d430b8c3 100644 --- a/src/Distribution/Server/Features/UserSignup/Acid.hs +++ b/src/Distribution/Server/Features/UserSignup/Acid.hs @@ -1,36 +1,24 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} +{-# OPTIONS_GHC -Wno-orphans #-} module Distribution.Server.Features.UserSignup.Acid where import Distribution.Server.Features.UserSignup.Types +import Distribution.Server.Features.UserSignup.State import Distribution.Server.Framework hiding (Method) import Distribution.Server.Util.Nonce -import Data.Map (Map) import qualified Data.Map as Map import Control.Monad.Reader (ask) import Control.Monad.State (get, put, modify) import Data.Acid.Compat -import Data.SafeCopy import Data.Time -------------------------- --- Types of stored data --- - -newtype SignupResetTable = SignupResetTable (Map Nonce SignupResetInfo) - deriving (Eq, Show, MemSize) - -emptySignupResetTable :: SignupResetTable -emptySignupResetTable = SignupResetTable Map.empty - -$(deriveSafeCopy 0 'base ''SignupResetTable) - ------------------------------ -- State queries and updates -- diff --git a/src/Distribution/Server/Features/UserSignup/Backup.hs b/src/Distribution/Server/Features/UserSignup/Backup.hs index abb20e35b..5d179a62e 100644 --- a/src/Distribution/Server/Features/UserSignup/Backup.hs +++ b/src/Distribution/Server/Features/UserSignup/Backup.hs @@ -3,7 +3,7 @@ module Distribution.Server.Features.UserSignup.Backup where import Distribution.Server.Features.UserSignup.Types -import qualified Distribution.Server.Features.UserSignup.Acid as Acid +import qualified Distribution.Server.Features.UserSignup.State as State import Distribution.Server.Framework.BackupDump import Distribution.Server.Framework.BackupRestore @@ -20,10 +20,10 @@ import Text.CSV (CSV, Record) -- Data backup and restore -- -signupResetBackup :: RestoreBackup Acid.SignupResetTable +signupResetBackup :: RestoreBackup State.SignupResetTable signupResetBackup = go [] where - go :: [(Nonce, SignupResetInfo)] -> RestoreBackup Acid.SignupResetTable + go :: [(Nonce, SignupResetInfo)] -> RestoreBackup State.SignupResetTable go st = RestoreBackup { restoreEntry = \entry -> case entry of @@ -40,7 +40,7 @@ signupResetBackup = go [] _ -> return (go st) , restoreFinalize = - return (Acid.SignupResetTable (Map.fromList st)) + return (State.SignupResetTable (Map.fromList st)) } importSignupInfo :: CSV -> Restore [(Nonce, SignupResetInfo)] @@ -59,8 +59,8 @@ importSignupInfo = mapM fromRecord . drop 2 return (nonce, signupinfo) fromRecord x = fail $ "Error processing signup info record: " ++ show x -signupInfoToCSV :: BackupType -> Acid.SignupResetTable -> CSV -signupInfoToCSV backuptype (Acid.SignupResetTable tbl) +signupInfoToCSV :: BackupType -> State.SignupResetTable -> CSV +signupInfoToCSV backuptype (State.SignupResetTable tbl) = ["0.1"] : [ "token", "username", "realname", "email", "timestamp" ] : [ [ if backuptype == FullBackup @@ -90,8 +90,8 @@ importResetInfo = mapM fromRecord . drop 2 return (nonce, signupinfo) fromRecord x = fail $ "Error processing signup info record: " ++ show x -resetInfoToCSV :: BackupType -> Acid.SignupResetTable -> CSV -resetInfoToCSV backuptype (Acid.SignupResetTable tbl) +resetInfoToCSV :: BackupType -> State.SignupResetTable -> CSV +resetInfoToCSV backuptype (State.SignupResetTable tbl) = ["0.1"] : [ "token", "userid", "timestamp" ] : [ [ if backuptype == FullBackup @@ -101,4 +101,3 @@ resetInfoToCSV backuptype (Acid.SignupResetTable tbl) , formatUTCTime nonceTimestamp ] | (nonce, ResetInfo{..}) <- Map.toList tbl ] - diff --git a/src/Distribution/Server/Features/UserSignup/State.hs b/src/Distribution/Server/Features/UserSignup/State.hs new file mode 100644 index 000000000..6a4371c2f --- /dev/null +++ b/src/Distribution/Server/Features/UserSignup/State.hs @@ -0,0 +1,23 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving, TemplateHaskell #-} + +module Distribution.Server.Features.UserSignup.State where + +import Distribution.Server.Features.UserSignup.Types +import Distribution.Server.Framework (MemSize) +import Distribution.Server.Util.Nonce (Nonce) + +import qualified Data.Map as Map +import Data.Map (Map) +import Data.SafeCopy + +------------------------- +-- Types of stored data +-- + +newtype SignupResetTable = SignupResetTable (Map Nonce SignupResetInfo) + deriving (Eq, Show, MemSize) + +emptySignupResetTable :: SignupResetTable +emptySignupResetTable = SignupResetTable Map.empty + +$(deriveSafeCopy 0 'base ''SignupResetTable) From 0e1f42abe459627be791d00a111d45dac1722f6d Mon Sep 17 00:00:00 2001 From: Tom Ellis Date: Fri, 25 Sep 2026 15:52:58 +0100 Subject: [PATCH 43/68] (refactor) Move signupResetStateComponent to UserSignup.Acid --- .../Server/Features/UserSignup.hs | 24 +------------------ .../Server/Features/UserSignup/Acid.hs | 17 +++++++++++++ 2 files changed, 18 insertions(+), 23 deletions(-) diff --git a/src/Distribution/Server/Features/UserSignup.hs b/src/Distribution/Server/Features/UserSignup.hs index fc8800149..fbfc26858 100644 --- a/src/Distribution/Server/Features/UserSignup.hs +++ b/src/Distribution/Server/Features/UserSignup.hs @@ -13,12 +13,10 @@ module Distribution.Server.Features.UserSignup ( import qualified Distribution.Server.Features.UserSignup.Acid as Acid import qualified Distribution.Server.Features.UserSignup.State as State -import Distribution.Server.Features.UserSignup.Backup import Distribution.Server.Features.UserSignup.Types import Distribution.Server.Framework import Distribution.Server.Framework.Templating -import Distribution.Server.Framework.BackupDump import Distribution.Server.Features.Upload import Distribution.Server.Features.Users @@ -91,26 +89,6 @@ instance IsHackageFeature UserSignupFeature where -- set new password -- ---------------------- --- State components --- - -signupResetStateComponent :: FilePath -> IO (StateComponent AcidState State.SignupResetTable) -signupResetStateComponent stateDir = do - st <- openLocalStateFrom (stateDir "db" "UserSignupReset") State.emptySignupResetTable - return StateComponent { - stateDesc = "State to keep track of outstanding requests for user signup and password resets" - , stateHandle = st - , getState = query st Acid.GetSignupResetTable - , putState = update st . Acid.ReplaceSignupResetTable - , backupState = \backuptype tbl -> - [csvToBackup ["signups.csv"] (signupInfoToCSV backuptype tbl) - ,csvToBackup ["resets.csv"] (resetInfoToCSV backuptype tbl)] - , restoreState = signupResetBackup - , resetState = signupResetStateComponent - } - - ---------------------------------------- -- Feature definition & initialisation -- @@ -123,7 +101,7 @@ initUserSignupFeature :: ServerEnv initUserSignupFeature env@ServerEnv{ serverStateDir, serverTemplatesDir, serverTemplatesMode } = do -- Canonical state - signupResetState <- signupResetStateComponent serverStateDir + signupResetState <- Acid.signupResetStateComponent serverStateDir -- Page templates templates <- loadTemplates serverTemplatesMode diff --git a/src/Distribution/Server/Features/UserSignup/Acid.hs b/src/Distribution/Server/Features/UserSignup/Acid.hs index 0d430b8c3..7f60e1837 100644 --- a/src/Distribution/Server/Features/UserSignup/Acid.hs +++ b/src/Distribution/Server/Features/UserSignup/Acid.hs @@ -7,8 +7,10 @@ module Distribution.Server.Features.UserSignup.Acid where import Distribution.Server.Features.UserSignup.Types import Distribution.Server.Features.UserSignup.State +import Distribution.Server.Features.UserSignup.Backup import Distribution.Server.Framework hiding (Method) +import Distribution.Server.Framework.BackupDump import Distribution.Server.Util.Nonce @@ -19,6 +21,21 @@ import Data.Acid.Compat import Data.Time +signupResetStateComponent :: FilePath -> IO (StateComponent AcidState SignupResetTable) +signupResetStateComponent stateDir = do + st <- openLocalStateFrom (stateDir "db" "UserSignupReset") emptySignupResetTable + return StateComponent { + stateDesc = "State to keep track of outstanding requests for user signup and password resets" + , stateHandle = st + , getState = query st GetSignupResetTable + , putState = update st . ReplaceSignupResetTable + , backupState = \backuptype tbl -> + [csvToBackup ["signups.csv"] (signupInfoToCSV backuptype tbl) + ,csvToBackup ["resets.csv"] (resetInfoToCSV backuptype tbl)] + , restoreState = signupResetBackup + , resetState = signupResetStateComponent + } + ------------------------------ -- State queries and updates -- From a359279de62e6cb53788438dec6aadcee401838c Mon Sep 17 00:00:00 2001 From: Tom Ellis Date: Fri, 25 Sep 2026 15:54:23 +0100 Subject: [PATCH 44/68] (refactor) Introduce UserSignup abstraction layer --- hackage-server.cabal | 1 + .../Server/Features/UserSignup.hs | 29 +++++++++---------- .../Server/Features/UserSignup/Acid.hs | 17 +++++++++++ .../Server/Features/UserSignup/Store.hs | 26 +++++++++++++++++ 4 files changed, 58 insertions(+), 15 deletions(-) create mode 100644 src/Distribution/Server/Features/UserSignup/Store.hs diff --git a/hackage-server.cabal b/hackage-server.cabal index 160033bfb..e149bef8a 100644 --- a/hackage-server.cabal +++ b/hackage-server.cabal @@ -431,6 +431,7 @@ library Distribution.Server.Features.UserSignup.Acid Distribution.Server.Features.UserSignup.Backup Distribution.Server.Features.UserSignup.State + Distribution.Server.Features.UserSignup.Store Distribution.Server.Features.UserSignup.Types Distribution.Server.Features.StaticFiles Distribution.Server.Features.ServerIntrospect diff --git a/src/Distribution/Server/Features/UserSignup.hs b/src/Distribution/Server/Features/UserSignup.hs index fbfc26858..8c19f7053 100644 --- a/src/Distribution/Server/Features/UserSignup.hs +++ b/src/Distribution/Server/Features/UserSignup.hs @@ -12,7 +12,7 @@ module Distribution.Server.Features.UserSignup ( ) where import qualified Distribution.Server.Features.UserSignup.Acid as Acid -import qualified Distribution.Server.Features.UserSignup.State as State +import qualified Distribution.Server.Features.UserSignup.Store as Store import Distribution.Server.Features.UserSignup.Types import Distribution.Server.Framework @@ -29,7 +29,6 @@ import Distribution.Server.Util.Nonce import Distribution.Server.Util.Validators import qualified Distribution.Server.Users.Users as Users -import qualified Data.Map as Map import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.Encoding as T @@ -101,7 +100,7 @@ initUserSignupFeature :: ServerEnv initUserSignupFeature env@ServerEnv{ serverStateDir, serverTemplatesDir, serverTemplatesMode } = do -- Canonical state - signupResetState <- Acid.signupResetStateComponent serverStateDir + signupResetBackend <- Acid.acidStore serverStateDir -- Page templates templates <- loadTemplates serverTemplatesMode @@ -114,7 +113,7 @@ initUserSignupFeature env@ServerEnv{ serverStateDir, serverTemplatesDir, return $ \users userdetails upload -> do let feature = userSignupFeature env users userdetails upload - signupResetState templates + signupResetBackend templates return feature @@ -122,15 +121,17 @@ userSignupFeature :: ServerEnv -> UserFeature -> UserDetailsFeature -> UploadFeature - -> StateComponent AcidState State.SignupResetTable + -> Store.Backend -> Templates -> UserSignupFeature userSignupFeature ServerEnv{serverBaseURI, serverCron} UserFeature{..} UserDetailsFeature{..} - UploadFeature{uploadersGroup} signupResetState templates + UploadFeature{uploadersGroup} signupResetBackend templates = UserSignupFeature {..} where + signupResetStore = Store.backendStore signupResetBackend + userSignupFeatureInterface = (emptyHackageFeature "user-signup-reset") { featureDesc = "Extra information about user accounts, email addresses etc." , featureResources = [signupRequestsResource, @@ -138,7 +139,7 @@ userSignupFeature ServerEnv{serverBaseURI, serverCron} signupRequestResource, resetRequestsResource, resetRequestResource] - , featureState = [abstractAcidStateComponent signupResetState] + , featureState = Store.backendState signupResetBackend , featureCaches = [] , featureReloadFiles = reloadTemplates templates , featurePostInit = setupExpireCronJob @@ -190,31 +191,29 @@ userSignupFeature ServerEnv{serverBaseURI, serverCron} -- queryAllSignupResetInfo :: MonadIO m => m [SignupResetInfo] - queryAllSignupResetInfo = - queryState signupResetState Acid.GetSignupResetTable - >>= \(State.SignupResetTable tbl) -> return (Map.elems tbl) + queryAllSignupResetInfo = Store.getSignupResetInfos signupResetStore querySignupInfo :: Nonce -> MonadIO m => m (Maybe SignupResetInfo) querySignupInfo nonce = - justSignupInfo <$> queryState signupResetState (Acid.LookupSignupResetInfo nonce) + justSignupInfo <$> Store.lookupSignupResetInfo signupResetStore nonce where justSignupInfo (Just info@SignupInfo{}) = Just info justSignupInfo _ = Nothing queryResetInfo :: Nonce -> MonadIO m => m (Maybe SignupResetInfo) queryResetInfo nonce = - justResetInfo <$> queryState signupResetState (Acid.LookupSignupResetInfo nonce) + justResetInfo <$> Store.lookupSignupResetInfo signupResetStore nonce where justResetInfo (Just info@ResetInfo{}) = Just info justResetInfo _ = Nothing updateAddSignupResetInfo :: Nonce -> SignupResetInfo -> MonadIO m => m Bool updateAddSignupResetInfo nonce signupInfo = - updateState signupResetState (Acid.AddSignupResetInfo nonce signupInfo) + Store.addSignupResetInfo signupResetStore nonce signupInfo updateDeleteSignupResetInfo :: Nonce -> MonadIO m => m () updateDeleteSignupResetInfo nonce = - updateState signupResetState (Acid.DeleteSignupResetInfo nonce) + Store.deleteSignupResetInfo signupResetStore nonce -- Expiry -- @@ -226,7 +225,7 @@ userSignupFeature ServerEnv{serverBaseURI, serverCron} cronJobAction = do now <- getCurrentTime let expire = now { utctDay = addDays (-7) (utctDay now) } - updateState signupResetState (Acid.DeleteAllExpired expire) + Store.deleteExpiredResetInfos signupResetStore expire } -- Request handlers diff --git a/src/Distribution/Server/Features/UserSignup/Acid.hs b/src/Distribution/Server/Features/UserSignup/Acid.hs index 7f60e1837..6ee9ec40a 100644 --- a/src/Distribution/Server/Features/UserSignup/Acid.hs +++ b/src/Distribution/Server/Features/UserSignup/Acid.hs @@ -8,6 +8,7 @@ module Distribution.Server.Features.UserSignup.Acid where import Distribution.Server.Features.UserSignup.Types import Distribution.Server.Features.UserSignup.State import Distribution.Server.Features.UserSignup.Backup +import qualified Distribution.Server.Features.UserSignup.Store as Store import Distribution.Server.Framework hiding (Method) import Distribution.Server.Framework.BackupDump @@ -21,6 +22,22 @@ import Data.Acid.Compat import Data.Time +acidStore :: FilePath -> IO Store.Backend +acidStore stateDir = do + signupResetState <- signupResetStateComponent stateDir + pure Store.Backend { + Store.backendStore = Store.Store { + Store.getSignupResetInfos = + queryState signupResetState GetSignupResetTable + >>= \(SignupResetTable tbl) -> return (Map.elems tbl) + , Store.lookupSignupResetInfo = \nonce -> queryState signupResetState (LookupSignupResetInfo nonce) + , Store.addSignupResetInfo = \nonce info -> updateState signupResetState (AddSignupResetInfo nonce info) + , Store.deleteSignupResetInfo = \nonce -> updateState signupResetState (DeleteSignupResetInfo nonce) + , Store.deleteExpiredResetInfos = \expiry -> updateState signupResetState (DeleteAllExpired expiry) + } + , Store.backendState = [abstractAcidStateComponent signupResetState] + } + signupResetStateComponent :: FilePath -> IO (StateComponent AcidState SignupResetTable) signupResetStateComponent stateDir = do st <- openLocalStateFrom (stateDir "db" "UserSignupReset") emptySignupResetTable diff --git a/src/Distribution/Server/Features/UserSignup/Store.hs b/src/Distribution/Server/Features/UserSignup/Store.hs new file mode 100644 index 000000000..81ba403c1 --- /dev/null +++ b/src/Distribution/Server/Features/UserSignup/Store.hs @@ -0,0 +1,26 @@ +{-# LANGUAGE RankNTypes #-} + +module Distribution.Server.Features.UserSignup.Store + ( Backend(..) + , Store(..) + ) where + +import Distribution.Server.Features.UserSignup.Types (SignupResetInfo) +import Distribution.Server.Framework (AbstractStateComponent) +import Distribution.Server.Util.Nonce (Nonce) + +import Control.Monad.Trans (MonadIO) +import Data.Time (UTCTime) + +data Backend = Backend { + backendStore :: Store + , backendState :: [AbstractStateComponent] + } + +data Store = Store { + getSignupResetInfos :: forall m. MonadIO m => m [SignupResetInfo] + , lookupSignupResetInfo :: forall m. MonadIO m => Nonce -> m (Maybe SignupResetInfo) + , addSignupResetInfo :: forall m. MonadIO m => Nonce -> SignupResetInfo -> m Bool + , deleteSignupResetInfo :: forall m. MonadIO m => Nonce -> m () + , deleteExpiredResetInfos :: forall m. MonadIO m => UTCTime -> m () + } From 078de4d96b796e41134e19e3072e9f59cf44c95d Mon Sep 17 00:00:00 2001 From: Tom Ellis Date: Fri, 25 Sep 2026 15:57:04 +0100 Subject: [PATCH 45/68] (refactor) Move documentationStateComponent to Documentation.Acid --- hackage-server.cabal | 1 + .../Server/Features/Documentation.hs | 51 ++++--------------- .../Server/Features/Documentation/Acid.hs | 45 ++++++++++++++++ 3 files changed, 55 insertions(+), 42 deletions(-) create mode 100644 src/Distribution/Server/Features/Documentation/Acid.hs diff --git a/hackage-server.cabal b/hackage-server.cabal index e149bef8a..b8df40c75 100644 --- a/hackage-server.cabal +++ b/hackage-server.cabal @@ -369,6 +369,7 @@ library Distribution.Server.Features.Distro.State Distribution.Server.Features.Distro.Types Distribution.Server.Features.Documentation + Distribution.Server.Features.Documentation.Acid Distribution.Server.Features.Documentation.State Distribution.Server.Features.DownloadCount Distribution.Server.Features.DownloadCount.State diff --git a/src/Distribution/Server/Features/Documentation.hs b/src/Distribution/Server/Features/Documentation.hs index fb3ebfa63..2ebb4ef6f 100644 --- a/src/Distribution/Server/Features/Documentation.hs +++ b/src/Distribution/Server/Features/Documentation.hs @@ -10,7 +10,8 @@ module Distribution.Server.Features.Documentation ( import Distribution.Server.Features.Security.SHA256 (sha256) import Distribution.Server.Framework -import qualified Distribution.Server.Features.Documentation.State as Acid +import qualified Distribution.Server.Features.Documentation.State as State +import Distribution.Server.Features.Documentation.Acid (documentationStateComponent) import Distribution.Server.Features.Upload import Distribution.Server.Features.Users import Distribution.Server.Features.Core @@ -18,7 +19,6 @@ import Distribution.Server.Features.TarIndexCache import Distribution.Server.Features.BuildReports import Distribution.Version (Version, nullVersion) -import Distribution.Server.Framework.BackupRestore import qualified Distribution.Server.Framework.ResponseContentTypes as Resource import Distribution.Server.Framework.BlobStorage (BlobId) import qualified Distribution.Server.Framework.BlobStorage as BlobStorage @@ -110,39 +110,6 @@ initDocumentationFeature name documentationChangeHook return feature -documentationStateComponent :: String -> FilePath -> IO (StateComponent AcidState Acid.Documentation) -documentationStateComponent name stateDir = do - st <- openLocalStateFrom (stateDir "db" name) Acid.initialDocumentation - return StateComponent { - stateDesc = "Package documentation" - , stateHandle = st - , getState = query st Acid.GetDocumentation - , putState = update st . Acid.ReplaceDocumentation - , backupState = \_ -> dumpBackup - , restoreState = updateDocumentation (Acid.Documentation Map.empty) - , resetState = documentationStateComponent name - } - where - dumpBackup doc = - let exportFunc (pkgid, blob) = BackupBlob [display pkgid, "documentation.tar"] blob - in map exportFunc . Map.toList $ Acid.documentation doc - - updateDocumentation :: Acid.Documentation -> RestoreBackup Acid.Documentation - updateDocumentation docs = RestoreBackup { - restoreEntry = \entry -> - case entry of - BackupBlob [str, "documentation.tar"] blobId | Just pkgId <- simpleParse str -> do - docs' <- importDocumentation pkgId blobId docs - return (updateDocumentation docs') - _ -> - return (updateDocumentation docs) - , restoreFinalize = return docs - } - - importDocumentation :: PackageId -> BlobId -> Acid.Documentation -> Restore Acid.Documentation - importDocumentation pkgId blobId (Acid.Documentation docs) = - return (Acid.Documentation (Map.insert pkgId blobId docs)) - documentationFeature :: String -> ServerEnv -> CoreResource @@ -152,7 +119,7 @@ documentationFeature :: String -> ReportsFeature -> UserFeature -> VersionsFeature - -> StateComponent AcidState Acid.Documentation + -> StateComponent AcidState State.Documentation -> Hook PackageId () -> DocumentationFeature documentationFeature name @@ -186,14 +153,14 @@ documentationFeature name } queryHasDocumentation :: MonadIO m => PackageIdentifier -> m Bool - queryHasDocumentation pkgid = queryState documentationState (Acid.HasDocumentation pkgid) + queryHasDocumentation pkgid = queryState documentationState (State.HasDocumentation pkgid) queryDocumentation :: MonadIO m => PackageIdentifier -> m (Maybe BlobId) - queryDocumentation pkgid = queryState documentationState (Acid.LookupDocumentation pkgid) + queryDocumentation pkgid = queryState documentationState (State.LookupDocumentation pkgid) queryDocumentationIndex :: MonadIO m => m (Map.Map PackageId BlobId) queryDocumentationIndex = - liftM Acid.documentation (queryState documentationState Acid.GetDocumentation) + liftM State.documentation (queryState documentationState State.GetDocumentation) documentationResource = fix $ \r -> DocumentationResource { packageDocsContent = (extendResourcePath "/docs/.." corePackagePage) { @@ -368,7 +335,7 @@ documentationFeature name case mres of Left err -> errBadRequest "Invalid documentation tarball" [MText err] Right ((), blobid) -> do - updateState documentationState $ Acid.InsertDocumentation pkgid blobid + updateState documentationState $ State.InsertDocumentation pkgid blobid runHook_ documentationChangeHook pkgid noContent (toResponse ()) @@ -401,7 +368,7 @@ documentationFeature name pkgid <- packageInPath dpath guardValidPackageId pkgid guardAuthorisedAsMaintainerOrTrustee (packageName pkgid) - updateState documentationState $ Acid.RemoveDocumentation pkgid + updateState documentationState $ State.RemoveDocumentation pkgid runHook_ documentationChangeHook pkgid noContent (toResponse ()) @@ -465,7 +432,7 @@ documentationFeature name tempRedirect latestPkgPath (toResponse "") Nothing -> errNotFoundH "Not Found" [MText "There is no documentation for this package."] False -> do - mdocs <- queryState documentationState $ Acid.LookupDocumentation pkgid + mdocs <- queryState documentationState $ State.LookupDocumentation pkgid case mdocs of Nothing -> errNotFoundH "Not Found" diff --git a/src/Distribution/Server/Features/Documentation/Acid.hs b/src/Distribution/Server/Features/Documentation/Acid.hs new file mode 100644 index 000000000..073eae8f0 --- /dev/null +++ b/src/Distribution/Server/Features/Documentation/Acid.hs @@ -0,0 +1,45 @@ +module Distribution.Server.Features.Documentation.Acid + ( documentationStateComponent + ) where + +import qualified Distribution.Server.Features.Documentation.State as State +import Distribution.Server.Framework +import Distribution.Server.Framework.BackupRestore +import Distribution.Server.Framework.BlobStorage (BlobId) + +import Distribution.Package (PackageId) +import Distribution.Text (display, simpleParse) +import qualified Data.Map as Map + +documentationStateComponent :: String -> FilePath -> IO (StateComponent AcidState State.Documentation) +documentationStateComponent name stateDir = do + st <- openLocalStateFrom (stateDir "db" name) State.initialDocumentation + return StateComponent { + stateDesc = "Package documentation" + , stateHandle = st + , getState = query st State.GetDocumentation + , putState = update st . State.ReplaceDocumentation + , backupState = \_ -> dumpBackup + , restoreState = updateDocumentation (State.Documentation Map.empty) + , resetState = documentationStateComponent name + } + where + dumpBackup doc = + let exportFunc (pkgid, blob) = BackupBlob [display pkgid, "documentation.tar"] blob + in map exportFunc . Map.toList $ State.documentation doc + + updateDocumentation :: State.Documentation -> RestoreBackup State.Documentation + updateDocumentation docs = RestoreBackup { + restoreEntry = \entry -> + case entry of + BackupBlob [str, "documentation.tar"] blobId | Just pkgId <- simpleParse str -> do + docs' <- importDocumentation pkgId blobId docs + return (updateDocumentation docs') + _ -> + return (updateDocumentation docs) + , restoreFinalize = return docs + } + + importDocumentation :: PackageId -> BlobId -> State.Documentation -> Restore State.Documentation + importDocumentation pkgId blobId (State.Documentation docs) = + return (State.Documentation (Map.insert pkgId blobId docs)) From 0f0296660c30b45d917c250bd4e77d2ddbcd0537 Mon Sep 17 00:00:00 2001 From: Tom Ellis Date: Fri, 25 Sep 2026 15:58:45 +0100 Subject: [PATCH 46/68] (refactor) Introduce Documentation abstraction layer --- hackage-server.cabal | 1 + .../Server/Features/Documentation.hs | 28 ++++++++++--------- .../Server/Features/Documentation/Acid.hs | 17 ++++++++++- .../Server/Features/Documentation/Store.hs | 27 ++++++++++++++++++ 4 files changed, 59 insertions(+), 14 deletions(-) create mode 100644 src/Distribution/Server/Features/Documentation/Store.hs diff --git a/hackage-server.cabal b/hackage-server.cabal index b8df40c75..a4e979f84 100644 --- a/hackage-server.cabal +++ b/hackage-server.cabal @@ -371,6 +371,7 @@ library Distribution.Server.Features.Documentation Distribution.Server.Features.Documentation.Acid Distribution.Server.Features.Documentation.State + Distribution.Server.Features.Documentation.Store Distribution.Server.Features.DownloadCount Distribution.Server.Features.DownloadCount.State Distribution.Server.Features.DownloadCount.Backup diff --git a/src/Distribution/Server/Features/Documentation.hs b/src/Distribution/Server/Features/Documentation.hs index 2ebb4ef6f..959856dec 100644 --- a/src/Distribution/Server/Features/Documentation.hs +++ b/src/Distribution/Server/Features/Documentation.hs @@ -10,8 +10,8 @@ module Distribution.Server.Features.Documentation ( import Distribution.Server.Features.Security.SHA256 (sha256) import Distribution.Server.Framework -import qualified Distribution.Server.Features.Documentation.State as State -import Distribution.Server.Features.Documentation.Acid (documentationStateComponent) +import Distribution.Server.Features.Documentation.Acid (acidStore) +import qualified Distribution.Server.Features.Documentation.Store as Store import Distribution.Server.Features.Upload import Distribution.Server.Features.Users import Distribution.Server.Features.Core @@ -98,7 +98,7 @@ initDocumentationFeature :: String initDocumentationFeature name env@ServerEnv{serverStateDir} = do -- Canonical state - documentationState <- documentationStateComponent name serverStateDir + documentationBackend <- acidStore name serverStateDir -- Hooks documentationChangeHook <- newHook @@ -106,7 +106,7 @@ initDocumentationFeature name return $ \core getPackages upload tarIndexCache reportsCore user version -> do let feature = documentationFeature name env core getPackages upload tarIndexCache reportsCore user version - documentationState + documentationBackend documentationChangeHook return feature @@ -119,7 +119,7 @@ documentationFeature :: String -> ReportsFeature -> UserFeature -> VersionsFeature - -> StateComponent AcidState State.Documentation + -> Store.Backend -> Hook PackageId () -> DocumentationFeature documentationFeature name @@ -137,10 +137,12 @@ documentationFeature name ReportsFeature{..} UserFeature{ guardAuthorised_ } VersionsFeature{queryGetPreferredInfo} - documentationState + documentationBackend documentationChangeHook = DocumentationFeature{..} where + documentationStore = Store.backendStore documentationBackend + documentationFeatureInterface = (emptyHackageFeature name) { featureDesc = "Maintain and display documentation" , featureResources = @@ -149,18 +151,18 @@ documentationFeature name , packageDocsWhole , packageDocsStats ] - , featureState = [abstractAcidStateComponent documentationState] + , featureState = Store.backendState documentationBackend } queryHasDocumentation :: MonadIO m => PackageIdentifier -> m Bool - queryHasDocumentation pkgid = queryState documentationState (State.HasDocumentation pkgid) + queryHasDocumentation pkgid = Store.hasDocumentation documentationStore pkgid queryDocumentation :: MonadIO m => PackageIdentifier -> m (Maybe BlobId) - queryDocumentation pkgid = queryState documentationState (State.LookupDocumentation pkgid) + queryDocumentation pkgid = Store.lookupDocumentation documentationStore pkgid queryDocumentationIndex :: MonadIO m => m (Map.Map PackageId BlobId) queryDocumentationIndex = - liftM State.documentation (queryState documentationState State.GetDocumentation) + Store.getDocumentationIndex documentationStore documentationResource = fix $ \r -> DocumentationResource { packageDocsContent = (extendResourcePath "/docs/.." corePackagePage) { @@ -335,7 +337,7 @@ documentationFeature name case mres of Left err -> errBadRequest "Invalid documentation tarball" [MText err] Right ((), blobid) -> do - updateState documentationState $ State.InsertDocumentation pkgid blobid + Store.insertDocumentation documentationStore pkgid blobid runHook_ documentationChangeHook pkgid noContent (toResponse ()) @@ -368,7 +370,7 @@ documentationFeature name pkgid <- packageInPath dpath guardValidPackageId pkgid guardAuthorisedAsMaintainerOrTrustee (packageName pkgid) - updateState documentationState $ State.RemoveDocumentation pkgid + Store.removeDocumentation documentationStore pkgid runHook_ documentationChangeHook pkgid noContent (toResponse ()) @@ -432,7 +434,7 @@ documentationFeature name tempRedirect latestPkgPath (toResponse "") Nothing -> errNotFoundH "Not Found" [MText "There is no documentation for this package."] False -> do - mdocs <- queryState documentationState $ State.LookupDocumentation pkgid + mdocs <- Store.lookupDocumentation documentationStore pkgid case mdocs of Nothing -> errNotFoundH "Not Found" diff --git a/src/Distribution/Server/Features/Documentation/Acid.hs b/src/Distribution/Server/Features/Documentation/Acid.hs index 073eae8f0..8349da2a6 100644 --- a/src/Distribution/Server/Features/Documentation/Acid.hs +++ b/src/Distribution/Server/Features/Documentation/Acid.hs @@ -1,8 +1,9 @@ module Distribution.Server.Features.Documentation.Acid - ( documentationStateComponent + ( acidStore ) where import qualified Distribution.Server.Features.Documentation.State as State +import qualified Distribution.Server.Features.Documentation.Store as Store import Distribution.Server.Framework import Distribution.Server.Framework.BackupRestore import Distribution.Server.Framework.BlobStorage (BlobId) @@ -11,6 +12,20 @@ import Distribution.Package (PackageId) import Distribution.Text (display, simpleParse) import qualified Data.Map as Map +acidStore :: String -> FilePath -> IO Store.Backend +acidStore name stateDir = do + documentationState <- documentationStateComponent name stateDir + pure Store.Backend { + Store.backendStore = Store.Store { + Store.hasDocumentation = \pkgid -> queryState documentationState (State.HasDocumentation pkgid) + , Store.lookupDocumentation = \pkgid -> queryState documentationState (State.LookupDocumentation pkgid) + , Store.getDocumentationIndex = State.documentation <$> queryState documentationState State.GetDocumentation + , Store.insertDocumentation = \pkgid blobid -> updateState documentationState (State.InsertDocumentation pkgid blobid) + , Store.removeDocumentation = \pkgid -> updateState documentationState (State.RemoveDocumentation pkgid) + } + , Store.backendState = [abstractAcidStateComponent documentationState] + } + documentationStateComponent :: String -> FilePath -> IO (StateComponent AcidState State.Documentation) documentationStateComponent name stateDir = do st <- openLocalStateFrom (stateDir "db" name) State.initialDocumentation diff --git a/src/Distribution/Server/Features/Documentation/Store.hs b/src/Distribution/Server/Features/Documentation/Store.hs new file mode 100644 index 000000000..9f72eeefd --- /dev/null +++ b/src/Distribution/Server/Features/Documentation/Store.hs @@ -0,0 +1,27 @@ +{-# LANGUAGE RankNTypes #-} + +module Distribution.Server.Features.Documentation.Store + ( Backend(..) + , Store(..) + ) where + +import Distribution.Server.Framework (AbstractStateComponent) +import Distribution.Server.Framework.BlobStorage (BlobId) + +import Distribution.Package (PackageId, PackageIdentifier) + +import Control.Monad.Trans (MonadIO) +import Data.Map (Map) + +data Backend = Backend { + backendStore :: Store + , backendState :: [AbstractStateComponent] + } + +data Store = Store { + hasDocumentation :: forall m. MonadIO m => PackageIdentifier -> m Bool + , lookupDocumentation :: forall m. MonadIO m => PackageIdentifier -> m (Maybe BlobId) + , getDocumentationIndex :: forall m. MonadIO m => m (Map PackageId BlobId) + , insertDocumentation :: forall m. MonadIO m => PackageId -> BlobId -> m () + , removeDocumentation :: forall m. MonadIO m => PackageId -> m () + } From 2642f36675c2caa0bd43a58a5befe34569ace3c0 Mon Sep 17 00:00:00 2001 From: Tom Ellis Date: Fri, 25 Sep 2026 16:00:34 +0100 Subject: [PATCH 47/68] (refactor) Move inMemStateComponent to DownloadCount.Acid --- hackage-server.cabal | 1 + .../Server/Features/DownloadCount.hs | 15 +----------- .../Server/Features/DownloadCount/Acid.hs | 23 +++++++++++++++++++ 3 files changed, 25 insertions(+), 14 deletions(-) create mode 100644 src/Distribution/Server/Features/DownloadCount/Acid.hs diff --git a/hackage-server.cabal b/hackage-server.cabal index a4e979f84..0747ee2e0 100644 --- a/hackage-server.cabal +++ b/hackage-server.cabal @@ -373,6 +373,7 @@ library Distribution.Server.Features.Documentation.State Distribution.Server.Features.Documentation.Store Distribution.Server.Features.DownloadCount + Distribution.Server.Features.DownloadCount.Acid Distribution.Server.Features.DownloadCount.State Distribution.Server.Features.DownloadCount.Backup Distribution.Server.Features.EditCabalFiles diff --git a/src/Distribution/Server/Features/DownloadCount.hs b/src/Distribution/Server/Features/DownloadCount.hs index 527ac859d..a07587498 100644 --- a/src/Distribution/Server/Features/DownloadCount.hs +++ b/src/Distribution/Server/Features/DownloadCount.hs @@ -33,6 +33,7 @@ import Distribution.Server.Framework.BackupRestore import Distribution.Server.Features.DownloadCount.State import Distribution.Server.Features.DownloadCount.Backup +import Distribution.Server.Features.DownloadCount.Acid (inMemStateComponent) import Distribution.Server.Features.Core import Distribution.Server.Features.Users @@ -89,20 +90,6 @@ initDownloadFeature serverEnv@ServerEnv{serverStateDir} = do registerHook (packageDownloadHook core) (writeChan downChan) return feature -inMemStateComponent :: FilePath -> IO (StateComponent AcidState InMemStats) -inMemStateComponent stateDir = do - initSt <- initInMemStats <$> getToday - st <- openLocalStateFrom (dcPath stateDir "inmem") initSt - return StateComponent { - stateDesc = "Today's download counts" - , stateHandle = st - , getState = query st GetInMemStats - , putState = update st . ReplaceInMemStats - , backupState = \_ -> inMemBackup - , restoreState = inMemRestore - , resetState = inMemStateComponent - } - onDiskStateComponent :: FilePath -> StateComponent OnDiskState OnDiskStats onDiskStateComponent stateDir = StateComponent { stateDesc = "All time download counts" diff --git a/src/Distribution/Server/Features/DownloadCount/Acid.hs b/src/Distribution/Server/Features/DownloadCount/Acid.hs new file mode 100644 index 000000000..2d20ef0e4 --- /dev/null +++ b/src/Distribution/Server/Features/DownloadCount/Acid.hs @@ -0,0 +1,23 @@ +module Distribution.Server.Features.DownloadCount.Acid + ( inMemStateComponent + ) where + +import Distribution.Server.Features.DownloadCount.Backup +import qualified Distribution.Server.Features.DownloadCount.State as State +import Distribution.Server.Framework + +import Data.Time.Clock (getCurrentTime, utctDay) + +inMemStateComponent :: FilePath -> IO (StateComponent AcidState State.InMemStats) +inMemStateComponent stateDir = do + initSt <- State.initInMemStats . utctDay <$> getCurrentTime + st <- openLocalStateFrom (stateDir "db" "DownloadCount" "inmem") initSt + return StateComponent { + stateDesc = "Today's download counts" + , stateHandle = st + , getState = query st State.GetInMemStats + , putState = update st . State.ReplaceInMemStats + , backupState = \_ -> inMemBackup + , restoreState = inMemRestore + , resetState = inMemStateComponent + } From 3700a1db24a668da75a77dd2ab9918afcc3cfeda Mon Sep 17 00:00:00 2001 From: Tom Ellis Date: Fri, 25 Sep 2026 16:12:15 +0100 Subject: [PATCH 48/68] (refactor) Pull out backendState --- src/Distribution/Server/Features/DownloadCount.hs | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/src/Distribution/Server/Features/DownloadCount.hs b/src/Distribution/Server/Features/DownloadCount.hs index a07587498..eb70b5c09 100644 --- a/src/Distribution/Server/Features/DownloadCount.hs +++ b/src/Distribution/Server/Features/DownloadCount.hs @@ -130,9 +130,8 @@ downloadFeature CoreFeature{} , downloadCSV ] , featurePostInit = void $ forkIO registerDownloads - , featureState = [ abstractAcidStateComponent inMemState - , abstractOnDiskStateComponent onDiskState - ] + , featureState = backendState + ++ [abstractOnDiskStateComponent onDiskState] , featureCaches = [ CacheComponent { cacheDesc = "recent package downloads cache", @@ -181,6 +180,8 @@ downloadFeature CoreFeature{} updateState inMemState $ RegisterDownload pkg + backendState = [abstractAcidStateComponent inMemState] + downloadResource = DownloadResource { topDownloads = (resourceAt "/packages/top.:format") { resourceDesc = [ (GET, "Get top downloaded packages for the last 30 days")] From ba0a194303d13a0b38823ed42cad1a23de46e516 Mon Sep 17 00:00:00 2001 From: Tom Ellis Date: Fri, 25 Sep 2026 16:14:08 +0100 Subject: [PATCH 49/68] (refactor) Introduce InMemStats abstraction layer --- hackage-server.cabal | 1 + .../Server/Features/DownloadCount.hs | 26 +++++++++--------- .../Server/Features/DownloadCount/Acid.hs | 17 +++++++++++- .../Server/Features/DownloadCount/Store.hs | 27 +++++++++++++++++++ 4 files changed, 58 insertions(+), 13 deletions(-) create mode 100644 src/Distribution/Server/Features/DownloadCount/Store.hs diff --git a/hackage-server.cabal b/hackage-server.cabal index 0747ee2e0..5e8c17b0c 100644 --- a/hackage-server.cabal +++ b/hackage-server.cabal @@ -375,6 +375,7 @@ library Distribution.Server.Features.DownloadCount Distribution.Server.Features.DownloadCount.Acid Distribution.Server.Features.DownloadCount.State + Distribution.Server.Features.DownloadCount.Store Distribution.Server.Features.DownloadCount.Backup Distribution.Server.Features.EditCabalFiles Distribution.Server.Features.Html diff --git a/src/Distribution/Server/Features/DownloadCount.hs b/src/Distribution/Server/Features/DownloadCount.hs index eb70b5c09..93dd607cb 100644 --- a/src/Distribution/Server/Features/DownloadCount.hs +++ b/src/Distribution/Server/Features/DownloadCount.hs @@ -33,7 +33,8 @@ import Distribution.Server.Framework.BackupRestore import Distribution.Server.Features.DownloadCount.State import Distribution.Server.Features.DownloadCount.Backup -import Distribution.Server.Features.DownloadCount.Acid (inMemStateComponent) +import Distribution.Server.Features.DownloadCount.Acid (acidStore) +import qualified Distribution.Server.Features.DownloadCount.Store as Store import Distribution.Server.Features.Core import Distribution.Server.Features.Users @@ -75,7 +76,7 @@ data PackageDownloads = PackageDownloads { initDownloadFeature :: ServerEnv -> IO (CoreFeature -> UserFeature -> IO DownloadFeature) initDownloadFeature serverEnv@ServerEnv{serverStateDir} = do - inMemState <- inMemStateComponent serverStateDir + inMemBackend <- acidStore serverStateDir let onDiskState = onDiskStateComponent serverStateDir (recentDownloads, totalDownloads) <- computeRecentAndTotalDownloads =<< getState onDiskState @@ -84,7 +85,7 @@ initDownloadFeature serverEnv@ServerEnv{serverStateDir} = do downChan <- newChan return $ \core users -> do - let feature = downloadFeature core users serverEnv inMemState + let feature = downloadFeature core users serverEnv inMemBackend onDiskState totalsCache recentCache downChan registerHook (packageDownloadHook core) (writeChan downChan) @@ -108,7 +109,7 @@ onDiskStateComponent stateDir = StateComponent { downloadFeature :: CoreFeature -> UserFeature -> ServerEnv - -> StateComponent AcidState InMemStats + -> Store.Backend -> StateComponent OnDiskState OnDiskStats -> MemState TotalDownloads -> MemState RecentDownloads @@ -118,19 +119,21 @@ downloadFeature :: CoreFeature downloadFeature CoreFeature{} UserFeature{..} ServerEnv{serverStateDir} - inMemState + inMemBackend onDiskState totalDownloadsCache recentDownloadsCache downloadStream = DownloadFeature{..} where + inMemStore = Store.backendStore inMemBackend + downloadFeatureInterface = (emptyHackageFeature "download") { featureResources = [ topDownloads downloadResource , downloadCSV ] , featurePostInit = void $ forkIO registerDownloads - , featureState = backendState + , featureState = Store.backendState inMemBackend ++ [abstractOnDiskStateComponent onDiskState] , featureCaches = [ CacheComponent { @@ -153,15 +156,15 @@ downloadFeature CoreFeature{} registerDownloads = forever $ do pkg <- readChan downloadStream today <- getToday - today' <- query (stateHandle inMemState) RecordedToday + today' <- Store.recordedToday inMemStore --TODO: do this asyncronously rather than blocking this request when (today /= today') $ do -- For the first download each day we reset the in-memory stats and.. - inMemStats <- getState inMemState - putState inMemState $ initInMemStats today + inMemStats <- Store.getInMemStats inMemStore + Store.replaceInMemStats inMemStore $ initInMemStats today -- we can discard the large eventlog by writing a small checkpoint - createCheckpoint (stateHandle inMemState) + Store.checkpointInMemStats inMemStore -- Write yesterday's downloads to the log appendToLog (dcPath serverStateDir) inMemStats @@ -177,10 +180,9 @@ downloadFeature CoreFeature{} writeMemState totalDownloadsCache totalDownloads - updateState inMemState $ RegisterDownload pkg + Store.registerDownload inMemStore pkg - backendState = [abstractAcidStateComponent inMemState] downloadResource = DownloadResource { topDownloads = (resourceAt "/packages/top.:format") diff --git a/src/Distribution/Server/Features/DownloadCount/Acid.hs b/src/Distribution/Server/Features/DownloadCount/Acid.hs index 2d20ef0e4..b300b86db 100644 --- a/src/Distribution/Server/Features/DownloadCount/Acid.hs +++ b/src/Distribution/Server/Features/DownloadCount/Acid.hs @@ -1,13 +1,28 @@ module Distribution.Server.Features.DownloadCount.Acid - ( inMemStateComponent + ( acidStore ) where import Distribution.Server.Features.DownloadCount.Backup import qualified Distribution.Server.Features.DownloadCount.State as State +import qualified Distribution.Server.Features.DownloadCount.Store as Store import Distribution.Server.Framework import Data.Time.Clock (getCurrentTime, utctDay) +acidStore :: FilePath -> IO Store.Backend +acidStore stateDir = do + inMemState <- inMemStateComponent stateDir + pure Store.Backend { + Store.backendStore = Store.Store { + Store.recordedToday = queryState inMemState State.RecordedToday + , Store.getInMemStats = queryState inMemState State.GetInMemStats + , Store.replaceInMemStats = \stats -> updateState inMemState (State.ReplaceInMemStats stats) + , Store.registerDownload = \pkgid -> updateState inMemState (State.RegisterDownload pkgid) + , Store.checkpointInMemStats = liftIO (createCheckpoint (stateHandle inMemState)) + } + , Store.backendState = [abstractAcidStateComponent inMemState] + } + inMemStateComponent :: FilePath -> IO (StateComponent AcidState State.InMemStats) inMemStateComponent stateDir = do initSt <- State.initInMemStats . utctDay <$> getCurrentTime diff --git a/src/Distribution/Server/Features/DownloadCount/Store.hs b/src/Distribution/Server/Features/DownloadCount/Store.hs new file mode 100644 index 000000000..e1cd90952 --- /dev/null +++ b/src/Distribution/Server/Features/DownloadCount/Store.hs @@ -0,0 +1,27 @@ +{-# LANGUAGE RankNTypes #-} + +module Distribution.Server.Features.DownloadCount.Store + ( Backend(..) + , Store(..) + ) where + +import qualified Distribution.Server.Features.DownloadCount.State as State +import Distribution.Server.Framework (AbstractStateComponent) + +import Distribution.Package (PackageId) + +import Control.Monad.Trans (MonadIO) +import Data.Time.Calendar (Day) + +data Backend = Backend { + backendStore :: Store + , backendState :: [AbstractStateComponent] + } + +data Store = Store { + recordedToday :: forall m. MonadIO m => m Day + , getInMemStats :: forall m. MonadIO m => m State.InMemStats + , replaceInMemStats :: forall m. MonadIO m => State.InMemStats -> m () + , registerDownload :: forall m. MonadIO m => PackageId -> m () + , checkpointInMemStats :: forall m. MonadIO m => m () + } From 629be1bb163d8f55c2ae630169e511914b403ddf Mon Sep 17 00:00:00 2001 From: Tom Ellis Date: Fri, 25 Sep 2026 16:09:15 +0100 Subject: [PATCH 50/68] (refactor) Move distrosStateComponent to Distro.Acid --- hackage-server.cabal | 1 + src/Distribution/Server/Features/Distro.hs | 51 +++++++------------ .../Server/Features/Distro/Acid.hs | 20 ++++++++ 3 files changed, 40 insertions(+), 32 deletions(-) create mode 100644 src/Distribution/Server/Features/Distro/Acid.hs diff --git a/hackage-server.cabal b/hackage-server.cabal index 5e8c17b0c..55c4a2a6b 100644 --- a/hackage-server.cabal +++ b/hackage-server.cabal @@ -364,6 +364,7 @@ library Distribution.Server.Features.PackageFeed Distribution.Server.Features.PackageList Distribution.Server.Features.Distro + Distribution.Server.Features.Distro.Acid Distribution.Server.Features.Distro.Distributions Distribution.Server.Features.Distro.Backup Distribution.Server.Features.Distro.State diff --git a/src/Distribution/Server/Features/Distro.hs b/src/Distribution/Server/Features/Distro.hs index 156714e00..4b047b423 100644 --- a/src/Distribution/Server/Features/Distro.hs +++ b/src/Distribution/Server/Features/Distro.hs @@ -11,9 +11,9 @@ import Distribution.Server.Features.Core import Distribution.Server.Features.Users import Distribution.Server.Users.Group (UserGroup(..), GroupDescription(..), nullDescription) -import qualified Distribution.Server.Features.Distro.State as Acid +import qualified Distribution.Server.Features.Distro.State as State +import Distribution.Server.Features.Distro.Acid (distrosStateComponent) import Distribution.Server.Features.Distro.Types -import Distribution.Server.Features.Distro.Backup (dumpBackup, restoreBackup) import Distribution.Server.Util.Parse (unpackUTF8) import Distribution.Text (display, simpleParse) @@ -55,14 +55,14 @@ initDistroFeature ServerEnv{serverStateDir} = do maintainersUserGroup name = UserGroup { groupDesc = maintainerGroupDescription name, - queryUserGroup = queryState distrosState $ Acid.GetDistroMaintainers name, - addUserToGroup = updateState distrosState . Acid.AddDistroMaintainer name, - removeUserFromGroup = updateState distrosState . Acid.RemoveDistroMaintainer name, + queryUserGroup = queryState distrosState $ State.GetDistroMaintainers name, + addUserToGroup = updateState distrosState . State.AddDistroMaintainer name, + removeUserFromGroup = updateState distrosState . State.RemoveDistroMaintainer name, groupsAllowedToAdd = [adminGroup], groupsAllowedToDelete = [adminGroup] } feature = distroFeature user core distrosState maintainersGroupResource maintainersUserGroup - distroNames <- queryState distrosState Acid.EnumerateDistros + distroNames <- queryState distrosState State.EnumerateDistros (_maintainersGroup, maintainersGroupResource) <- groupResourcesAt "/distro/:package/maintainers" maintainersUserGroup @@ -72,22 +72,9 @@ initDistroFeature ServerEnv{serverStateDir} = do return feature -distrosStateComponent :: FilePath -> IO (StateComponent AcidState Acid.Distros) -distrosStateComponent stateDir = do - st <- openLocalStateFrom (stateDir "db" "Distros") Acid.initialDistros - return StateComponent { - stateDesc = "" - , stateHandle = st - , getState = query st Acid.GetDistributions - , putState = \(Acid.Distros dists versions) -> update st (Acid.ReplaceDistributions dists versions) - , backupState = \_ -> dumpBackup - , restoreState = restoreBackup - , resetState = distrosStateComponent - } - distroFeature :: UserFeature -> CoreFeature - -> StateComponent AcidState Acid.Distros + -> StateComponent AcidState State.Distros -> GroupResource -> (DistroName -> UserGroup) -> DistroFeature @@ -112,7 +99,7 @@ distroFeature UserFeature{..} } queryPackageStatus :: MonadIO m => PackageName -> m [(DistroName, DistroPackageInfo)] - queryPackageStatus pkgname = queryState distrosState (Acid.PackageStatus pkgname) + queryPackageStatus pkgname = queryState distrosState (State.PackageStatus pkgname) distroResource = DistroResource { distroIndexPage = (resourceAt "/distros/.:format") { @@ -135,7 +122,7 @@ distroFeature UserFeature{..} } } - textEnumDistros _ = fmap (toResponse . intercalate ", " . map display) (queryState distrosState Acid.EnumerateDistros) + textEnumDistros _ = fmap (toResponse . intercalate ", " . map display) (queryState distrosState State.EnumerateDistros) textDistroPkgs dpath = withDistroPath dpath $ \dname pkgs -> do let pkglines = map (\(name, info) -> display name ++ " at " ++ display (distroVersion info) ++ ": " ++ distroUrl info) pkgs return $ toResponse (unlines $ ("Packages for " ++ display dname):pkglines) @@ -148,7 +135,7 @@ distroFeature UserFeature{..} withDistroNamePath dpath $ \distro -> do guardAuthorised_ [InGroup adminGroup] -- should also check for existence here of distro here - void $ updateState distrosState $ Acid.RemoveDistro distro + void $ updateState distrosState $ State.RemoveDistro distro seeOther "/distros/" (toResponse ()) -- result: ok response or not-found error @@ -158,21 +145,21 @@ distroFeature UserFeature{..} case info of Nothing -> notFound . toResponse $ "Package not found for " ++ display pkgname Just {} -> do - void $ updateState distrosState $ Acid.DropPackage dname pkgname + void $ updateState distrosState $ State.DropPackage dname pkgname ok $ toResponse "Ok!" -- result: see-other response, or an error: not authenticated or not found (todo) distroPackagePut dpath = withDistroPackagePath dpath $ \dname pkgname _ -> lookPackageInfo $ \newPkgInfo -> do guardAuthorised_ [InGroup $ distroGroup dname] - void $ updateState distrosState $ Acid.AddPackage dname pkgname newPkgInfo + void $ updateState distrosState $ State.AddPackage dname pkgname newPkgInfo seeOther ("/distro/" ++ display dname ++ "/" ++ display pkgname) $ toResponse "Ok!" -- result: see-other response, or an error: not authentcated or bad request distroPostNew _ = lookDistroName $ \dname -> do guardAuthorised_ [InGroup adminGroup] - success <- updateState distrosState $ Acid.AddDistro dname + success <- updateState distrosState $ State.AddDistro dname if success then seeOther ("/distro/" ++ display dname) $ toResponse "Ok!" else badRequest $ toResponse "Selected distribution name is already in use" @@ -180,7 +167,7 @@ distroFeature UserFeature{..} distroPutNew dpath = withDistroNamePath dpath $ \dname -> do guardAuthorised_ [InGroup adminGroup] - _success <- updateState distrosState $ Acid.AddDistro dname + _success <- updateState distrosState $ State.AddDistro dname -- it doesn't matter if it exists already or not ok $ toResponse "Ok!" @@ -194,7 +181,7 @@ distroFeature UserFeature{..} badRequest $ toResponse $ "Could not parse CSV File to a distro package list: " ++ msg Right list -> do - void $ updateState distrosState $ Acid.PutDistroPackageList dname list + void $ updateState distrosState $ State.PutDistroPackageList dname list ok $ toResponse "Ok!" withDistroNamePath :: DynamicPath -> (DistroName -> ServerPartE Response) -> ServerPartE Response @@ -202,11 +189,11 @@ distroFeature UserFeature{..} withDistroPath :: DynamicPath -> (DistroName -> [(PackageName, DistroPackageInfo)] -> ServerPartE Response) -> ServerPartE Response withDistroPath dpath func = withDistroNamePath dpath $ \dname -> do - isDist <- queryState distrosState (Acid.IsDistribution dname) + isDist <- queryState distrosState (State.IsDistribution dname) case isDist of False -> notFound $ toResponse "Distribution does not exist" True -> do - pkgs <- queryState distrosState (Acid.DistroStatus dname) + pkgs <- queryState distrosState (State.DistroStatus dname) func dname pkgs -- guards on the distro existing, but not the package @@ -214,11 +201,11 @@ distroFeature UserFeature{..} withDistroPackagePath dpath func = withDistroNamePath dpath $ \dname -> do pkgname <- packageInPath dpath - isDist <- queryState distrosState (Acid.IsDistribution dname) + isDist <- queryState distrosState (State.IsDistribution dname) case isDist of False -> notFound $ toResponse "Distribution does not exist" True -> do - pkgInfo <- queryState distrosState (Acid.DistroPackageStatus dname pkgname) + pkgInfo <- queryState distrosState (State.DistroPackageStatus dname pkgname) func dname pkgname pkgInfo lookPackageInfo :: (DistroPackageInfo -> ServerPartE Response) -> ServerPartE Response diff --git a/src/Distribution/Server/Features/Distro/Acid.hs b/src/Distribution/Server/Features/Distro/Acid.hs new file mode 100644 index 000000000..e8eabf6ee --- /dev/null +++ b/src/Distribution/Server/Features/Distro/Acid.hs @@ -0,0 +1,20 @@ +module Distribution.Server.Features.Distro.Acid + ( distrosStateComponent + ) where + +import qualified Distribution.Server.Features.Distro.State as State +import Distribution.Server.Features.Distro.Backup (dumpBackup, restoreBackup) +import Distribution.Server.Framework + +distrosStateComponent :: FilePath -> IO (StateComponent AcidState State.Distros) +distrosStateComponent stateDir = do + st <- openLocalStateFrom (stateDir "db" "Distros") State.initialDistros + return StateComponent { + stateDesc = "" + , stateHandle = st + , getState = query st State.GetDistributions + , putState = \(State.Distros dists versions) -> update st (State.ReplaceDistributions dists versions) + , backupState = \_ -> dumpBackup + , restoreState = restoreBackup + , resetState = distrosStateComponent + } From c0347722ad04b98d5546fbac9fd3a436e6cdcfe6 Mon Sep 17 00:00:00 2001 From: Tom Ellis Date: Fri, 25 Sep 2026 16:16:28 +0100 Subject: [PATCH 51/68] (refactor) Introduce Distro abstraction layer --- hackage-server.cabal | 1 + src/Distribution/Server/Features/Distro.hs | 47 ++++++++++--------- .../Server/Features/Distro/Acid.hs | 25 +++++++++- .../Server/Features/Distro/Store.hs | 35 ++++++++++++++ 4 files changed, 84 insertions(+), 24 deletions(-) create mode 100644 src/Distribution/Server/Features/Distro/Store.hs diff --git a/hackage-server.cabal b/hackage-server.cabal index 55c4a2a6b..7457eb749 100644 --- a/hackage-server.cabal +++ b/hackage-server.cabal @@ -368,6 +368,7 @@ library Distribution.Server.Features.Distro.Distributions Distribution.Server.Features.Distro.Backup Distribution.Server.Features.Distro.State + Distribution.Server.Features.Distro.Store Distribution.Server.Features.Distro.Types Distribution.Server.Features.Documentation Distribution.Server.Features.Documentation.Acid diff --git a/src/Distribution/Server/Features/Distro.hs b/src/Distribution/Server/Features/Distro.hs index 4b047b423..9f7fa0eae 100644 --- a/src/Distribution/Server/Features/Distro.hs +++ b/src/Distribution/Server/Features/Distro.hs @@ -11,8 +11,8 @@ import Distribution.Server.Features.Core import Distribution.Server.Features.Users import Distribution.Server.Users.Group (UserGroup(..), GroupDescription(..), nullDescription) -import qualified Distribution.Server.Features.Distro.State as State -import Distribution.Server.Features.Distro.Acid (distrosStateComponent) +import qualified Distribution.Server.Features.Distro.Acid as Acid +import qualified Distribution.Server.Features.Distro.Store as Store import Distribution.Server.Features.Distro.Types import Distribution.Server.Util.Parse (unpackUTF8) @@ -46,7 +46,8 @@ data DistroResource = DistroResource { initDistroFeature :: ServerEnv -> IO (UserFeature -> CoreFeature -> IO DistroFeature) initDistroFeature ServerEnv{serverStateDir} = do - distrosState <- distrosStateComponent serverStateDir + distrosBackend <- Acid.acidStore serverStateDir + let distrosStore = Store.backendStore distrosBackend return $ \user@UserFeature{adminGroup, groupResourcesAt} core@CoreFeature{coreResource} -> do rec @@ -55,14 +56,14 @@ initDistroFeature ServerEnv{serverStateDir} = do maintainersUserGroup name = UserGroup { groupDesc = maintainerGroupDescription name, - queryUserGroup = queryState distrosState $ State.GetDistroMaintainers name, - addUserToGroup = updateState distrosState . State.AddDistroMaintainer name, - removeUserFromGroup = updateState distrosState . State.RemoveDistroMaintainer name, + queryUserGroup = Store.queryDistroMaintainers distrosStore name, + addUserToGroup = Store.addDistroMaintainer distrosStore name, + removeUserFromGroup = Store.removeDistroMaintainer distrosStore name, groupsAllowedToAdd = [adminGroup], groupsAllowedToDelete = [adminGroup] } - feature = distroFeature user core distrosState maintainersGroupResource maintainersUserGroup - distroNames <- queryState distrosState State.EnumerateDistros + feature = distroFeature user core distrosBackend maintainersGroupResource maintainersUserGroup + distroNames <- Store.enumerateDistros distrosStore (_maintainersGroup, maintainersGroupResource) <- groupResourcesAt "/distro/:package/maintainers" maintainersUserGroup @@ -74,13 +75,13 @@ initDistroFeature ServerEnv{serverStateDir} = do distroFeature :: UserFeature -> CoreFeature - -> StateComponent AcidState State.Distros + -> Store.Backend -> GroupResource -> (DistroName -> UserGroup) -> DistroFeature distroFeature UserFeature{..} CoreFeature{coreResource=CoreResource{packageInPath}} - distrosState + Store.Backend{backendStore = distrosStore, backendState} maintainersGroupResource distroGroup = DistroFeature{..} @@ -95,11 +96,11 @@ distroFeature UserFeature{..} , distroPackages , distroPackage ] - , featureState = [abstractAcidStateComponent distrosState] + , featureState = backendState } queryPackageStatus :: MonadIO m => PackageName -> m [(DistroName, DistroPackageInfo)] - queryPackageStatus pkgname = queryState distrosState (State.PackageStatus pkgname) + queryPackageStatus = Store.queryPackageStatus distrosStore distroResource = DistroResource { distroIndexPage = (resourceAt "/distros/.:format") { @@ -122,7 +123,7 @@ distroFeature UserFeature{..} } } - textEnumDistros _ = fmap (toResponse . intercalate ", " . map display) (queryState distrosState State.EnumerateDistros) + textEnumDistros _ = fmap (toResponse . intercalate ", " . map display) (Store.enumerateDistros distrosStore) textDistroPkgs dpath = withDistroPath dpath $ \dname pkgs -> do let pkglines = map (\(name, info) -> display name ++ " at " ++ display (distroVersion info) ++ ": " ++ distroUrl info) pkgs return $ toResponse (unlines $ ("Packages for " ++ display dname):pkglines) @@ -135,7 +136,7 @@ distroFeature UserFeature{..} withDistroNamePath dpath $ \distro -> do guardAuthorised_ [InGroup adminGroup] -- should also check for existence here of distro here - void $ updateState distrosState $ State.RemoveDistro distro + Store.removeDistro distrosStore distro seeOther "/distros/" (toResponse ()) -- result: ok response or not-found error @@ -145,21 +146,21 @@ distroFeature UserFeature{..} case info of Nothing -> notFound . toResponse $ "Package not found for " ++ display pkgname Just {} -> do - void $ updateState distrosState $ State.DropPackage dname pkgname + Store.dropDistroPackage distrosStore dname pkgname ok $ toResponse "Ok!" -- result: see-other response, or an error: not authenticated or not found (todo) distroPackagePut dpath = withDistroPackagePath dpath $ \dname pkgname _ -> lookPackageInfo $ \newPkgInfo -> do guardAuthorised_ [InGroup $ distroGroup dname] - void $ updateState distrosState $ State.AddPackage dname pkgname newPkgInfo + Store.addDistroPackage distrosStore dname pkgname newPkgInfo seeOther ("/distro/" ++ display dname ++ "/" ++ display pkgname) $ toResponse "Ok!" -- result: see-other response, or an error: not authentcated or bad request distroPostNew _ = lookDistroName $ \dname -> do guardAuthorised_ [InGroup adminGroup] - success <- updateState distrosState $ State.AddDistro dname + success <- Store.addDistro distrosStore dname if success then seeOther ("/distro/" ++ display dname) $ toResponse "Ok!" else badRequest $ toResponse "Selected distribution name is already in use" @@ -167,7 +168,7 @@ distroFeature UserFeature{..} distroPutNew dpath = withDistroNamePath dpath $ \dname -> do guardAuthorised_ [InGroup adminGroup] - _success <- updateState distrosState $ State.AddDistro dname + _success <- Store.addDistro distrosStore dname -- it doesn't matter if it exists already or not ok $ toResponse "Ok!" @@ -181,7 +182,7 @@ distroFeature UserFeature{..} badRequest $ toResponse $ "Could not parse CSV File to a distro package list: " ++ msg Right list -> do - void $ updateState distrosState $ State.PutDistroPackageList dname list + Store.putDistroPackageList distrosStore dname list ok $ toResponse "Ok!" withDistroNamePath :: DynamicPath -> (DistroName -> ServerPartE Response) -> ServerPartE Response @@ -189,11 +190,11 @@ distroFeature UserFeature{..} withDistroPath :: DynamicPath -> (DistroName -> [(PackageName, DistroPackageInfo)] -> ServerPartE Response) -> ServerPartE Response withDistroPath dpath func = withDistroNamePath dpath $ \dname -> do - isDist <- queryState distrosState (State.IsDistribution dname) + isDist <- Store.isDistribution distrosStore dname case isDist of False -> notFound $ toResponse "Distribution does not exist" True -> do - pkgs <- queryState distrosState (State.DistroStatus dname) + pkgs <- Store.queryDistroStatus distrosStore dname func dname pkgs -- guards on the distro existing, but not the package @@ -201,11 +202,11 @@ distroFeature UserFeature{..} withDistroPackagePath dpath func = withDistroNamePath dpath $ \dname -> do pkgname <- packageInPath dpath - isDist <- queryState distrosState (State.IsDistribution dname) + isDist <- Store.isDistribution distrosStore dname case isDist of False -> notFound $ toResponse "Distribution does not exist" True -> do - pkgInfo <- queryState distrosState (State.DistroPackageStatus dname pkgname) + pkgInfo <- Store.queryDistroPackageStatus distrosStore dname pkgname func dname pkgname pkgInfo lookPackageInfo :: (DistroPackageInfo -> ServerPartE Response) -> ServerPartE Response diff --git a/src/Distribution/Server/Features/Distro/Acid.hs b/src/Distribution/Server/Features/Distro/Acid.hs index e8eabf6ee..053e09bba 100644 --- a/src/Distribution/Server/Features/Distro/Acid.hs +++ b/src/Distribution/Server/Features/Distro/Acid.hs @@ -1,11 +1,34 @@ module Distribution.Server.Features.Distro.Acid - ( distrosStateComponent + ( acidStore ) where import qualified Distribution.Server.Features.Distro.State as State +import qualified Distribution.Server.Features.Distro.Store as Store import Distribution.Server.Features.Distro.Backup (dumpBackup, restoreBackup) import Distribution.Server.Framework +acidStore :: FilePath -> IO Store.Backend +acidStore stateDir = do + distrosState <- distrosStateComponent stateDir + pure Store.Backend { + Store.backendStore = Store.Store { + Store.queryDistroMaintainers = \name -> queryState distrosState (State.GetDistroMaintainers name) + , Store.addDistroMaintainer = \name uid -> updateState distrosState (State.AddDistroMaintainer name uid) + , Store.removeDistroMaintainer = \name uid -> updateState distrosState (State.RemoveDistroMaintainer name uid) + , Store.enumerateDistros = queryState distrosState State.EnumerateDistros + , Store.queryPackageStatus = \pkgname -> queryState distrosState (State.PackageStatus pkgname) + , Store.queryDistroStatus = \name -> queryState distrosState (State.DistroStatus name) + , Store.isDistribution = \name -> queryState distrosState (State.IsDistribution name) + , Store.queryDistroPackageStatus = \name pkgname -> queryState distrosState (State.DistroPackageStatus name pkgname) + , Store.removeDistro = \name -> updateState distrosState (State.RemoveDistro name) + , Store.dropDistroPackage = \name pkgname -> updateState distrosState (State.DropPackage name pkgname) + , Store.addDistroPackage = \name pkgname info -> updateState distrosState (State.AddPackage name pkgname info) + , Store.addDistro = \name -> updateState distrosState (State.AddDistro name) + , Store.putDistroPackageList = \name pkgs -> updateState distrosState (State.PutDistroPackageList name pkgs) + } + , Store.backendState = [abstractAcidStateComponent distrosState] + } + distrosStateComponent :: FilePath -> IO (StateComponent AcidState State.Distros) distrosStateComponent stateDir = do st <- openLocalStateFrom (stateDir "db" "Distros") State.initialDistros diff --git a/src/Distribution/Server/Features/Distro/Store.hs b/src/Distribution/Server/Features/Distro/Store.hs new file mode 100644 index 000000000..40f7d6960 --- /dev/null +++ b/src/Distribution/Server/Features/Distro/Store.hs @@ -0,0 +1,35 @@ +{-# LANGUAGE RankNTypes #-} + +module Distribution.Server.Features.Distro.Store + ( Backend(..) + , Store(..) + ) where + +import Distribution.Package (PackageName) +import Distribution.Server.Features.Distro.Types (DistroName, DistroPackageInfo) +import Distribution.Server.Framework (AbstractStateComponent) +import Distribution.Server.Users.Group (UserIdSet) +import Distribution.Server.Users.Types (UserId) + +import Control.Monad.Trans (MonadIO) + +data Backend = Backend { + backendStore :: Store + , backendState :: [AbstractStateComponent] + } + +data Store = Store { + queryDistroMaintainers :: forall m. MonadIO m => DistroName -> m UserIdSet + , addDistroMaintainer :: forall m. MonadIO m => DistroName -> UserId -> m () + , removeDistroMaintainer :: forall m. MonadIO m => DistroName -> UserId -> m () + , enumerateDistros :: forall m. MonadIO m => m [DistroName] + , queryPackageStatus :: forall m. MonadIO m => PackageName -> m [(DistroName, DistroPackageInfo)] + , queryDistroStatus :: forall m. MonadIO m => DistroName -> m [(PackageName, DistroPackageInfo)] + , isDistribution :: forall m. MonadIO m => DistroName -> m Bool + , queryDistroPackageStatus :: forall m. MonadIO m => DistroName -> PackageName -> m (Maybe DistroPackageInfo) + , removeDistro :: forall m. MonadIO m => DistroName -> m () + , dropDistroPackage :: forall m. MonadIO m => DistroName -> PackageName -> m () + , addDistroPackage :: forall m. MonadIO m => DistroName -> PackageName -> DistroPackageInfo -> m () + , addDistro :: forall m. MonadIO m => DistroName -> m Bool + , putDistroPackageList :: forall m. MonadIO m => DistroName -> [(PackageName, DistroPackageInfo)] -> m () + } From d0d265414442d6f4b024b5a94ec31f87c8e8f254 Mon Sep 17 00:00:00 2001 From: Tom Ellis Date: Fri, 25 Sep 2026 16:19:56 +0100 Subject: [PATCH 52/68] (refactor) Move preferredStateComponent to PreferredVersions.Acid --- hackage-server.cabal | 1 + .../Server/Features/PreferredVersions.hs | 16 +------------- .../Server/Features/PreferredVersions/Acid.hs | 21 +++++++++++++++++++ 3 files changed, 23 insertions(+), 15 deletions(-) create mode 100644 src/Distribution/Server/Features/PreferredVersions/Acid.hs diff --git a/hackage-server.cabal b/hackage-server.cabal index 7457eb749..3e1fe911b 100644 --- a/hackage-server.cabal +++ b/hackage-server.cabal @@ -413,6 +413,7 @@ library Distribution.Server.Features.Vouch.Types Distribution.Server.Features.RecentPackages Distribution.Server.Features.PreferredVersions + Distribution.Server.Features.PreferredVersions.Acid Distribution.Server.Features.PreferredVersions.State Distribution.Server.Features.PreferredVersions.Types Distribution.Server.Features.PreferredVersions.Backup diff --git a/src/Distribution/Server/Features/PreferredVersions.hs b/src/Distribution/Server/Features/PreferredVersions.hs index a66def777..c2605d1e2 100644 --- a/src/Distribution/Server/Features/PreferredVersions.hs +++ b/src/Distribution/Server/Features/PreferredVersions.hs @@ -19,8 +19,8 @@ module Distribution.Server.Features.PreferredVersions ( import Distribution.Server.Framework +import Distribution.Server.Features.PreferredVersions.Acid (preferredStateComponent) import Distribution.Server.Features.PreferredVersions.State -import Distribution.Server.Features.PreferredVersions.Backup import Distribution.Server.Features.PreferredVersions.Types import Distribution.Server.Features.Core @@ -118,20 +118,6 @@ initVersionsFeature env@ServerEnv{serverStateDir} = do updatePreferredHook return feature -preferredStateComponent :: Bool -> FilePath -> IO (StateComponent AcidState PreferredVersions) -preferredStateComponent freshDB stateDir = do - st <- openLocalStateFrom (stateDir "db" "PreferredVersions") - (initialPreferredVersions freshDB) - return StateComponent { - stateDesc = "Preferred package versions" - , stateHandle = st - , getState = query st GetPreferredVersions - , putState = update st . ReplacePreferredVersions - , resetState = preferredStateComponent True - , backupState = \_ -> backupPreferredVersions - , restoreState = restorePreferredVersions - } - versionsFeature :: ServerEnv -> CoreFeature -> UploadFeature diff --git a/src/Distribution/Server/Features/PreferredVersions/Acid.hs b/src/Distribution/Server/Features/PreferredVersions/Acid.hs new file mode 100644 index 000000000..1f19cd833 --- /dev/null +++ b/src/Distribution/Server/Features/PreferredVersions/Acid.hs @@ -0,0 +1,21 @@ +module Distribution.Server.Features.PreferredVersions.Acid + ( preferredStateComponent + ) where + +import qualified Distribution.Server.Features.PreferredVersions.State as State +import Distribution.Server.Features.PreferredVersions.Backup +import Distribution.Server.Framework + +preferredStateComponent :: Bool -> FilePath -> IO (StateComponent AcidState State.PreferredVersions) +preferredStateComponent freshDB stateDir = do + st <- openLocalStateFrom (stateDir "db" "PreferredVersions") + (State.initialPreferredVersions freshDB) + return StateComponent { + stateDesc = "Preferred package versions" + , stateHandle = st + , getState = query st State.GetPreferredVersions + , putState = update st . State.ReplacePreferredVersions + , resetState = preferredStateComponent True + , backupState = \_ -> backupPreferredVersions + , restoreState = restorePreferredVersions + } From 5490cb36e8d1cad39e64e6dd99fc6dde49c971af Mon Sep 17 00:00:00 2001 From: Tom Ellis Date: Fri, 25 Sep 2026 16:21:59 +0100 Subject: [PATCH 53/68] (refactor) Introduce PreferredVersions abstraction layer --- hackage-server.cabal | 1 + .../Server/Features/PreferredVersions.hs | 46 ++++++++++--------- .../Server/Features/PreferredVersions/Acid.hs | 17 +++++++ .../Features/PreferredVersions/Store.hs | 27 +++++++++++ 4 files changed, 69 insertions(+), 22 deletions(-) create mode 100644 src/Distribution/Server/Features/PreferredVersions/Store.hs diff --git a/hackage-server.cabal b/hackage-server.cabal index 3e1fe911b..d99506eb8 100644 --- a/hackage-server.cabal +++ b/hackage-server.cabal @@ -417,6 +417,7 @@ library Distribution.Server.Features.PreferredVersions.State Distribution.Server.Features.PreferredVersions.Types Distribution.Server.Features.PreferredVersions.Backup + Distribution.Server.Features.PreferredVersions.Store Distribution.Server.Features.ReverseDependencies Distribution.Server.Features.ReverseDependencies.State Distribution.Server.Features.Tags diff --git a/src/Distribution/Server/Features/PreferredVersions.hs b/src/Distribution/Server/Features/PreferredVersions.hs index c2605d1e2..a654aa175 100644 --- a/src/Distribution/Server/Features/PreferredVersions.hs +++ b/src/Distribution/Server/Features/PreferredVersions.hs @@ -19,7 +19,9 @@ module Distribution.Server.Features.PreferredVersions ( import Distribution.Server.Framework +import qualified Distribution.Server.Features.PreferredVersions.Acid as Acid import Distribution.Server.Features.PreferredVersions.Acid (preferredStateComponent) +import qualified Distribution.Server.Features.PreferredVersions.Store as Store import Distribution.Server.Features.PreferredVersions.State import Distribution.Server.Features.PreferredVersions.Types @@ -106,7 +108,7 @@ initVersionsFeature :: ServerEnv -> UserFeature -> IO VersionsFeature) initVersionsFeature env@ServerEnv{serverStateDir} = do - preferredState <- preferredStateComponent False serverStateDir + preferredBackend <- Acid.acidStore serverStateDir deprecatedHook <- newHook updatePreferredHook <- newHook @@ -114,7 +116,7 @@ initVersionsFeature env@ServerEnv{serverStateDir} = do let feature = versionsFeature env core upload tags user - preferredState deprecatedHook + preferredBackend deprecatedHook updatePreferredHook return feature @@ -123,7 +125,7 @@ versionsFeature :: ServerEnv -> UploadFeature -> TagsFeature -> UserFeature - -> StateComponent AcidState PreferredVersions + -> Store.Backend -> Hook (PackageName, Maybe [PackageName]) () -> Hook (PackageName, PreferredInfo) () -> VersionsFeature @@ -132,7 +134,7 @@ versionsFeature ServerEnv{ serverVerbosity = verbosity } UploadFeature{..} TagsFeature{..} UserFeature{ guardAuthorised_ } - preferredState + Store.Backend{backendStore = preferredStore, backendState} deprecatedHook updatePreferredHook = VersionsFeature{..} @@ -148,20 +150,20 @@ versionsFeature ServerEnv{ serverVerbosity = verbosity } ] , featurePostInit = do updateDeprecatedTags ephemeralPrefsMigration - , featureState = [abstractAcidStateComponent preferredState] + , featureState = backendState } queryGetPreferredInfo :: MonadIO m => PackageName -> m PreferredInfo - queryGetPreferredInfo name = queryState preferredState (GetPreferredInfo name) + queryGetPreferredInfo = Store.getPreferredInfo preferredStore queryGetDeprecatedFor :: MonadIO m => PackageName -> m (Maybe [PackageName]) - queryGetDeprecatedFor name = queryState preferredState (GetDeprecatedFor name) + queryGetDeprecatedFor = Store.getDeprecatedFor preferredStore queryGetPreferredVersions :: MonadIO m => m PreferredVersions - queryGetPreferredVersions = queryState preferredState GetPreferredVersions + queryGetPreferredVersions = Store.getPreferredVersions preferredStore updateDeprecatedTags = do - pkgs <- deprecatedMap <$> queryState preferredState GetPreferredVersions + pkgs <- deprecatedMap <$> Store.getPreferredVersions preferredStore setCalculatedTag (Tag "deprecated") (Map.keysSet pkgs) CoreResource{..} = coreResource @@ -211,7 +213,7 @@ versionsFeature ServerEnv{ serverVerbosity = verbosity } handlePackagesDeprecatedGet :: DynamicPath -> ServerPartE Response handlePackagesDeprecatedGet _ = do - deprPkgs <- deprecatedMap <$> queryState preferredState GetPreferredVersions + deprPkgs <- deprecatedMap <$> Store.getPreferredVersions preferredStore return $ toResponse $ array [ object [ ("deprecated-package", string $ display deprPkg) @@ -224,7 +226,7 @@ versionsFeature ServerEnv{ serverVerbosity = verbosity } handlePackageDeprecatedGet dpath = do pkgname <- packageInPath dpath guardValidPackageName pkgname - mdep <- queryState preferredState (GetDeprecatedFor pkgname) + mdep <- Store.getDeprecatedFor preferredStore pkgname return $ toResponse $ object [ ("is-deprecated", Bool (isJust mdep)) @@ -263,7 +265,7 @@ versionsFeature ServerEnv{ serverVerbosity = verbosity } updatePackageDeprecation :: MonadIO m => PackageName -> Maybe [PackageName] -> m () updatePackageDeprecation pkgname deprs = liftIO $ do - updateState preferredState $ SetDeprecatedFor pkgname deprs + Store.setDeprecatedFor preferredStore pkgname deprs runHook_ deprecatedHook (pkgname, deprs) updateDeprecatedTags @@ -287,7 +289,7 @@ versionsFeature ServerEnv{ serverVerbosity = verbosity } pkgIndex <- queryGetPackageIndex case PackageIndex.lookupPackageName pkgIndex (packageName pkgid) of [] -> packageError [MText "No such package in package index. ", MLink "Search for related terms instead?" $ "/packages/search?terms=" ++ (display $ pkgName pkgid)] - pkgs | pkgVersion pkgid == nullVersion -> queryState preferredState (GetPreferredInfo $ packageName pkgid) >>= \info -> do + pkgs | pkgVersion pkgid == nullVersion -> Store.getPreferredInfo preferredStore (packageName pkgid) >>= \info -> do let rangeToCheck = sumRange info case maybe id (\r -> filter (flip withinRange r . packageVersion)) rangeToCheck pkgs of -- no preferred version available, choose latest from list ordered by version @@ -310,7 +312,7 @@ versionsFeature ServerEnv{ serverVerbosity = verbosity } guardAuthorisedAsMaintainerOrTrustee pkgname (prefs, deprs) <- lookPrefRangeDeprecatedVersions pkgs - prefinfo <- updateState preferredState (SetPreferredInfo pkgname prefs deprs) + prefinfo <- Store.setPreferredInfo preferredStore pkgname prefs deprs runHook_ updatePreferredHook (pkgname, prefinfo { deprecatedVersions = deprs }) -- It seems they are not set updateIndexPackagePreferredVersions pkgname prefinfo where @@ -364,7 +366,7 @@ versionsFeature ServerEnv{ serverVerbosity = verbosity } where deprecatedError = errBadRequest "Deprecation failed" . return . MText doUpdates deprs = do - void $ updateState preferredState $ SetDeprecatedFor pkgname deprs + Store.setDeprecatedFor preferredStore pkgname deprs runHook_ deprecatedHook (pkgname, deprs) liftIO updateDeprecatedTags @@ -378,25 +380,25 @@ versionsFeature ServerEnv{ serverVerbosity = verbosity } doPreferredRender :: PackageName -> ServerPartE PreferredRender doPreferredRender pkgname = do guardValidPackageName pkgname - pref <- queryState preferredState $ GetPreferredInfo pkgname + pref <- Store.getPreferredInfo preferredStore pkgname return $ renderPrefInfo pref doDeprecatedRender :: PackageName -> ServerPartE (Maybe [PackageName]) doDeprecatedRender pkgname = do guardValidPackageName pkgname - queryState preferredState $ GetDeprecatedFor pkgname + Store.getDeprecatedFor preferredStore pkgname doPreferredsRender :: MonadIO m => m [(PackageName, PreferredRender)] - doPreferredsRender = queryState preferredState GetPreferredVersions >>= + doPreferredsRender = Store.getPreferredVersions preferredStore >>= return . map (second renderPrefInfo) . Map.toList . preferredMap doDeprecatedsRender :: MonadIO m => m [(PackageName, [PackageName])] - doDeprecatedsRender = queryState preferredState GetPreferredVersions >>= + doDeprecatedsRender = Store.getPreferredVersions preferredStore >>= return . Map.toList . deprecatedMap makeGlobalPreferredVersions :: (Functor m, MonadIO m) => m String makeGlobalPreferredVersions = do - prefs <- preferredMap <$> queryState preferredState GetPreferredVersions + prefs <- preferredMap <$> Store.getPreferredVersions preferredStore return $! formatGlobalPreferredVersions (Map.toList prefs) formatSinglePreferredVersions :: PackageName -> PreferredInfo -> Maybe String @@ -423,13 +425,13 @@ versionsFeature ServerEnv{ serverVerbosity = verbosity } -- One-off complex migration ephemeralPrefsMigration = do PreferredVersions {migratedEphemeralPrefs, preferredMap} - <- queryState preferredState GetPreferredVersions + <- Store.getPreferredVersions preferredStore unless migratedEphemeralPrefs $ logTiming verbosity "preferred-versions migration" $ do sequence_ [ updateIndexPackagePreferredVersions pkgname prefinfo | (pkgname, prefinfo) <- Map.toList preferredMap ] - updateState preferredState SetMigratedEphemeralPrefs + Store.setMigratedEphemeralPrefs preferredStore {------------------------------------------------------------------------------ Some aeson auxiliary functions diff --git a/src/Distribution/Server/Features/PreferredVersions/Acid.hs b/src/Distribution/Server/Features/PreferredVersions/Acid.hs index 1f19cd833..a96406242 100644 --- a/src/Distribution/Server/Features/PreferredVersions/Acid.hs +++ b/src/Distribution/Server/Features/PreferredVersions/Acid.hs @@ -1,11 +1,28 @@ module Distribution.Server.Features.PreferredVersions.Acid ( preferredStateComponent + , acidStore ) where import qualified Distribution.Server.Features.PreferredVersions.State as State import Distribution.Server.Features.PreferredVersions.Backup +import qualified Distribution.Server.Features.PreferredVersions.Store as Store import Distribution.Server.Framework +acidStore :: FilePath -> IO Store.Backend +acidStore stateDir = do + preferredState <- preferredStateComponent False stateDir + pure Store.Backend { + Store.backendStore = Store.Store { + Store.getPreferredInfo = \name -> queryState preferredState (State.GetPreferredInfo name) + , Store.getDeprecatedFor = \name -> queryState preferredState (State.GetDeprecatedFor name) + , Store.getPreferredVersions = queryState preferredState State.GetPreferredVersions + , Store.setDeprecatedFor = \name deprs -> updateState preferredState (State.SetDeprecatedFor name deprs) + , Store.setPreferredInfo = \name ranges versions -> updateState preferredState (State.SetPreferredInfo name ranges versions) + , Store.setMigratedEphemeralPrefs = updateState preferredState State.SetMigratedEphemeralPrefs + } + , Store.backendState = [abstractAcidStateComponent preferredState] + } + preferredStateComponent :: Bool -> FilePath -> IO (StateComponent AcidState State.PreferredVersions) preferredStateComponent freshDB stateDir = do st <- openLocalStateFrom (stateDir "db" "PreferredVersions") diff --git a/src/Distribution/Server/Features/PreferredVersions/Store.hs b/src/Distribution/Server/Features/PreferredVersions/Store.hs new file mode 100644 index 000000000..e49450f60 --- /dev/null +++ b/src/Distribution/Server/Features/PreferredVersions/Store.hs @@ -0,0 +1,27 @@ +{-# LANGUAGE RankNTypes #-} + +module Distribution.Server.Features.PreferredVersions.Store + ( Backend(..) + , Store(..) + ) where + +import Distribution.Package (PackageName) +import Distribution.Server.Features.PreferredVersions.State (PreferredInfo, PreferredVersions) +import Distribution.Server.Framework (AbstractStateComponent) +import Distribution.Version (Version, VersionRange) + +import Control.Monad.Trans (MonadIO) + +data Backend = Backend { + backendStore :: Store + , backendState :: [AbstractStateComponent] + } + +data Store = Store { + getPreferredInfo :: forall m. MonadIO m => PackageName -> m PreferredInfo + , getDeprecatedFor :: forall m. MonadIO m => PackageName -> m (Maybe [PackageName]) + , getPreferredVersions :: forall m. MonadIO m => m PreferredVersions + , setDeprecatedFor :: forall m. MonadIO m => PackageName -> Maybe [PackageName] -> m () + , setPreferredInfo :: forall m. MonadIO m => PackageName -> [VersionRange] -> [Version] -> m PreferredInfo + , setMigratedEphemeralPrefs :: forall m. MonadIO m => m () + } From 60e625c15885cbb6ce3919a53c5ec8d9c5845f13 Mon Sep 17 00:00:00 2001 From: Tom Ellis Date: Fri, 25 Sep 2026 16:25:31 +0100 Subject: [PATCH 54/68] (refactor) Move tag state components to Tags.Acid --- hackage-server.cabal | 1 + src/Distribution/Server/Features/Tags.hs | 103 +++++++----------- src/Distribution/Server/Features/Tags/Acid.hs | 35 ++++++ 3 files changed, 74 insertions(+), 65 deletions(-) create mode 100644 src/Distribution/Server/Features/Tags/Acid.hs diff --git a/hackage-server.cabal b/hackage-server.cabal index d99506eb8..266f907bc 100644 --- a/hackage-server.cabal +++ b/hackage-server.cabal @@ -421,6 +421,7 @@ library Distribution.Server.Features.ReverseDependencies Distribution.Server.Features.ReverseDependencies.State Distribution.Server.Features.Tags + Distribution.Server.Features.Tags.Acid Distribution.Server.Features.Tags.Backup Distribution.Server.Features.Tags.State Distribution.Server.Features.Tags.Types diff --git a/src/Distribution/Server/Features/Tags.hs b/src/Distribution/Server/Features/Tags.hs index ae51e24a4..7c0148a53 100644 --- a/src/Distribution/Server/Features/Tags.hs +++ b/src/Distribution/Server/Features/Tags.hs @@ -10,11 +10,10 @@ module Distribution.Server.Features.Tags ( ) where import Distribution.Server.Framework -import Distribution.Server.Framework.BackupDump import Distribution.Server.Features.Tags.Types -import qualified Distribution.Server.Features.Tags.State as Acid -import Distribution.Server.Features.Tags.Backup +import qualified Distribution.Server.Features.Tags.Acid as Acid +import qualified Distribution.Server.Features.Tags.State as State import Distribution.Server.Features.Core import Distribution.Server.Features.Upload import Distribution.Server.Features.Users @@ -95,9 +94,9 @@ initTagsFeature :: ServerEnv -> UserFeature -> IO TagsFeature) initTagsFeature ServerEnv{serverStateDir} = do - tagsState <- tagsStateComponent serverStateDir - tagAlias <- tagsAliasComponent serverStateDir - specials <- newMemStateWHNF Acid.emptyPackageTags + tagsState <- Acid.tagsStateComponent serverStateDir + tagAlias <- Acid.tagsAliasComponent serverStateDir + specials <- newMemStateWHNF State.emptyPackageTags updateTag <- newHook tagProposalLog <- newMemStateWHNF Map.empty @@ -110,46 +109,20 @@ initTagsFeature ServerEnv{serverStateDir} = do Just pkginfo -> do let pkgname = packageName pkgid itags = constructImmutableTags . pkgDesc $ pkginfo - curtags <- queryState tagsState $ Acid.TagsForPackage pkgname - aliases <- mapM (queryState tagAlias . Acid.GetTagAlias) (itags ++ Set.toList curtags) + curtags <- queryState tagsState $ State.TagsForPackage pkgname + aliases <- mapM (queryState tagAlias . State.GetTagAlias) (itags ++ Set.toList curtags) let newtags = Set.fromList aliases - updateState tagsState . Acid.SetPackageTags pkgname $ newtags + updateState tagsState . State.SetPackageTags pkgname $ newtags runHook_ updateTag (Set.singleton pkgname, newtags) return feature -tagsStateComponent :: FilePath -> IO (StateComponent AcidState Acid.PackageTags) -tagsStateComponent stateDir = do - st <- openLocalStateFrom (stateDir "db" "Tags" "Existing") Acid.initialPackageTags - return StateComponent { - stateDesc = "Package tags" - , stateHandle = st - , getState = query st Acid.GetPackageTags - , putState = update st . Acid.ReplacePackageTags - , backupState = \_ pkgTags -> [csvToBackup ["tags.csv"] $ tagsToCSV pkgTags] - , restoreState = tagsBackup - , resetState = tagsStateComponent - } - -tagsAliasComponent :: FilePath -> IO (StateComponent AcidState Acid.TagAlias) -tagsAliasComponent stateDir = do - st <- openLocalStateFrom (stateDir "db" "Tags" "Alias") Acid.emptyTagAlias - return StateComponent { - stateDesc = "Tags Alias" - , stateHandle = st - , getState = query st Acid.GetTagAliasesState - , putState = update st . Acid.AddTagAliasesState - , backupState = \_ aliases -> [csvToBackup ["aliases.csv"] $ aliasToCSV aliases] - , restoreState = aliasBackup - , resetState = tagsAliasComponent - } - tagsFeature :: CoreFeature -> UploadFeature -> UserFeature - -> StateComponent AcidState Acid.PackageTags - -> StateComponent AcidState Acid.TagAlias - -> MemState Acid.PackageTags + -> StateComponent AcidState State.PackageTags + -> StateComponent AcidState State.TagAlias + -> MemState State.PackageTags -> Hook (Set PackageName, Set Tag) () -> MemState (Map PackageName (Set Tag, Set Tag)) -> TagsFeature @@ -201,39 +174,39 @@ tagsFeature CoreFeature{ queryLatestPackages } initImmutableTags :: IO () initImmutableTags = do latestPackages <- queryLatestPackages - let calcTags = Acid.tagPackages $ constructImmutableTagIndex latestPackages - aliases <- mapM (queryState tagsAlias . Acid.GetTagAlias) $ Map.keys calcTags + let calcTags = State.tagPackages $ constructImmutableTagIndex latestPackages + aliases <- mapM (queryState tagsAlias . State.GetTagAlias) $ Map.keys calcTags let calcTags' = Map.toList . Map.fromListWith Set.union $ zip aliases (Map.elems calcTags) forM_ calcTags' $ uncurry setCalculatedTag queryGetTagList :: MonadIO m => m [(Tag, Set PackageName)] - queryGetTagList = queryState tagsState Acid.GetTagList + queryGetTagList = queryState tagsState State.GetTagList queryTagsForPackage :: MonadIO m => PackageName -> m (Set Tag) - queryTagsForPackage pkgname = queryState tagsState (Acid.TagsForPackage pkgname) + queryTagsForPackage pkgname = queryState tagsState (State.TagsForPackage pkgname) queryAliasForTag :: MonadIO m => Tag -> m Tag - queryAliasForTag tag = queryState tagsAlias (Acid.GetTagAlias tag) + queryAliasForTag tag = queryState tagsAlias (State.GetTagAlias tag) queryReviewTagsForPackage :: MonadIO m => PackageName -> m (Set Tag,Set Tag) - queryReviewTagsForPackage pkgname = queryState tagsState (Acid.LookupReviewTags pkgname) + queryReviewTagsForPackage pkgname = queryState tagsState (State.LookupReviewTags pkgname) setCalculatedTag :: Tag -> Set PackageName -> IO () setCalculatedTag tag pkgs = do - modifyMemState calculatedTags (Acid.setTag tag pkgs) - void $ updateState tagsState $ Acid.SetTagPackages tag pkgs + modifyMemState calculatedTags (State.setTag tag pkgs) + void $ updateState tagsState $ State.SetTagPackages tag pkgs runHook_ tagsUpdated (pkgs, Set.singleton tag) withTagPath :: DynamicPath -> (Tag -> Set PackageName -> ServerPartE a) -> ServerPartE a withTagPath dpath func = case simpleParse =<< lookup "tag" dpath of Nothing -> mzero Just tag -> do - pkgs <- queryState tagsState $ Acid.PackagesForTag tag + pkgs <- queryState tagsState $ State.PackagesForTag tag func tag pkgs collectTags :: MonadIO m => Set PackageName -> m (Map PackageName (Set Tag)) collectTags pkgs = do - pkgMap <- liftM Acid.packageTags $ queryState tagsState Acid.GetPackageTags + pkgMap <- liftM State.packageTags $ queryState tagsState State.GetPackageTags return $ Map.fromDistinctAscList . map (\pkg -> (pkg, Map.findWithDefault Set.empty pkg pkgMap)) $ Set.toList pkgs mergeTags :: Maybe String -> Tag -> ServerPartE () @@ -242,22 +215,22 @@ tagsFeature CoreFeature{ queryLatestPackages } Just (Tag orig) -> do latestPkgs <- queryLatestPackages let pkgNames = packageName <$> latestPkgs - void $ updateState tagsAlias $ Acid.AddTagAlias (Tag orig) deprTag + void $ updateState tagsAlias $ State.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."] -- tags on merging - constructMergedTagIndex :: forall m. (Functor m, MonadIO m) => Tag -> Tag -> [PackageName] -> m Acid.PackageTags - constructMergedTagIndex orig depr = foldM addToTags Acid.emptyPackageTags + constructMergedTagIndex :: forall m. (Functor m, MonadIO m) => Tag -> Tag -> [PackageName] -> m State.PackageTags + constructMergedTagIndex orig depr = foldM addToTags State.emptyPackageTags where addToTags calcTags pn = do pkgTags <- queryTagsForPackage pn if Set.member depr pkgTags then do let newTags = Set.delete depr (Set.insert orig pkgTags) - void $ updateState tagsState $ Acid.SetPackageTags pn newTags + void $ updateState tagsState $ State.SetPackageTags pn newTags runHook_ tagsUpdated (Set.singleton pn, newTags) - return $ Acid.setTags pn newTags calcTags - else return $ Acid.setTags pn pkgTags calcTags + return $ State.setTags pn newTags calcTags + else return $ State.setTags pn pkgTags calcTags putTags :: Maybe String -> Maybe String -> Maybe String -> Maybe String -> PackageName -> ServerPartE () putTags addns delns raddns rdelns pkgname = @@ -270,7 +243,7 @@ tagsFeature CoreFeature{ queryLatestPackages } if trustainer then do calcTags <- queryTagsForPackage pkgname - aliases <- mapM (queryState tagsAlias . Acid.GetTagAlias) add + aliases <- mapM (queryState tagsAlias . State.GetTagAlias) add revTags <- queryReviewTagsForPackage pkgname let tagSet = (addTags `Set.union` calcTags) `Set.difference` delTags addTags = Set.fromList aliases @@ -284,18 +257,18 @@ tagsFeature CoreFeature{ queryLatestPackages } addRev = Set.difference (fst revTags) (Set.fromList add `Set.union` Set.fromList radd') delRev = Set.difference (snd revTags) (Set.fromList del `Set.union` Set.fromList rdel') modifyTags (a, d) = (a `Set.intersection` addRev, d `Set.intersection` delRev) - updateState tagsState $ Acid.SetPackageTags pkgname tagSet - updateState tagsState $ Acid.InsertReviewTags' pkgname addRev delRev + updateState tagsState $ State.SetPackageTags pkgname tagSet + updateState tagsState $ State.InsertReviewTags' pkgname addRev delRev modifyMemState tagProposalLog (Map.adjust modifyTags pkgname) runHook_ tagsUpdated (Set.singleton pkgname, tagSet) return () else if user then do - aliases <- mapM (queryState tagsAlias . Acid.GetTagAlias) add + aliases <- mapM (queryState tagsAlias . State.GetTagAlias) add calcTags <- queryTagsForPackage pkgname let addTags = Set.fromList aliases `Set.difference` calcTags delTags = Set.fromList del `Set.intersection` calcTags - updateState tagsState $ Acid.InsertReviewTags pkgname addTags delTags + updateState tagsState $ State.InsertReviewTags pkgname addTags delTags modifyMemState tagProposalLog (Map.insertWith (<>) pkgname (addTags, delTags)) return () else errBadRequest "Authorization Error" [MText "You need to be logged in to propose tags"] @@ -303,23 +276,23 @@ tagsFeature CoreFeature{ queryLatestPackages } Nothing -> errBadRequest "Tags not recognized" [MText "Couldn't parse your tag list. It should be comma separated with any number of alphanumerical tags. Tags can also also have -+#*."] -- initial tags, on import -constructTagIndex :: PackageIndex PkgInfo -> Acid.PackageTags -constructTagIndex = foldl' addToTags Acid.emptyPackageTags . PackageIndex.allPackagesByName +constructTagIndex :: PackageIndex PkgInfo -> State.PackageTags +constructTagIndex = foldl' addToTags State.emptyPackageTags . PackageIndex.allPackagesByName where addToTags pkgTags pkgList = let info = pkgDesc $ last pkgList pkgname = packageName info categoryTags = Set.fromList . constructCategoryTags . packageDescription $ info immutableTags = Set.fromList . constructImmutableTags $ info - in Acid.setTags pkgname (Set.union categoryTags immutableTags) pkgTags + in State.setTags pkgname (Set.union categoryTags immutableTags) pkgTags -- tags on startup -constructImmutableTagIndex :: [PkgInfo] -> Acid.PackageTags -constructImmutableTagIndex = foldl' addToTags Acid.emptyPackageTags +constructImmutableTagIndex :: [PkgInfo] -> State.PackageTags +constructImmutableTagIndex = foldl' addToTags State.emptyPackageTags where addToTags calcTags pkg = let info = pkgDesc pkg !pn = packageName info !tags = constructImmutableTags info - in Acid.setTags pn (Set.fromList tags) calcTags + in State.setTags pn (Set.fromList tags) calcTags -- These are constructed when a package is uploaded/on startup constructCategoryTags :: PackageDescription -> [Tag] diff --git a/src/Distribution/Server/Features/Tags/Acid.hs b/src/Distribution/Server/Features/Tags/Acid.hs new file mode 100644 index 000000000..77028ea57 --- /dev/null +++ b/src/Distribution/Server/Features/Tags/Acid.hs @@ -0,0 +1,35 @@ +module Distribution.Server.Features.Tags.Acid + ( tagsStateComponent + , tagsAliasComponent + ) where + +import qualified Distribution.Server.Features.Tags.State as State +import Distribution.Server.Features.Tags.Backup +import Distribution.Server.Framework +import Distribution.Server.Framework.BackupDump + +tagsStateComponent :: FilePath -> IO (StateComponent AcidState State.PackageTags) +tagsStateComponent stateDir = do + st <- openLocalStateFrom (stateDir "db" "Tags" "Existing") State.initialPackageTags + return StateComponent { + stateDesc = "Package tags" + , stateHandle = st + , getState = query st State.GetPackageTags + , putState = update st . State.ReplacePackageTags + , backupState = \_ pkgTags -> [csvToBackup ["tags.csv"] $ tagsToCSV pkgTags] + , restoreState = tagsBackup + , resetState = tagsStateComponent + } + +tagsAliasComponent :: FilePath -> IO (StateComponent AcidState State.TagAlias) +tagsAliasComponent stateDir = do + st <- openLocalStateFrom (stateDir "db" "Tags" "Alias") State.emptyTagAlias + return StateComponent { + stateDesc = "Tags Alias" + , stateHandle = st + , getState = query st State.GetTagAliasesState + , putState = update st . State.AddTagAliasesState + , backupState = \_ aliases -> [csvToBackup ["aliases.csv"] $ aliasToCSV aliases] + , restoreState = aliasBackup + , resetState = tagsAliasComponent + } From 66b418dd0e5b5bbf50caf171450978d008ea2e71 Mon Sep 17 00:00:00 2001 From: Tom Ellis Date: Fri, 25 Sep 2026 16:27:51 +0100 Subject: [PATCH 55/68] (refactor) Introduce Tags abstraction layer --- hackage-server.cabal | 1 + src/Distribution/Server/Features/Tags.hs | 51 +++++++++---------- src/Distribution/Server/Features/Tags/Acid.hs | 25 +++++++++ .../Server/Features/Tags/State.hs | 4 +- .../Server/Features/Tags/Store.hs | 33 ++++++++++++ 5 files changed, 87 insertions(+), 27 deletions(-) create mode 100644 src/Distribution/Server/Features/Tags/Store.hs diff --git a/hackage-server.cabal b/hackage-server.cabal index 266f907bc..4c7ff70f1 100644 --- a/hackage-server.cabal +++ b/hackage-server.cabal @@ -423,6 +423,7 @@ library Distribution.Server.Features.Tags Distribution.Server.Features.Tags.Acid Distribution.Server.Features.Tags.Backup + Distribution.Server.Features.Tags.Store Distribution.Server.Features.Tags.State Distribution.Server.Features.Tags.Types Distribution.Server.Features.AnalyticsPixels diff --git a/src/Distribution/Server/Features/Tags.hs b/src/Distribution/Server/Features/Tags.hs index 7c0148a53..b9a6fa112 100644 --- a/src/Distribution/Server/Features/Tags.hs +++ b/src/Distribution/Server/Features/Tags.hs @@ -13,6 +13,7 @@ import Distribution.Server.Framework import Distribution.Server.Features.Tags.Types import qualified Distribution.Server.Features.Tags.Acid as Acid +import qualified Distribution.Server.Features.Tags.Store as Store import qualified Distribution.Server.Features.Tags.State as State import Distribution.Server.Features.Core import Distribution.Server.Features.Upload @@ -94,14 +95,14 @@ initTagsFeature :: ServerEnv -> UserFeature -> IO TagsFeature) initTagsFeature ServerEnv{serverStateDir} = do - tagsState <- Acid.tagsStateComponent serverStateDir - tagAlias <- Acid.tagsAliasComponent serverStateDir + tagsBackend <- Acid.acidStore serverStateDir + let tagsStore = Store.backendStore tagsBackend specials <- newMemStateWHNF State.emptyPackageTags updateTag <- newHook tagProposalLog <- newMemStateWHNF Map.empty return $ \core@CoreFeature{..} upload user -> do - let feature = tagsFeature core upload user tagsState tagAlias specials updateTag tagProposalLog + let feature = tagsFeature core upload user tagsBackend specials updateTag tagProposalLog registerHookJust packageChangeHook isPackageChangeAny $ \(pkgid, mpkginfo) -> case mpkginfo of @@ -109,10 +110,10 @@ initTagsFeature ServerEnv{serverStateDir} = do Just pkginfo -> do let pkgname = packageName pkgid itags = constructImmutableTags . pkgDesc $ pkginfo - curtags <- queryState tagsState $ State.TagsForPackage pkgname - aliases <- mapM (queryState tagAlias . State.GetTagAlias) (itags ++ Set.toList curtags) + curtags <- Store.getTagsForPackage tagsStore pkgname + aliases <- mapM (Store.getTagAlias tagsStore) (itags ++ Set.toList curtags) let newtags = Set.fromList aliases - updateState tagsState . State.SetPackageTags pkgname $ newtags + Store.setPackageTags tagsStore pkgname newtags runHook_ updateTag (Set.singleton pkgname, newtags) return feature @@ -120,8 +121,7 @@ initTagsFeature ServerEnv{serverStateDir} = do tagsFeature :: CoreFeature -> UploadFeature -> UserFeature - -> StateComponent AcidState State.PackageTags - -> StateComponent AcidState State.TagAlias + -> Store.Backend -> MemState State.PackageTags -> Hook (Set PackageName, Set Tag) () -> MemState (Map PackageName (Set Tag, Set Tag)) @@ -130,8 +130,7 @@ tagsFeature :: CoreFeature tagsFeature CoreFeature{ queryLatestPackages } UploadFeature{ maintainersGroup, trusteesGroup } UserFeature{ guardAuthorised' } - tagsState - tagsAlias + Store.Backend{backendStore = tagsStore, backendState} calculatedTags tagsUpdated tagProposalLog @@ -162,7 +161,7 @@ tagsFeature CoreFeature{ queryLatestPackages } , packageTagsListing ] , featurePostInit = initImmutableTags - , featureState = [abstractAcidStateComponent tagsState] + , featureState = backendState , featureCaches = [ CacheComponent { cacheDesc = "calculated tags", @@ -175,38 +174,38 @@ tagsFeature CoreFeature{ queryLatestPackages } initImmutableTags = do latestPackages <- queryLatestPackages let calcTags = State.tagPackages $ constructImmutableTagIndex latestPackages - aliases <- mapM (queryState tagsAlias . State.GetTagAlias) $ Map.keys calcTags + aliases <- mapM (Store.getTagAlias tagsStore) $ Map.keys calcTags let calcTags' = Map.toList . Map.fromListWith Set.union $ zip aliases (Map.elems calcTags) forM_ calcTags' $ uncurry setCalculatedTag queryGetTagList :: MonadIO m => m [(Tag, Set PackageName)] - queryGetTagList = queryState tagsState State.GetTagList + queryGetTagList = Store.getTagList tagsStore queryTagsForPackage :: MonadIO m => PackageName -> m (Set Tag) - queryTagsForPackage pkgname = queryState tagsState (State.TagsForPackage pkgname) + queryTagsForPackage = Store.getTagsForPackage tagsStore queryAliasForTag :: MonadIO m => Tag -> m Tag - queryAliasForTag tag = queryState tagsAlias (State.GetTagAlias tag) + queryAliasForTag = Store.getTagAlias tagsStore queryReviewTagsForPackage :: MonadIO m => PackageName -> m (Set Tag,Set Tag) - queryReviewTagsForPackage pkgname = queryState tagsState (State.LookupReviewTags pkgname) + queryReviewTagsForPackage = Store.getReviewTagsForPackage tagsStore setCalculatedTag :: Tag -> Set PackageName -> IO () setCalculatedTag tag pkgs = do modifyMemState calculatedTags (State.setTag tag pkgs) - void $ updateState tagsState $ State.SetTagPackages tag pkgs + Store.setTagPackages tagsStore tag pkgs runHook_ tagsUpdated (pkgs, Set.singleton tag) withTagPath :: DynamicPath -> (Tag -> Set PackageName -> ServerPartE a) -> ServerPartE a withTagPath dpath func = case simpleParse =<< lookup "tag" dpath of Nothing -> mzero Just tag -> do - pkgs <- queryState tagsState $ State.PackagesForTag tag + pkgs <- Store.getPackagesForTag tagsStore tag func tag pkgs collectTags :: MonadIO m => Set PackageName -> m (Map PackageName (Set Tag)) collectTags pkgs = do - pkgMap <- liftM State.packageTags $ queryState tagsState State.GetPackageTags + pkgMap <- liftM State.packageTags $ Store.getPackageTags tagsStore return $ Map.fromDistinctAscList . map (\pkg -> (pkg, Map.findWithDefault Set.empty pkg pkgMap)) $ Set.toList pkgs mergeTags :: Maybe String -> Tag -> ServerPartE () @@ -215,7 +214,7 @@ tagsFeature CoreFeature{ queryLatestPackages } Just (Tag orig) -> do latestPkgs <- queryLatestPackages let pkgNames = packageName <$> latestPkgs - void $ updateState tagsAlias $ State.AddTagAlias (Tag orig) deprTag + Store.addTagAlias tagsStore (Tag orig) deprTag void $ constructMergedTagIndex (Tag orig) deprTag pkgNames _ -> errBadRequest "Tag not recognised" [MText "Couldn't parse tag. It should be a single tag."] @@ -227,7 +226,7 @@ tagsFeature CoreFeature{ queryLatestPackages } if Set.member depr pkgTags then do let newTags = Set.delete depr (Set.insert orig pkgTags) - void $ updateState tagsState $ State.SetPackageTags pn newTags + Store.setPackageTags tagsStore pn newTags runHook_ tagsUpdated (Set.singleton pn, newTags) return $ State.setTags pn newTags calcTags else return $ State.setTags pn pkgTags calcTags @@ -243,7 +242,7 @@ tagsFeature CoreFeature{ queryLatestPackages } if trustainer then do calcTags <- queryTagsForPackage pkgname - aliases <- mapM (queryState tagsAlias . State.GetTagAlias) add + aliases <- mapM (Store.getTagAlias tagsStore) add revTags <- queryReviewTagsForPackage pkgname let tagSet = (addTags `Set.union` calcTags) `Set.difference` delTags addTags = Set.fromList aliases @@ -257,18 +256,18 @@ tagsFeature CoreFeature{ queryLatestPackages } addRev = Set.difference (fst revTags) (Set.fromList add `Set.union` Set.fromList radd') delRev = Set.difference (snd revTags) (Set.fromList del `Set.union` Set.fromList rdel') modifyTags (a, d) = (a `Set.intersection` addRev, d `Set.intersection` delRev) - updateState tagsState $ State.SetPackageTags pkgname tagSet - updateState tagsState $ State.InsertReviewTags' pkgname addRev delRev + Store.setPackageTags tagsStore pkgname tagSet + Store.replaceReviewTags tagsStore pkgname addRev delRev modifyMemState tagProposalLog (Map.adjust modifyTags pkgname) runHook_ tagsUpdated (Set.singleton pkgname, tagSet) return () else if user then do - aliases <- mapM (queryState tagsAlias . State.GetTagAlias) add + aliases <- mapM (Store.getTagAlias tagsStore) add calcTags <- queryTagsForPackage pkgname let addTags = Set.fromList aliases `Set.difference` calcTags delTags = Set.fromList del `Set.intersection` calcTags - updateState tagsState $ State.InsertReviewTags pkgname addTags delTags + Store.insertReviewTags tagsStore pkgname addTags delTags modifyMemState tagProposalLog (Map.insertWith (<>) pkgname (addTags, delTags)) return () else errBadRequest "Authorization Error" [MText "You need to be logged in to propose tags"] diff --git a/src/Distribution/Server/Features/Tags/Acid.hs b/src/Distribution/Server/Features/Tags/Acid.hs index 77028ea57..14995306a 100644 --- a/src/Distribution/Server/Features/Tags/Acid.hs +++ b/src/Distribution/Server/Features/Tags/Acid.hs @@ -1,13 +1,38 @@ module Distribution.Server.Features.Tags.Acid ( tagsStateComponent , tagsAliasComponent + , acidStore ) where import qualified Distribution.Server.Features.Tags.State as State +import qualified Distribution.Server.Features.Tags.Store as Store import Distribution.Server.Features.Tags.Backup import Distribution.Server.Framework import Distribution.Server.Framework.BackupDump +acidStore :: FilePath -> IO Store.Backend +acidStore stateDir = do + tagsState <- tagsStateComponent stateDir + tagAlias <- tagsAliasComponent stateDir + pure Store.Backend { + Store.backendStore = Store.Store { + Store.getTagList = queryState tagsState State.GetTagList + , Store.getTagsForPackage = \pkgname -> queryState tagsState (State.TagsForPackage pkgname) + , Store.getReviewTagsForPackage = \pkgname -> queryState tagsState (State.LookupReviewTags pkgname) + , Store.getTagAlias = \tag -> queryState tagAlias (State.GetTagAlias tag) + , Store.getPackagesForTag = \tag -> queryState tagsState (State.PackagesForTag tag) + , Store.getPackageTags = queryState tagsState State.GetPackageTags + , Store.setPackageTags = \pkgname tags -> updateState tagsState (State.SetPackageTags pkgname tags) + , Store.setTagPackages = \tag pkgs -> updateState tagsState (State.SetTagPackages tag pkgs) + , Store.addTagAlias = \tag alias -> updateState tagAlias (State.AddTagAlias tag alias) + , Store.insertReviewTags = \pkgname add del -> updateState tagsState (State.InsertReviewTags pkgname add del) + , Store.replaceReviewTags = \pkgname add del -> updateState tagsState (State.InsertReviewTags' pkgname add del) + } + , Store.backendState = [ abstractAcidStateComponent tagsState + , abstractAcidStateComponent tagAlias + ] + } + tagsStateComponent :: FilePath -> IO (StateComponent AcidState State.PackageTags) tagsStateComponent stateDir = do st <- openLocalStateFrom (stateDir "db" "Tags" "Existing") State.initialPackageTags diff --git a/src/Distribution/Server/Features/Tags/State.hs b/src/Distribution/Server/Features/Tags/State.hs index 4f0956f8e..014bd262d 100644 --- a/src/Distribution/Server/Features/Tags/State.hs +++ b/src/Distribution/Server/Features/Tags/State.hs @@ -34,6 +34,9 @@ data PackageTags = PackageTags { data TagAlias = TagAlias (Map Tag (Set Tag)) deriving (Eq, Show) +instance MemSize TagAlias where + memSize (TagAlias aliases) = memSize1 aliases + addTagAlias :: Tag -> Tag -> Update TagAlias () addTagAlias tag alias = do TagAlias m <- get @@ -216,4 +219,3 @@ $(makeAcidic ''PackageTags ['tagsForPackage ,'lookupReviewTags ,'clearReviewTags ]) - diff --git a/src/Distribution/Server/Features/Tags/Store.hs b/src/Distribution/Server/Features/Tags/Store.hs new file mode 100644 index 000000000..d303b0668 --- /dev/null +++ b/src/Distribution/Server/Features/Tags/Store.hs @@ -0,0 +1,33 @@ +{-# LANGUAGE RankNTypes #-} + +module Distribution.Server.Features.Tags.Store + ( Backend(..) + , Store(..) + ) where + +import Distribution.Package (PackageName) +import Distribution.Server.Features.Tags.State (PackageTags) +import Distribution.Server.Features.Tags.Types (Tag) +import Distribution.Server.Framework (AbstractStateComponent) + +import Control.Monad.Trans (MonadIO) +import Data.Set (Set) + +data Backend = Backend { + backendStore :: Store + , backendState :: [AbstractStateComponent] + } + +data Store = Store { + getTagList :: forall m. MonadIO m => m [(Tag, Set PackageName)] + , getTagsForPackage :: forall m. MonadIO m => PackageName -> m (Set Tag) + , getReviewTagsForPackage :: forall m. MonadIO m => PackageName -> m (Set Tag, Set Tag) + , getTagAlias :: forall m. MonadIO m => Tag -> m Tag + , getPackagesForTag :: forall m. MonadIO m => Tag -> m (Set PackageName) + , getPackageTags :: forall m. MonadIO m => m PackageTags + , setPackageTags :: forall m. MonadIO m => PackageName -> Set Tag -> m () + , setTagPackages :: forall m. MonadIO m => Tag -> Set PackageName -> m () + , addTagAlias :: forall m. MonadIO m => Tag -> Tag -> m () + , insertReviewTags :: forall m. MonadIO m => PackageName -> Set Tag -> Set Tag -> m () + , replaceReviewTags :: forall m. MonadIO m => PackageName -> Set Tag -> Set Tag -> m () + } From d80fdc7411545eb51716ddda17b9d67972f4cc19 Mon Sep 17 00:00:00 2001 From: Tom Ellis Date: Fri, 25 Sep 2026 16:28:58 +0100 Subject: [PATCH 56/68] (refactor) Move reportsStateComponent to BuildReports.Acid --- hackage-server.cabal | 1 + .../Server/Features/BuildReports.hs | 15 +------------ .../Server/Features/BuildReports/Acid.hs | 21 +++++++++++++++++++ 3 files changed, 23 insertions(+), 14 deletions(-) create mode 100644 src/Distribution/Server/Features/BuildReports/Acid.hs diff --git a/hackage-server.cabal b/hackage-server.cabal index 4c7ff70f1..816fef960 100644 --- a/hackage-server.cabal +++ b/hackage-server.cabal @@ -354,6 +354,7 @@ library Distribution.Server.Features.BuildReports Distribution.Server.Features.BuildReports.BuildReport Distribution.Server.Features.BuildReports.BuildReports + Distribution.Server.Features.BuildReports.Acid Distribution.Server.Features.BuildReports.Backup Distribution.Server.Features.BuildReports.Render Distribution.Server.Features.BuildReports.State diff --git a/src/Distribution/Server/Features/BuildReports.hs b/src/Distribution/Server/Features/BuildReports.hs index 7a3fb7be8..82aee165d 100644 --- a/src/Distribution/Server/Features/BuildReports.hs +++ b/src/Distribution/Server/Features/BuildReports.hs @@ -12,7 +12,7 @@ import Distribution.Server.Features.Users import Distribution.Server.Features.Upload import Distribution.Server.Features.Core -import Distribution.Server.Features.BuildReports.Backup +import Distribution.Server.Features.BuildReports.Acid (reportsStateComponent) import qualified Distribution.Server.Features.BuildReports.State as Acid import qualified Distribution.Server.Features.BuildReports.BuildReport as BuildReport import Distribution.Server.Features.BuildReports.BuildReport (BuildReport(..)) @@ -87,19 +87,6 @@ initBuildReportsFeature name env@ServerEnv{serverStateDir} = do reportsState return feature -reportsStateComponent :: String -> FilePath -> IO (StateComponent AcidState BuildReports) -reportsStateComponent name stateDir = do - st <- openLocalStateFrom (stateDir "db" name) Acid.initialBuildReports - return StateComponent { - stateDesc = "Build reports" - , stateHandle = st - , getState = query st Acid.GetBuildReports - , putState = update st . Acid.ReplaceBuildReports - , backupState = \_ -> dumpBackup - , restoreState = restoreBackup - , resetState = reportsStateComponent name - } - buildReportsFeature :: String -> ServerEnv -> UserFeature diff --git a/src/Distribution/Server/Features/BuildReports/Acid.hs b/src/Distribution/Server/Features/BuildReports/Acid.hs new file mode 100644 index 000000000..11dcf04d9 --- /dev/null +++ b/src/Distribution/Server/Features/BuildReports/Acid.hs @@ -0,0 +1,21 @@ +module Distribution.Server.Features.BuildReports.Acid + ( reportsStateComponent + ) where + +import qualified Distribution.Server.Features.BuildReports.State as State +import Distribution.Server.Features.BuildReports.Backup (dumpBackup, restoreBackup) +import Distribution.Server.Features.BuildReports.BuildReports (BuildReports) +import Distribution.Server.Framework + +reportsStateComponent :: String -> FilePath -> IO (StateComponent AcidState BuildReports) +reportsStateComponent name stateDir = do + st <- openLocalStateFrom (stateDir "db" name) State.initialBuildReports + return StateComponent { + stateDesc = "Build reports" + , stateHandle = st + , getState = query st State.GetBuildReports + , putState = update st . State.ReplaceBuildReports + , backupState = \_ -> dumpBackup + , restoreState = restoreBackup + , resetState = reportsStateComponent name + } From 5622cc843900531103e2c4fb298d0507e6280ac3 Mon Sep 17 00:00:00 2001 From: Tom Ellis Date: Fri, 25 Sep 2026 16:31:35 +0100 Subject: [PATCH 57/68] (refactor) Introduce BuildReports abstraction layer --- hackage-server.cabal | 1 + .../Server/Features/BuildReports.hs | 54 +++++++++---------- .../Server/Features/BuildReports/Acid.hs | 26 +++++++++ .../Server/Features/BuildReports/Store.hs | 35 ++++++++++++ 4 files changed, 87 insertions(+), 29 deletions(-) create mode 100644 src/Distribution/Server/Features/BuildReports/Store.hs diff --git a/hackage-server.cabal b/hackage-server.cabal index 816fef960..6b325219e 100644 --- a/hackage-server.cabal +++ b/hackage-server.cabal @@ -356,6 +356,7 @@ library Distribution.Server.Features.BuildReports.BuildReports Distribution.Server.Features.BuildReports.Acid Distribution.Server.Features.BuildReports.Backup + Distribution.Server.Features.BuildReports.Store Distribution.Server.Features.BuildReports.Render Distribution.Server.Features.BuildReports.State Distribution.Server.Features.PackageCandidates diff --git a/src/Distribution/Server/Features/BuildReports.hs b/src/Distribution/Server/Features/BuildReports.hs index 82aee165d..f4fb58f88 100644 --- a/src/Distribution/Server/Features/BuildReports.hs +++ b/src/Distribution/Server/Features/BuildReports.hs @@ -12,11 +12,11 @@ import Distribution.Server.Features.Users import Distribution.Server.Features.Upload import Distribution.Server.Features.Core -import Distribution.Server.Features.BuildReports.Acid (reportsStateComponent) -import qualified Distribution.Server.Features.BuildReports.State as Acid +import qualified Distribution.Server.Features.BuildReports.Acid as Acid +import qualified Distribution.Server.Features.BuildReports.Store as Store import qualified Distribution.Server.Features.BuildReports.BuildReport as BuildReport import Distribution.Server.Features.BuildReports.BuildReport (BuildReport(..)) -import Distribution.Server.Features.BuildReports.BuildReports (BuildReports, BuildReportId(..), BuildCovg(..), BuildLog(..), TestLog(..), TestReportLog(..)) +import Distribution.Server.Features.BuildReports.BuildReports (BuildReportId(..), BuildCovg(..), BuildLog(..), TestLog(..), TestReportLog(..)) import qualified Distribution.Server.Framework.ResponseContentTypes as Resource import Distribution.Server.Packages.Types @@ -27,7 +27,6 @@ import Distribution.Text import Distribution.Package import Distribution.Version (nullVersion) -import Control.Arrow (second) import Data.ByteString.Lazy (toStrict) import Data.String (fromString) import Data.Maybe @@ -79,12 +78,12 @@ initBuildReportsFeature :: String -> CoreResource -> IO ReportsFeature) initBuildReportsFeature name env@ServerEnv{serverStateDir} = do - reportsState <- reportsStateComponent name serverStateDir + reportsBackend <- Acid.acidStore name serverStateDir return $ \user upload core -> do let feature = buildReportsFeature name env user upload core - reportsState + reportsBackend return feature buildReportsFeature :: String @@ -92,7 +91,7 @@ buildReportsFeature :: String -> UserFeature -> UploadFeature -> CoreResource - -> StateComponent AcidState BuildReports + -> Store.Backend -> ReportsFeature buildReportsFeature name ServerEnv{serverBlobStore = store} @@ -102,7 +101,7 @@ buildReportsFeature name , lookupPackageId , corePackagePage } - reportsState + Store.Backend{backendStore = reportsStore, backendState} = ReportsFeature{..} where reportsFeatureInterface = (emptyHackageFeature name) { @@ -117,7 +116,7 @@ buildReportsFeature name , reportsReset , reportsTestsEnabled ] - , featureState = [abstractAcidStateComponent reportsState] + , featureState = backendState } reportsResource = ReportsResource @@ -199,15 +198,13 @@ buildReportsFeature name pkgid <- packageInPath dpath guardValidPackageId pkgid reportId <- reportIdInPath dpath - mreport <- queryState reportsState $ Acid.LookupReportCovg pkgid reportId + mreport <- Store.lookupReportCovg reportsStore pkgid reportId case mreport of Nothing -> errNotFound "Report not found" [MText "Build report does not exist"] Just (report, mlog, mtest, covg, testReportLog) -> return (reportId, report, mlog, mtest, covg, testReportLog) queryPackageReports :: MonadIO m => PackageId -> m [(BuildReportId, BuildReport)] - queryPackageReports pkgid = do - reports <- queryState reportsState $ Acid.LookupPackageReports pkgid - return $ map (second (\(a, _, _, _) -> a)) reports + queryPackageReports = Store.lookupPackageReports reportsStore queryBuildLog :: MonadIO m => BuildLog -> m Resource.BuildLog queryBuildLog (BuildLog blobId) = do @@ -226,9 +223,9 @@ buildReportsFeature name pkgReportDetails :: MonadIO m => (PackageIdentifier, Bool) -> m BuildReport.PkgDetails--(PackageIdentifier, Bool, Maybe (BuildStatus, Maybe UTCTime, Maybe Version)) pkgReportDetails (pkgid, docs) = do - failCnt <- queryState reportsState $ Acid.LookupFailCount pkgid - latestRpt <- queryState reportsState $ Acid.LookupLatestReport pkgid - runTests <- fmap Just . queryState reportsState $ Acid.LookupRunTests pkgid + failCnt <- Store.lookupFailCount reportsStore pkgid + latestRpt <- Store.lookupLatestReport reportsStore pkgid + runTests <- fmap Just $ Store.lookupRunTests reportsStore pkgid (time, ghcId) <- case latestRpt of Nothing -> return (Nothing,Nothing) Just (_, brp, _, _, _, _) -> do @@ -238,13 +235,13 @@ buildReportsFeature name queryLastReportStats :: MonadIO m => PackageIdentifier -> m (Maybe (BuildReportId, BuildReport, Maybe BuildCovg, Maybe TestReportLog)) queryLastReportStats pkgid = do - lookupRes <- queryState reportsState $ Acid.LookupLatestReport pkgid + lookupRes <- Store.lookupLatestReport reportsStore pkgid case lookupRes of Nothing -> return Nothing Just (rptId, rpt, _, _, covg, testReportLog) -> return (Just (rptId, rpt, covg, testReportLog)) queryRunTests :: MonadIO m => PackageId -> m Bool - queryRunTests pkgid = queryState reportsState $ Acid.LookupRunTests pkgid + queryRunTests = Store.lookupRunTests reportsStore --------------------------------------------------------------------------- @@ -298,7 +295,7 @@ buildReportsFeature name -- Check that the submitter can actually upload docs guardAuthorisedAsMaintainerOrTrustee (packageName pkgid) report' <- liftIO $ BuildReport.affixTimestamp report - reportId <- updateState reportsState $ Acid.AddReport pkgid (report', Nothing) + reportId <- Store.addReport reportsStore pkgid (report', Nothing) -- redirect to new reports page seeOther (reportsPageUri reportsResource "" pkgid reportId) $ toResponse () @@ -319,7 +316,7 @@ buildReportsFeature name guardValidPackageId pkgid reportId <- reportIdInPath dpath guardAuthorised_ [InGroup trusteesGroup] - success <- updateState reportsState $ Acid.DeleteReport pkgid reportId + success <- Store.deleteReport reportsStore pkgid reportId if success then seeOther (reportsListUri reportsResource "" pkgid) $ toResponse () else errNotFound "Build report not found" [MText $ "Build report #" ++ display reportId ++ " not found"] @@ -333,7 +330,7 @@ buildReportsFeature name guardAuthorised_ [AnyKnownUser] blogbody <- expectTextPlain buildLog <- liftIO $ BlobStorage.add store blogbody - void $ updateState reportsState $ Acid.SetBuildLog pkgid reportId (Just $ BuildLog buildLog) + void $ Store.setBuildLog reportsStore pkgid reportId (Just $ BuildLog buildLog) noContent (toResponse ()) putTestLog :: DynamicPath -> ServerPartE Response @@ -345,7 +342,7 @@ buildReportsFeature name guardAuthorised_ [AnyKnownUser] blogbody <- expectTextPlain testLog <- liftIO $ BlobStorage.add store blogbody - void $ updateState reportsState $ Acid.SetTestLog pkgid reportId (Just $ TestLog testLog) + void $ Store.setTestLog reportsStore pkgid reportId (Just $ TestLog testLog) noContent (toResponse ()) {- @@ -364,7 +361,7 @@ buildReportsFeature name guardValidPackageId pkgid reportId <- reportIdInPath dpath guardAuthorised_ [InGroup trusteesGroup] - void $ updateState reportsState $ Acid.SetBuildLog pkgid reportId Nothing + void $ Store.setBuildLog reportsStore pkgid reportId Nothing noContent (toResponse ()) deleteTestLog :: DynamicPath -> ServerPartE Response @@ -373,7 +370,7 @@ buildReportsFeature name guardValidPackageId pkgid reportId <- reportIdInPath dpath guardAuthorised_ [InGroup trusteesGroup] - void $ updateState reportsState $ Acid.SetTestLog pkgid reportId Nothing + void $ Store.setTestLog reportsStore pkgid reportId Nothing noContent (toResponse ()) guardAuthorisedAsMaintainerOrTrustee pkgname = @@ -384,7 +381,7 @@ buildReportsFeature name pkgid <- packageInPath dpath guardValidPackageId pkgid guardAuthorisedAsMaintainerOrTrustee (packageName pkgid) - success <- updateState reportsState $ Acid.ResetFailCount pkgid + success <- Store.resetFailCount reportsStore pkgid if success then seeOther (reportsListUri reportsResource "" pkgid) $ toResponse () else errNotFound "Report not found" [MText "Build report does not exist"] @@ -403,7 +400,7 @@ buildReportsFeature name runTests <- body $ looks "runTests" guardValidPackageId pkgid guardAuthorisedAsMaintainerOrTrustee (packageName pkgid) - success <- updateState reportsState $ Acid.SetRunTests pkgid ("on" `elem` runTests) + success <- Store.setRunTests reportsStore pkgid ("on" `elem` runTests) if success then seeOther (reportsListUri reportsResource "" pkgid) $ toResponse () else errNotFound "Package not found" [MText "Package does not exist"] @@ -422,7 +419,7 @@ buildReportsFeature name testReportBody = BuildReport.testReportContent buildFiles failStatus = BuildReport.buildFail buildFiles - updateState reportsState $ Acid.SetFailStatus pkgid failStatus + Store.setFailStatus reportsStore pkgid failStatus -- Upload BuildReport case BuildReport.parse $ toStrict $ fromString $ fromMaybe "" reportBody of @@ -435,8 +432,7 @@ buildReportsFeature name logBlob <- liftIO $ traverse (\x -> BlobStorage.add store $ fromString x) logBody testBlob <- liftIO $ traverse (\x -> BlobStorage.add store $ fromString x) testBody testReportBlob <- liftIO $ traverse (\x -> BlobStorage.add store $ fromString x) testReportBody - reportId <- updateState reportsState $ - Acid.AddRptAllLogsCovg pkgid (report', (fmap BuildLog logBlob), (fmap TestLog testBlob), (fmap BuildReport.parseCovg covgBody), (fmap TestReportLog testReportBlob)) + reportId <- Store.addRptAllLogsCovg reportsStore pkgid (report', (fmap BuildLog logBlob), (fmap TestLog testBlob), (fmap BuildReport.parseCovg covgBody), (fmap TestReportLog testReportBlob)) -- redirect to new reports page seeOther (reportsPageUri reportsResource "" pkgid reportId) $ toResponse () diff --git a/src/Distribution/Server/Features/BuildReports/Acid.hs b/src/Distribution/Server/Features/BuildReports/Acid.hs index 11dcf04d9..0bbe2aa18 100644 --- a/src/Distribution/Server/Features/BuildReports/Acid.hs +++ b/src/Distribution/Server/Features/BuildReports/Acid.hs @@ -1,12 +1,38 @@ module Distribution.Server.Features.BuildReports.Acid ( reportsStateComponent + , acidStore ) where import qualified Distribution.Server.Features.BuildReports.State as State import Distribution.Server.Features.BuildReports.Backup (dumpBackup, restoreBackup) import Distribution.Server.Features.BuildReports.BuildReports (BuildReports) +import qualified Distribution.Server.Features.BuildReports.Store as Store import Distribution.Server.Framework +acidStore :: String -> FilePath -> IO Store.Backend +acidStore name stateDir = do + reportsState <- reportsStateComponent name stateDir + pure Store.Backend { + Store.backendStore = Store.Store { + Store.lookupReportCovg = \pkgid reportId -> queryState reportsState (State.LookupReportCovg pkgid reportId) + , Store.lookupPackageReports = \pkgid -> do + reports <- queryState reportsState (State.LookupPackageReports pkgid) + pure $ map (\(reportId, (report, _, _, _)) -> (reportId, report)) reports + , Store.lookupFailCount = \pkgid -> queryState reportsState (State.LookupFailCount pkgid) + , Store.lookupLatestReport = \pkgid -> queryState reportsState (State.LookupLatestReport pkgid) + , Store.lookupRunTests = \pkgid -> queryState reportsState (State.LookupRunTests pkgid) + , Store.addReport = \pkgid report -> updateState reportsState (State.AddReport pkgid report) + , Store.deleteReport = \pkgid reportId -> updateState reportsState (State.DeleteReport pkgid reportId) + , Store.setBuildLog = \pkgid reportId buildLog -> updateState reportsState (State.SetBuildLog pkgid reportId buildLog) + , Store.setTestLog = \pkgid reportId testLog -> updateState reportsState (State.SetTestLog pkgid reportId testLog) + , Store.resetFailCount = \pkgid -> updateState reportsState (State.ResetFailCount pkgid) + , Store.setRunTests = \pkgid enabled -> updateState reportsState (State.SetRunTests pkgid enabled) + , Store.setFailStatus = \pkgid status -> updateState reportsState (State.SetFailStatus pkgid status) + , Store.addRptAllLogsCovg = \pkgid report -> updateState reportsState (State.AddRptAllLogsCovg pkgid report) + } + , Store.backendState = [abstractAcidStateComponent reportsState] + } + reportsStateComponent :: String -> FilePath -> IO (StateComponent AcidState BuildReports) reportsStateComponent name stateDir = do st <- openLocalStateFrom (stateDir "db" name) State.initialBuildReports diff --git a/src/Distribution/Server/Features/BuildReports/Store.hs b/src/Distribution/Server/Features/BuildReports/Store.hs new file mode 100644 index 000000000..197b06583 --- /dev/null +++ b/src/Distribution/Server/Features/BuildReports/Store.hs @@ -0,0 +1,35 @@ +{-# LANGUAGE RankNTypes #-} + +module Distribution.Server.Features.BuildReports.Store + ( Backend(..) + , Store(..) + ) where + +import Distribution.Package (PackageId) +import Distribution.Server.Features.BuildReports.BuildReport (BuildReport) +import Distribution.Server.Features.BuildReports.BuildReports + ( BuildReportId, BuildCovg, BuildLog, BuildStatus, TestLog, TestReportLog ) +import Distribution.Server.Framework (AbstractStateComponent) + +import Control.Monad.Trans (MonadIO) + +data Backend = Backend { + backendStore :: Store + , backendState :: [AbstractStateComponent] + } + +data Store = Store { + lookupReportCovg :: forall m. MonadIO m => PackageId -> BuildReportId -> m (Maybe (BuildReport, Maybe BuildLog, Maybe TestLog, Maybe BuildCovg, Maybe TestReportLog)) + , lookupPackageReports :: forall m. MonadIO m => PackageId -> m [(BuildReportId, BuildReport)] + , lookupFailCount :: forall m. MonadIO m => PackageId -> m (Maybe BuildStatus) + , lookupLatestReport :: forall m. MonadIO m => PackageId -> m (Maybe (BuildReportId, BuildReport, Maybe BuildLog, Maybe TestLog, Maybe BuildCovg, Maybe TestReportLog)) + , lookupRunTests :: forall m. MonadIO m => PackageId -> m Bool + , addReport :: forall m. MonadIO m => PackageId -> (BuildReport, Maybe BuildLog) -> m BuildReportId + , deleteReport :: forall m. MonadIO m => PackageId -> BuildReportId -> m Bool + , setBuildLog :: forall m. MonadIO m => PackageId -> BuildReportId -> Maybe BuildLog -> m Bool + , setTestLog :: forall m. MonadIO m => PackageId -> BuildReportId -> Maybe TestLog -> m Bool + , resetFailCount :: forall m. MonadIO m => PackageId -> m Bool + , setRunTests :: forall m. MonadIO m => PackageId -> Bool -> m Bool + , setFailStatus :: forall m. MonadIO m => PackageId -> Bool -> m () + , addRptAllLogsCovg :: forall m. MonadIO m => PackageId -> (BuildReport, Maybe BuildLog, Maybe TestLog, Maybe BuildCovg, Maybe TestReportLog) -> m BuildReportId + } From fd377027c1e77e63d6a8f991eb9955c140e63936 Mon Sep 17 00:00:00 2001 From: Tom Ellis Date: Fri, 25 Sep 2026 16:33:14 +0100 Subject: [PATCH 58/68] (refactor) Move notifyStateComponent to UserNotify.Acid.Component --- hackage-server.cabal | 1 + .../Server/Features/UserNotify.hs | 18 ++------------- .../Features/UserNotify/Acid/Component.hs | 22 +++++++++++++++++++ 3 files changed, 25 insertions(+), 16 deletions(-) create mode 100644 src/Distribution/Server/Features/UserNotify/Acid/Component.hs diff --git a/hackage-server.cabal b/hackage-server.cabal index 6b325219e..a9a008672 100644 --- a/hackage-server.cabal +++ b/hackage-server.cabal @@ -332,6 +332,7 @@ library Distribution.Server.Features.Users Distribution.Server.Features.UserNotify Distribution.Server.Features.UserNotify.Acid + Distribution.Server.Features.UserNotify.Acid.Component Distribution.Server.Features.UserNotify.Backup Distribution.Server.Features.UserNotify.Types diff --git a/src/Distribution/Server/Features/UserNotify.hs b/src/Distribution/Server/Features/UserNotify.hs index 15025f1cc..df3fd39c6 100644 --- a/src/Distribution/Server/Features/UserNotify.hs +++ b/src/Distribution/Server/Features/UserNotify.hs @@ -18,6 +18,7 @@ module Distribution.Server.Features.UserNotify ( ) where import Distribution.Server.Features.UserDetails.Types +import qualified Distribution.Server.Features.UserNotify.Acid.Component as AcidComponent import qualified Distribution.Server.Features.UserNotify.Acid as Acid import Distribution.Server.Features.UserNotify.Acid (NotifyPref(..)) import Distribution.Server.Features.UserNotify.Backup @@ -36,7 +37,6 @@ import Distribution.Server.Packages.Types import qualified Distribution.Server.Packages.PackageIndex as PackageIndex import Distribution.Server.Framework -import Distribution.Server.Framework.BackupDump import Distribution.Server.Framework.Templating import Distribution.Server.Features.AdminLog @@ -210,20 +210,6 @@ instance ToRadioButtons OK where -- State Component -- -notifyStateComponent :: FilePath -> IO (StateComponent AcidState Acid.NotifyData) -notifyStateComponent stateDir = do - st <- openLocalStateFrom (stateDir "db" "UserNotify") =<< Acid.emptyNotifyData - return StateComponent { - stateDesc = "State to keep track of revision notifications" - , stateHandle = st - , getState = query st Acid.GetNotifyData - , putState = update st . Acid.ReplaceNotifyData - , backupState = \backuptype tbl -> - [csvToBackup ["notifydata.csv"] (notifyDataToCSV backuptype tbl)] - , restoreState = userNotifyBackup - , resetState = notifyStateComponent - } - ---------------------------- -- Core Feature -- @@ -242,7 +228,7 @@ initUserNotifyFeature :: ServerEnv initUserNotifyFeature ServerEnv{ serverStateDir, serverTemplatesDir, serverTemplatesMode } = do -- Canonical state - notifyState <- notifyStateComponent serverStateDir + notifyState <- AcidComponent.notifyStateComponent serverStateDir -- Page templates templates <- loadTemplates serverTemplatesMode diff --git a/src/Distribution/Server/Features/UserNotify/Acid/Component.hs b/src/Distribution/Server/Features/UserNotify/Acid/Component.hs new file mode 100644 index 000000000..f106cdf55 --- /dev/null +++ b/src/Distribution/Server/Features/UserNotify/Acid/Component.hs @@ -0,0 +1,22 @@ +module Distribution.Server.Features.UserNotify.Acid.Component + ( notifyStateComponent + ) where + +import qualified Distribution.Server.Features.UserNotify.Acid as Acid +import Distribution.Server.Features.UserNotify.Backup +import Distribution.Server.Framework +import Distribution.Server.Framework.BackupDump + +notifyStateComponent :: FilePath -> IO (StateComponent AcidState Acid.NotifyData) +notifyStateComponent stateDir = do + st <- openLocalStateFrom (stateDir "db" "UserNotify") =<< Acid.emptyNotifyData + return StateComponent { + stateDesc = "State to keep track of revision notifications" + , stateHandle = st + , getState = query st Acid.GetNotifyData + , putState = update st . Acid.ReplaceNotifyData + , backupState = \backuptype tbl -> + [csvToBackup ["notifydata.csv"] (notifyDataToCSV backuptype tbl)] + , restoreState = userNotifyBackup + , resetState = notifyStateComponent + } From fcf11898e9916badf6566c9eb1824162d4a435f0 Mon Sep 17 00:00:00 2001 From: Tom Ellis Date: Fri, 25 Sep 2026 16:34:37 +0100 Subject: [PATCH 59/68] (refactor) Introduce UserNotify abstraction layer --- hackage-server.cabal | 1 + .../Server/Features/UserNotify.hs | 20 +++++++------- .../Features/UserNotify/Acid/Component.hs | 15 +++++++++++ .../Server/Features/UserNotify/Store.hs | 26 +++++++++++++++++++ 4 files changed, 53 insertions(+), 9 deletions(-) create mode 100644 src/Distribution/Server/Features/UserNotify/Store.hs diff --git a/hackage-server.cabal b/hackage-server.cabal index a9a008672..61c770f21 100644 --- a/hackage-server.cabal +++ b/hackage-server.cabal @@ -334,6 +334,7 @@ library Distribution.Server.Features.UserNotify.Acid Distribution.Server.Features.UserNotify.Acid.Component Distribution.Server.Features.UserNotify.Backup + Distribution.Server.Features.UserNotify.Store Distribution.Server.Features.UserNotify.Types diff --git a/src/Distribution/Server/Features/UserNotify.hs b/src/Distribution/Server/Features/UserNotify.hs index df3fd39c6..7370513fd 100644 --- a/src/Distribution/Server/Features/UserNotify.hs +++ b/src/Distribution/Server/Features/UserNotify.hs @@ -20,6 +20,7 @@ module Distribution.Server.Features.UserNotify ( import Distribution.Server.Features.UserDetails.Types import qualified Distribution.Server.Features.UserNotify.Acid.Component as AcidComponent import qualified Distribution.Server.Features.UserNotify.Acid as Acid +import qualified Distribution.Server.Features.UserNotify.Store as Store import Distribution.Server.Features.UserNotify.Acid (NotifyPref(..)) import Distribution.Server.Features.UserNotify.Backup import Distribution.Server.Features.UserNotify.Types @@ -228,7 +229,7 @@ initUserNotifyFeature :: ServerEnv initUserNotifyFeature ServerEnv{ serverStateDir, serverTemplatesDir, serverTemplatesMode } = do -- Canonical state - notifyState <- AcidComponent.notifyStateComponent serverStateDir + notifyBackend <- AcidComponent.acidStore serverStateDir -- Page templates templates <- loadTemplates serverTemplatesMode @@ -238,7 +239,7 @@ initUserNotifyFeature ServerEnv{ serverStateDir, serverTemplatesDir, return $ \users core uploadfeature adminlog userdetails reports tags revers vouch -> do let feature = userNotifyFeature users core uploadfeature adminlog userdetails reports tags - revers vouch notifyState templates + revers vouch notifyBackend templates return feature data InRange = InRange | OutOfRange @@ -369,7 +370,7 @@ userNotifyFeature :: UserFeature -> TagsFeature -> ReverseFeature -> VouchFeature - -> StateComponent AcidState Acid.NotifyData + -> Store.Backend -> Templates -> UserNotifyFeature userNotifyFeature UserFeature{..} @@ -381,7 +382,8 @@ userNotifyFeature UserFeature{..} TagsFeature{..} ReverseFeature{queryReverseIndex} VouchFeature{drainQueuedNotifications} - notifyState templates + Store.Backend{backendStore = notifyStore, backendState} + templates = UserNotifyFeature {..} where @@ -389,7 +391,7 @@ userNotifyFeature UserFeature{..} userNotifyFeatureInterface = (emptyHackageFeature "user-notify") { featureDesc = "Notifications to users on metadata updates." , featureResources = [userNotifyResource] -- TODO we can add json features here for updating prefs - , featureState = [abstractAcidStateComponent notifyState] + , featureState = backendState , featureCaches = [] , featureReloadFiles = reloadTemplates templates , featurePostInit = setupNotifyCronJob @@ -413,10 +415,10 @@ userNotifyFeature UserFeature{..} -- queryGetUserNotifyPref :: MonadIO m => UserId -> m (Maybe Acid.NotifyPref) - queryGetUserNotifyPref uid = queryState notifyState (Acid.LookupNotifyPref uid) + queryGetUserNotifyPref = Store.lookupNotifyPref notifyStore updateSetUserNotifyPref :: MonadIO m => UserId -> Acid.NotifyPref -> m () - updateSetUserNotifyPref uid np = updateState notifyState (Acid.AddNotifyPref uid np) + updateSetUserNotifyPref = Store.addNotifyPref notifyStore -- Request handlers -- @@ -474,7 +476,7 @@ userNotifyFeature UserFeature{..} } notifyCronAction = do - (notifyPrefs, lastNotifyTime) <- Acid.unNotifyData <$> queryState notifyState Acid.GetNotifyData + (notifyPrefs, lastNotifyTime) <- Store.getNotificationData notifyStore now <- getCurrentTime let trimLastTime = if diffUTCTime now lastNotifyTime > (60*60*6) -- cap at 6hr then addUTCTime (negate $ (60*60*6)) now @@ -511,7 +513,7 @@ userNotifyFeature UserFeature{..} ] mapM_ sendNotifyEmailAndDelay emails - updateState notifyState (Acid.SetNotifyTime now) + Store.setNotifyTime notifyStore now collectRevisionsAndUploads earlier now = do pkgIndex <- queryGetPackageIndex diff --git a/src/Distribution/Server/Features/UserNotify/Acid/Component.hs b/src/Distribution/Server/Features/UserNotify/Acid/Component.hs index f106cdf55..630ab15a3 100644 --- a/src/Distribution/Server/Features/UserNotify/Acid/Component.hs +++ b/src/Distribution/Server/Features/UserNotify/Acid/Component.hs @@ -1,12 +1,27 @@ module Distribution.Server.Features.UserNotify.Acid.Component ( notifyStateComponent + , acidStore ) where import qualified Distribution.Server.Features.UserNotify.Acid as Acid import Distribution.Server.Features.UserNotify.Backup +import qualified Distribution.Server.Features.UserNotify.Store as Store import Distribution.Server.Framework import Distribution.Server.Framework.BackupDump +acidStore :: FilePath -> IO Store.Backend +acidStore stateDir = do + notifyState <- notifyStateComponent stateDir + pure Store.Backend { + Store.backendStore = Store.Store { + Store.lookupNotifyPref = \uid -> queryState notifyState (Acid.LookupNotifyPref uid) + , Store.addNotifyPref = \uid pref -> updateState notifyState (Acid.AddNotifyPref uid pref) + , Store.getNotificationData = Acid.unNotifyData <$> queryState notifyState Acid.GetNotifyData + , Store.setNotifyTime = \time -> updateState notifyState (Acid.SetNotifyTime time) + } + , Store.backendState = [abstractAcidStateComponent notifyState] + } + notifyStateComponent :: FilePath -> IO (StateComponent AcidState Acid.NotifyData) notifyStateComponent stateDir = do st <- openLocalStateFrom (stateDir "db" "UserNotify") =<< Acid.emptyNotifyData diff --git a/src/Distribution/Server/Features/UserNotify/Store.hs b/src/Distribution/Server/Features/UserNotify/Store.hs new file mode 100644 index 000000000..131984f20 --- /dev/null +++ b/src/Distribution/Server/Features/UserNotify/Store.hs @@ -0,0 +1,26 @@ +{-# LANGUAGE RankNTypes #-} + +module Distribution.Server.Features.UserNotify.Store + ( Backend(..) + , Store(..) + ) where + +import qualified Distribution.Server.Features.UserNotify.Acid as Acid +import Distribution.Server.Framework (AbstractStateComponent) +import Distribution.Server.Users.Types (UserId) + +import Control.Monad.Trans (MonadIO) +import Data.Map (Map) +import Data.Time (UTCTime) + +data Backend = Backend { + backendStore :: Store + , backendState :: [AbstractStateComponent] + } + +data Store = Store { + lookupNotifyPref :: forall m. MonadIO m => UserId -> m (Maybe Acid.NotifyPref) + , addNotifyPref :: forall m. MonadIO m => UserId -> Acid.NotifyPref -> m () + , getNotificationData :: forall m. MonadIO m => m (Map UserId Acid.NotifyPref, UTCTime) + , setNotifyTime :: forall m. MonadIO m => UTCTime -> m () + } From 533c0ac61e83beb2a786cc0763e686327305e822 Mon Sep 17 00:00:00 2001 From: Tom Ellis Date: Fri, 25 Sep 2026 16:36:02 +0100 Subject: [PATCH 60/68] (refactor) Move candidatesStateComponent to PackageCandidates.Acid --- hackage-server.cabal | 1 + .../Server/Features/PackageCandidates.hs | 16 +------------- .../Server/Features/PackageCandidates/Acid.hs | 21 +++++++++++++++++++ 3 files changed, 23 insertions(+), 15 deletions(-) create mode 100644 src/Distribution/Server/Features/PackageCandidates/Acid.hs diff --git a/hackage-server.cabal b/hackage-server.cabal index 61c770f21..57dda231a 100644 --- a/hackage-server.cabal +++ b/hackage-server.cabal @@ -362,6 +362,7 @@ library Distribution.Server.Features.BuildReports.Render Distribution.Server.Features.BuildReports.State Distribution.Server.Features.PackageCandidates + Distribution.Server.Features.PackageCandidates.Acid Distribution.Server.Features.PackageCandidates.Types Distribution.Server.Features.PackageCandidates.State Distribution.Server.Features.PackageCandidates.Backup diff --git a/src/Distribution/Server/Features/PackageCandidates.hs b/src/Distribution/Server/Features/PackageCandidates.hs index 7ad2c22c4..905e26a08 100644 --- a/src/Distribution/Server/Features/PackageCandidates.hs +++ b/src/Distribution/Server/Features/PackageCandidates.hs @@ -11,8 +11,8 @@ module Distribution.Server.Features.PackageCandidates ( import Distribution.Server.Framework import Distribution.Server.Features.PackageCandidates.Types +import Distribution.Server.Features.PackageCandidates.Acid (candidatesStateComponent) import Distribution.Server.Features.PackageCandidates.State -import Distribution.Server.Features.PackageCandidates.Backup import Distribution.Server.Features.Core import Distribution.Server.Features.Upload @@ -155,20 +155,6 @@ initPackageCandidatesFeature env@ServerEnv{serverStateDir} = do candidatesState return feature -candidatesStateComponent :: Bool -> FilePath -> IO (StateComponent AcidState CandidatePackages) -candidatesStateComponent freshDB stateDir = do - st <- openLocalStateFrom (stateDir "db" "CandidatePackages") - (initialCandidatePackages freshDB) - return StateComponent { - stateDesc = "Candidate packages" - , stateHandle = st - , getState = query st GetCandidatePackages - , putState = update st . ReplaceCandidatePackages - , resetState = candidatesStateComponent True - , backupState = \_ -> backupCandidates - , restoreState = restoreCandidates - } - candidatesFeature :: ServerEnv -> UserFeature -> CoreFeature diff --git a/src/Distribution/Server/Features/PackageCandidates/Acid.hs b/src/Distribution/Server/Features/PackageCandidates/Acid.hs new file mode 100644 index 000000000..3b22f2026 --- /dev/null +++ b/src/Distribution/Server/Features/PackageCandidates/Acid.hs @@ -0,0 +1,21 @@ +module Distribution.Server.Features.PackageCandidates.Acid + ( candidatesStateComponent + ) where + +import Distribution.Server.Features.PackageCandidates.State +import Distribution.Server.Features.PackageCandidates.Backup +import Distribution.Server.Framework + +candidatesStateComponent :: Bool -> FilePath -> IO (StateComponent AcidState CandidatePackages) +candidatesStateComponent freshDB stateDir = do + st <- openLocalStateFrom (stateDir "db" "CandidatePackages") + (initialCandidatePackages freshDB) + return StateComponent { + stateDesc = "Candidate packages" + , stateHandle = st + , getState = query st GetCandidatePackages + , putState = update st . ReplaceCandidatePackages + , resetState = candidatesStateComponent True + , backupState = \_ -> backupCandidates + , restoreState = restoreCandidates + } From eff2165ae6749723b1fd35ee62cb51e3ae924f71 Mon Sep 17 00:00:00 2001 From: Tom Ellis Date: Fri, 25 Sep 2026 16:39:36 +0100 Subject: [PATCH 61/68] (refactor) Introduce PackageCandidates abstraction layer --- hackage-server.cabal | 1 + .../Server/Features/PackageCandidates.hs | 44 ++++++++++--------- .../Server/Features/PackageCandidates/Acid.hs | 28 +++++++++--- .../Features/PackageCandidates/Store.hs | 29 ++++++++++++ .../Server/Features/Security/Migration.hs | 17 +++---- 5 files changed, 81 insertions(+), 38 deletions(-) create mode 100644 src/Distribution/Server/Features/PackageCandidates/Store.hs diff --git a/hackage-server.cabal b/hackage-server.cabal index 57dda231a..fbf3d71f6 100644 --- a/hackage-server.cabal +++ b/hackage-server.cabal @@ -366,6 +366,7 @@ library Distribution.Server.Features.PackageCandidates.Types Distribution.Server.Features.PackageCandidates.State Distribution.Server.Features.PackageCandidates.Backup + Distribution.Server.Features.PackageCandidates.Store Distribution.Server.Features.PackageFeed Distribution.Server.Features.PackageList Distribution.Server.Features.Distro diff --git a/src/Distribution/Server/Features/PackageCandidates.hs b/src/Distribution/Server/Features/PackageCandidates.hs index 905e26a08..ee82812ce 100644 --- a/src/Distribution/Server/Features/PackageCandidates.hs +++ b/src/Distribution/Server/Features/PackageCandidates.hs @@ -11,8 +11,8 @@ module Distribution.Server.Features.PackageCandidates ( import Distribution.Server.Framework import Distribution.Server.Features.PackageCandidates.Types -import Distribution.Server.Features.PackageCandidates.Acid (candidatesStateComponent) -import Distribution.Server.Features.PackageCandidates.State +import qualified Distribution.Server.Features.PackageCandidates.Acid as Acid +import qualified Distribution.Server.Features.PackageCandidates.Store as Store import Distribution.Server.Features.Core import Distribution.Server.Features.Upload @@ -138,21 +138,23 @@ initPackageCandidatesFeature :: ServerEnv -> TarIndexCacheFeature -> IO PackageCandidatesFeature) initPackageCandidatesFeature env@ServerEnv{serverStateDir} = do - candidatesState <- candidatesStateComponent False serverStateDir + candidatesBackend <- Acid.acidStore serverStateDir + let candidatesStore = Store.backendStore candidatesBackend return $ \user core upload@UploadFeature{..} tarIndexCache -> do -- one-off migration - CandidatePackages{candidateMigratedPkgTarball = migratedPkgTarball} <- - queryState candidatesState GetCandidatePackages + migratedPkgTarball <- Store.candidateTarballIsMigrated candidatesStore unless migratedPkgTarball $ do - migrateCandidatePkgTarball_v1_to_v2 env candidatesState - updateState candidatesState SetMigratedPkgTarball + candidateIndex <- Store.getCandidateIndex candidatesStore + migrateCandidatePkgTarball_v1_to_v2 env candidateIndex $ \pkgid pkginfo -> + void $ Store.updateCandidatePkgInfo candidatesStore pkgid pkginfo + Store.setCandidateTarballMigrated candidatesStore - registerHook packageUploaded $ updateState candidatesState . DeleteCandidate + registerHook packageUploaded $ Store.deleteCandidate candidatesStore let feature = candidatesFeature env user core upload tarIndexCache - candidatesState + candidatesBackend return feature candidatesFeature :: ServerEnv @@ -160,7 +162,7 @@ candidatesFeature :: ServerEnv -> CoreFeature -> UploadFeature -> TarIndexCacheFeature - -> StateComponent AcidState CandidatePackages + -> Store.Backend -> PackageCandidatesFeature candidatesFeature ServerEnv{serverBlobStore = store} UserFeature{..} @@ -170,7 +172,7 @@ candidatesFeature ServerEnv{serverBlobStore = store} } UploadFeature{..} TarIndexCacheFeature{packageTarball, findToplevelFile} - candidatesState + Store.Backend{backendStore = candidatesStore, backendState} = PackageCandidatesFeature{..} where candidatesFeatureInterface = (emptyHackageFeature "candidates") { @@ -188,11 +190,11 @@ candidatesFeature ServerEnv{serverBlobStore = store} , candidateContents , candidateChangeLog ] - , featureState = [abstractAcidStateComponent candidatesState] + , featureState = backendState } queryGetCandidateIndex :: MonadIO m => m (PackageIndex CandPkgInfo) - queryGetCandidateIndex = return . candidateList =<< queryState candidatesState GetCandidatePackages + queryGetCandidateIndex = Store.getCandidateIndex candidatesStore candidatesCoreResource = fix $ \r -> CoreResource { -- TODO: There is significant overlap between this definition and the one in Core @@ -339,14 +341,14 @@ candidatesFeature ServerEnv{serverBlobStore = store} doDeleteCandidate dpath = do candidate <- packageInPath dpath >>= lookupCandidateId guardAuthorisedAsMaintainerOrTrustee (packageName candidate) - void $ updateState candidatesState $ DeleteCandidate (packageId candidate) + Store.deleteCandidate candidatesStore (packageId candidate) seeOther (packageCandidatesUri candidatesResource "" $ packageName candidate) $ toResponse () doDeleteCandidates :: DynamicPath -> ServerPartE Response doDeleteCandidates dpath = do pkgname <- packageInPath dpath guardAuthorisedAsMaintainerOrTrustee pkgname - void $ updateState candidatesState $ DeleteCandidates pkgname + Store.deleteCandidates candidatesStore pkgname seeOther (packageCandidatesUri candidatesResource "" pkgname) $ toResponse () serveCandidateTarball :: DynamicPath -> ServerPartE Response @@ -398,7 +400,7 @@ candidatesFeature ServerEnv{serverBlobStore = store} checkCandidate "Upload failed" uid regularIndex candidate >>= \case Just failed -> throwError failed Nothing -> do - void $ updateState candidatesState $ AddCandidate candidate + Store.addCandidate candidatesStore candidate let group = maintainersGroup (packageName pkgid) liftIO $ Group.addUserToGroup group uid return candidate @@ -459,7 +461,7 @@ candidatesFeature ServerEnv{serverBlobStore = store} then do -- delete when requested: "moving" the resource -- should this be required? (see notes in PackageCandidatesResource) - when doDelete $ updateState candidatesState $ DeleteCandidate (packageId candidate) + when doDelete $ Store.deleteCandidate candidatesStore (packageId candidate) return uresult else errForbidden "Upload failed" [MText "Package already exists."] @@ -538,8 +540,8 @@ candidatesFeature ServerEnv{serverBlobStore = store} lookupCandidateName :: PackageName -> ServerPartE [CandPkgInfo] lookupCandidateName pkgname = do guardValidPackageName core pkgname - state <- queryState candidatesState GetCandidatePackages - return $ PackageIndex.lookupPackageName (candidateList state) pkgname + candidateIndex <- queryGetCandidateIndex + return $ PackageIndex.lookupPackageName candidateIndex pkgname -- TODO: Unlike the corresponding function in core, we don't return the -- "latest" candidate when Version is empty. Should we? @@ -547,8 +549,8 @@ candidatesFeature ServerEnv{serverBlobStore = store} lookupCandidateId :: PackageId -> ServerPartE CandPkgInfo lookupCandidateId pkgid = do guard (pkgVersion pkgid /= nullVersion) - state <- queryState candidatesState GetCandidatePackages - case PackageIndex.lookupPackageId (candidateList state) pkgid of + candidateIndex <- queryGetCandidateIndex + case PackageIndex.lookupPackageId candidateIndex pkgid of Just pkg -> return pkg _ -> errNotFound "Candidate not found" [MText $ "No such candidate version for " ++ display (packageName pkgid)] diff --git a/src/Distribution/Server/Features/PackageCandidates/Acid.hs b/src/Distribution/Server/Features/PackageCandidates/Acid.hs index 3b22f2026..5a26e6c1d 100644 --- a/src/Distribution/Server/Features/PackageCandidates/Acid.hs +++ b/src/Distribution/Server/Features/PackageCandidates/Acid.hs @@ -1,20 +1,38 @@ module Distribution.Server.Features.PackageCandidates.Acid ( candidatesStateComponent + , acidStore ) where -import Distribution.Server.Features.PackageCandidates.State +import qualified Distribution.Server.Features.PackageCandidates.State as State import Distribution.Server.Features.PackageCandidates.Backup +import qualified Distribution.Server.Features.PackageCandidates.Store as Store import Distribution.Server.Framework -candidatesStateComponent :: Bool -> FilePath -> IO (StateComponent AcidState CandidatePackages) +acidStore :: FilePath -> IO Store.Backend +acidStore stateDir = do + candidatesState <- candidatesStateComponent False stateDir + pure Store.Backend { + Store.backendStore = Store.Store { + Store.getCandidateIndex = State.candidateList <$> queryState candidatesState State.GetCandidatePackages + , Store.candidateTarballIsMigrated = State.candidateMigratedPkgTarball <$> queryState candidatesState State.GetCandidatePackages + , Store.setCandidateTarballMigrated = updateState candidatesState State.SetMigratedPkgTarball + , Store.addCandidate = \candidate -> updateState candidatesState (State.AddCandidate candidate) + , Store.deleteCandidate = \pkgid -> updateState candidatesState (State.DeleteCandidate pkgid) + , Store.deleteCandidates = \pkgname -> updateState candidatesState (State.DeleteCandidates pkgname) + , Store.updateCandidatePkgInfo = \pkgid pkginfo -> updateState candidatesState (State.UpdateCandidatePkgInfo pkgid pkginfo) + } + , Store.backendState = [abstractAcidStateComponent candidatesState] + } + +candidatesStateComponent :: Bool -> FilePath -> IO (StateComponent AcidState State.CandidatePackages) candidatesStateComponent freshDB stateDir = do st <- openLocalStateFrom (stateDir "db" "CandidatePackages") - (initialCandidatePackages freshDB) + (State.initialCandidatePackages freshDB) return StateComponent { stateDesc = "Candidate packages" , stateHandle = st - , getState = query st GetCandidatePackages - , putState = update st . ReplaceCandidatePackages + , getState = query st State.GetCandidatePackages + , putState = update st . State.ReplaceCandidatePackages , resetState = candidatesStateComponent True , backupState = \_ -> backupCandidates , restoreState = restoreCandidates diff --git a/src/Distribution/Server/Features/PackageCandidates/Store.hs b/src/Distribution/Server/Features/PackageCandidates/Store.hs new file mode 100644 index 000000000..461d67f35 --- /dev/null +++ b/src/Distribution/Server/Features/PackageCandidates/Store.hs @@ -0,0 +1,29 @@ +{-# LANGUAGE RankNTypes #-} + +module Distribution.Server.Features.PackageCandidates.Store + ( Backend(..) + , Store(..) + ) where + +import Distribution.Package (PackageId, PackageName) +import Distribution.Server.Features.PackageCandidates.Types (CandPkgInfo) +import Distribution.Server.Framework (AbstractStateComponent) +import Distribution.Server.Packages.PackageIndex (PackageIndex) +import Distribution.Server.Packages.Types (PkgInfo) + +import Control.Monad.Trans (MonadIO) + +data Backend = Backend { + backendStore :: Store + , backendState :: [AbstractStateComponent] + } + +data Store = Store { + getCandidateIndex :: forall m. MonadIO m => m (PackageIndex CandPkgInfo) + , candidateTarballIsMigrated :: forall m. MonadIO m => m Bool + , setCandidateTarballMigrated :: forall m. MonadIO m => m () + , addCandidate :: forall m. MonadIO m => CandPkgInfo -> m () + , deleteCandidate :: forall m. MonadIO m => PackageId -> m () + , deleteCandidates :: forall m. MonadIO m => PackageName -> m () + , updateCandidatePkgInfo :: forall m. MonadIO m => PackageId -> PkgInfo -> m Bool + } diff --git a/src/Distribution/Server/Features/Security/Migration.hs b/src/Distribution/Server/Features/Security/Migration.hs index c30fe525b..b612c44ef 100644 --- a/src/Distribution/Server/Features/Security/Migration.hs +++ b/src/Distribution/Server/Features/Security/Migration.hs @@ -25,7 +25,6 @@ import Distribution.Package (PackageId) -- hackage import Distribution.Server.Features.Core.State -import Distribution.Server.Features.PackageCandidates.State import Distribution.Server.Features.PackageCandidates.Types import Distribution.Server.Features.Security.Layout import Distribution.Server.Framework hiding (Length) @@ -68,15 +67,15 @@ migratePkgTarball_v1_to_v2 env@ServerEnv{ serverVerbosity = verbosity } -- | Similar migration for candidates migrateCandidatePkgTarball_v1_to_v2 :: ServerEnv - -> StateComponent AcidState CandidatePackages + -> PackageIndex.PackageIndex CandPkgInfo + -> (PackageId -> PkgInfo -> IO ()) -> IO () migrateCandidatePkgTarball_v1_to_v2 env@ServerEnv{ serverVerbosity = verbosity } - candidatesState + candidateIndex updatePackage = do precomputedHashes <- readPrecomputedHashes env - CandidatePackages{candidateList} <- queryState candidatesState GetCandidatePackages - let allCandidates = PackageIndex.allPackages candidateList - partitionSz = PackageIndex.numPackageVersions candidateList `div` 10 + let allCandidates = PackageIndex.allPackages candidateIndex + partitionSz = PackageIndex.numPackageVersions candidateIndex `div` 10 partitioned = partition partitionSz allCandidates stats <- forM (zip [1..] partitioned) $ \(i, candidates) -> do let pkgs = map candPkgInfo candidates @@ -84,12 +83,6 @@ migrateCandidatePkgTarball_v1_to_v2 env@ServerEnv{ serverVerbosity = verbosity } migratePkgs env updatePackage precomputedHashes pkgs loginfo verbosity $ prettyMigrationStats (mconcat stats) where - updatePackage :: PackageId -> PkgInfo -> IO () - updatePackage pkgId pkgInfo = do - _didUpdate <- updateState candidatesState $ - UpdateCandidatePkgInfo pkgId pkgInfo - return () - partitionLogMsg :: Int -> Int -> String partitionLogMsg i n = "Computing candidates blob info " ++ "(" ++ show i ++ "/" ++ show n ++ ")" From c5dd34c307fdaa25df81d6de57f78db4941358be Mon Sep 17 00:00:00 2001 From: Tom Ellis Date: Fri, 25 Sep 2026 16:42:04 +0100 Subject: [PATCH 62/68] (refactor) Move securityStateComponent to Security.Acid --- hackage-server.cabal | 7 +++--- src/Distribution/Server/Features/Security.hs | 21 ++-------------- .../Server/Features/Security/Acid.hs | 24 +++++++++++++++++++ 3 files changed, 30 insertions(+), 22 deletions(-) create mode 100644 src/Distribution/Server/Features/Security/Acid.hs diff --git a/hackage-server.cabal b/hackage-server.cabal index fbf3d71f6..4c50cda79 100644 --- a/hackage-server.cabal +++ b/hackage-server.cabal @@ -310,9 +310,10 @@ library 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 + Distribution.Server.Features.Core.Backup + Distribution.Server.Features.Security + Distribution.Server.Features.Security.Acid + Distribution.Server.Features.Security.Backup Distribution.Server.Features.Security.FileInfo Distribution.Server.Features.Security.Layout Distribution.Server.Features.Security.MD5 diff --git a/src/Distribution/Server/Features/Security.hs b/src/Distribution/Server/Features/Security.hs index 71780d0ce..3704a3c4e 100644 --- a/src/Distribution/Server/Features/Security.hs +++ b/src/Distribution/Server/Features/Security.hs @@ -13,7 +13,7 @@ import qualified Data.ByteString.Lazy.Char8 as BS.Lazy -- Hackage import Distribution.Server.Features.Core -import Distribution.Server.Features.Security.Backup +import qualified Distribution.Server.Features.Security.Acid as Acid import Distribution.Server.Features.Security.Layout import Distribution.Server.Features.Security.ResponseContentTypes import Distribution.Server.Features.Security.State @@ -36,7 +36,7 @@ instance IsHackageFeature SecurityFeature where initSecurityFeature :: ServerEnv -> IO (CoreFeature -> IO SecurityFeature) initSecurityFeature env = do - securityState <- securityStateComponent env (serverStateDir env) + securityState <- Acid.securityStateComponent env (serverStateDir env) return $ \coreFeature -> do -- Update the security state whenever the main package index changes @@ -156,23 +156,6 @@ securityFeature env securityState = enableRange return $ toResponse tufFile -securityStateComponent :: ServerEnv - -> FilePath - -> IO (StateComponent AcidState SecurityState) -securityStateComponent env stateDir = do - let stateFile = stateDir "db" "TUF" - st <- logTiming (serverVerbosity env) "Loaded SecurityState" $ - openLocalStateFrom stateFile initialSecurityState - return StateComponent { - stateDesc = "TUF specific state" - , stateHandle = st - , getState = query st GetSecurityState - , putState = update st . ReplaceSecurityState - , resetState = securityStateComponent env - , backupState = \_ -> securityBackup - , restoreState = securityRestore - } - updateIndexFileInfo :: CoreFeature -> StateComponent AcidState SecurityState -> IO () diff --git a/src/Distribution/Server/Features/Security/Acid.hs b/src/Distribution/Server/Features/Security/Acid.hs new file mode 100644 index 000000000..96e7eb622 --- /dev/null +++ b/src/Distribution/Server/Features/Security/Acid.hs @@ -0,0 +1,24 @@ +module Distribution.Server.Features.Security.Acid + ( securityStateComponent + ) where + +import qualified Distribution.Server.Features.Security.State as State +import Distribution.Server.Features.Security.Backup (securityBackup, securityRestore) +import Distribution.Server.Framework + +securityStateComponent :: ServerEnv + -> FilePath + -> IO (StateComponent AcidState State.SecurityState) +securityStateComponent env stateDir = do + let stateFile = stateDir "db" "TUF" + st <- logTiming (serverVerbosity env) "Loaded SecurityState" $ + openLocalStateFrom stateFile State.initialSecurityState + return StateComponent { + stateDesc = "TUF specific state" + , stateHandle = st + , getState = query st State.GetSecurityState + , putState = update st . State.ReplaceSecurityState + , resetState = securityStateComponent env + , backupState = \_ -> securityBackup + , restoreState = securityRestore + } From 81669b8d55443daeebe98035de2af9ad29d1d0c7 Mon Sep 17 00:00:00 2001 From: Tom Ellis Date: Fri, 25 Sep 2026 16:45:24 +0100 Subject: [PATCH 63/68] (refactor) Introduce Security abstraction layer --- hackage-server.cabal | 1 + src/Distribution/Server/Features/Security.hs | 45 +++++++++---------- .../Server/Features/Security/Acid.hs | 19 ++++++++ .../Server/Features/Security/Store.hs | 29 ++++++++++++ 4 files changed, 71 insertions(+), 23 deletions(-) create mode 100644 src/Distribution/Server/Features/Security/Store.hs diff --git a/hackage-server.cabal b/hackage-server.cabal index 4c50cda79..a4ff40059 100644 --- a/hackage-server.cabal +++ b/hackage-server.cabal @@ -322,6 +322,7 @@ library Distribution.Server.Features.Security.ResponseContentTypes Distribution.Server.Features.Security.SHA256 Distribution.Server.Features.Security.State + Distribution.Server.Features.Security.Store Distribution.Server.Features.Mirror Distribution.Server.Features.Mirror.Acid Distribution.Server.Features.Mirror.Store diff --git a/src/Distribution/Server/Features/Security.hs b/src/Distribution/Server/Features/Security.hs index 3704a3c4e..8baab97d3 100644 --- a/src/Distribution/Server/Features/Security.hs +++ b/src/Distribution/Server/Features/Security.hs @@ -16,6 +16,7 @@ import Distribution.Server.Features.Core import qualified Distribution.Server.Features.Security.Acid as Acid import Distribution.Server.Features.Security.Layout import Distribution.Server.Features.Security.ResponseContentTypes +import qualified Distribution.Server.Features.Security.Store as Store import Distribution.Server.Features.Security.State import Distribution.Server.Features.Security.FileInfo import Distribution.Server.Framework @@ -36,12 +37,13 @@ instance IsHackageFeature SecurityFeature where initSecurityFeature :: ServerEnv -> IO (CoreFeature -> IO SecurityFeature) initSecurityFeature env = do - securityState <- Acid.securityStateComponent env (serverStateDir env) + securityBackend <- Acid.acidStore env (serverStateDir env) return $ \coreFeature -> do + let securityStore = Store.backendStore securityBackend -- Update the security state whenever the main package index changes registerHook (indexUpdatedHook coreFeature) $ \_ -> - updateIndexFileInfo coreFeature securityState + updateIndexFileInfo coreFeature securityStore -- Add package metadata whenever a package is added/changed -- @@ -78,7 +80,7 @@ initSecurityFeature env = do loginfo maxBound (mconcat ["TUF preIndexUpdateHook invoked (", msg, ", n = ", show (length ents), ")"]) return ents - return $ securityFeature env securityState + return $ securityFeature env securityBackend where indexEntriesFor :: PkgInfo -> [TarIndexEntry] indexEntriesFor pkgInfo = @@ -98,17 +100,17 @@ initSecurityFeature env = do -- Note that even once we have author signing, per-package targets.json file -- do not get their own resource, but are instead recorded in the tarball. securityFeature :: ServerEnv - -> StateComponent AcidState SecurityState + -> Store.Backend -> SecurityFeature -securityFeature env securityState = +securityFeature env Store.Backend{backendStore = securityStore, backendState = securityStateComponents} = SecurityFeature{..} where securityFeatureInterface = (emptyHackageFeature "security") { featureDesc = "TUF Security" - , featureState = [abstractAcidStateComponent securityState] - , featureReloadFiles = updateRootMirrorsAndKeys env securityState - , featurePostInit = updateRootMirrorsAndKeys env securityState - >> setupResignCronJob env securityState + , featureState = securityStateComponents + , featureReloadFiles = updateRootMirrorsAndKeys env securityStore + , featurePostInit = updateRootMirrorsAndKeys env securityStore + >> setupResignCronJob env securityStore , featureResources = [ resourceTimestamp , resourceSnapshot @@ -139,7 +141,7 @@ securityFeature env securityState = -> DynamicPath -> ServerPartE Response serveFromState file _ = do - msfiles <- queryState securityState GetSecurityFiles + msfiles <- Store.getSecurityFiles securityStore case msfiles of Nothing -> errNotFound "Security files not available" [MText $ "The repository is not currently using TUF " @@ -157,30 +159,27 @@ securityFeature env securityState = return $ toResponse tufFile updateIndexFileInfo :: CoreFeature - -> StateComponent AcidState SecurityState + -> Store.Store -> IO () -updateIndexFileInfo coreFeature securityState = do +updateIndexFileInfo coreFeature securityStore = do IndexTarballInfo{..} <- queryGetIndexTarballInfo coreFeature let !tarGzFileInfo = fileInfo indexTarballIncremGz !tarFileInfo = fileInfo indexTarballIncremUn now <- getCurrentTime - updateState securityState (SetTarGzFileInfo tarGzFileInfo tarFileInfo now) + Store.setTarGzFileInfo securityStore tarGzFileInfo tarFileInfo now updateRootMirrorsAndKeys :: ServerEnv - -> StateComponent AcidState SecurityState + -> Store.Store -> IO () -updateRootMirrorsAndKeys env securityState = do +updateRootMirrorsAndKeys env securityStore = do mbRootMirrorsAndKeys <- loadRootMirrorsAndKeys env - st <- queryState securityState GetSecurityState + st <- Store.getSecurityState securityStore case mbRootMirrorsAndKeys of Just (root, mirrors, snapshotKey, timestampKey) | anyChange st root mirrors snapshotKey timestampKey -> do loginfo (serverVerbosity env) "Security files changed, updating" now <- getCurrentTime - updateState securityState (SetRootMirrorsAndKeys - root mirrors - snapshotKey timestampKey - now) + Store.setRootMirrorsAndKeys securityStore root mirrors snapshotKey timestampKey now _ -> loginfo (serverVerbosity env) "Security files unchanged" where anyChange SecurityState{ securityStateFiles = Nothing } _ _ _ _ = True @@ -210,16 +209,16 @@ loadRootMirrorsAndKeys env = do return (Just (root, mirrors, snapshotKey, timestampKey)) setupResignCronJob :: ServerEnv - -> StateComponent AcidState SecurityState + -> Store.Store -> IO () -setupResignCronJob env securityState = +setupResignCronJob env securityStore = addCronJob (serverCron env) CronJob { cronJobName = "Resign TUF data" , cronJobFrequency = DailyJobFrequency , cronJobOneShot = False , cronJobAction = do now <- getCurrentTime - updateState securityState (ResignSnapshotAndTimestamp maxAge now) + Store.resignSnapshotAndTimestamp securityStore maxAge now } where maxAge = 60 * 60 * 23 -- Don't resign if unchanged and younger than ~1 day diff --git a/src/Distribution/Server/Features/Security/Acid.hs b/src/Distribution/Server/Features/Security/Acid.hs index 96e7eb622..37f4140e2 100644 --- a/src/Distribution/Server/Features/Security/Acid.hs +++ b/src/Distribution/Server/Features/Security/Acid.hs @@ -1,11 +1,30 @@ module Distribution.Server.Features.Security.Acid ( securityStateComponent + , acidStore ) where import qualified Distribution.Server.Features.Security.State as State import Distribution.Server.Features.Security.Backup (securityBackup, securityRestore) +import qualified Distribution.Server.Features.Security.Store as Store import Distribution.Server.Framework +acidStore :: ServerEnv -> FilePath -> IO Store.Backend +acidStore env stateDir = do + securityState <- securityStateComponent env stateDir + pure Store.Backend { + Store.backendStore = Store.Store { + Store.getSecurityState = queryState securityState State.GetSecurityState + , Store.getSecurityFiles = queryState securityState State.GetSecurityFiles + , Store.setRootMirrorsAndKeys = \root mirrors snapshotKey timestampKey now -> + updateState securityState (State.SetRootMirrorsAndKeys root mirrors snapshotKey timestampKey now) + , Store.setTarGzFileInfo = \tarGzInfo tarInfo now -> + updateState securityState (State.SetTarGzFileInfo tarGzInfo tarInfo now) + , Store.resignSnapshotAndTimestamp = \maxAge now -> + updateState securityState (State.ResignSnapshotAndTimestamp maxAge now) + } + , Store.backendState = [abstractAcidStateComponent securityState] + } + securityStateComponent :: ServerEnv -> FilePath -> IO (StateComponent AcidState State.SecurityState) diff --git a/src/Distribution/Server/Features/Security/Store.hs b/src/Distribution/Server/Features/Security/Store.hs new file mode 100644 index 000000000..fc4a02984 --- /dev/null +++ b/src/Distribution/Server/Features/Security/Store.hs @@ -0,0 +1,29 @@ +{-# LANGUAGE RankNTypes #-} + +module Distribution.Server.Features.Security.Store + ( Backend(..) + , Store(..) + ) where + +import Distribution.Server.Features.Security.FileInfo (FileInfo) +import Distribution.Server.Features.Security.ResponseContentTypes (Mirrors, Root) +import Distribution.Server.Features.Security.State (SecurityState, SecurityStateFiles) +import Distribution.Server.Framework (AbstractStateComponent) + +import Control.Monad.Trans (MonadIO) +import Data.Time (UTCTime) +import Hackage.Security.Util.Some (Some) +import qualified Hackage.Security.Server as Sec + +data Backend = Backend { + backendStore :: Store + , backendState :: [AbstractStateComponent] + } + +data Store = Store { + getSecurityState :: forall m. MonadIO m => m SecurityState + , getSecurityFiles :: forall m. MonadIO m => m (Maybe SecurityStateFiles) + , setRootMirrorsAndKeys :: forall m. MonadIO m => Root -> Mirrors -> Some Sec.Key -> Some Sec.Key -> UTCTime -> m () + , setTarGzFileInfo :: forall m. MonadIO m => FileInfo -> FileInfo -> UTCTime -> m () + , resignSnapshotAndTimestamp :: forall m. MonadIO m => Int -> UTCTime -> m () + } From 9fb4363fcf6bb0cabc1c22ed20c7fd73ddcb37b6 Mon Sep 17 00:00:00 2001 From: Tom Ellis Date: Fri, 25 Sep 2026 16:47:52 +0100 Subject: [PATCH 64/68] (refactor) Move user state components to Users.Acid --- hackage-server.cabal | 1 + src/Distribution/Server/Features/Users.hs | 33 ++--------------- .../Server/Features/Users/Acid.hs | 36 +++++++++++++++++++ 3 files changed, 40 insertions(+), 30 deletions(-) create mode 100644 src/Distribution/Server/Features/Users/Acid.hs diff --git a/hackage-server.cabal b/hackage-server.cabal index a4ff40059..7826e6a75 100644 --- a/hackage-server.cabal +++ b/hackage-server.cabal @@ -332,6 +332,7 @@ library Distribution.Server.Features.Upload.State Distribution.Server.Features.Upload.Backup Distribution.Server.Features.Users + Distribution.Server.Features.Users.Acid Distribution.Server.Features.UserNotify Distribution.Server.Features.UserNotify.Acid Distribution.Server.Features.UserNotify.Acid.Component diff --git a/src/Distribution/Server/Features/Users.hs b/src/Distribution/Server/Features/Users.hs index b158521a7..20853b9e5 100644 --- a/src/Distribution/Server/Features/Users.hs +++ b/src/Distribution/Server/Features/Users.hs @@ -10,14 +10,13 @@ module Distribution.Server.Features.Users ( ) where import Distribution.Server.Framework -import Distribution.Server.Framework.BackupDump import Distribution.Server.Framework.Templating import qualified Distribution.Server.Framework.Auth as Auth import Distribution.Server.Users.Types import qualified Distribution.Server.Users.State as Acid -import Distribution.Server.Users.Backup import qualified Distribution.Server.Users.Users as Acid +import qualified Distribution.Server.Features.Users.Acid as UserAcid import qualified Distribution.Server.Users.Group as Group import Distribution.Server.Users.Group (UserGroup(..), GroupDescription(..), UserIdSet, nullDescription) @@ -230,8 +229,8 @@ deriveJSON (compatAesonOptionsDropPrefix "ui_") ''UserGroupResource initUserFeature :: ServerEnv -> IO (IO UserFeature) initUserFeature serverEnv@ServerEnv{serverStateDir, serverTemplatesDir, serverTemplatesMode} = do -- Canonical state - usersState <- usersStateComponent serverStateDir - adminsState <- adminsStateComponent serverStateDir + usersState <- UserAcid.usersStateComponent serverStateDir + adminsState <- UserAcid.adminsStateComponent serverStateDir -- Ephemeral state groupIndex <- newMemStateWHNF emptyGroupIndex @@ -268,32 +267,6 @@ initUserFeature serverEnv@ServerEnv{serverStateDir, serverTemplatesDir, serverTe return feature -usersStateComponent :: FilePath -> IO (StateComponent AcidState Acid.Users) -usersStateComponent stateDir = do - st <- openLocalStateFrom (stateDir "db" "Users") Acid.initialUsers - return StateComponent { - stateDesc = "List of users" - , stateHandle = st - , getState = query st Acid.GetUserDb - , putState = update st . Acid.ReplaceUserDb - , backupState = usersBackup - , restoreState = usersRestore - , resetState = usersStateComponent - } - -adminsStateComponent :: FilePath -> IO (StateComponent AcidState Acid.HackageAdmins) -adminsStateComponent stateDir = do - st <- openLocalStateFrom (stateDir "db" "HackageAdmins") Acid.initialHackageAdmins - return StateComponent { - stateDesc = "Admins" - , stateHandle = st - , getState = query st Acid.GetHackageAdmins - , putState = update st . Acid.ReplaceHackageAdmins . Acid.adminList - , backupState = \_ (Acid.HackageAdmins admins) -> [csvToBackup ["admins.csv"] (groupToCSV admins)] - , restoreState = Acid.HackageAdmins <$> groupBackup ["admins.csv"] - , resetState = adminsStateComponent - } - userFeature :: Templates -> StateComponent AcidState Acid.Users -> StateComponent AcidState Acid.HackageAdmins diff --git a/src/Distribution/Server/Features/Users/Acid.hs b/src/Distribution/Server/Features/Users/Acid.hs new file mode 100644 index 000000000..d1c55d3ad --- /dev/null +++ b/src/Distribution/Server/Features/Users/Acid.hs @@ -0,0 +1,36 @@ +module Distribution.Server.Features.Users.Acid + ( usersStateComponent + , adminsStateComponent + ) where + +import Distribution.Server.Framework +import Distribution.Server.Framework.BackupDump +import Distribution.Server.Users.Backup +import qualified Distribution.Server.Users.State as Acid +import qualified Distribution.Server.Users.Users as Acid + +usersStateComponent :: FilePath -> IO (StateComponent AcidState Acid.Users) +usersStateComponent stateDir = do + st <- openLocalStateFrom (stateDir "db" "Users") Acid.initialUsers + return StateComponent { + stateDesc = "List of users" + , stateHandle = st + , getState = query st Acid.GetUserDb + , putState = update st . Acid.ReplaceUserDb + , backupState = usersBackup + , restoreState = usersRestore + , resetState = usersStateComponent + } + +adminsStateComponent :: FilePath -> IO (StateComponent AcidState Acid.HackageAdmins) +adminsStateComponent stateDir = do + st <- openLocalStateFrom (stateDir "db" "HackageAdmins") Acid.initialHackageAdmins + return StateComponent { + stateDesc = "Admins" + , stateHandle = st + , getState = query st Acid.GetHackageAdmins + , putState = update st . Acid.ReplaceHackageAdmins . Acid.adminList + , backupState = \_ (Acid.HackageAdmins admins) -> [csvToBackup ["admins.csv"] (groupToCSV admins)] + , restoreState = Acid.HackageAdmins <$> groupBackup ["admins.csv"] + , resetState = adminsStateComponent + } From b559c00f5f2b8ed9fbb51fc4c4aa53cf986857ab Mon Sep 17 00:00:00 2001 From: Tom Ellis Date: Sun, 27 Sep 2026 13:23:20 +0100 Subject: [PATCH 65/68] (refactor) Name user state components --- src/Distribution/Server/Features/Users.hs | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/src/Distribution/Server/Features/Users.hs b/src/Distribution/Server/Features/Users.hs index 20853b9e5..3db9a9134 100644 --- a/src/Distribution/Server/Features/Users.hs +++ b/src/Distribution/Server/Features/Users.hs @@ -283,6 +283,11 @@ userFeature templates usersState adminsState adminGroup adminResource userFeatureServerEnv = (UserFeature {..}, adminGroupDesc) where + userStateComponents = [ + abstractAcidStateComponent usersState + , abstractAcidStateComponent adminsState + ] + userFeatureInterface = (emptyHackageFeature "users") { featureDesc = "Manipulate the user database." , featureResources = From f15b7580c936514cdad36912c60f8e94334a184f Mon Sep 17 00:00:00 2001 From: Tom Ellis Date: Sun, 27 Sep 2026 13:23:24 +0100 Subject: [PATCH 66/68] (refactor) Introduce Users abstraction layer --- hackage-server.cabal | 1 + src/Distribution/Server/Features/Users.hs | 59 ++++++++----------- .../Server/Features/Users/Acid.hs | 25 ++++++++ .../Server/Features/Users/Store.hs | 39 ++++++++++++ 4 files changed, 89 insertions(+), 35 deletions(-) create mode 100644 src/Distribution/Server/Features/Users/Store.hs diff --git a/hackage-server.cabal b/hackage-server.cabal index 7826e6a75..155c89756 100644 --- a/hackage-server.cabal +++ b/hackage-server.cabal @@ -333,6 +333,7 @@ library Distribution.Server.Features.Upload.Backup Distribution.Server.Features.Users Distribution.Server.Features.Users.Acid + Distribution.Server.Features.Users.Store Distribution.Server.Features.UserNotify Distribution.Server.Features.UserNotify.Acid Distribution.Server.Features.UserNotify.Acid.Component diff --git a/src/Distribution/Server/Features/Users.hs b/src/Distribution/Server/Features/Users.hs index 3db9a9134..227098bf3 100644 --- a/src/Distribution/Server/Features/Users.hs +++ b/src/Distribution/Server/Features/Users.hs @@ -14,9 +14,9 @@ import Distribution.Server.Framework.Templating import qualified Distribution.Server.Framework.Auth as Auth import Distribution.Server.Users.Types -import qualified Distribution.Server.Users.State as Acid import qualified Distribution.Server.Users.Users as Acid import qualified Distribution.Server.Features.Users.Acid as UserAcid +import qualified Distribution.Server.Features.Users.Store as UserStore import qualified Distribution.Server.Users.Group as Group import Distribution.Server.Users.Group (UserGroup(..), GroupDescription(..), UserIdSet, nullDescription) @@ -229,8 +229,7 @@ deriveJSON (compatAesonOptionsDropPrefix "ui_") ''UserGroupResource initUserFeature :: ServerEnv -> IO (IO UserFeature) initUserFeature serverEnv@ServerEnv{serverStateDir, serverTemplatesDir, serverTemplatesMode} = do -- Canonical state - usersState <- UserAcid.usersStateComponent serverStateDir - adminsState <- UserAcid.adminsStateComponent serverStateDir + userBackend <- UserAcid.acidStore serverStateDir -- Ephemeral state groupIndex <- newMemStateWHNF emptyGroupIndex @@ -256,8 +255,7 @@ initUserFeature serverEnv@ServerEnv{serverStateDir, serverTemplatesDir, serverTe -- rec let (feature@UserFeature{groupResourceAt}, adminGroupDesc) = userFeature templates - usersState - adminsState + userBackend groupIndex userAdded authFailHook groupChangedHook adminG adminR @@ -268,8 +266,7 @@ initUserFeature serverEnv@ServerEnv{serverStateDir, serverTemplatesDir, serverTe return feature userFeature :: Templates - -> StateComponent AcidState Acid.Users - -> StateComponent AcidState Acid.HackageAdmins + -> UserStore.Backend -> MemState GroupIndex -> Hook () () -> Hook Auth.AuthError (Maybe ErrorResponse) @@ -278,16 +275,11 @@ userFeature :: Templates -> GroupResource -> ServerEnv -> (UserFeature, UserGroup) -userFeature templates usersState adminsState +userFeature templates UserStore.Backend{backendStore = userStore, backendState = userStateComponents} groupIndex userAdded authFailHook groupChangedHook adminGroup adminResource userFeatureServerEnv = (UserFeature {..}, adminGroupDesc) where - userStateComponents = [ - abstractAcidStateComponent usersState - , abstractAcidStateComponent adminsState - ] - userFeatureInterface = (emptyHackageFeature "users") { featureDesc = "Manipulate the user database." , featureResources = @@ -303,10 +295,7 @@ userFeature templates usersState adminsState groupResource adminResource , groupUserResource adminResource ] - , featureState = [ - abstractAcidStateComponent usersState - , abstractAcidStateComponent adminsState - ] + , featureState = userStateComponents , featureCaches = [ CacheComponent { cacheDesc = "user group index", @@ -375,18 +364,18 @@ userFeature templates usersState adminsState -- queryGetUserDb :: MonadIO m => m Acid.Users - queryGetUserDb = queryState usersState Acid.GetUserDb + queryGetUserDb = UserStore.getUsers userStore updateAddUser :: MonadIO m => UserName -> UserAuth -> m (Either Acid.ErrUserNameClash UserId) - updateAddUser uname auth = updateState usersState (Acid.AddUserEnabled uname auth) + updateAddUser = UserStore.addUser userStore updateSetUserEnabledStatus :: MonadIO m => UserId -> Bool -> m (Maybe (Either Acid.ErrNoSuchUserId Acid.ErrDeletedUser)) - updateSetUserEnabledStatus uid isenabled = updateState usersState (Acid.SetUserEnabledStatus uid isenabled) + updateSetUserEnabledStatus = UserStore.setUserEnabledStatus userStore updateSetUserAuth :: MonadIO m => UserId -> UserAuth -> m (Maybe (Either Acid.ErrNoSuchUserId Acid.ErrDeletedUser)) - updateSetUserAuth uid auth = updateState usersState (Acid.SetUserAuth uid auth) + updateSetUserAuth = UserStore.setUserAuth userStore -- -- Authorisation: authentication checks and privilege checks @@ -533,7 +522,7 @@ userFeature templates usersState adminsState serveUserPut dpath = do guardAuthorised_ [InGroup adminGroup] username <- userNameInPath dpath - muid <- updateState usersState $ Acid.AddUserDisabled username + muid <- UserStore.addDisabledUser userStore username case muid of Left Acid.ErrUserNameClash -> errBadRequest "Username already exists" @@ -548,7 +537,7 @@ userFeature templates usersState adminsState serveUserDelete dpath = do guardAuthorised_ [InGroup adminGroup] uid <- lookupUserName =<< userNameInPath dpath - merr <- updateState usersState $ Acid.DeleteUser uid + merr <- UserStore.deleteUser userStore uid case merr of Nothing -> noContent $ toResponse () --TODO: need to be able to delete user by name to fix this race condition @@ -568,7 +557,7 @@ userFeature templates usersState adminsState guardAuthorised_ [InGroup adminGroup] uid <- lookupUserName =<< userNameInPath dpath EnabledResource enabled <- expectAesonContent - merr <- updateState usersState (Acid.SetUserEnabledStatus uid enabled) + merr <- UserStore.setUserEnabledStatus userStore uid enabled case merr of Nothing -> noContent $ toResponse () Just (Left Acid.ErrNoSuchUserId) -> @@ -612,7 +601,7 @@ userFeature templates usersState adminsState template <- getTemplate templates "token-created.html" origTok <- liftIO generateOriginalToken let storeTok = convertToken origTok - res <- updateState usersState (Acid.AddAuthToken uid storeTok desc) + res <- UserStore.addAuthToken userStore uid storeTok desc case res of Nothing -> ok $ toResponse $ @@ -631,7 +620,7 @@ userFeature templates usersState adminsState [MText "The auth token provided is malformed: " ,MText err] Right authToken -> do - res <- updateState usersState (Acid.RevokeAuthToken uid authToken) + res <- UserStore.revokeAuthToken userStore uid authToken case res of Nothing -> ok $ toResponse $ @@ -656,7 +645,7 @@ userFeature templates usersState adminsState lookupUserNameFull :: UserName -> ServerPartE (UserId, UserInfo) lookupUserNameFull uname = do - users <- queryState usersState Acid.GetUserDb + users <- UserStore.getUsers userStore case Acid.lookupUserName uname users of Just u -> return u Nothing -> userLost "Could not find user: not presently registered" @@ -667,7 +656,7 @@ userFeature templates usersState adminsState lookupUserInfo :: UserId -> ServerPartE UserInfo lookupUserInfo uid = do - users <- queryState usersState Acid.GetUserDb + users <- UserStore.getUsers userStore case Acid.lookupUserId uid users of Just uinfo -> return uinfo Nothing -> errInternalError [MText "user id does not exist"] @@ -695,7 +684,7 @@ userFeature templates usersState adminsState Nothing -> errBadRequest "Error registering user" [MText "Not a valid user name!"] Just uname -> do let auth = newUserAuth uname password - muid <- updateState usersState $ Acid.AddUserEnabled uname auth + muid <- UserStore.addUser userStore uname auth case muid of Left Acid.ErrUserNameClash -> errForbidden "Error registering user" [MText "A user account with that user name already exists."] Right _ -> return uname @@ -703,7 +692,7 @@ userFeature templates usersState adminsState -- Arguments: the auth'd user id, the user path id (derived from the :username) canChangePassword :: MonadIO m => UserId -> UserId -> m Bool canChangePassword uid userPathId = do - admins <- queryState adminsState Acid.GetAdminList + admins <- UserStore.getAdminList userStore return $ uid == userPathId || (uid `Group.member` admins) --FIXME: this thing is a total mess! @@ -718,7 +707,7 @@ userFeature templates usersState adminsState forbidChange "Copies of new password do not match or is an invalid password (ex: blank)" let passwd = PasswdPlain passwd1 auth = newUserAuth username passwd - res <- updateState usersState (Acid.SetUserAuth uid auth) + res <- UserStore.setUserAuth userStore uid auth case res of Nothing -> return () Just (Left Acid.ErrNoSuchUserId) -> errInternalError [MText "user id lookup failure"] @@ -733,9 +722,9 @@ userFeature templates usersState adminsState adminGroupDesc :: UserGroup adminGroupDesc = UserGroup { groupDesc = nullDescription { groupTitle = "Hackage admins" }, - queryUserGroup = queryState adminsState Acid.GetAdminList, - addUserToGroup = updateState adminsState . Acid.AddHackageAdmin, - removeUserFromGroup = updateState adminsState . Acid.RemoveHackageAdmin, + queryUserGroup = UserStore.getAdminList userStore, + addUserToGroup = UserStore.addAdmin userStore, + removeUserFromGroup = UserStore.removeAdmin userStore, groupsAllowedToAdd = [adminGroupDesc], groupsAllowedToDelete = [adminGroupDesc] } @@ -743,7 +732,7 @@ userFeature templates usersState adminsState groupAddUser :: UserGroup -> DynamicPath -> ServerPartE () groupAddUser group _ = do actorUid <- guardAuthorised (map InGroup (groupsAllowedToAdd group)) - users <- queryState usersState Acid.GetUserDb + users <- UserStore.getUsers userStore muser <- optional $ look "user" reason <- optional $ look "reason" case muser of diff --git a/src/Distribution/Server/Features/Users/Acid.hs b/src/Distribution/Server/Features/Users/Acid.hs index d1c55d3ad..1f424c1b8 100644 --- a/src/Distribution/Server/Features/Users/Acid.hs +++ b/src/Distribution/Server/Features/Users/Acid.hs @@ -1,14 +1,39 @@ module Distribution.Server.Features.Users.Acid ( usersStateComponent , adminsStateComponent + , acidStore ) where +import qualified Distribution.Server.Features.Users.Store as Store import Distribution.Server.Framework import Distribution.Server.Framework.BackupDump import Distribution.Server.Users.Backup import qualified Distribution.Server.Users.State as Acid import qualified Distribution.Server.Users.Users as Acid +acidStore :: FilePath -> IO Store.Backend +acidStore stateDir = do + usersState <- usersStateComponent stateDir + adminsState <- adminsStateComponent stateDir + pure Store.Backend { + Store.backendStore = Store.Store { + Store.getUsers = queryState usersState Acid.GetUserDb + , Store.addUser = \uname auth -> updateState usersState (Acid.AddUserEnabled uname auth) + , Store.addDisabledUser = \uname -> updateState usersState (Acid.AddUserDisabled uname) + , Store.setUserEnabledStatus = \uid enabled -> updateState usersState (Acid.SetUserEnabledStatus uid enabled) + , Store.deleteUser = \uid -> updateState usersState (Acid.DeleteUser uid) + , Store.setUserAuth = \uid auth -> updateState usersState (Acid.SetUserAuth uid auth) + , Store.addAuthToken = \uid token description -> updateState usersState (Acid.AddAuthToken uid token description) + , Store.revokeAuthToken = \uid token -> updateState usersState (Acid.RevokeAuthToken uid token) + , Store.getAdminList = queryState adminsState Acid.GetAdminList + , Store.addAdmin = updateState adminsState . Acid.AddHackageAdmin + , Store.removeAdmin = updateState adminsState . Acid.RemoveHackageAdmin + } + , Store.backendState = [ abstractAcidStateComponent usersState + , abstractAcidStateComponent adminsState + ] + } + usersStateComponent :: FilePath -> IO (StateComponent AcidState Acid.Users) usersStateComponent stateDir = do st <- openLocalStateFrom (stateDir "db" "Users") Acid.initialUsers diff --git a/src/Distribution/Server/Features/Users/Store.hs b/src/Distribution/Server/Features/Users/Store.hs new file mode 100644 index 000000000..a68989f89 --- /dev/null +++ b/src/Distribution/Server/Features/Users/Store.hs @@ -0,0 +1,39 @@ +{-# LANGUAGE RankNTypes #-} + +module Distribution.Server.Features.Users.Store + ( Backend(..) + , Store(..) + ) where + +import Distribution.Server.Framework (AbstractStateComponent) +import Distribution.Server.Users.Group (UserIdSet) +import Distribution.Server.Users.Types (AuthToken, UserAuth, UserId, UserName) +import Distribution.Server.Users.Users + ( Users + , ErrUserNameClash + , ErrNoSuchUserId + , ErrDeletedUser + , ErrTokenNotOwned + ) + +import Control.Monad.Trans (MonadIO) +import Data.Text (Text) + +data Backend = Backend { + backendStore :: Store + , backendState :: [AbstractStateComponent] + } + +data Store = Store { + getUsers :: forall m. MonadIO m => m Users + , addUser :: forall m. MonadIO m => UserName -> UserAuth -> m (Either ErrUserNameClash UserId) + , addDisabledUser :: forall m. MonadIO m => UserName -> m (Either ErrUserNameClash UserId) + , setUserEnabledStatus :: forall m. MonadIO m => UserId -> Bool -> m (Maybe (Either ErrNoSuchUserId ErrDeletedUser)) + , deleteUser :: forall m. MonadIO m => UserId -> m (Maybe ErrNoSuchUserId) + , setUserAuth :: forall m. MonadIO m => UserId -> UserAuth -> m (Maybe (Either ErrNoSuchUserId ErrDeletedUser)) + , addAuthToken :: forall m. MonadIO m => UserId -> AuthToken -> Text -> m (Maybe ErrNoSuchUserId) + , revokeAuthToken :: forall m. MonadIO m => UserId -> AuthToken -> m (Maybe (Either ErrNoSuchUserId ErrTokenNotOwned)) + , getAdminList :: forall m. MonadIO m => m UserIdSet + , addAdmin :: forall m. MonadIO m => UserId -> m () + , removeAdmin :: forall m. MonadIO m => UserId -> m () + } From 92623c0f772422deea2560b83a231de0426dd0ab Mon Sep 17 00:00:00 2001 From: Tom Ellis Date: Fri, 25 Sep 2026 16:51:54 +0100 Subject: [PATCH 67/68] (refactor) Move upload state components to Upload.Acid --- hackage-server.cabal | 1 + src/Distribution/Server/Features/Upload.hs | 49 ++---------------- .../Server/Features/Upload/Acid.hs | 50 +++++++++++++++++++ 3 files changed, 55 insertions(+), 45 deletions(-) create mode 100644 src/Distribution/Server/Features/Upload/Acid.hs diff --git a/hackage-server.cabal b/hackage-server.cabal index 155c89756..9f4dc2a86 100644 --- a/hackage-server.cabal +++ b/hackage-server.cabal @@ -329,6 +329,7 @@ library Distribution.Server.Features.TarIndexCache.Acid Distribution.Server.Features.TarIndexCache.Store Distribution.Server.Features.Upload + Distribution.Server.Features.Upload.Acid Distribution.Server.Features.Upload.State Distribution.Server.Features.Upload.Backup Distribution.Server.Features.Users diff --git a/src/Distribution/Server/Features/Upload.hs b/src/Distribution/Server/Features/Upload.hs index d01da0dc4..e31e5cd9f 100644 --- a/src/Distribution/Server/Features/Upload.hs +++ b/src/Distribution/Server/Features/Upload.hs @@ -7,15 +7,13 @@ module Distribution.Server.Features.Upload ( ) where import Distribution.Server.Framework -import Distribution.Server.Framework.BackupDump import qualified Distribution.Server.Features.Upload.State as Acid -import Distribution.Server.Features.Upload.Backup +import qualified Distribution.Server.Features.Upload.Acid as UploadAcid import Distribution.Server.Features.Core import Distribution.Server.Features.Users -import Distribution.Server.Users.Backup import Distribution.Server.Packages.Types import qualified Distribution.Server.Users.Types as Users import qualified Distribution.Server.Users.Group as Group @@ -109,9 +107,9 @@ initUploadFeature :: ServerEnv -> IO (UserFeature -> CoreFeature -> IO UploadFeature) initUploadFeature env@ServerEnv{serverStateDir} = do -- Canonical state - trusteesState <- trusteesStateComponent serverStateDir - uploadersState <- uploadersStateComponent serverStateDir - maintainersState <- maintainersStateComponent serverStateDir + trusteesState <- UploadAcid.trusteesStateComponent serverStateDir + uploadersState <- UploadAcid.uploadersStateComponent serverStateDir + maintainersState <- UploadAcid.maintainersStateComponent serverStateDir packageUploaded <- newHook @@ -145,45 +143,6 @@ initUploadFeature env@ServerEnv{serverStateDir} = do return feature -trusteesStateComponent :: FilePath -> IO (StateComponent AcidState Acid.HackageTrustees) -trusteesStateComponent stateDir = do - st <- openLocalStateFrom (stateDir "db" "HackageTrustees") Acid.initialHackageTrustees - return StateComponent { - stateDesc = "Trustees" - , stateHandle = st - , getState = query st Acid.GetHackageTrustees - , putState = update st . Acid.ReplaceHackageTrustees . Acid.trusteeList - , backupState = \_ (Acid.HackageTrustees trustees) -> [csvToBackup ["trustees.csv"] $ groupToCSV trustees] - , restoreState = Acid.HackageTrustees <$> groupBackup ["trustees.csv"] - , resetState = trusteesStateComponent - } - -uploadersStateComponent :: FilePath -> IO (StateComponent AcidState Acid.HackageUploaders) -uploadersStateComponent stateDir = do - st <- openLocalStateFrom (stateDir "db" "HackageUploaders") Acid.initialHackageUploaders - return StateComponent { - stateDesc = "Uploaders" - , stateHandle = st - , getState = query st Acid.GetHackageUploaders - , putState = update st . Acid.ReplaceHackageUploaders . Acid.uploaderList - , backupState = \_ (Acid.HackageUploaders uploaders) -> [csvToBackup ["uploaders.csv"] $ groupToCSV uploaders] - , restoreState = Acid.HackageUploaders <$> groupBackup ["uploaders.csv"] - , resetState = uploadersStateComponent - } - -maintainersStateComponent :: FilePath -> IO (StateComponent AcidState Acid.PackageMaintainers) -maintainersStateComponent stateDir = do - st <- openLocalStateFrom (stateDir "db" "PackageMaintainers") Acid.initialPackageMaintainers - return StateComponent { - stateDesc = "Package maintainers" - , stateHandle = st - , getState = query st Acid.AllPackageMaintainers - , putState = update st . Acid.ReplacePackageMaintainers - , backupState = \_ (Acid.PackageMaintainers mains) -> [maintToExport mains] - , restoreState = maintainerBackup - , resetState = maintainersStateComponent - } - uploadFeature :: ServerEnv -> CoreFeature -> UserFeature diff --git a/src/Distribution/Server/Features/Upload/Acid.hs b/src/Distribution/Server/Features/Upload/Acid.hs new file mode 100644 index 000000000..b6982a604 --- /dev/null +++ b/src/Distribution/Server/Features/Upload/Acid.hs @@ -0,0 +1,50 @@ +module Distribution.Server.Features.Upload.Acid + ( trusteesStateComponent + , uploadersStateComponent + , maintainersStateComponent + ) where + +import Distribution.Server.Framework +import Distribution.Server.Framework.BackupDump +import Distribution.Server.Features.Upload.Backup (maintToExport, maintainerBackup) +import qualified Distribution.Server.Features.Upload.State as Acid +import Distribution.Server.Users.Backup + +trusteesStateComponent :: FilePath -> IO (StateComponent AcidState Acid.HackageTrustees) +trusteesStateComponent stateDir = do + st <- openLocalStateFrom (stateDir "db" "HackageTrustees") Acid.initialHackageTrustees + return StateComponent { + stateDesc = "Trustees" + , stateHandle = st + , getState = query st Acid.GetHackageTrustees + , putState = update st . Acid.ReplaceHackageTrustees . Acid.trusteeList + , backupState = \_ (Acid.HackageTrustees trustees) -> [csvToBackup ["trustees.csv"] $ groupToCSV trustees] + , restoreState = Acid.HackageTrustees <$> groupBackup ["trustees.csv"] + , resetState = trusteesStateComponent + } + +uploadersStateComponent :: FilePath -> IO (StateComponent AcidState Acid.HackageUploaders) +uploadersStateComponent stateDir = do + st <- openLocalStateFrom (stateDir "db" "HackageUploaders") Acid.initialHackageUploaders + return StateComponent { + stateDesc = "Uploaders" + , stateHandle = st + , getState = query st Acid.GetHackageUploaders + , putState = update st . Acid.ReplaceHackageUploaders . Acid.uploaderList + , backupState = \_ (Acid.HackageUploaders uploaders) -> [csvToBackup ["uploaders.csv"] $ groupToCSV uploaders] + , restoreState = Acid.HackageUploaders <$> groupBackup ["uploaders.csv"] + , resetState = uploadersStateComponent + } + +maintainersStateComponent :: FilePath -> IO (StateComponent AcidState Acid.PackageMaintainers) +maintainersStateComponent stateDir = do + st <- openLocalStateFrom (stateDir "db" "PackageMaintainers") Acid.initialPackageMaintainers + return StateComponent { + stateDesc = "Package maintainers" + , stateHandle = st + , getState = query st Acid.AllPackageMaintainers + , putState = update st . Acid.ReplacePackageMaintainers + , backupState = \_ (Acid.PackageMaintainers mains) -> [maintToExport mains] + , restoreState = maintainerBackup + , resetState = maintainersStateComponent + } From 557e789b3427d67eaa21daa999595907ca12488d Mon Sep 17 00:00:00 2001 From: Tom Ellis Date: Fri, 25 Sep 2026 16:54:09 +0100 Subject: [PATCH 68/68] (refactor) Introduce Upload abstraction layer --- hackage-server.cabal | 1 + src/Distribution/Server/Features/Upload.hs | 51 +++++++++---------- .../Server/Features/Upload/Acid.hs | 25 +++++++++ .../Server/Features/Upload/Store.hs | 31 +++++++++++ 4 files changed, 81 insertions(+), 27 deletions(-) create mode 100644 src/Distribution/Server/Features/Upload/Store.hs diff --git a/hackage-server.cabal b/hackage-server.cabal index 9f4dc2a86..ac0972b60 100644 --- a/hackage-server.cabal +++ b/hackage-server.cabal @@ -330,6 +330,7 @@ library Distribution.Server.Features.TarIndexCache.Store Distribution.Server.Features.Upload Distribution.Server.Features.Upload.Acid + Distribution.Server.Features.Upload.Store Distribution.Server.Features.Upload.State Distribution.Server.Features.Upload.Backup Distribution.Server.Features.Users diff --git a/src/Distribution/Server/Features/Upload.hs b/src/Distribution/Server/Features/Upload.hs index e31e5cd9f..03cca15ba 100644 --- a/src/Distribution/Server/Features/Upload.hs +++ b/src/Distribution/Server/Features/Upload.hs @@ -8,8 +8,8 @@ module Distribution.Server.Features.Upload ( import Distribution.Server.Framework -import qualified Distribution.Server.Features.Upload.State as Acid import qualified Distribution.Server.Features.Upload.Acid as UploadAcid +import qualified Distribution.Server.Features.Upload.Store as UploadStore import Distribution.Server.Features.Core import Distribution.Server.Features.Users @@ -107,9 +107,7 @@ initUploadFeature :: ServerEnv -> IO (UserFeature -> CoreFeature -> IO UploadFeature) initUploadFeature env@ServerEnv{serverStateDir} = do -- Canonical state - trusteesState <- UploadAcid.trusteesStateComponent serverStateDir - uploadersState <- UploadAcid.uploadersStateComponent serverStateDir - maintainersState <- UploadAcid.maintainersStateComponent serverStateDir + uploadBackend <- UploadAcid.acidStore serverStateDir packageUploaded <- newHook @@ -122,9 +120,10 @@ initUploadFeature env@ServerEnv{serverStateDir} = do trusteesGroupDescription, uploadersGroupDescription, maintainersGroupDescription) = uploadFeature env core user - trusteesState trusteesGroup trusteesGroupResource - uploadersState uploadersGroup uploadersGroupResource - maintainersState maintainersGroup maintainersGroupResource + uploadBackend + trusteesGroup trusteesGroupResource + uploadersGroup uploadersGroupResource + maintainersGroup maintainersGroupResource packageUploaded (trusteesGroup, trusteesGroupResource) <- @@ -146,9 +145,10 @@ initUploadFeature env@ServerEnv{serverStateDir} = do uploadFeature :: ServerEnv -> CoreFeature -> UserFeature - -> StateComponent AcidState Acid.HackageTrustees -> UserGroup -> GroupResource - -> StateComponent AcidState Acid.HackageUploaders -> UserGroup -> GroupResource - -> StateComponent AcidState Acid.PackageMaintainers -> (PackageName -> UserGroup) -> GroupResource + -> UploadStore.Backend + -> UserGroup -> GroupResource + -> UserGroup -> GroupResource + -> (PackageName -> UserGroup) -> GroupResource -> Hook PackageId () -> (UploadFeature, UserGroup, @@ -161,9 +161,10 @@ uploadFeature ServerEnv{serverBlobStore = store} , updateAddPackage } UserFeature{..} - trusteesState trusteesGroup trusteesGroupResource - uploadersState uploadersGroup uploadersGroupResource - maintainersState maintainersGroup maintainersGroupResource + UploadStore.Backend{backendStore = uploadStore, backendState = uploadStateComponents} + trusteesGroup trusteesGroupResource + uploadersGroup uploadersGroupResource + maintainersGroup maintainersGroupResource packageUploaded = ( UploadFeature {..} , trusteesGroupDescription, uploadersGroupDescription, maintainersGroupDescription) @@ -179,11 +180,7 @@ uploadFeature ServerEnv{serverBlobStore = store} , groupResource uploadersGroupResource , groupUserResource uploadersGroupResource ] - , featureState = [ - abstractAcidStateComponent trusteesState - , abstractAcidStateComponent uploadersState - , abstractAcidStateComponent maintainersState - ] + , featureState = uploadStateComponents } uploadResource = UploadResource @@ -214,9 +211,9 @@ uploadFeature ServerEnv{serverBlobStore = store} trusteesGroupDescription :: UserGroup trusteesGroupDescription = UserGroup { groupDesc = trusteeDescription, - queryUserGroup = queryState trusteesState Acid.GetTrusteesList, - addUserToGroup = updateState trusteesState . Acid.AddHackageTrustee, - removeUserFromGroup = updateState trusteesState . Acid.RemoveHackageTrustee, + queryUserGroup = UploadStore.getTrustees uploadStore, + addUserToGroup = UploadStore.addTrustee uploadStore, + removeUserFromGroup = UploadStore.removeTrustee uploadStore, groupsAllowedToAdd = [adminGroup], groupsAllowedToDelete = [adminGroup] } @@ -224,9 +221,9 @@ uploadFeature ServerEnv{serverBlobStore = store} uploadersGroupDescription :: UserGroup uploadersGroupDescription = UserGroup { groupDesc = uploaderDescription, - queryUserGroup = queryState uploadersState Acid.GetUploadersList, - addUserToGroup = updateState uploadersState . Acid.AddHackageUploader, - removeUserFromGroup = updateState uploadersState . Acid.RemoveHackageUploader, + queryUserGroup = UploadStore.getUploaders uploadStore, + addUserToGroup = UploadStore.addUploader uploadStore, + removeUserFromGroup = UploadStore.removeUploader uploadStore, groupsAllowedToAdd = [adminGroup, trusteesGroup], groupsAllowedToDelete = [adminGroup, trusteesGroup] } @@ -236,9 +233,9 @@ uploadFeature ServerEnv{serverBlobStore = store} fix $ \thisgroup -> UserGroup { groupDesc = maintainerDescription name, - queryUserGroup = queryState maintainersState $ Acid.GetPackageMaintainers name, - addUserToGroup = updateState maintainersState . Acid.AddPackageMaintainer name, - removeUserFromGroup = updateState maintainersState . Acid.RemovePackageMaintainer name, + queryUserGroup = UploadStore.getPackageMaintainers uploadStore name, + addUserToGroup = UploadStore.addPackageMaintainer uploadStore name, + removeUserFromGroup = UploadStore.removePackageMaintainer uploadStore name, groupsAllowedToAdd = [thisgroup, adminGroup], groupsAllowedToDelete = [thisgroup, adminGroup] } diff --git a/src/Distribution/Server/Features/Upload/Acid.hs b/src/Distribution/Server/Features/Upload/Acid.hs index b6982a604..ca7f175eb 100644 --- a/src/Distribution/Server/Features/Upload/Acid.hs +++ b/src/Distribution/Server/Features/Upload/Acid.hs @@ -2,14 +2,39 @@ module Distribution.Server.Features.Upload.Acid ( trusteesStateComponent , uploadersStateComponent , maintainersStateComponent + , acidStore ) where +import qualified Distribution.Server.Features.Upload.Store as Store import Distribution.Server.Framework import Distribution.Server.Framework.BackupDump import Distribution.Server.Features.Upload.Backup (maintToExport, maintainerBackup) import qualified Distribution.Server.Features.Upload.State as Acid import Distribution.Server.Users.Backup +acidStore :: FilePath -> IO Store.Backend +acidStore stateDir = do + trusteesState <- trusteesStateComponent stateDir + uploadersState <- uploadersStateComponent stateDir + maintainersState <- maintainersStateComponent stateDir + pure Store.Backend { + Store.backendStore = Store.Store { + Store.getTrustees = queryState trusteesState Acid.GetTrusteesList + , Store.addTrustee = updateState trusteesState . Acid.AddHackageTrustee + , Store.removeTrustee = updateState trusteesState . Acid.RemoveHackageTrustee + , Store.getUploaders = queryState uploadersState Acid.GetUploadersList + , Store.addUploader = updateState uploadersState . Acid.AddHackageUploader + , Store.removeUploader = updateState uploadersState . Acid.RemoveHackageUploader + , Store.getPackageMaintainers = \name -> queryState maintainersState (Acid.GetPackageMaintainers name) + , Store.addPackageMaintainer = \name -> updateState maintainersState . Acid.AddPackageMaintainer name + , Store.removePackageMaintainer = \name -> updateState maintainersState . Acid.RemovePackageMaintainer name + } + , Store.backendState = [ abstractAcidStateComponent trusteesState + , abstractAcidStateComponent uploadersState + , abstractAcidStateComponent maintainersState + ] + } + trusteesStateComponent :: FilePath -> IO (StateComponent AcidState Acid.HackageTrustees) trusteesStateComponent stateDir = do st <- openLocalStateFrom (stateDir "db" "HackageTrustees") Acid.initialHackageTrustees diff --git a/src/Distribution/Server/Features/Upload/Store.hs b/src/Distribution/Server/Features/Upload/Store.hs new file mode 100644 index 000000000..bac013abb --- /dev/null +++ b/src/Distribution/Server/Features/Upload/Store.hs @@ -0,0 +1,31 @@ +{-# LANGUAGE RankNTypes #-} + +module Distribution.Server.Features.Upload.Store + ( Backend(..) + , Store(..) + ) where + +import Distribution.Server.Framework (AbstractStateComponent) +import Distribution.Server.Users.Group (UserIdSet) + +import Distribution.Package (PackageName) +import Distribution.Server.Users.Types (UserId) + +import Control.Monad.Trans (MonadIO) + +data Backend = Backend { + backendStore :: Store + , backendState :: [AbstractStateComponent] + } + +data Store = Store { + getTrustees :: forall m. MonadIO m => m UserIdSet + , addTrustee :: forall m. MonadIO m => UserId -> m () + , removeTrustee :: forall m. MonadIO m => UserId -> m () + , getUploaders :: forall m. MonadIO m => m UserIdSet + , addUploader :: forall m. MonadIO m => UserId -> m () + , removeUploader :: forall m. MonadIO m => UserId -> m () + , getPackageMaintainers :: forall m. MonadIO m => PackageName -> m UserIdSet + , addPackageMaintainer :: forall m. MonadIO m => PackageName -> UserId -> m () + , removePackageMaintainer :: forall m. MonadIO m => PackageName -> UserId -> m () + }