From 5f6fc026178ea8c5f8bbde83d6d115963ae8e5c9 Mon Sep 17 00:00:00 2001 From: Sandy Maguire Date: Thu, 16 Apr 2026 08:54:10 -0700 Subject: [PATCH 01/32] =?UTF-8?q?=E2=88=85?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit From 88e046c3506f5424ad8a44c5b2ed65a83779f071 Mon Sep 17 00:00:00 2001 From: Sandy Maguire Date: Wed, 15 Apr 2026 14:52:17 -0700 Subject: [PATCH 02/32] Remove TarIndex --- hackage-server.cabal | 1 - src/Distribution/Server/Util/TarIndex.hs | 54 ------------------------ 2 files changed, 55 deletions(-) delete mode 100644 src/Distribution/Server/Util/TarIndex.hs diff --git a/hackage-server.cabal b/hackage-server.cabal index ef5c984cd..91260e3a5 100644 --- a/hackage-server.cabal +++ b/hackage-server.cabal @@ -288,7 +288,6 @@ library Distribution.Server.Util.ServeTarball Distribution.Server.Util.Validators Distribution.Server.Util.Validators.Internal - -- [unused] Distribution.Server.Util.TarIndex Distribution.Server.Util.GZip Distribution.Server.Util.ContentType Distribution.Server.Util.SigTerm diff --git a/src/Distribution/Server/Util/TarIndex.hs b/src/Distribution/Server/Util/TarIndex.hs deleted file mode 100644 index 2c2a94e02..000000000 --- a/src/Distribution/Server/Util/TarIndex.hs +++ /dev/null @@ -1,54 +0,0 @@ -{-# LANGUAGE TemplateHaskell, DeriveDataTypeable, TypeFamilies, - MultiParamTypeClasses, FlexibleInstances, FlexibleContexts #-} - --- This is presently unused: features provide their own BlobId-to-TarIndex --- mappings. - -module Distribution.Server.Util.TarIndex - where - -import Control.Applicative ((<$>)) -import Control.Monad.Reader.Class (asks) -import Control.Monad.State.Class (put, modify) -import qualified Data.Map as Map - -import Data.Acid (makeAcidic) -import Data.SafeCopy (base, deriveSafeCopy) -import Data.TarIndex (TarIndex) - -import Distribution.Server.Framework.BlobStorage (BlobId) - -data TarIndexMap = M {indexMap :: Map.Map BlobId TarIndex} - deriving (Show) - -addIndex :: BlobId -> TarIndex -> Update TarIndexMap () -addIndex blob index = modify $ insertTarIndex blob index - -insertTarIndex :: BlobId -> TarIndex -> TarIndexMap -> TarIndexMap -insertTarIndex blob index (M state) = M (Map.insert blob index state) - -dropIndex :: BlobId -> Update TarIndexMap () -dropIndex blob = modify $ \(M state) -> M (Map.delete blob state) - -lookupIndex :: BlobId -> Query TarIndexMap (Maybe TarIndex) -lookupIndex blob = Map.lookup blob <$> asks indexMap - -replaceTarIndexMap :: TarIndexMap -> Update TarIndexMap () -replaceTarIndexMap = put - -$(deriveSafeCopy 0 'base ''TarIndexMap) - -initialTarIndexMap :: TarIndexMap -initialTarIndexMap = emptyTarIndex - -emptyTarIndex :: TarIndexMap -emptyTarIndex = M Map.empty - - -$(makeAcidic ''TarIndexMap - [ 'addIndex - , 'dropIndex - , 'lookupIndex - , 'replaceTarIndexMap - ] - ) From 7dca595b725582107b3d19da08a103bd451886cf Mon Sep 17 00:00:00 2001 From: Sandy Maguire Date: Thu, 16 Apr 2026 08:55:35 -0700 Subject: [PATCH 03/32] refactor: remove tarindex From 2628de4c53433bb0c4c58bd3bdfa5387758d2251 Mon Sep 17 00:00:00 2001 From: Sandy Maguire Date: Wed, 15 Apr 2026 10:21:40 -0700 Subject: [PATCH 04/32] Deacidify tags --- hackage-server.cabal | 1 + src/Distribution/Server/Features/Tags.hs | 97 +++++++++++-------- .../Server/Features/Tags/Backup.hs | 1 + .../Server/Features/Tags/State.hs | 64 +----------- .../Server/Features/Tags/Types.hs | 46 +++++++++ 5 files changed, 105 insertions(+), 104 deletions(-) create mode 100644 src/Distribution/Server/Features/Tags/Types.hs diff --git a/hackage-server.cabal b/hackage-server.cabal index 91260e3a5..fcf1c9410 100644 --- a/hackage-server.cabal +++ b/hackage-server.cabal @@ -390,6 +390,7 @@ library Distribution.Server.Features.Tags Distribution.Server.Features.Tags.Backup Distribution.Server.Features.Tags.State + Distribution.Server.Features.Tags.Types Distribution.Server.Features.AnalyticsPixels Distribution.Server.Features.AnalyticsPixels.State Distribution.Server.Features.UserDetails diff --git a/src/Distribution/Server/Features/Tags.hs b/src/Distribution/Server/Features/Tags.hs index d6c526e8e..09b4723e8 100644 --- a/src/Distribution/Server/Features/Tags.hs +++ b/src/Distribution/Server/Features/Tags.hs @@ -12,7 +12,8 @@ module Distribution.Server.Features.Tags ( import Distribution.Server.Framework import Distribution.Server.Framework.BackupDump -import Distribution.Server.Features.Tags.State +import Distribution.Server.Features.Tags.Types +import qualified Distribution.Server.Features.Tags.State as Acid import Distribution.Server.Features.Tags.Backup import Distribution.Server.Features.Core import Distribution.Server.Features.Upload @@ -96,7 +97,7 @@ initTagsFeature :: ServerEnv initTagsFeature ServerEnv{serverStateDir} = do tagsState <- tagsStateComponent serverStateDir tagAlias <- tagsAliasComponent serverStateDir - specials <- newMemStateWHNF emptyPackageTags + specials <- newMemStateWHNF Acid.emptyPackageTags updateTag <- newHook tagProposalLog <- newMemStateWHNF Map.empty @@ -109,35 +110,35 @@ initTagsFeature ServerEnv{serverStateDir} = do Just pkginfo -> do let pkgname = packageName pkgid itags = constructImmutableTags . pkgDesc $ pkginfo - curtags <- queryState tagsState $ TagsForPackage pkgname - aliases <- mapM (queryState tagAlias . GetTagAlias) (itags ++ Set.toList curtags) + curtags <- queryState tagsState $ Acid.TagsForPackage pkgname + aliases <- mapM (queryState tagAlias . Acid.GetTagAlias) (itags ++ Set.toList curtags) let newtags = Set.fromList aliases - updateState tagsState . SetPackageTags pkgname $ newtags + updateState tagsState . Acid.SetPackageTags pkgname $ newtags runHook_ updateTag (Set.singleton pkgname, newtags) return feature -tagsStateComponent :: FilePath -> IO (StateComponent AcidState PackageTags) +tagsStateComponent :: FilePath -> IO (StateComponent AcidState Acid.PackageTags) tagsStateComponent stateDir = do - st <- openLocalStateFrom (stateDir "db" "Tags" "Existing") initialPackageTags + st <- openLocalStateFrom (stateDir "db" "Tags" "Existing") Acid.initialPackageTags return StateComponent { stateDesc = "Package tags" , stateHandle = st - , getState = query st GetPackageTags - , putState = update st . ReplacePackageTags + , 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 TagAlias) +tagsAliasComponent :: FilePath -> IO (StateComponent AcidState Acid.TagAlias) tagsAliasComponent stateDir = do - st <- openLocalStateFrom (stateDir "db" "Tags" "Alias") emptyTagAlias + st <- openLocalStateFrom (stateDir "db" "Tags" "Alias") Acid.emptyTagAlias return StateComponent { stateDesc = "Tags Alias" , stateHandle = st - , getState = query st GetTagAliasesState - , putState = update st . AddTagAliasesState + , getState = query st Acid.GetTagAliasesState + , putState = update st . Acid.AddTagAliasesState , backupState = \_ aliases -> [csvToBackup ["aliases.csv"] $ aliasToCSV aliases] , restoreState = aliasBackup , resetState = tagsAliasComponent @@ -146,9 +147,9 @@ tagsAliasComponent stateDir = do tagsFeature :: CoreFeature -> UploadFeature -> UserFeature - -> StateComponent AcidState PackageTags - -> StateComponent AcidState TagAlias - -> MemState PackageTags + -> StateComponent AcidState Acid.PackageTags + -> StateComponent AcidState Acid.TagAlias + -> MemState Acid.PackageTags -> Hook (Set PackageName, Set Tag) () -> MemState (Map PackageName (Set Tag, Set Tag)) -> TagsFeature @@ -200,39 +201,39 @@ tagsFeature CoreFeature{ queryGetPackageIndex } initImmutableTags :: IO () initImmutableTags = do index <- queryGetPackageIndex - let calcTags = tagPackages $ constructImmutableTagIndex index - aliases <- mapM (queryState tagsAlias . GetTagAlias) $ Map.keys calcTags + let calcTags = Acid.tagPackages $ constructImmutableTagIndex 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 queryGetTagList :: MonadIO m => m [(Tag, Set PackageName)] - queryGetTagList = queryState tagsState GetTagList + queryGetTagList = queryState tagsState Acid.GetTagList queryTagsForPackage :: MonadIO m => PackageName -> m (Set Tag) - queryTagsForPackage pkgname = queryState tagsState (TagsForPackage pkgname) + queryTagsForPackage pkgname = queryState tagsState (Acid.TagsForPackage pkgname) queryAliasForTag :: MonadIO m => Tag -> m Tag - queryAliasForTag tag = queryState tagsAlias (GetTagAlias tag) + queryAliasForTag tag = queryState tagsAlias (Acid.GetTagAlias tag) queryReviewTagsForPackage :: MonadIO m => PackageName -> m (Set Tag,Set Tag) - queryReviewTagsForPackage pkgname = queryState tagsState (LookupReviewTags pkgname) + queryReviewTagsForPackage pkgname = queryState tagsState (Acid.LookupReviewTags pkgname) setCalculatedTag :: Tag -> Set PackageName -> IO () setCalculatedTag tag pkgs = do - modifyMemState calculatedTags (setTag tag pkgs) - void $ updateState tagsState $ SetTagPackages tag pkgs + modifyMemState calculatedTags (Acid.setTag tag pkgs) + void $ updateState tagsState $ Acid.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 $ PackagesForTag tag + pkgs <- queryState tagsState $ Acid.PackagesForTag tag func tag pkgs collectTags :: MonadIO m => Set PackageName -> m (Map PackageName (Set Tag)) collectTags pkgs = do - pkgMap <- liftM packageTags $ queryState tagsState GetPackageTags + pkgMap <- liftM Acid.packageTags $ queryState tagsState Acid.GetPackageTags return $ Map.fromDistinctAscList . map (\pkg -> (pkg, Map.findWithDefault Set.empty pkg pkgMap)) $ Set.toList pkgs mergeTags :: Maybe String -> Tag -> ServerPartE () @@ -240,22 +241,22 @@ tagsFeature CoreFeature{ queryGetPackageIndex } case simpleParse =<< targetTag of Just (Tag orig) -> do index <- queryGetPackageIndex - void $ updateState tagsAlias $ AddTagAlias (Tag orig) deprTag + void $ updateState tagsAlias $ Acid.AddTagAlias (Tag orig) deprTag void $ constructMergedTagIndex (Tag orig) deprTag 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 PackageTags - constructMergedTagIndex orig depr = foldM addToTags emptyPackageTags . PackageIndex.allPackageNames + constructMergedTagIndex :: forall m. (Functor m, MonadIO m) => Tag -> Tag -> PackageIndex PkgInfo -> m Acid.PackageTags + constructMergedTagIndex orig depr = foldM addToTags Acid.emptyPackageTags . PackageIndex.allPackageNames 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 $ SetPackageTags pn newTags + void $ updateState tagsState $ Acid.SetPackageTags pn newTags runHook_ tagsUpdated (Set.singleton pn, newTags) - return $ setTags pn newTags calcTags - else return $ setTags pn pkgTags calcTags + return $ Acid.setTags pn newTags calcTags + else return $ Acid.setTags pn pkgTags calcTags putTags :: Maybe String -> Maybe String -> Maybe String -> Maybe String -> PackageName -> ServerPartE () putTags addns delns raddns rdelns pkgname = @@ -268,7 +269,7 @@ tagsFeature CoreFeature{ queryGetPackageIndex } if trustainer then do calcTags <- queryTagsForPackage pkgname - aliases <- mapM (queryState tagsAlias . GetTagAlias) add + aliases <- mapM (queryState tagsAlias . Acid.GetTagAlias) add revTags <- queryReviewTagsForPackage pkgname let tagSet = (addTags `Set.union` calcTags) `Set.difference` delTags addTags = Set.fromList aliases @@ -282,18 +283,18 @@ tagsFeature CoreFeature{ queryGetPackageIndex } 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 $ SetPackageTags pkgname tagSet - updateState tagsState $ InsertReviewTags' pkgname addRev delRev + updateState tagsState $ Acid.SetPackageTags pkgname tagSet + updateState tagsState $ Acid.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 . GetTagAlias) add + aliases <- mapM (queryState tagsAlias . Acid.GetTagAlias) add calcTags <- queryTagsForPackage pkgname let addTags = Set.fromList aliases `Set.difference` calcTags delTags = Set.fromList del `Set.intersection` calcTags - updateState tagsState $ InsertReviewTags pkgname addTags delTags + updateState tagsState $ Acid.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"] @@ -301,23 +302,23 @@ tagsFeature CoreFeature{ queryGetPackageIndex } 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 -> PackageTags -constructTagIndex = foldl' addToTags emptyPackageTags . PackageIndex.allPackagesByName +constructTagIndex :: PackageIndex PkgInfo -> Acid.PackageTags +constructTagIndex = foldl' addToTags Acid.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 setTags pkgname (Set.union categoryTags immutableTags) pkgTags + in Acid.setTags pkgname (Set.union categoryTags immutableTags) pkgTags -- tags on startup -constructImmutableTagIndex :: PackageIndex PkgInfo -> PackageTags -constructImmutableTagIndex = foldl' addToTags emptyPackageTags . PackageIndex.allPackagesByName +constructImmutableTagIndex :: PackageIndex PkgInfo -> Acid.PackageTags +constructImmutableTagIndex = foldl' addToTags Acid.emptyPackageTags . PackageIndex.allPackagesByName where addToTags calcTags pkgList = let info = pkgDesc $ last pkgList !pn = packageName info !tags = constructImmutableTags info - in setTags pn (Set.fromList tags) calcTags + in Acid.setTags pn (Set.fromList tags) calcTags -- These are constructed when a package is uploaded/on startup constructCategoryTags :: PackageDescription -> [Tag] @@ -358,3 +359,13 @@ constructImmutableTags genDesc = PublicDomain -> [Tag "public-domain"] AllRightsReserved -> [Tag "all-rights-reserved"] _ -> [] + + +-- mutilates a string to appease the parser +tagify :: String -> Tag +tagify (x:xs) = Tag $ (if tagInitialChar x then (x:) else id) $ tagify' xs + where tagify' (c:cs) | tagLaterChar c = c:tagify' cs + tagify' (c:cs) | c `elem` " /\\" = '-':tagify' cs -- dash is the preferred word separator? + tagify' (_:cs) = tagify' cs + tagify' [] = [] +tagify [] = Tag "" diff --git a/src/Distribution/Server/Features/Tags/Backup.hs b/src/Distribution/Server/Features/Tags/Backup.hs index 2e4c0d2e1..6f9a7777c 100644 --- a/src/Distribution/Server/Features/Tags/Backup.hs +++ b/src/Distribution/Server/Features/Tags/Backup.hs @@ -8,6 +8,7 @@ module Distribution.Server.Features.Tags.Backup ( ) where import Distribution.Server.Features.Tags.State +import Distribution.Server.Features.Tags.Types import Distribution.Server.Framework.BackupRestore import Distribution.Package diff --git a/src/Distribution/Server/Features/Tags/State.hs b/src/Distribution/Server/Features/Tags/State.hs index 1bdb6be21..4f0956f8e 100644 --- a/src/Distribution/Server/Features/Tags/State.hs +++ b/src/Distribution/Server/Features/Tags/State.hs @@ -2,23 +2,19 @@ module Distribution.Server.Features.Tags.State where +import Distribution.Server.Features.Tags.Types + import Distribution.Server.Framework.Instances () import Distribution.Server.Framework.MemSize -import qualified Distribution.Compat.CharParsing as P -import Distribution.Parsec (Parsec(..), parsecCommaList) -import Distribution.Pretty (Pretty(..)) import Distribution.Package -import qualified Text.PrettyPrint as Disp import Data.Acid (Query, Update, makeAcidic) import Data.Map (Map) import qualified Data.Map as Map import Data.Set (Set) import qualified Data.Set as Set -import Control.Monad (liftM2) import Data.SafeCopy (base, deriveSafeCopy) -import qualified Data.Char as Char import Data.Functor ( (<&>) ) import Data.Maybe (fromMaybe) import Data.List (find, foldl') @@ -26,44 +22,6 @@ import Control.Monad.State (get, put, modify) import Control.Monad.Reader (ask, asks) import Control.DeepSeq -newtype TagList = TagList [Tag] deriving (Show) - -instance Pretty TagList where - pretty (TagList tags) = Disp.hsep . Disp.punctuate Disp.comma $ map pretty tags -instance Parsec TagList where - parsec = fmap TagList $ P.spaces >> parsecCommaList parsec - --- A tag is a string describing a package; presently the preferred word-separation --- character is the dash. -newtype Tag = Tag String deriving (Show, Ord, Eq, NFData, MemSize) - -instance Pretty Tag where - pretty (Tag tag) = Disp.text tag -instance Parsec Tag where - parsec = do - -- adding 'many1 $ do' here would allow multiword tags. - -- spaces aren't very aesthetic in URIs, though. - strs <- do - t <- liftM2 (:) (P.satisfy tagInitialChar) - $ P.munch1 tagLaterChar - P.spaces - return t - return $ Tag strs - -tagInitialChar, tagLaterChar :: Char -> Bool --- reserve + and - first-letters for queries -tagInitialChar c = Char.isAlphaNum c || c `elem` ".#*" -tagLaterChar c = Char.isAlphaNum c || c `elem` "-+#*." - --- mutilates a string to appease the parser -tagify :: String -> Tag -tagify (x:xs) = Tag $ (if tagInitialChar x then (x:) else id) $ tagify' xs - where tagify' (c:cs) | tagLaterChar c = c:tagify' cs - tagify' (c:cs) | c `elem` " /\\" = '-':tagify' cs -- dash is the preferred word separator? - tagify' (_:cs) = tagify' cs - tagify' [] = [] -tagify [] = Tag "" - data PackageTags = PackageTags { -- the primary index packageTags :: Map PackageName (Set Tag), @@ -97,12 +55,6 @@ emptyPackageTags = PackageTags Map.empty Map.empty Map.empty emptyTagAlias :: TagAlias emptyTagAlias = TagAlias Map.empty -tagToPackages :: Tag -> PackageTags -> Set PackageName -tagToPackages tag = Map.findWithDefault Set.empty tag . tagPackages - -packageToTags :: PackageName -> PackageTags -> Set Tag -packageToTags pkg = Map.findWithDefault Set.empty pkg . packageTags - alterTags :: PackageName -> Maybe (Set Tag) -> PackageTags -> PackageTags alterTags name mtagList pt@(PackageTags tags packages _) = let tagList = fromMaybe Set.empty mtagList @@ -122,9 +74,6 @@ setTags pkgname tagList = alterTags pkgname (keepSet tagList) setAliases :: Tag -> Set Tag -> TagAlias -> TagAlias setAliases tag aliases (TagAlias ta) = TagAlias (Map.insertWith Set.union tag aliases ta) -deletePackageTags :: PackageName -> PackageTags -> PackageTags -deletePackageTags name = alterTags name Nothing - addTag :: PackageName -> Tag -> PackageTags -> Maybe PackageTags addTag name tag (PackageTags tags packages review) = let existing = Map.findWithDefault Set.empty name tags @@ -162,16 +111,8 @@ keepSet s = if Set.null s then Nothing else Just s setTag :: Tag -> Set PackageName -> PackageTags -> PackageTags setTag tag pkgs = alterTag tag (keepSet pkgs) -deleteTag :: Tag -> PackageTags -> PackageTags -deleteTag tag = alterTag tag Nothing - -renameTag :: Tag -> Tag -> PackageTags -> PackageTags -renameTag tag tag' pkgTags@(PackageTags _ packages _) = - let oldPkgs = Map.findWithDefault Set.empty tag packages - in setTag tag' oldPkgs . deleteTag tag $ pkgTags ------------------------------------------------------------------------------- -$(deriveSafeCopy 0 'base ''Tag) $(deriveSafeCopy 0 'base ''PackageTags) $(deriveSafeCopy 0 'base ''TagAlias) @@ -275,3 +216,4 @@ $(makeAcidic ''PackageTags ['tagsForPackage ,'lookupReviewTags ,'clearReviewTags ]) + diff --git a/src/Distribution/Server/Features/Tags/Types.hs b/src/Distribution/Server/Features/Tags/Types.hs new file mode 100644 index 000000000..7e03c0300 --- /dev/null +++ b/src/Distribution/Server/Features/Tags/Types.hs @@ -0,0 +1,46 @@ +{-# LANGUAGE DeriveDataTypeable, TypeFamilies, TemplateHaskell, GeneralizedNewtypeDeriving #-} + +module Distribution.Server.Features.Tags.Types where + +import Distribution.Server.Framework.MemSize + +import qualified Distribution.Compat.CharParsing as P +import Distribution.Parsec (Parsec(..), parsecCommaList) +import Distribution.Pretty (Pretty(..)) +import qualified Text.PrettyPrint as Disp + +import Control.Monad (liftM2) +import qualified Data.Char as Char +import Control.DeepSeq +import Data.SafeCopy (base, deriveSafeCopy) + +newtype TagList = TagList [Tag] deriving (Show) + +instance Pretty TagList where + pretty (TagList tags) = Disp.hsep . Disp.punctuate Disp.comma $ map pretty tags +instance Parsec TagList where + parsec = fmap TagList $ P.spaces >> parsecCommaList parsec + +-- A tag is a string describing a package; presently the preferred word-separation +-- character is the dash. +newtype Tag = Tag String deriving (Show, Ord, Eq, NFData, MemSize) + +instance Pretty Tag where + pretty (Tag tag) = Disp.text tag +instance Parsec Tag where + parsec = do + -- adding 'many1 $ do' here would allow multiword tags. + -- spaces aren't very aesthetic in URIs, though. + strs <- do + t <- liftM2 (:) (P.satisfy tagInitialChar) + $ P.munch1 tagLaterChar + P.spaces + return t + return $ Tag strs + +tagInitialChar, tagLaterChar :: Char -> Bool +-- reserve + and - first-letters for queries +tagInitialChar c = Char.isAlphaNum c || c `elem` ".#*" +tagLaterChar c = Char.isAlphaNum c || c `elem` "-+#*." + +$(deriveSafeCopy 0 'base ''Tag) From 70f9a0ba9a4bedea3eb7bcf9b3ee1be06da8f449 Mon Sep 17 00:00:00 2001 From: Sandy Maguire Date: Wed, 15 Apr 2026 10:21:40 -0700 Subject: [PATCH 05/32] Deacidify votes --- hackage-server.cabal | 1 + src/Distribution/Server/Features/Votes.hs | 31 ++++++++++--------- .../Server/Features/Votes/State.hs | 3 +- .../Server/Features/Votes/Types.hs | 3 ++ 4 files changed, 21 insertions(+), 17 deletions(-) create mode 100644 src/Distribution/Server/Features/Votes/Types.hs diff --git a/hackage-server.cabal b/hackage-server.cabal index fcf1c9410..6fd8ac931 100644 --- a/hackage-server.cabal +++ b/hackage-server.cabal @@ -380,6 +380,7 @@ library Distribution.Server.Features.Votes Distribution.Server.Features.Votes.Render Distribution.Server.Features.Votes.State + Distribution.Server.Features.Votes.Types Distribution.Server.Features.Vouch Distribution.Server.Features.RecentPackages Distribution.Server.Features.PreferredVersions diff --git a/src/Distribution/Server/Features/Votes.hs b/src/Distribution/Server/Features/Votes.hs index 2720a02fb..8739824c1 100644 --- a/src/Distribution/Server/Features/Votes.hs +++ b/src/Distribution/Server/Features/Votes.hs @@ -7,7 +7,8 @@ module Distribution.Server.Features.Votes , initVotesFeature ) where -import Distribution.Server.Features.Votes.State +import Distribution.Server.Features.Votes.Types (Score) +import qualified Distribution.Server.Features.Votes.State as Acid import qualified Distribution.Server.Features.Votes.Render as Render import Distribution.Server.Framework @@ -62,26 +63,26 @@ initVotesFeature env@ServerEnv{serverStateDir} = do return feature -- | Define the backing store (i.e. database component) -votesStateComponent :: FilePath -> IO (StateComponent AcidState VotesState) +votesStateComponent :: FilePath -> IO (StateComponent AcidState Acid.VotesState) votesStateComponent stateDir = do - st <- openLocalStateFrom (stateDir "db" "Votes") initialVotesState + 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 GetVotesState - , putState = update st . ReplaceVotesState + , getState = query st Acid.GetVotesState + , putState = update st . Acid.ReplaceVotesState , resetState = votesStateComponent , backupState = \_ _ -> [] , restoreState = RestoreBackup { restoreEntry = error "Unexpected backup entry" - , restoreFinalize = return $ VotesState Map.empty + , restoreFinalize = return $ Acid.VotesState Map.empty } } -- | Default constructor for building this feature. votesFeature :: ServerEnv - -> StateComponent AcidState VotesState + -> StateComponent AcidState Acid.VotesState -> CoreFeature -- To get site package list -> UserFeature -- To authenticate users -> Hook (PackageName, Float) () @@ -128,9 +129,9 @@ votesFeature ServerEnv{..} servePackageVotesGet :: DynamicPath -> ServerPartE Response servePackageVotesGet _ = do cacheControlWithoutETag [Public, maxAgeMinutes 10] - votesMap <- queryState votesState GetAllPackageVoteSets + votesMap <- queryState votesState Acid.GetAllPackageVoteSets ok . toResponse $ objectL - [ (display pkgname, toJSON (votesScore pkgMap)) + [ (display pkgname, toJSON (Acid.votesScore pkgMap)) | (pkgname, pkgMap) <- Map.toList votesMap ] -- Get the number of votes a package has. If the package @@ -160,7 +161,7 @@ votesFeature ServerEnv{..} "2" -> pure 2 "3" -> pure 3 _ -> fail "invalid score value received" - _ <- updateState votesState (AddVote pkgname uid score) + _ <- updateState votesState (Acid.AddVote pkgname uid score) pkgScore <- pkgNumScore pkgname runHook_ votesUpdated (pkgname, pkgScore) ok . toResponse $ "Package voted for successfully" @@ -173,7 +174,7 @@ votesFeature ServerEnv{..} pkgname <- packageInPath dpath guardValidPackageName pkgname - success <- updateState votesState (RemoveVote pkgname uid) + success <- updateState votesState (Acid.RemoveVote pkgname uid) pkgScore <- pkgNumScore pkgname when success $ runHook_ votesUpdated (pkgname, pkgScore) @@ -187,20 +188,20 @@ votesFeature ServerEnv{..} -- package in question. didUserVote :: MonadIO m => PackageName -> UserId -> m Bool didUserVote pkgname uid = - queryState votesState (GetPackageUserVoted pkgname uid) + queryState votesState (Acid.GetPackageUserVoted pkgname uid) -- Returns the number of votes a package has. pkgNumVotes :: MonadIO m => PackageName -> m Int pkgNumVotes pkgname = - queryState votesState (GetPackageVoteCount pkgname) + queryState votesState (Acid.GetPackageVoteCount pkgname) pkgNumScore :: MonadIO m => PackageName -> m Float pkgNumScore pkgname = - queryState votesState (GetPackageVoteScore pkgname) + queryState votesState (Acid.GetPackageVoteScore pkgname) pkgUserVote :: MonadIO m => PackageName -> UserId -> m (Maybe Score) pkgUserVote pkgname uid = - queryState votesState (GetPackageUserVote pkgname uid) + queryState votesState (Acid.GetPackageUserVote 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/State.hs b/src/Distribution/Server/Features/Votes/State.hs index 1abf5b209..17b05bda3 100644 --- a/src/Distribution/Server/Features/Votes/State.hs +++ b/src/Distribution/Server/Features/Votes/State.hs @@ -3,6 +3,7 @@ module Distribution.Server.Features.Votes.State where +import Distribution.Server.Features.Votes.Types import Distribution.Server.Framework.MemSize import Distribution.Package (PackageName) @@ -23,8 +24,6 @@ import Data.SafeCopy (base, extension, deriveSafeCopy, Migrate(..)) import qualified Control.Monad.State as State import Control.Monad.Reader.Class (ask) -type Score = Int - newtype VotesState_v0 = VotesState_v0 { votesMap :: Map PackageName UserIdSet } newtype VotesState = VotesState (Map PackageName (Map UserId Score)) diff --git a/src/Distribution/Server/Features/Votes/Types.hs b/src/Distribution/Server/Features/Votes/Types.hs new file mode 100644 index 000000000..085fe1790 --- /dev/null +++ b/src/Distribution/Server/Features/Votes/Types.hs @@ -0,0 +1,3 @@ +module Distribution.Server.Features.Votes.Types where + +type Score = Int From bae96fecbab373b2a9c4ff5d17ca6054e40ce12b Mon Sep 17 00:00:00 2001 From: Sandy Maguire Date: Wed, 15 Apr 2026 10:48:33 -0700 Subject: [PATCH 06/32] Deacidify vouches --- hackage-server.cabal | 2 + src/Distribution/Server/Features/Vouch.hs | 90 ++++++------------- .../Server/Features/Vouch/State.hs | 55 ++++++++++++ 3 files changed, 82 insertions(+), 65 deletions(-) create mode 100644 src/Distribution/Server/Features/Vouch/State.hs diff --git a/hackage-server.cabal b/hackage-server.cabal index 6fd8ac931..717dd5e92 100644 --- a/hackage-server.cabal +++ b/hackage-server.cabal @@ -382,6 +382,8 @@ library Distribution.Server.Features.Votes.State Distribution.Server.Features.Votes.Types Distribution.Server.Features.Vouch + Distribution.Server.Features.Vouch.State + Distribution.Server.Features.Vouch.Types Distribution.Server.Features.RecentPackages Distribution.Server.Features.PreferredVersions Distribution.Server.Features.PreferredVersions.State diff --git a/src/Distribution/Server/Features/Vouch.hs b/src/Distribution/Server/Features/Vouch.hs index ba08ecc4a..46a296e08 100644 --- a/src/Distribution/Server/Features/Vouch.hs +++ b/src/Distribution/Server/Features/Vouch.hs @@ -4,27 +4,25 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE RankNTypes #-} -module Distribution.Server.Features.Vouch (VouchFeature(..), VouchData(..), VouchError(..), VouchSuccess(..), initVouchFeature, judgeVouch) where +module Distribution.Server.Features.Vouch (VouchFeature(..), initVouchFeature, judgeVouch) where + +import qualified Distribution.Server.Features.Vouch.State as Acid +import Distribution.Server.Features.Vouch.Types import Control.Monad (when, join) import Control.Monad.Except (runExceptT, throwError) -import Control.Monad.Reader (ask) -import Control.Monad.State (get, put) import Control.Monad.IO.Class (MonadIO) import qualified Data.ByteString.Lazy.Char8 as LBS -import qualified Data.Map.Strict as Map import qualified Data.Set as Set -import Data.Maybe (fromMaybe) import Data.Time (UTCTime(..), addUTCTime, getCurrentTime, nominalDay, secondsToDiffTime) import Data.Time.Format.ISO8601 (formatShow, iso8601Format) import Text.XHtml.Strict (prettyHtmlFragment, stringToHtml, li) -import Data.SafeCopy (base, deriveSafeCopy) -import Distribution.Server.Framework ((), AcidState, DynamicPath, HackageFeature, IsHackageFeature, IsHackageFeature(..), MemSize(..), memSize2) -import Distribution.Server.Framework (MessageSpan(MText), Method(..), Query, Response, ServerEnv(..), ServerPartE, StateComponent(..), Update) +import Distribution.Server.Framework ((), AcidState, DynamicPath, HackageFeature, IsHackageFeature, IsHackageFeature(..)) +import Distribution.Server.Framework (MessageSpan(MText), Method(..), Response, ServerEnv(..), ServerPartE, StateComponent(..)) import Distribution.Server.Framework (abstractAcidStateComponent, emptyHackageFeature, errBadRequest) import Distribution.Server.Framework (featureDesc, featureReloadFiles, featureResources, featureState) -import Distribution.Server.Framework (liftIO, makeAcidic, openLocalStateFrom, query, queryState, resourceAt, resourceDesc, resourceGet) +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.Templating (($=), TemplateAttr, getTemplate, loadTemplates, reloadTemplates, templateUnescaped) @@ -34,48 +32,10 @@ import Distribution.Server.Features.Upload(UploadFeature(..)) import Distribution.Server.Features.Users (UserFeature(..)) import Distribution.Simple.Utils (toUTF8LBS) -data VouchData = - VouchData - { vouches :: Map.Map UserId [(UserId, UTCTime)] - , notNotified :: Set.Set UserId - } - deriving (Show, Eq) - -instance MemSize VouchData where - memSize (VouchData vouches notified) = memSize2 vouches notified - -putVouch :: UserId -> (UserId, UTCTime) -> Update VouchData () -putVouch vouchee (voucher, now) = do - VouchData tbl notNotified <- get - let oldMap = fromMaybe [] (Map.lookup vouchee tbl) - newMap = (voucher, now) : oldMap - put $ VouchData (Map.insert vouchee newMap tbl) notNotified - -getVouchesFor :: UserId -> Query VouchData [(UserId, UTCTime)] -getVouchesFor needle = do - VouchData tbl _notNotified <- ask - pure . fromMaybe [] $ Map.lookup needle tbl - -getVouchesData :: Query VouchData VouchData -getVouchesData = ask - -replaceVouchesData :: VouchData -> Update VouchData () -replaceVouchesData = put - -$(deriveSafeCopy 0 'base ''VouchData) - -makeAcidic ''VouchData - [ 'putVouch - , 'getVouchesFor - -- Stock - , 'getVouchesData - , 'replaceVouchesData - ] - -vouchStateComponent :: FilePath -> IO (StateComponent AcidState VouchData) +vouchStateComponent :: FilePath -> IO (StateComponent AcidState Acid.VouchData) vouchStateComponent stateDir = do - st <- openLocalStateFrom (stateDir "db" "Vouch") (VouchData mempty mempty) - let initialVouchData = VouchData mempty mempty + st <- openLocalStateFrom (stateDir "db" "Vouch") (Acid.VouchData mempty mempty) + let initialVouchData = Acid.VouchData mempty mempty restore = RestoreBackup { restoreEntry = error "Unexpected backup entry" @@ -84,8 +44,8 @@ vouchStateComponent stateDir = do pure StateComponent { stateDesc = "Keeps track of vouches" , stateHandle = st - , getState = query st GetVouchesData - , putState = update st . ReplaceVouchesData + , getState = query st Acid.GetVouchesData + , putState = update st . Acid.ReplaceVouchesData , backupState = \_ _ -> [] , restoreState = restore , resetState = vouchStateComponent @@ -177,7 +137,7 @@ initVouchFeature ServerEnv{serverStateDir, serverTemplatesDir, serverTemplatesMo handleGetVouches :: DynamicPath -> ServerPartE Response handleGetVouches dpath = do uid <- lookupUserName =<< userNameInPath dpath - vouches <- queryState vouchState $ GetVouchesFor uid + vouches <- queryState vouchState $ Acid.GetVouchesFor uid param <- renderToLBS lookupUserInfo vouches pure . toResponse $ vouchTemplate [ "msg" $= "" @@ -190,8 +150,8 @@ initVouchFeature ServerEnv{serverStateDir, serverTemplatesDir, serverTemplatesMo ugroup <- liftIO $ Group.queryUserGroup uploadersGroup now <- liftIO getCurrentTime vouchee <- lookupUserName =<< userNameInPath dpath - vouchersForVoucher <- queryState vouchState $ GetVouchesFor voucher - existingVouchers <- queryState vouchState $ GetVouchesFor vouchee + vouchersForVoucher <- queryState vouchState $ Acid.GetVouchesFor voucher + existingVouchers <- queryState vouchState $ Acid.GetVouchesFor 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."] @@ -204,21 +164,21 @@ initVouchFeature ServerEnv{serverStateDir, serverTemplatesDir, serverTemplatesMo Left YouAlreadyVouched -> errBadRequest "Already endorsed" [MText "You have already endorsed this user."] Right result -> do - updateState vouchState $ PutVouch vouchee (voucher, now) + updateState vouchState $ Acid.PutVouch vouchee (voucher, now) param <- renderToLBS lookupUserInfo $ existingVouchers ++ [(voucher, now)] case result of AddVouchComplete -> do -- enqueue vouching completed notification -- which will be read using drainQueuedNotifications - VouchData vouches notNotified <- - queryState vouchState GetVouchesData - let newState = VouchData vouches (Set.insert vouchee notNotified) - updateState vouchState $ ReplaceVouchesData newState + Acid.VouchData vouches notNotified <- + queryState vouchState Acid.GetVouchesData + let newState = Acid.VouchData vouches (Set.insert vouchee notNotified) + updateState vouchState $ Acid.ReplaceVouchesData newState liftIO $ Group.addUserToGroup uploadersGroup vouchee pure . toResponse $ vouchTemplate [ "msg" $= "Added endorsement. User is now an uploader!" - , "requiredNumber" $= show requiredCountOfVouches + , "requiredNumber" $= show requiredCountOfVouches , param ] AddVouchIncomplete stillRequired -> @@ -247,9 +207,9 @@ initVouchFeature ServerEnv{serverStateDir, serverTemplatesDir, serverTemplatesMo , featureReloadFiles = reloadTemplates templates }, drainQueuedNotifications = do - VouchData vouches notNotified <- - queryState vouchState GetVouchesData - let newState = VouchData vouches mempty - updateState vouchState $ ReplaceVouchesData newState + Acid.VouchData vouches notNotified <- + queryState vouchState Acid.GetVouchesData + let newState = Acid.VouchData vouches mempty + updateState vouchState $ Acid.ReplaceVouchesData newState pure $ Set.toList notNotified } diff --git a/src/Distribution/Server/Features/Vouch/State.hs b/src/Distribution/Server/Features/Vouch/State.hs new file mode 100644 index 000000000..176136b8d --- /dev/null +++ b/src/Distribution/Server/Features/Vouch/State.hs @@ -0,0 +1,55 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} + +module Distribution.Server.Features.Vouch.State where + +import Control.Monad.Reader (ask) +import Control.Monad.State (get, put) +import qualified Data.Map.Strict as Map +import qualified Data.Set as Set +import Data.Maybe (fromMaybe) +import Data.Time (UTCTime(..)) + +import Data.SafeCopy (base, deriveSafeCopy) +import Distribution.Server.Framework (MemSize(..), memSize2) +import Distribution.Server.Framework (Query, Update) +import Distribution.Server.Framework (makeAcidic) +import Distribution.Server.Users.Types (UserId(..)) + +data VouchData = + VouchData + { vouches :: Map.Map UserId [(UserId, UTCTime)] + , notNotified :: Set.Set UserId + } + deriving (Show, Eq) + +instance MemSize VouchData where + memSize (VouchData vouches notified) = memSize2 vouches notified + +putVouch :: UserId -> (UserId, UTCTime) -> Update VouchData () +putVouch vouchee (voucher, now) = do + VouchData tbl notNotified <- get + let oldMap = fromMaybe [] (Map.lookup vouchee tbl) + newMap = (voucher, now) : oldMap + put $ VouchData (Map.insert vouchee newMap tbl) notNotified + +getVouchesFor :: UserId -> Query VouchData [(UserId, UTCTime)] +getVouchesFor needle = do + VouchData tbl _notNotified <- ask + pure . fromMaybe [] $ Map.lookup needle tbl + +getVouchesData :: Query VouchData VouchData +getVouchesData = ask + +replaceVouchesData :: VouchData -> Update VouchData () +replaceVouchesData = put + +$(deriveSafeCopy 0 'base ''VouchData) + +makeAcidic ''VouchData + [ 'putVouch + , 'getVouchesFor + -- Stock + , 'getVouchesData + , 'replaceVouchesData + ] From a96fbe325922101b7f7117f1a8e2aa36d50902bc Mon Sep 17 00:00:00 2001 From: Sandy Maguire Date: Wed, 15 Apr 2026 11:20:02 -0700 Subject: [PATCH 07/32] Deacidify analytics pixels --- hackage-server.cabal | 1 + .../Server/Features/AnalyticsPixels.hs | 23 ++++++++++--------- .../Server/Features/AnalyticsPixels/State.hs | 23 +++++++------------ .../Server/Features/AnalyticsPixels/Types.hs | 17 ++++++++++++++ 4 files changed, 38 insertions(+), 26 deletions(-) create mode 100644 src/Distribution/Server/Features/AnalyticsPixels/Types.hs diff --git a/hackage-server.cabal b/hackage-server.cabal index 717dd5e92..049d7e948 100644 --- a/hackage-server.cabal +++ b/hackage-server.cabal @@ -396,6 +396,7 @@ library Distribution.Server.Features.Tags.Types Distribution.Server.Features.AnalyticsPixels Distribution.Server.Features.AnalyticsPixels.State + Distribution.Server.Features.AnalyticsPixels.Types Distribution.Server.Features.UserDetails Distribution.Server.Features.UserSignup Distribution.Server.Features.StaticFiles diff --git a/src/Distribution/Server/Features/AnalyticsPixels.hs b/src/Distribution/Server/Features/AnalyticsPixels.hs index f8b71be75..fb211cda3 100644 --- a/src/Distribution/Server/Features/AnalyticsPixels.hs +++ b/src/Distribution/Server/Features/AnalyticsPixels.hs @@ -10,7 +10,8 @@ module Distribution.Server.Features.AnalyticsPixels import Data.Set (Set) -import Distribution.Server.Features.AnalyticsPixels.State +import Distribution.Server.Features.AnalyticsPixels.Types +import qualified Distribution.Server.Features.AnalyticsPixels.State as Acid import Distribution.Server.Framework import Distribution.Server.Framework.BackupRestore @@ -64,26 +65,26 @@ initAnalyticsPixelsFeature env@ServerEnv{serverStateDir} = do return feature -- | Define the backing store (i.e. database component) -analyticsPixelsStateComponent :: FilePath -> IO (StateComponent AcidState AnalyticsPixelsState) +analyticsPixelsStateComponent :: FilePath -> IO (StateComponent AcidState Acid.AnalyticsPixelsState) analyticsPixelsStateComponent stateDir = do - st <- openLocalStateFrom (stateDir "db" "AnalyticsPixels") initialAnalyticsPixelsState + st <- openLocalStateFrom (stateDir "db" "AnalyticsPixels") Acid.initialAnalyticsPixelsState return StateComponent { stateDesc = "Backing store for AnalyticsPixels feature" , stateHandle = st - , getState = query st GetAnalyticsPixelsState - , putState = update st . ReplaceAnalyticsPixelsState + , getState = query st Acid.GetAnalyticsPixelsState + , putState = update st . Acid.ReplaceAnalyticsPixelsState , resetState = analyticsPixelsStateComponent , backupState = \_ _ -> [] , restoreState = RestoreBackup { restoreEntry = error "Unexpected backup entry" - , restoreFinalize = return initialAnalyticsPixelsState + , restoreFinalize = return Acid.initialAnalyticsPixelsState } } -- | Default constructor for building this feature. analyticsPixelsFeature :: ServerEnv - -> StateComponent AcidState AnalyticsPixelsState + -> StateComponent AcidState Acid.AnalyticsPixelsState -> CoreFeature -- To get site package list -> UserFeature -- To authenticate users -> UploadFeature -- For accessing package maintainers and trustees @@ -113,16 +114,16 @@ analyticsPixelsFeature ServerEnv{..} userAnalyticsPixelsResource = resourceAt "/user/:username/analytics-pixels.:format" getPackageAnalyticsPixels :: MonadIO m => PackageName -> m (Set AnalyticsPixel) - getPackageAnalyticsPixels name = - queryState analyticsPixelsState (AnalyticsPixelsForPackage name) + getPackageAnalyticsPixels name = + queryState analyticsPixelsState (Acid.AnalyticsPixelsForPackage name) addPackageAnalyticsPixel :: MonadIO m => PackageName -> AnalyticsPixel -> m Bool addPackageAnalyticsPixel name pixel = do - added <- updateState analyticsPixelsState (AddPackageAnalyticsPixel name pixel) + added <- updateState analyticsPixelsState (Acid.AddPackageAnalyticsPixel name pixel) when added $ runHook_ analyticsPixelAdded (name, pixel) pure added removePackageAnalyticsPixel :: MonadIO m => PackageName -> AnalyticsPixel -> m () removePackageAnalyticsPixel name pixel = do - updateState analyticsPixelsState (RemovePackageAnalyticsPixel name pixel) + updateState analyticsPixelsState (Acid.RemovePackageAnalyticsPixel name pixel) runHook_ analyticsPixelRemoved (name, pixel) diff --git a/src/Distribution/Server/Features/AnalyticsPixels/State.hs b/src/Distribution/Server/Features/AnalyticsPixels/State.hs index 1684880a5..e58da4b6f 100644 --- a/src/Distribution/Server/Features/AnalyticsPixels/State.hs +++ b/src/Distribution/Server/Features/AnalyticsPixels/State.hs @@ -1,9 +1,8 @@ -{-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving, - TypeFamilies, TemplateHaskell #-} +{-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving, TypeFamilies, TemplateHaskell #-} +{-# OPTIONS_GHC -Wno-orphans #-} -module Distribution.Server.Features.AnalyticsPixels.State - ( AnalyticsPixel(..) - , AnalyticsPixelsState(..) +module Distribution.Server.Features.AnalyticsPixels.State + ( AnalyticsPixelsState(..) , initialAnalyticsPixelsState -- * State queries and updates @@ -14,12 +13,12 @@ module Distribution.Server.Features.AnalyticsPixels.State , ReplaceAnalyticsPixelsState(..) ) where +import Distribution.Server.Features.AnalyticsPixels.Types import Distribution.Package (PackageName) import Distribution.Server.Framework.MemSize (MemSize) import Distribution.Server.Users.State () -import Data.Text (Text) import Data.Map (Map) import qualified Data.Map.Strict as Map import Data.Acid (Query, Update, makeAcidic) @@ -31,12 +30,6 @@ import Control.DeepSeq (NFData) import qualified Control.Monad.State as State import Control.Monad.Reader.Class (ask, asks) -newtype AnalyticsPixel = AnalyticsPixel - { - analyticsPixelUrl :: Text - } - deriving (Show, Eq, Ord, NFData, MemSize) - newtype AnalyticsPixelsState = AnalyticsPixelsState { analyticsPixels :: Map PackageName (Set AnalyticsPixel) @@ -68,12 +61,12 @@ addPackageAnalyticsPixel name analyticsPixel = do pure successfullyInserted where insertAnalyticsPixel :: Maybe (Set AnalyticsPixel) -> (Bool, Maybe (Set AnalyticsPixel)) - insertAnalyticsPixel Nothing = + insertAnalyticsPixel Nothing = (True, Just (Set.singleton analyticsPixel)) insertAnalyticsPixel existingPixels@(Just pixels) - | analyticsPixel `Set.member` pixels = + | analyticsPixel `Set.member` pixels = (False, existingPixels) - | otherwise = + | otherwise = (True, Just (Set.insert analyticsPixel pixels)) -- | Removes a 'AnalyticsPixel' from a 'Package'. diff --git a/src/Distribution/Server/Features/AnalyticsPixels/Types.hs b/src/Distribution/Server/Features/AnalyticsPixels/Types.hs new file mode 100644 index 000000000..d204ecb82 --- /dev/null +++ b/src/Distribution/Server/Features/AnalyticsPixels/Types.hs @@ -0,0 +1,17 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +module Distribution.Server.Features.AnalyticsPixels.Types + ( AnalyticsPixel(..) + ) where + +import Distribution.Server.Framework.MemSize (MemSize) + +import Data.Text (Text) + +import Control.DeepSeq (NFData) + +newtype AnalyticsPixel = AnalyticsPixel + { + analyticsPixelUrl :: Text + } + deriving (Show, Eq, Ord, NFData, MemSize) From 65fa3ad90236322e7aeb3e122e6ba9a49cdba970 Mon Sep 17 00:00:00 2001 From: Sandy Maguire Date: Wed, 15 Apr 2026 11:26:10 -0700 Subject: [PATCH 08/32] Deacidify documentation --- .../Server/Features/Documentation.hs | 38 +++++++++---------- 1 file changed, 19 insertions(+), 19 deletions(-) diff --git a/src/Distribution/Server/Features/Documentation.hs b/src/Distribution/Server/Features/Documentation.hs index 30fc7bde0..fb3ebfa63 100644 --- a/src/Distribution/Server/Features/Documentation.hs +++ b/src/Distribution/Server/Features/Documentation.hs @@ -10,7 +10,7 @@ module Distribution.Server.Features.Documentation ( import Distribution.Server.Features.Security.SHA256 (sha256) import Distribution.Server.Framework -import Distribution.Server.Features.Documentation.State +import qualified Distribution.Server.Features.Documentation.State as Acid import Distribution.Server.Features.Upload import Distribution.Server.Features.Users import Distribution.Server.Features.Core @@ -110,24 +110,24 @@ initDocumentationFeature name documentationChangeHook return feature -documentationStateComponent :: String -> FilePath -> IO (StateComponent AcidState Documentation) +documentationStateComponent :: String -> FilePath -> IO (StateComponent AcidState Acid.Documentation) documentationStateComponent name stateDir = do - st <- openLocalStateFrom (stateDir "db" name) initialDocumentation + st <- openLocalStateFrom (stateDir "db" name) Acid.initialDocumentation return StateComponent { stateDesc = "Package documentation" , stateHandle = st - , getState = query st GetDocumentation - , putState = update st . ReplaceDocumentation + , getState = query st Acid.GetDocumentation + , putState = update st . Acid.ReplaceDocumentation , backupState = \_ -> dumpBackup - , restoreState = updateDocumentation (Documentation Map.empty) + , 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 $ documentation doc + in map exportFunc . Map.toList $ Acid.documentation doc - updateDocumentation :: Documentation -> RestoreBackup Documentation + updateDocumentation :: Acid.Documentation -> RestoreBackup Acid.Documentation updateDocumentation docs = RestoreBackup { restoreEntry = \entry -> case entry of @@ -139,9 +139,9 @@ documentationStateComponent name stateDir = do , restoreFinalize = return docs } - importDocumentation :: PackageId -> BlobId -> Documentation -> Restore Documentation - importDocumentation pkgId blobId (Documentation docs) = - return (Documentation (Map.insert pkgId blobId 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 @@ -152,7 +152,7 @@ documentationFeature :: String -> ReportsFeature -> UserFeature -> VersionsFeature - -> StateComponent AcidState Documentation + -> StateComponent AcidState Acid.Documentation -> Hook PackageId () -> DocumentationFeature documentationFeature name @@ -186,14 +186,14 @@ documentationFeature name } queryHasDocumentation :: MonadIO m => PackageIdentifier -> m Bool - queryHasDocumentation pkgid = queryState documentationState (HasDocumentation pkgid) + queryHasDocumentation pkgid = queryState documentationState (Acid.HasDocumentation pkgid) queryDocumentation :: MonadIO m => PackageIdentifier -> m (Maybe BlobId) - queryDocumentation pkgid = queryState documentationState (LookupDocumentation pkgid) + queryDocumentation pkgid = queryState documentationState (Acid.LookupDocumentation pkgid) queryDocumentationIndex :: MonadIO m => m (Map.Map PackageId BlobId) queryDocumentationIndex = - liftM documentation (queryState documentationState GetDocumentation) + liftM Acid.documentation (queryState documentationState Acid.GetDocumentation) documentationResource = fix $ \r -> DocumentationResource { packageDocsContent = (extendResourcePath "/docs/.." corePackagePage) { @@ -363,12 +363,12 @@ documentationFeature name fileContents <- expectCompressedTarball let filename = display pkgid ++ "-docs" <.> "tar.gz" unpacked = Gzip.decompressNamed filename fileContents - mres <- liftIO $ BlobStorage.addWith store unpacked + mres <- liftIO $ BlobStorage.addWith store unpacked (\content -> return (checkDocTarball pkgid content)) case mres of Left err -> errBadRequest "Invalid documentation tarball" [MText err] Right ((), blobid) -> do - updateState documentationState $ InsertDocumentation pkgid blobid + updateState documentationState $ Acid.InsertDocumentation pkgid blobid runHook_ documentationChangeHook pkgid noContent (toResponse ()) @@ -401,7 +401,7 @@ documentationFeature name pkgid <- packageInPath dpath guardValidPackageId pkgid guardAuthorisedAsMaintainerOrTrustee (packageName pkgid) - updateState documentationState $ RemoveDocumentation pkgid + updateState documentationState $ Acid.RemoveDocumentation pkgid runHook_ documentationChangeHook pkgid noContent (toResponse ()) @@ -465,7 +465,7 @@ documentationFeature name tempRedirect latestPkgPath (toResponse "") Nothing -> errNotFoundH "Not Found" [MText "There is no documentation for this package."] False -> do - mdocs <- queryState documentationState $ LookupDocumentation pkgid + mdocs <- queryState documentationState $ Acid.LookupDocumentation pkgid case mdocs of Nothing -> errNotFoundH "Not Found" From c52acb3d8df4d806f2df861525681353d2ac22c4 Mon Sep 17 00:00:00 2001 From: Sandy Maguire Date: Wed, 15 Apr 2026 11:27:42 -0700 Subject: [PATCH 09/32] Deacidify users --- src/Distribution/Server.hs | 1 - src/Distribution/Server/Features/Users.hs | 130 +++++++++++----------- src/Distribution/Server/Users/Types.hs | 13 +++ src/Distribution/Server/Users/Users.hs | 13 --- 4 files changed, 78 insertions(+), 79 deletions(-) diff --git a/src/Distribution/Server.hs b/src/Distribution/Server.hs index d1b944090..b5a5d97f5 100644 --- a/src/Distribution/Server.hs +++ b/src/Distribution/Server.hs @@ -39,7 +39,6 @@ import qualified Distribution.Server.Features as Features import Distribution.Server.Features.Users import qualified Distribution.Server.Users.Types as Users -import qualified Distribution.Server.Users.Users as Users import qualified Distribution.Server.Users.Group as Group import Distribution.Text diff --git a/src/Distribution/Server/Features/Users.hs b/src/Distribution/Server/Features/Users.hs index d74e0185d..b158521a7 100644 --- a/src/Distribution/Server/Features/Users.hs +++ b/src/Distribution/Server/Features/Users.hs @@ -15,9 +15,9 @@ import Distribution.Server.Framework.Templating import qualified Distribution.Server.Framework.Auth as Auth import Distribution.Server.Users.Types -import Distribution.Server.Users.State +import qualified Distribution.Server.Users.State as Acid import Distribution.Server.Users.Backup -import qualified Distribution.Server.Users.Users as Users +import qualified Distribution.Server.Users.Users as Acid import qualified Distribution.Server.Users.Group as Group import Distribution.Server.Users.Group (UserGroup(..), GroupDescription(..), UserIdSet, nullDescription) @@ -67,39 +67,39 @@ data UserFeature = UserFeature { guardAuthorised' :: [PrivilegeCondition] -> ServerPartE Bool, -- | Require being logged in, giving the id of the current user. guardAuthenticated :: ServerPartE UserId, - -- | Gets the authentication if it exists. + -- Gets the authentication if it exists. checkAuthenticated :: ServerPartE (Maybe UserId), -- | A hook to override the default authentication error in particular -- circumstances. authFailHook :: Hook Auth.AuthError (Maybe ErrorResponse), -- | Retrieves the entire user base. - queryGetUserDb :: forall m. MonadIO m => m Users.Users, + queryGetUserDb :: forall m. MonadIO m => m Acid.Users, -- | Creates a Hackage 2 user credential. newUserAuth :: UserName -> PasswdPlain -> UserAuth, - -- | Adds a user with a fresh name. - updateAddUser :: forall m. MonadIO m => UserName -> UserAuth -> m (Either Users.ErrUserNameClash UserId), - -- | Sets the account-enabled status of an existing user to True or False. + -- Adds a user with a fresh name. + updateAddUser :: forall m. MonadIO m => UserName -> UserAuth -> m (Either Acid.ErrUserNameClash UserId), + -- Sets the account-enabled status of an existing user to True or False. updateSetUserEnabledStatus :: forall m. MonadIO m => UserId -> Bool - -> m (Maybe (Either Users.ErrNoSuchUserId Users.ErrDeletedUser)), - -- | Sets the credentials of an existing user. + -> m (Maybe (Either Acid.ErrNoSuchUserId Acid.ErrDeletedUser)), + -- Sets the credentials of an existing user. updateSetUserAuth :: forall m. MonadIO m => UserId -> UserAuth - -> m (Maybe (Either Users.ErrNoSuchUserId Users.ErrDeletedUser)), + -> m (Maybe (Either Acid.ErrNoSuchUserId Acid.ErrDeletedUser)), - -- | Adds a user to a group based on a "user" path component. + -- Adds a user to a group based on a "user" path component. -- -- Use the UserGroup or GroupResource directly instead, as this is a hack. groupAddUser :: UserGroup -> DynamicPath -> ServerPartE (), -- | Likewise, deletes a user, will go away soon. groupDeleteUser :: UserGroup -> DynamicPath -> ServerPartE (), - -- | Get a username from a path. + -- Get a username from a path. userNameInPath :: forall m. MonadPlus m => DynamicPath -> m UserName, - -- | Lookup a `UserId` from a name, if the name exists. + -- Lookup a `UserId` from a name, if the name exists. lookupUserName :: UserName -> ServerPartE UserId, - -- | Lookup full `UserInfo` from a name, if the name exists. + -- Lookup full `UserInfo` from a name, if the name exists. lookupUserNameFull :: UserName -> ServerPartE (UserId, UserInfo), - -- | Lookup full `UserInfo` from an id, if the id exists. + -- Lookup full `UserInfo` from an id, if the id exists. lookupUserInfo :: UserId -> ServerPartE UserInfo, -- | An action to change a password directly, using "password" and @@ -268,35 +268,35 @@ initUserFeature serverEnv@ServerEnv{serverStateDir, serverTemplatesDir, serverTe return feature -usersStateComponent :: FilePath -> IO (StateComponent AcidState Users.Users) +usersStateComponent :: FilePath -> IO (StateComponent AcidState Acid.Users) usersStateComponent stateDir = do - st <- openLocalStateFrom (stateDir "db" "Users") initialUsers + st <- openLocalStateFrom (stateDir "db" "Users") Acid.initialUsers return StateComponent { stateDesc = "List of users" , stateHandle = st - , getState = query st GetUserDb - , putState = update st . ReplaceUserDb + , getState = query st Acid.GetUserDb + , putState = update st . Acid.ReplaceUserDb , backupState = usersBackup , restoreState = usersRestore , resetState = usersStateComponent } -adminsStateComponent :: FilePath -> IO (StateComponent AcidState HackageAdmins) +adminsStateComponent :: FilePath -> IO (StateComponent AcidState Acid.HackageAdmins) adminsStateComponent stateDir = do - st <- openLocalStateFrom (stateDir "db" "HackageAdmins") initialHackageAdmins + st <- openLocalStateFrom (stateDir "db" "HackageAdmins") Acid.initialHackageAdmins return StateComponent { stateDesc = "Admins" , stateHandle = st - , getState = query st GetHackageAdmins - , putState = update st . ReplaceHackageAdmins . adminList - , backupState = \_ (HackageAdmins admins) -> [csvToBackup ["admins.csv"] (groupToCSV admins)] - , restoreState = HackageAdmins <$> groupBackup ["admins.csv"] + , 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 Users.Users - -> StateComponent AcidState HackageAdmins + -> StateComponent AcidState Acid.Users + -> StateComponent AcidState Acid.HackageAdmins -> MemState GroupIndex -> Hook () () -> Hook Auth.AuthError (Maybe ErrorResponse) @@ -396,19 +396,19 @@ userFeature templates usersState adminsState -- Queries and updates -- - queryGetUserDb :: MonadIO m => m Users.Users - queryGetUserDb = queryState usersState GetUserDb + queryGetUserDb :: MonadIO m => m Acid.Users + queryGetUserDb = queryState usersState Acid.GetUserDb - updateAddUser :: MonadIO m => UserName -> UserAuth -> m (Either Users.ErrUserNameClash UserId) - updateAddUser uname auth = updateState usersState (AddUserEnabled uname auth) + updateAddUser :: MonadIO m => UserName -> UserAuth -> m (Either Acid.ErrUserNameClash UserId) + updateAddUser uname auth = updateState usersState (Acid.AddUserEnabled uname auth) updateSetUserEnabledStatus :: MonadIO m => UserId -> Bool - -> m (Maybe (Either Users.ErrNoSuchUserId Users.ErrDeletedUser)) - updateSetUserEnabledStatus uid isenabled = updateState usersState (SetUserEnabledStatus uid isenabled) + -> m (Maybe (Either Acid.ErrNoSuchUserId Acid.ErrDeletedUser)) + updateSetUserEnabledStatus uid isenabled = updateState usersState (Acid.SetUserEnabledStatus uid isenabled) updateSetUserAuth :: MonadIO m => UserId -> UserAuth - -> m (Maybe (Either Users.ErrNoSuchUserId Users.ErrDeletedUser)) - updateSetUserAuth uid auth = updateState usersState (SetUserAuth uid auth) + -> m (Maybe (Either Acid.ErrNoSuchUserId Acid.ErrDeletedUser)) + updateSetUserAuth uid auth = updateState usersState (Acid.SetUserAuth uid auth) -- -- Authorisation: authentication checks and privilege checks @@ -485,7 +485,7 @@ userFeature templates usersState adminsState -- As above but using the given userdb snapshot -- See note about "authn" cookie above - guardAuthenticatedWithErrHook :: Users.Users -> ServerPartE UserId + guardAuthenticatedWithErrHook :: Acid.Users -> ServerPartE UserId guardAuthenticatedWithErrHook users = do uid <- Auth.checkAuthenticated realm users userFeatureServerEnv >>= either handleAuthError return @@ -532,7 +532,7 @@ userFeature templates usersState adminsState serveUsersGet :: DynamicPath -> ServerPartE Response serveUsersGet _ = do - userlist <- Users.enumerateActiveUsers <$> queryGetUserDb + userlist <- Acid.enumerateActiveUsers <$> queryGetUserDb let users = [ UserNameIdResource { ui_username = userName uinfo, ui_userid = uid @@ -555,9 +555,9 @@ userFeature templates usersState adminsState serveUserPut dpath = do guardAuthorised_ [InGroup adminGroup] username <- userNameInPath dpath - muid <- updateState usersState $ AddUserDisabled username + muid <- updateState usersState $ Acid.AddUserDisabled username case muid of - Left Users.ErrUserNameClash -> + Left Acid.ErrUserNameClash -> errBadRequest "Username already exists" [MText "Cannot create a new user account with that username because already exists"] Right uid -> return . toResponse $ @@ -570,11 +570,11 @@ userFeature templates usersState adminsState serveUserDelete dpath = do guardAuthorised_ [InGroup adminGroup] uid <- lookupUserName =<< userNameInPath dpath - merr <- updateState usersState $ DeleteUser uid + merr <- updateState usersState $ Acid.DeleteUser uid case merr of Nothing -> noContent $ toResponse () --TODO: need to be able to delete user by name to fix this race condition - Just Users.ErrNoSuchUserId -> errInternalError [MText "uid does not exist"] + Just Acid.ErrNoSuchUserId -> errInternalError [MText "uid does not exist"] serveUserEnabledGet :: DynamicPath -> ServerPartE Response serveUserEnabledGet dpath = do @@ -590,12 +590,12 @@ userFeature templates usersState adminsState guardAuthorised_ [InGroup adminGroup] uid <- lookupUserName =<< userNameInPath dpath EnabledResource enabled <- expectAesonContent - merr <- updateState usersState (SetUserEnabledStatus uid enabled) + merr <- updateState usersState (Acid.SetUserEnabledStatus uid enabled) case merr of Nothing -> noContent $ toResponse () - Just (Left Users.ErrNoSuchUserId) -> + Just (Left Acid.ErrNoSuchUserId) -> errInternalError [MText "uid does not exist"] - Just (Right Users.ErrDeletedUser) -> + Just (Right Acid.ErrDeletedUser) -> errBadRequest "User deleted" [MText "Cannot disable account, it has already been deleted"] @@ -634,7 +634,7 @@ userFeature templates usersState adminsState template <- getTemplate templates "token-created.html" origTok <- liftIO generateOriginalToken let storeTok = convertToken origTok - res <- updateState usersState (AddAuthToken uid storeTok desc) + res <- updateState usersState (Acid.AddAuthToken uid storeTok desc) case res of Nothing -> ok $ toResponse $ @@ -642,7 +642,7 @@ userFeature templates usersState adminsState [ "username" $= display (userName uinfo) , "token" $= viewOriginalToken origTok ] - Just Users.ErrNoSuchUserId -> + Just Acid.ErrNoSuchUserId -> errInternalError [MText "uid does not exist"] "revoke-auth-token" -> do @@ -653,14 +653,14 @@ userFeature templates usersState adminsState [MText "The auth token provided is malformed: " ,MText err] Right authToken -> do - res <- updateState usersState (RevokeAuthToken uid authToken) + res <- updateState usersState (Acid.RevokeAuthToken uid authToken) case res of Nothing -> ok $ toResponse $ template [ "username" $= display (userName uinfo) ] - Just (Left Users.ErrNoSuchUserId) -> + Just (Left Acid.ErrNoSuchUserId) -> errInternalError [MText "uid does not exist"] - Just (Right Users.ErrTokenNotOwned) -> + Just (Right Acid.ErrTokenNotOwned) -> errBadRequest "Invalid auth token" [MText "Cannot revoke this token, no such token."] @@ -678,8 +678,8 @@ userFeature templates usersState adminsState lookupUserNameFull :: UserName -> ServerPartE (UserId, UserInfo) lookupUserNameFull uname = do - users <- queryState usersState GetUserDb - case Users.lookupUserName uname users of + users <- queryState usersState Acid.GetUserDb + case Acid.lookupUserName uname users of Just u -> return u Nothing -> userLost "Could not find user: not presently registered" where userLost = errNotFound "User not found" . return . MText @@ -689,8 +689,8 @@ userFeature templates usersState adminsState lookupUserInfo :: UserId -> ServerPartE UserInfo lookupUserInfo uid = do - users <- queryState usersState GetUserDb - case Users.lookupUserId uid users of + users <- queryState usersState Acid.GetUserDb + case Acid.lookupUserId uid users of Just uinfo -> return uinfo Nothing -> errInternalError [MText "user id does not exist"] @@ -717,15 +717,15 @@ 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 $ AddUserEnabled uname auth + muid <- updateState usersState $ Acid.AddUserEnabled uname auth case muid of - Left Users.ErrUserNameClash -> errForbidden "Error registering user" [MText "A user account with that user name already exists."] + Left Acid.ErrUserNameClash -> errForbidden "Error registering user" [MText "A user account with that user name already exists."] Right _ -> return uname -- 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 GetAdminList + admins <- queryState adminsState Acid.GetAdminList return $ uid == userPathId || (uid `Group.member` admins) --FIXME: this thing is a total mess! @@ -740,11 +740,11 @@ 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 (SetUserAuth uid auth) + res <- updateState usersState (Acid.SetUserAuth uid auth) case res of Nothing -> return () - Just (Left Users.ErrNoSuchUserId) -> errInternalError [MText "user id lookup failure"] - Just (Right Users.ErrDeletedUser) -> forbidChange "Cannot set passwords for deleted users" + Just (Left Acid.ErrNoSuchUserId) -> errInternalError [MText "user id lookup failure"] + Just (Right Acid.ErrDeletedUser) -> forbidChange "Cannot set passwords for deleted users" where forbidChange = errForbidden "Error changing password" . return . MText @@ -755,9 +755,9 @@ userFeature templates usersState adminsState adminGroupDesc :: UserGroup adminGroupDesc = UserGroup { groupDesc = nullDescription { groupTitle = "Hackage admins" }, - queryUserGroup = queryState adminsState GetAdminList, - addUserToGroup = updateState adminsState . AddHackageAdmin, - removeUserFromGroup = updateState adminsState . RemoveHackageAdmin, + queryUserGroup = queryState adminsState Acid.GetAdminList, + addUserToGroup = updateState adminsState . Acid.AddHackageAdmin, + removeUserFromGroup = updateState adminsState . Acid.RemoveHackageAdmin, groupsAllowedToAdd = [adminGroupDesc], groupsAllowedToDelete = [adminGroupDesc] } @@ -765,12 +765,12 @@ userFeature templates usersState adminsState groupAddUser :: UserGroup -> DynamicPath -> ServerPartE () groupAddUser group _ = do actorUid <- guardAuthorised (map InGroup (groupsAllowedToAdd group)) - users <- queryState usersState GetUserDb + users <- queryState usersState Acid.GetUserDb muser <- optional $ look "user" reason <- optional $ look "reason" case muser of Nothing -> addError "Bad request (could not find 'user' argument)" - Just ustr -> case simpleParse ustr >>= \uname -> Users.lookupUserName uname users of + Just ustr -> case simpleParse ustr >>= \uname -> Acid.lookupUserName uname users of Nothing -> addError $ "No user with name " ++ show ustr ++ " found" Just (uid,_) -> do liftIO $ addUserToGroup group uid @@ -893,7 +893,7 @@ userFeature templates usersState adminsState ui_title = T.pack $ groupTitle (groupDesc group), ui_description = T.pack $ groupPrologue (groupDesc group), ui_members = [ UserNameIdResource { - ui_username = Users.userIdToName userDb uid, + ui_username = Acid.userIdToName userDb uid, ui_userid = uid } | uid <- Group.toList userlist ] diff --git a/src/Distribution/Server/Users/Types.hs b/src/Distribution/Server/Users/Types.hs index b297ab800..ca7fd7df3 100644 --- a/src/Distribution/Server/Users/Types.hs +++ b/src/Distribution/Server/Users/Types.hs @@ -110,3 +110,16 @@ instance Migrate UserInfo where } $(deriveSafeCopy 1 'extension ''UserInfo) + +-- error codes +data ErrUserNameClash = ErrUserNameClash +data ErrUserIdClash = ErrUserIdClash +data ErrNoSuchUserId = ErrNoSuchUserId +data ErrDeletedUser = ErrDeletedUser +data ErrTokenNotOwned = ErrTokenNotOwned + +$(deriveSafeCopy 0 'base ''ErrUserNameClash) +$(deriveSafeCopy 0 'base ''ErrUserIdClash) +$(deriveSafeCopy 0 'base ''ErrNoSuchUserId) +$(deriveSafeCopy 0 'base ''ErrDeletedUser) +$(deriveSafeCopy 0 'base ''ErrTokenNotOwned) diff --git a/src/Distribution/Server/Users/Users.hs b/src/Distribution/Server/Users/Users.hs index 2881cb7a7..619c8f6d2 100644 --- a/src/Distribution/Server/Users/Users.hs +++ b/src/Distribution/Server/Users/Users.hs @@ -145,19 +145,6 @@ emptyUsers = Users { authTokenMap = Map.empty } --- error codes -data ErrUserNameClash = ErrUserNameClash -data ErrUserIdClash = ErrUserIdClash -data ErrNoSuchUserId = ErrNoSuchUserId -data ErrDeletedUser = ErrDeletedUser -data ErrTokenNotOwned = ErrTokenNotOwned - -$(deriveSafeCopy 0 'base ''ErrUserNameClash) -$(deriveSafeCopy 0 'base ''ErrUserIdClash) -$(deriveSafeCopy 0 'base ''ErrNoSuchUserId) -$(deriveSafeCopy 0 'base ''ErrDeletedUser) -$(deriveSafeCopy 0 'base ''ErrTokenNotOwned) - (?!) :: Maybe a -> e -> Either e a ma ?! e = maybe (Left e) Right ma From 6a9ecb085869fff545878b05495f1df6a03ef8fd Mon Sep 17 00:00:00 2001 From: Sandy Maguire Date: Wed, 15 Apr 2026 14:23:56 -0700 Subject: [PATCH 10/32] Deacidify uploads --- src/Distribution/Server/Features/Upload.hs | 60 +++++++++++----------- 1 file changed, 30 insertions(+), 30 deletions(-) diff --git a/src/Distribution/Server/Features/Upload.hs b/src/Distribution/Server/Features/Upload.hs index dc512ccef..d01da0dc4 100644 --- a/src/Distribution/Server/Features/Upload.hs +++ b/src/Distribution/Server/Features/Upload.hs @@ -9,7 +9,7 @@ module Distribution.Server.Features.Upload ( import Distribution.Server.Framework import Distribution.Server.Framework.BackupDump -import Distribution.Server.Features.Upload.State +import qualified Distribution.Server.Features.Upload.State as Acid import Distribution.Server.Features.Upload.Backup import Distribution.Server.Features.Core @@ -145,41 +145,41 @@ initUploadFeature env@ServerEnv{serverStateDir} = do return feature -trusteesStateComponent :: FilePath -> IO (StateComponent AcidState HackageTrustees) +trusteesStateComponent :: FilePath -> IO (StateComponent AcidState Acid.HackageTrustees) trusteesStateComponent stateDir = do - st <- openLocalStateFrom (stateDir "db" "HackageTrustees") initialHackageTrustees + st <- openLocalStateFrom (stateDir "db" "HackageTrustees") Acid.initialHackageTrustees return StateComponent { stateDesc = "Trustees" , stateHandle = st - , getState = query st GetHackageTrustees - , putState = update st . ReplaceHackageTrustees . trusteeList - , backupState = \_ (HackageTrustees trustees) -> [csvToBackup ["trustees.csv"] $ groupToCSV trustees] - , restoreState = HackageTrustees <$> groupBackup ["trustees.csv"] + , 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 HackageUploaders) +uploadersStateComponent :: FilePath -> IO (StateComponent AcidState Acid.HackageUploaders) uploadersStateComponent stateDir = do - st <- openLocalStateFrom (stateDir "db" "HackageUploaders") initialHackageUploaders + st <- openLocalStateFrom (stateDir "db" "HackageUploaders") Acid.initialHackageUploaders return StateComponent { stateDesc = "Uploaders" , stateHandle = st - , getState = query st GetHackageUploaders - , putState = update st . ReplaceHackageUploaders . uploaderList - , backupState = \_ (HackageUploaders uploaders) -> [csvToBackup ["uploaders.csv"] $ groupToCSV uploaders] - , restoreState = HackageUploaders <$> groupBackup ["uploaders.csv"] + , 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 PackageMaintainers) +maintainersStateComponent :: FilePath -> IO (StateComponent AcidState Acid.PackageMaintainers) maintainersStateComponent stateDir = do - st <- openLocalStateFrom (stateDir "db" "PackageMaintainers") initialPackageMaintainers + st <- openLocalStateFrom (stateDir "db" "PackageMaintainers") Acid.initialPackageMaintainers return StateComponent { stateDesc = "Package maintainers" , stateHandle = st - , getState = query st AllPackageMaintainers - , putState = update st . ReplacePackageMaintainers - , backupState = \_ (PackageMaintainers mains) -> [maintToExport mains] + , getState = query st Acid.AllPackageMaintainers + , putState = update st . Acid.ReplacePackageMaintainers + , backupState = \_ (Acid.PackageMaintainers mains) -> [maintToExport mains] , restoreState = maintainerBackup , resetState = maintainersStateComponent } @@ -187,9 +187,9 @@ maintainersStateComponent stateDir = do uploadFeature :: ServerEnv -> CoreFeature -> UserFeature - -> StateComponent AcidState HackageTrustees -> UserGroup -> GroupResource - -> StateComponent AcidState HackageUploaders -> UserGroup -> GroupResource - -> StateComponent AcidState PackageMaintainers -> (PackageName -> UserGroup) -> GroupResource + -> StateComponent AcidState Acid.HackageTrustees -> UserGroup -> GroupResource + -> StateComponent AcidState Acid.HackageUploaders -> UserGroup -> GroupResource + -> StateComponent AcidState Acid.PackageMaintainers -> (PackageName -> UserGroup) -> GroupResource -> Hook PackageId () -> (UploadFeature, UserGroup, @@ -255,9 +255,9 @@ uploadFeature ServerEnv{serverBlobStore = store} trusteesGroupDescription :: UserGroup trusteesGroupDescription = UserGroup { groupDesc = trusteeDescription, - queryUserGroup = queryState trusteesState GetTrusteesList, - addUserToGroup = updateState trusteesState . AddHackageTrustee, - removeUserFromGroup = updateState trusteesState . RemoveHackageTrustee, + queryUserGroup = queryState trusteesState Acid.GetTrusteesList, + addUserToGroup = updateState trusteesState . Acid.AddHackageTrustee, + removeUserFromGroup = updateState trusteesState . Acid.RemoveHackageTrustee, groupsAllowedToAdd = [adminGroup], groupsAllowedToDelete = [adminGroup] } @@ -265,9 +265,9 @@ uploadFeature ServerEnv{serverBlobStore = store} uploadersGroupDescription :: UserGroup uploadersGroupDescription = UserGroup { groupDesc = uploaderDescription, - queryUserGroup = queryState uploadersState GetUploadersList, - addUserToGroup = updateState uploadersState . AddHackageUploader, - removeUserFromGroup = updateState uploadersState . RemoveHackageUploader, + queryUserGroup = queryState uploadersState Acid.GetUploadersList, + addUserToGroup = updateState uploadersState . Acid.AddHackageUploader, + removeUserFromGroup = updateState uploadersState . Acid.RemoveHackageUploader, groupsAllowedToAdd = [adminGroup, trusteesGroup], groupsAllowedToDelete = [adminGroup, trusteesGroup] } @@ -277,9 +277,9 @@ uploadFeature ServerEnv{serverBlobStore = store} fix $ \thisgroup -> UserGroup { groupDesc = maintainerDescription name, - queryUserGroup = queryState maintainersState $ GetPackageMaintainers name, - addUserToGroup = updateState maintainersState . AddPackageMaintainer name, - removeUserFromGroup = updateState maintainersState . RemovePackageMaintainer name, + queryUserGroup = queryState maintainersState $ Acid.GetPackageMaintainers name, + addUserToGroup = updateState maintainersState . Acid.AddPackageMaintainer name, + removeUserFromGroup = updateState maintainersState . Acid.RemovePackageMaintainer name, groupsAllowedToAdd = [thisgroup, adminGroup], groupsAllowedToDelete = [thisgroup, adminGroup] } From 57a4e0aae4fe5324ca344d93aca39c8512ea7444 Mon Sep 17 00:00:00 2001 From: Sandy Maguire Date: Wed, 15 Apr 2026 14:26:44 -0700 Subject: [PATCH 11/32] Deacidify distros --- src/Distribution/Server/Features/Distro.hs | 44 +++++++++++----------- 1 file changed, 22 insertions(+), 22 deletions(-) diff --git a/src/Distribution/Server/Features/Distro.hs b/src/Distribution/Server/Features/Distro.hs index 82042d113..156714e00 100644 --- a/src/Distribution/Server/Features/Distro.hs +++ b/src/Distribution/Server/Features/Distro.hs @@ -11,7 +11,7 @@ import Distribution.Server.Features.Core import Distribution.Server.Features.Users import Distribution.Server.Users.Group (UserGroup(..), GroupDescription(..), nullDescription) -import Distribution.Server.Features.Distro.State +import qualified Distribution.Server.Features.Distro.State as Acid import Distribution.Server.Features.Distro.Types import Distribution.Server.Features.Distro.Backup (dumpBackup, restoreBackup) import Distribution.Server.Util.Parse (unpackUTF8) @@ -55,14 +55,14 @@ initDistroFeature ServerEnv{serverStateDir} = do maintainersUserGroup name = UserGroup { groupDesc = maintainerGroupDescription name, - queryUserGroup = queryState distrosState $ GetDistroMaintainers name, - addUserToGroup = updateState distrosState . AddDistroMaintainer name, - removeUserFromGroup = updateState distrosState . RemoveDistroMaintainer name, + queryUserGroup = queryState distrosState $ Acid.GetDistroMaintainers name, + addUserToGroup = updateState distrosState . Acid.AddDistroMaintainer name, + removeUserFromGroup = updateState distrosState . Acid.RemoveDistroMaintainer name, groupsAllowedToAdd = [adminGroup], groupsAllowedToDelete = [adminGroup] } feature = distroFeature user core distrosState maintainersGroupResource maintainersUserGroup - distroNames <- queryState distrosState EnumerateDistros + distroNames <- queryState distrosState Acid.EnumerateDistros (_maintainersGroup, maintainersGroupResource) <- groupResourcesAt "/distro/:package/maintainers" maintainersUserGroup @@ -72,14 +72,14 @@ initDistroFeature ServerEnv{serverStateDir} = do return feature -distrosStateComponent :: FilePath -> IO (StateComponent AcidState Distros) +distrosStateComponent :: FilePath -> IO (StateComponent AcidState Acid.Distros) distrosStateComponent stateDir = do - st <- openLocalStateFrom (stateDir "db" "Distros") initialDistros + st <- openLocalStateFrom (stateDir "db" "Distros") Acid.initialDistros return StateComponent { stateDesc = "" , stateHandle = st - , getState = query st GetDistributions - , putState = \(Distros dists versions) -> update st (ReplaceDistributions dists versions) + , getState = query st Acid.GetDistributions + , putState = \(Acid.Distros dists versions) -> update st (Acid.ReplaceDistributions dists versions) , backupState = \_ -> dumpBackup , restoreState = restoreBackup , resetState = distrosStateComponent @@ -87,7 +87,7 @@ distrosStateComponent stateDir = do distroFeature :: UserFeature -> CoreFeature - -> StateComponent AcidState Distros + -> StateComponent AcidState Acid.Distros -> GroupResource -> (DistroName -> UserGroup) -> DistroFeature @@ -112,7 +112,7 @@ distroFeature UserFeature{..} } queryPackageStatus :: MonadIO m => PackageName -> m [(DistroName, DistroPackageInfo)] - queryPackageStatus pkgname = queryState distrosState (PackageStatus pkgname) + queryPackageStatus pkgname = queryState distrosState (Acid.PackageStatus pkgname) distroResource = DistroResource { distroIndexPage = (resourceAt "/distros/.:format") { @@ -135,7 +135,7 @@ distroFeature UserFeature{..} } } - textEnumDistros _ = fmap (toResponse . intercalate ", " . map display) (queryState distrosState EnumerateDistros) + textEnumDistros _ = fmap (toResponse . intercalate ", " . map display) (queryState distrosState Acid.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 +148,7 @@ distroFeature UserFeature{..} withDistroNamePath dpath $ \distro -> do guardAuthorised_ [InGroup adminGroup] -- should also check for existence here of distro here - void $ updateState distrosState $ RemoveDistro distro + void $ updateState distrosState $ Acid.RemoveDistro distro seeOther "/distros/" (toResponse ()) -- result: ok response or not-found error @@ -158,21 +158,21 @@ distroFeature UserFeature{..} case info of Nothing -> notFound . toResponse $ "Package not found for " ++ display pkgname Just {} -> do - void $ updateState distrosState $ DropPackage dname pkgname + void $ updateState distrosState $ Acid.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 $ AddPackage dname pkgname newPkgInfo + void $ updateState distrosState $ Acid.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 $ AddDistro dname + success <- updateState distrosState $ Acid.AddDistro dname if success then seeOther ("/distro/" ++ display dname) $ toResponse "Ok!" else badRequest $ toResponse "Selected distribution name is already in use" @@ -180,7 +180,7 @@ distroFeature UserFeature{..} distroPutNew dpath = withDistroNamePath dpath $ \dname -> do guardAuthorised_ [InGroup adminGroup] - _success <- updateState distrosState $ AddDistro dname + _success <- updateState distrosState $ Acid.AddDistro dname -- it doesn't matter if it exists already or not ok $ toResponse "Ok!" @@ -194,7 +194,7 @@ distroFeature UserFeature{..} badRequest $ toResponse $ "Could not parse CSV File to a distro package list: " ++ msg Right list -> do - void $ updateState distrosState $ PutDistroPackageList dname list + void $ updateState distrosState $ Acid.PutDistroPackageList dname list ok $ toResponse "Ok!" withDistroNamePath :: DynamicPath -> (DistroName -> ServerPartE Response) -> ServerPartE Response @@ -202,11 +202,11 @@ distroFeature UserFeature{..} withDistroPath :: DynamicPath -> (DistroName -> [(PackageName, DistroPackageInfo)] -> ServerPartE Response) -> ServerPartE Response withDistroPath dpath func = withDistroNamePath dpath $ \dname -> do - isDist <- queryState distrosState (IsDistribution dname) + isDist <- queryState distrosState (Acid.IsDistribution dname) case isDist of False -> notFound $ toResponse "Distribution does not exist" True -> do - pkgs <- queryState distrosState (DistroStatus dname) + pkgs <- queryState distrosState (Acid.DistroStatus dname) func dname pkgs -- guards on the distro existing, but not the package @@ -214,11 +214,11 @@ distroFeature UserFeature{..} withDistroPackagePath dpath func = withDistroNamePath dpath $ \dname -> do pkgname <- packageInPath dpath - isDist <- queryState distrosState (IsDistribution dname) + isDist <- queryState distrosState (Acid.IsDistribution dname) case isDist of False -> notFound $ toResponse "Distribution does not exist" True -> do - pkgInfo <- queryState distrosState (DistroPackageStatus dname pkgname) + pkgInfo <- queryState distrosState (Acid.DistroPackageStatus dname pkgname) func dname pkgname pkgInfo lookPackageInfo :: (DistroPackageInfo -> ServerPartE Response) -> ServerPartE Response From 06895e62b7b72441dc63cc652ae19f759dbf377d Mon Sep 17 00:00:00 2001 From: Sandy Maguire Date: Wed, 15 Apr 2026 14:28:38 -0700 Subject: [PATCH 12/32] Deacidify build reports --- .../Server/Features/BuildReports.hs | 42 +++++++++---------- 1 file changed, 21 insertions(+), 21 deletions(-) diff --git a/src/Distribution/Server/Features/BuildReports.hs b/src/Distribution/Server/Features/BuildReports.hs index 300872e11..7dcd20e09 100644 --- a/src/Distribution/Server/Features/BuildReports.hs +++ b/src/Distribution/Server/Features/BuildReports.hs @@ -13,7 +13,7 @@ import Distribution.Server.Features.Upload import Distribution.Server.Features.Core import Distribution.Server.Features.BuildReports.Backup -import Distribution.Server.Features.BuildReports.State +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(..)) import Distribution.Server.Features.BuildReports.BuildReports (BuildReports, BuildReportId(..), BuildCovg(..), BuildLog(..), TestLog(..)) @@ -87,12 +87,12 @@ initBuildReportsFeature name env@ServerEnv{serverStateDir} = do reportsStateComponent :: String -> FilePath -> IO (StateComponent AcidState BuildReports) reportsStateComponent name stateDir = do - st <- openLocalStateFrom (stateDir "db" name) initialBuildReports + st <- openLocalStateFrom (stateDir "db" name) Acid.initialBuildReports return StateComponent { stateDesc = "Build reports" , stateHandle = st - , getState = query st GetBuildReports - , putState = update st . ReplaceBuildReports + , getState = query st Acid.GetBuildReports + , putState = update st . Acid.ReplaceBuildReports , backupState = \_ -> dumpBackup , restoreState = restoreBackup , resetState = reportsStateComponent name @@ -204,14 +204,14 @@ buildReportsFeature name pkgid <- packageInPath dpath guardValidPackageId pkgid reportId <- reportIdInPath dpath - mreport <- queryState reportsState $ LookupReportCovg pkgid reportId + mreport <- queryState reportsState $ Acid.LookupReportCovg pkgid reportId case mreport of Nothing -> errNotFound "Report not found" [MText "Build report does not exist"] Just (report, mlog, mtest, covg) -> return (reportId, report, mlog, mtest, covg) queryPackageReports :: MonadIO m => PackageId -> m [(BuildReportId, BuildReport)] queryPackageReports pkgid = do - reports <- queryState reportsState $ LookupPackageReports pkgid + reports <- queryState reportsState $ Acid.LookupPackageReports pkgid return $ map (second (\(a, _, _) -> a)) reports queryBuildLog :: MonadIO m => BuildLog -> m Resource.BuildLog @@ -226,9 +226,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 $ LookupFailCount pkgid - latestRpt <- queryState reportsState $ LookupLatestReport pkgid - runTests <- fmap Just . queryState reportsState $ LookupRunTests pkgid + failCnt <- queryState reportsState $ Acid.LookupFailCount pkgid + latestRpt <- queryState reportsState $ Acid.LookupLatestReport pkgid + runTests <- fmap Just . queryState reportsState $ Acid.LookupRunTests pkgid (time, ghcId) <- case latestRpt of Nothing -> return (Nothing,Nothing) Just (_, brp, _, _, _) -> do @@ -238,13 +238,13 @@ buildReportsFeature name queryLastReportStats :: MonadIO m => PackageIdentifier -> m (Maybe (BuildReportId, BuildReport, Maybe BuildCovg)) queryLastReportStats pkgid = do - lookupRes <- queryState reportsState $ LookupLatestReport pkgid + lookupRes <- queryState reportsState $ Acid.LookupLatestReport pkgid case lookupRes of Nothing -> return Nothing Just (rptId, rpt, _, _, covg) -> return (Just (rptId, rpt, covg)) queryRunTests :: MonadIO m => PackageId -> m Bool - queryRunTests pkgid = queryState reportsState $ LookupRunTests pkgid + queryRunTests pkgid = queryState reportsState $ Acid.LookupRunTests pkgid --------------------------------------------------------------------------- @@ -289,7 +289,7 @@ buildReportsFeature name -- Check that the submitter can actually upload docs guardAuthorisedAsMaintainerOrTrustee (packageName pkgid) report' <- liftIO $ BuildReport.affixTimestamp report - reportId <- updateState reportsState $ AddReport pkgid (report', Nothing) + reportId <- updateState reportsState $ Acid.AddReport pkgid (report', Nothing) -- redirect to new reports page seeOther (reportsPageUri reportsResource "" pkgid reportId) $ toResponse () @@ -310,7 +310,7 @@ buildReportsFeature name guardValidPackageId pkgid reportId <- reportIdInPath dpath guardAuthorised_ [InGroup trusteesGroup] - success <- updateState reportsState $ DeleteReport pkgid reportId + success <- updateState reportsState $ Acid.DeleteReport pkgid reportId if success then seeOther (reportsListUri reportsResource "" pkgid) $ toResponse () else errNotFound "Build report not found" [MText $ "Build report #" ++ display reportId ++ " not found"] @@ -324,7 +324,7 @@ buildReportsFeature name guardAuthorised_ [AnyKnownUser] blogbody <- expectTextPlain buildLog <- liftIO $ BlobStorage.add store blogbody - void $ updateState reportsState $ SetBuildLog pkgid reportId (Just $ BuildLog buildLog) + void $ updateState reportsState $ Acid.SetBuildLog pkgid reportId (Just $ BuildLog buildLog) noContent (toResponse ()) putTestLog :: DynamicPath -> ServerPartE Response @@ -336,7 +336,7 @@ buildReportsFeature name guardAuthorised_ [AnyKnownUser] blogbody <- expectTextPlain testLog <- liftIO $ BlobStorage.add store blogbody - void $ updateState reportsState $ SetTestLog pkgid reportId (Just $ TestLog testLog) + void $ updateState reportsState $ Acid.SetTestLog pkgid reportId (Just $ TestLog testLog) noContent (toResponse ()) {- @@ -355,7 +355,7 @@ buildReportsFeature name guardValidPackageId pkgid reportId <- reportIdInPath dpath guardAuthorised_ [InGroup trusteesGroup] - void $ updateState reportsState $ SetBuildLog pkgid reportId Nothing + void $ updateState reportsState $ Acid.SetBuildLog pkgid reportId Nothing noContent (toResponse ()) deleteTestLog :: DynamicPath -> ServerPartE Response @@ -364,7 +364,7 @@ buildReportsFeature name guardValidPackageId pkgid reportId <- reportIdInPath dpath guardAuthorised_ [InGroup trusteesGroup] - void $ updateState reportsState $ SetTestLog pkgid reportId Nothing + void $ updateState reportsState $ Acid.SetTestLog pkgid reportId Nothing noContent (toResponse ()) guardAuthorisedAsMaintainerOrTrustee pkgname = @@ -375,7 +375,7 @@ buildReportsFeature name pkgid <- packageInPath dpath guardValidPackageId pkgid guardAuthorisedAsMaintainerOrTrustee (packageName pkgid) - success <- updateState reportsState $ ResetFailCount pkgid + success <- updateState reportsState $ Acid.ResetFailCount pkgid if success then seeOther (reportsListUri reportsResource "" pkgid) $ toResponse () else errNotFound "Report not found" [MText "Build report does not exist"] @@ -394,7 +394,7 @@ buildReportsFeature name runTests <- body $ looks "runTests" guardValidPackageId pkgid guardAuthorisedAsMaintainerOrTrustee (packageName pkgid) - success <- updateState reportsState $ SetRunTests pkgid ("on" `elem` runTests) + success <- updateState reportsState $ Acid.SetRunTests pkgid ("on" `elem` runTests) if success then seeOther (reportsListUri reportsResource "" pkgid) $ toResponse () else errNotFound "Package not found" [MText "Package does not exist"] @@ -412,7 +412,7 @@ buildReportsFeature name covgBody = BuildReport.coverageContent buildFiles failStatus = BuildReport.buildFail buildFiles - updateState reportsState $ SetFailStatus pkgid failStatus + updateState reportsState $ Acid.SetFailStatus pkgid failStatus -- Upload BuildReport case BuildReport.parse $ toStrict $ fromString $ fromMaybe "" reportBody of @@ -425,7 +425,7 @@ buildReportsFeature name logBlob <- liftIO $ traverse (\x -> BlobStorage.add store $ fromString x) logBody testBlob <- liftIO $ traverse (\x -> BlobStorage.add store $ fromString x) testBody reportId <- updateState reportsState $ - AddRptLogTestCovg pkgid (report', (fmap BuildLog logBlob), (fmap TestLog testBlob), (fmap BuildReport.parseCovg covgBody)) + Acid.AddRptLogTestCovg pkgid (report', (fmap BuildLog logBlob), (fmap TestLog testBlob), (fmap BuildReport.parseCovg covgBody)) -- redirect to new reports page seeOther (reportsPageUri reportsResource "" pkgid reportId) $ toResponse () From b53834d6c3f3e2a4bb1e0b2c68c284129a3e5029 Mon Sep 17 00:00:00 2001 From: Sandy Maguire Date: Wed, 15 Apr 2026 14:31:59 -0700 Subject: [PATCH 13/32] Deacidify tarindexcache --- .../Server/Features/TarIndexCache.hs | 22 +++++++++---------- 1 file changed, 11 insertions(+), 11 deletions(-) diff --git a/src/Distribution/Server/Features/TarIndexCache.hs b/src/Distribution/Server/Features/TarIndexCache.hs index b2d1876b9..e075d1b8c 100644 --- a/src/Distribution/Server/Features/TarIndexCache.hs +++ b/src/Distribution/Server/Features/TarIndexCache.hs @@ -17,7 +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.State +import qualified Distribution.Server.Features.TarIndexCache.State as Acid import Distribution.Server.Features.Users import Distribution.Server.Packages.Types import Data.TarIndex @@ -51,26 +51,26 @@ initTarIndexCacheFeature env@ServerEnv{serverStateDir} = do let feature = tarIndexCacheFeature env users tarIndexCache return feature -tarIndexCacheStateComponent :: FilePath -> IO (StateComponent AcidState TarIndexCache) +tarIndexCacheStateComponent :: FilePath -> IO (StateComponent AcidState Acid.TarIndexCache) tarIndexCacheStateComponent stateDir = do - st <- openLocalStateFrom (stateDir "db" "TarIndexCache") initialTarIndexCache + st <- openLocalStateFrom (stateDir "db" "TarIndexCache") Acid.initialTarIndexCache return StateComponent { stateDesc = "Mapping from tarball blob IDs to tarindex blob IDs" , stateHandle = st - , getState = query st GetTarIndexCache - , putState = update st . ReplaceTarIndexCache + , 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 initialTarIndexCache + , restoreFinalize = return Acid.initialTarIndexCache } } tarIndexCacheFeature :: ServerEnv -> UserFeature - -> StateComponent AcidState TarIndexCache + -> StateComponent AcidState Acid.TarIndexCache -> TarIndexCacheFeature tarIndexCacheFeature ServerEnv{serverBlobStore = store} UserFeature{..} @@ -99,7 +99,7 @@ tarIndexCacheFeature ServerEnv{serverBlobStore = store} -- This is the heart of this feature cachedTarIndex :: BlobId -> IO TarIndex cachedTarIndex tarBallBlobId = do - mTarIndexBlobId <- queryState tarIndexCache (FindTarIndex tarBallBlobId) + mTarIndexBlobId <- queryState tarIndexCache (Acid.FindTarIndex tarBallBlobId) case mTarIndexBlobId of Just tarIndexBlobId -> do serializedTarIndex <- fetch store tarIndexBlobId @@ -112,7 +112,7 @@ tarIndexCacheFeature ServerEnv{serverBlobStore = store} Left err -> throwIO (userError err) Right tarIndex -> return tarIndex tarIndexBlobId <- add store (runPutLazy (safePut tarIndex)) - updateState tarIndexCache (SetTarIndex tarBallBlobId tarIndexBlobId) + updateState tarIndexCache (Acid.SetTarIndex tarBallBlobId tarIndexBlobId) return tarIndex cachedPackageTarIndex :: PkgTarball -> IO TarIndex @@ -120,7 +120,7 @@ tarIndexCacheFeature ServerEnv{serverBlobStore = store} serveTarIndicesStatus :: ServerPartE Response serveTarIndicesStatus = do - TarIndexCache state <- liftIO $ getState tarIndexCache + Acid.TarIndexCache state <- liftIO $ getState tarIndexCache return . toResponse . toJSON . Map.toList $ state -- | With curl: @@ -131,7 +131,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 initialTarIndexCache + liftIO $ putState tarIndexCache Acid.initialTarIndexCache ok $ toResponse "Ok!" -- Functions to access specific files in a tarball From 28bebfe01da2551155d9c3c19b16e8004da85ed2 Mon Sep 17 00:00:00 2001 From: Sandy Maguire Date: Wed, 15 Apr 2026 14:33:29 -0700 Subject: [PATCH 14/32] Deacidify download count --- .../Server/Features/HaskellPlatform.hs | 22 +++++++++---------- 1 file changed, 11 insertions(+), 11 deletions(-) diff --git a/src/Distribution/Server/Features/HaskellPlatform.hs b/src/Distribution/Server/Features/HaskellPlatform.hs index 9d0840bd8..90f5f241b 100644 --- a/src/Distribution/Server/Features/HaskellPlatform.hs +++ b/src/Distribution/Server/Features/HaskellPlatform.hs @@ -8,7 +8,7 @@ module Distribution.Server.Features.HaskellPlatform ( import Distribution.Server.Framework import Distribution.Server.Framework.BackupRestore -import Distribution.Server.Features.HaskellPlatform.State +import qualified Distribution.Server.Features.HaskellPlatform.State as Acid import Distribution.Package import Distribution.Version @@ -53,14 +53,14 @@ initPlatformFeature ServerEnv{serverStateDir} = do let feature = platformFeature platformState return feature -platformStateComponent :: FilePath -> IO (StateComponent AcidState PlatformPackages) +platformStateComponent :: FilePath -> IO (StateComponent AcidState Acid.PlatformPackages) platformStateComponent stateDir = do - st <- openLocalStateFrom (stateDir "db" "PlatformPackages") initialPlatformPackages + st <- openLocalStateFrom (stateDir "db" "Acid.PlatformPackages") Acid.initialPlatformPackages return StateComponent { stateDesc = "Platform packages" , stateHandle = st - , getState = query st GetPlatformPackages - , putState = update st . ReplacePlatformPackages + , 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 @@ -68,11 +68,11 @@ platformStateComponent stateDir = do , backupState = \_ _ -> [] , restoreState = RestoreBackup { restoreEntry = error "Unexpected backup entry for platform" - , restoreFinalize = return initialPlatformPackages + , restoreFinalize = return Acid.initialPlatformPackages } } -platformFeature :: StateComponent AcidState PlatformPackages +platformFeature :: StateComponent AcidState Acid.PlatformPackages -> PlatformFeature platformFeature platformState = PlatformFeature{..} @@ -107,14 +107,14 @@ 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 $ GetPlatformPackage pkgname + platformVersions pkgname = liftM Set.toList $ queryState platformState $ Acid.GetPlatformPackage pkgname platformPackageLatest :: MonadIO m => m [(PackageName, Version)] - platformPackageLatest = liftM (Map.toList . Map.map Set.findMax . blessedPackages) $ queryState platformState GetPlatformPackages + platformPackageLatest = liftM (Map.toList . Map.map Set.findMax . Acid.blessedPackages) $ queryState platformState Acid.GetPlatformPackages setPlatform :: MonadIO m => PackageName -> [Version] -> m () - setPlatform pkgname versions = updateState platformState $ SetPlatformPackage pkgname (Set.fromList versions) + setPlatform pkgname versions = updateState platformState $ Acid.SetPlatformPackage pkgname (Set.fromList versions) removePlatform :: MonadIO m => PackageName -> m () - removePlatform pkgname = updateState platformState $ SetPlatformPackage pkgname Set.empty + removePlatform pkgname = updateState platformState $ Acid.SetPlatformPackage pkgname Set.empty From 15c8bba3dd15cee4fe40f02c0e43468a99f4432b Mon Sep 17 00:00:00 2001 From: Sandy Maguire Date: Wed, 15 Apr 2026 14:38:03 -0700 Subject: [PATCH 15/32] Deacidify preferred versions --- .../Server/Features/PreferredVersions.hs | 104 ++++++++++++++++ .../Features/PreferredVersions/State.hs | 114 +----------------- .../Features/PreferredVersions/Types.hs | 9 ++ .../Features/ReverseDependencies/State.hs | 1 + 4 files changed, 115 insertions(+), 113 deletions(-) create mode 100644 src/Distribution/Server/Features/PreferredVersions/Types.hs diff --git a/src/Distribution/Server/Features/PreferredVersions.hs b/src/Distribution/Server/Features/PreferredVersions.hs index 6097afa0c..440484ed6 100644 --- a/src/Distribution/Server/Features/PreferredVersions.hs +++ b/src/Distribution/Server/Features/PreferredVersions.hs @@ -12,6 +12,8 @@ module Distribution.Server.Features.PreferredVersions ( PreferredRender(..), preferredStateComponent, + + maybeBestVersion, ) where import Distribution.Server.Framework @@ -42,6 +44,8 @@ import qualified Data.Aeson.Key as Key import qualified Data.Aeson.KeyMap as KeyMap import qualified Data.ByteString.Lazy.Char8 as BS (pack) -- Only used for ASCII data import qualified Data.Map as Map +import Data.Set (Set) +import qualified Data.Set as Set import qualified Data.Text as Text import qualified Data.Vector as Vector @@ -452,3 +456,103 @@ object = Object . KeyMap.fromList . map (first Key.fromString) string :: String -> Value string = String . Text.pack + +--------------- + +getVersionStatus :: PreferredInfo -> Version -> VersionStatus +getVersionStatus info version + | version `elem` deprecatedVersions info = DeprecatedVersion + | maybe True (withinRange version) (sumRange info) = NormalVersion + | otherwise = UnpreferredVersion + +classifyVersions :: PreferredInfo -> [Version] -> [(Version, VersionStatus)] +classifyVersions (PreferredInfo [] [] _) = map (flip (,) NormalVersion) +classifyVersions info = map ((,) `ap` getVersionStatus info) + +maybeBestVersion :: PreferredInfo -> [Version] -> Set Version -> Maybe (Version, Maybe VersionStatus) +maybeBestVersion info allVersions versions = if null allVersions || Set.null versions then Nothing else Just $ findBestVersion info allVersions versions + +{- +findBestVersion attempts to find the best version to display out of a set +of versions. The quality of a given version is encoded in a pair (VersionStatus, +Bool). If the version is a NormalVersion, then the boolean indicates whether if +it the most recently uploaded preferred version (and all higher versions are +either deprecated or unpreferred). Otherwise, if it is a DeprecatedVersion or +UnpreferredVersion, the boolean indicates that it is the maximum of all uploaded +versions. + +The list of available versions is scanned from the back (most recent) to the +front (first one uploaded). If a 'better' version is found than the current +best version, it is replaced. If no better version can be found, the algorithm +finishes up. The exact ordering is defined as: + +1. (NormalVersion, True) means the latest preferred version of the package is +available. This option may appear anywhere, although it is always seen before +(NormalVersion, False). In this case, the algorithm finishes up. + +2. (UnpreferredVersion, True) means the latest available version of the package +is not preferred, but the latest preferred version is not available. If this +option appears anywhere, it will be the most recent version in the set, +excluding deprecated versions. + +3. (NormalVersion, False) means neither the actual latest version nor the +preferred latest version are available, but there is some preferred version +that's available. It can only be scanned after (NormalVersion, True) and +(UnpreferredVersion, True), so the algorithm finishes up in this case. +4. (UnpreferredVersion, False) means no preferred versions are available, and +only an older version is available. It is still possible to see a NormalVersion +after this option, so the algorithm continues. + +5. (DeprecatedVersion, True) and (DeprecatedVersion, False) mean only a +deprecated version is available. This is not so great. + +This is a bit complex but I think it has the most intuitive result, and is +rather efficient in 99% of cases. + +The version set and version list should both be non-empty; otherwise this +function is partial. Use maybeBestVersion for a safe check. + +-} +findBestVersion :: PreferredInfo -> [Version] -> Set Version -> (Version, Maybe VersionStatus) +findBestVersion info allVersions versions = + let topStatus = getVersionStatus info maxVersion + in if maxAllVersion == maxVersion && topStatus == NormalVersion + then (maxVersion, Just NormalVersion) -- most common case + else second classifyOpt $ newSearch (reverse $ Set.toList versions) (maxVersion, (topStatus, True)) + where + maxVersion = Set.findMax versions + maxAllVersion = last allVersions + + newestPreferred = case filter ((==NormalVersion) . (infoMap Map.!)) allVersions of + [] -> Nothing + prefs -> Just $ last prefs + + infoMap = Map.fromDistinctAscList $ classifyVersions info allVersions + + newSearch (v:vs) _ = case infoMap Map.! v of + NormalVersion | v == maxAllVersion -> (v, (NormalVersion, True)) + NormalVersion -> oldSearch vs (v, (NormalVersion, False)) + DeprecatedVersion -> newSearch vs (v, (DeprecatedVersion, True)) + UnpreferredVersion -> oldSearch vs (v, (UnpreferredVersion, True)) + newSearch [] opt = opt + + oldSearch (v:vs) opt = case infoMap Map.! v of + NormalVersion -> replaceBetter opt (v, (NormalVersion, newestPreferred == Just v)) + other -> oldSearch vs $ replaceBetter opt (v, (other, False)) + oldSearch [] opt = opt + + replaceBetter keep@(_, old) replace@(_, new) = if optionPrefs new > optionPrefs old then replace else keep + + optionPrefs :: (VersionStatus, Bool) -> Int + optionPrefs opt = case opt of + (NormalVersion, True) -> 4 + (UnpreferredVersion, True) -> 3 + (NormalVersion, False) -> 2 + (UnpreferredVersion, False) -> 1 + _ -> 0 + + classifyOpt opt = case opt of + (NormalVersion, True) -> Just NormalVersion + (UnpreferredVersion, True) -> Just UnpreferredVersion + (DeprecatedVersion, _) -> Just DeprecatedVersion + _ -> Nothing diff --git a/src/Distribution/Server/Features/PreferredVersions/State.hs b/src/Distribution/Server/Features/PreferredVersions/State.hs index e4cb5c8a0..92c059dde 100644 --- a/src/Distribution/Server/Features/PreferredVersions/State.hs +++ b/src/Distribution/Server/Features/PreferredVersions/State.hs @@ -9,16 +9,12 @@ import Distribution.Package import Distribution.Version import Data.Acid (Query, Update, makeAcidic) -import Data.Maybe (fromMaybe, isNothing) -import Control.Arrow (second) -import Control.Monad (ap) +import Data.Maybe (fromMaybe) import Control.Monad.State (put, modify) import Control.Monad.Reader (ask, asks) import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map import Data.SafeCopy (Migrate(..), base, extension, deriveSafeCopy) -import Data.Set (Set) -import qualified Data.Set as Set data PreferredVersions = PreferredVersions { preferredMap :: Map PackageName PreferredInfo, @@ -44,32 +40,12 @@ consolidateRanges ranges depr = data VersionStatus = NormalVersion | DeprecatedVersion | UnpreferredVersion deriving (Show, Eq, Ord, Enum) -getVersionStatus :: PreferredInfo -> Version -> VersionStatus -getVersionStatus info version - | version `elem` deprecatedVersions info = DeprecatedVersion - | maybe True (withinRange version) (sumRange info) = NormalVersion - | otherwise = UnpreferredVersion - -classifyVersions :: PreferredInfo -> [Version] -> [(Version, VersionStatus)] -classifyVersions (PreferredInfo [] [] _) = map (flip (,) NormalVersion) -classifyVersions info = map ((,) `ap` getVersionStatus info) - -partitionVersions :: PreferredInfo -> [Version] -> ([Version], [Version], [Version]) -partitionVersions info versions = if isNothing $ sumRange info then (versions, [], []) else go versions - where go :: [Version] -> ([Version], [Version], [Version]) -- foldr-type approach - go (v:vs) = let ~(norm, depr, unpref) = go vs in case getVersionStatus info v of - NormalVersion -> (v:norm, depr, unpref) - DeprecatedVersion -> (norm, v:depr, unpref) - UnpreferredVersion -> (norm, depr, v:unpref) - go [] = ([], [], []) - data PreferredVersions_v0 = PreferredVersions_v0 (Map PackageName PreferredInfo) (Map PackageName [PackageName]) $(deriveSafeCopy 0 'base ''PreferredInfo) -$(deriveSafeCopy 0 'base ''VersionStatus) $(deriveSafeCopy 0 'base ''PreferredVersions_v0) instance Migrate PreferredVersions where @@ -182,91 +158,3 @@ makeAcidic ''PreferredVersions ['setPreferredInfo ] ---------------- -maybeBestVersion :: PreferredInfo -> [Version] -> Set Version -> Maybe (Version, Maybe VersionStatus) -maybeBestVersion info allVersions versions = if null allVersions || Set.null versions then Nothing else Just $ findBestVersion info allVersions versions - -{- -findBestVersion attempts to find the best version to display out of a set -of versions. The quality of a given version is encoded in a pair (VersionStatus, -Bool). If the version is a NormalVersion, then the boolean indicates whether if -it the most recently uploaded preferred version (and all higher versions are -either deprecated or unpreferred). Otherwise, if it is a DeprecatedVersion or -UnpreferredVersion, the boolean indicates that it is the maximum of all uploaded -versions. - -The list of available versions is scanned from the back (most recent) to the -front (first one uploaded). If a 'better' version is found than the current -best version, it is replaced. If no better version can be found, the algorithm -finishes up. The exact ordering is defined as: - -1. (NormalVersion, True) means the latest preferred version of the package is -available. This option may appear anywhere, although it is always seen before -(NormalVersion, False). In this case, the algorithm finishes up. - -2. (UnpreferredVersion, True) means the latest available version of the package -is not preferred, but the latest preferred version is not available. If this -option appears anywhere, it will be the most recent version in the set, -excluding deprecated versions. - -3. (NormalVersion, False) means neither the actual latest version nor the -preferred latest version are available, but there is some preferred version -that's available. It can only be scanned after (NormalVersion, True) and -(UnpreferredVersion, True), so the algorithm finishes up in this case. -4. (UnpreferredVersion, False) means no preferred versions are available, and -only an older version is available. It is still possible to see a NormalVersion -after this option, so the algorithm continues. - -5. (DeprecatedVersion, True) and (DeprecatedVersion, False) mean only a -deprecated version is available. This is not so great. - -This is a bit complex but I think it has the most intuitive result, and is -rather efficient in 99% of cases. - -The version set and version list should both be non-empty; otherwise this -function is partial. Use maybeBestVersion for a safe check. - --} -findBestVersion :: PreferredInfo -> [Version] -> Set Version -> (Version, Maybe VersionStatus) -findBestVersion info allVersions versions = - let topStatus = getVersionStatus info maxVersion - in if maxAllVersion == maxVersion && topStatus == NormalVersion - then (maxVersion, Just NormalVersion) -- most common case - else second classifyOpt $ newSearch (reverse $ Set.toList versions) (maxVersion, (topStatus, True)) - where - maxVersion = Set.findMax versions - maxAllVersion = last allVersions - - newestPreferred = case filter ((==NormalVersion) . (infoMap Map.!)) allVersions of - [] -> Nothing - prefs -> Just $ last prefs - - infoMap = Map.fromDistinctAscList $ classifyVersions info allVersions - - newSearch (v:vs) _ = case infoMap Map.! v of - NormalVersion | v == maxAllVersion -> (v, (NormalVersion, True)) - NormalVersion -> oldSearch vs (v, (NormalVersion, False)) - DeprecatedVersion -> newSearch vs (v, (DeprecatedVersion, True)) - UnpreferredVersion -> oldSearch vs (v, (UnpreferredVersion, True)) - newSearch [] opt = opt - - oldSearch (v:vs) opt = case infoMap Map.! v of - NormalVersion -> replaceBetter opt (v, (NormalVersion, newestPreferred == Just v)) - other -> oldSearch vs $ replaceBetter opt (v, (other, False)) - oldSearch [] opt = opt - - replaceBetter keep@(_, old) replace@(_, new) = if optionPrefs new > optionPrefs old then replace else keep - - optionPrefs :: (VersionStatus, Bool) -> Int - optionPrefs opt = case opt of - (NormalVersion, True) -> 4 - (UnpreferredVersion, True) -> 3 - (NormalVersion, False) -> 2 - (UnpreferredVersion, False) -> 1 - _ -> 0 - - classifyOpt opt = case opt of - (NormalVersion, True) -> Just NormalVersion - (UnpreferredVersion, True) -> Just UnpreferredVersion - (DeprecatedVersion, _) -> Just DeprecatedVersion - _ -> Nothing diff --git a/src/Distribution/Server/Features/PreferredVersions/Types.hs b/src/Distribution/Server/Features/PreferredVersions/Types.hs new file mode 100644 index 000000000..c53f1a125 --- /dev/null +++ b/src/Distribution/Server/Features/PreferredVersions/Types.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE TemplateHaskell #-} + +module Distribution.Server.Features.PreferredVersions.Types where + +import Data.SafeCopy (base, deriveSafeCopy) + +data VersionStatus = NormalVersion | DeprecatedVersion | UnpreferredVersion deriving (Show, Eq, Ord, Enum) + +$(deriveSafeCopy 0 'base ''VersionStatus) diff --git a/src/Distribution/Server/Features/ReverseDependencies/State.hs b/src/Distribution/Server/Features/ReverseDependencies/State.hs index 88df8752a..3bbaeeeb8 100644 --- a/src/Distribution/Server/Features/ReverseDependencies/State.hs +++ b/src/Distribution/Server/Features/ReverseDependencies/State.hs @@ -47,6 +47,7 @@ import Distribution.Package import Distribution.PackageDescription import Distribution.Server.Packages.Types import Distribution.Server.Framework.MemSize +import Distribution.Server.Features.PreferredVersions (maybeBestVersion) import Distribution.Server.Features.PreferredVersions.State import Distribution.Server.Packages.PackageIndex (PackageIndex) import qualified Distribution.Server.Packages.PackageIndex as PackageIndex From 90188acf3169b6ed4c7878d5d1a90656edca0334 Mon Sep 17 00:00:00 2001 From: Sandy Maguire Date: Wed, 15 Apr 2026 14:49:55 -0700 Subject: [PATCH 16/32] Deacidify core state --- src/Distribution/Server/Features/Core.hs | 46 ++++++++++++------------ 1 file changed, 23 insertions(+), 23 deletions(-) diff --git a/src/Distribution/Server/Features/Core.hs b/src/Distribution/Server/Features/Core.hs index 1a506c2f1..9cb5c45b7 100644 --- a/src/Distribution/Server/Features/Core.hs +++ b/src/Distribution/Server/Features/Core.hs @@ -38,7 +38,7 @@ import qualified Data.Vector as Vec import Distribution.Server.Prelude import Distribution.Server.Features.Core.Backup -import Distribution.Server.Features.Core.State +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 @@ -116,7 +116,7 @@ data CoreFeature = CoreFeature { -- If this package was found, runs a `PackageChangeInfo` hook when done and -- returns True. updateSetPackageUploader :: forall m. MonadIO m => PackageId -> UserId -> m Bool, - -- | Sets the upload time of an existing package version. + -- | Acid.Sets the upload time of an existing package version. -- -- If this package was found, runs a `PackageChangeInfo` hook when done and -- returns True. @@ -289,7 +289,7 @@ initCoreFeature env@ServerEnv{serverStateDir, serverCacheDelay, -- rather than BlobId; that is, we additionally record the length and -- SHA256 hash for all blobs. -- - -- Additionally, we now need `package.json` files for all versions of all + -- Acid.Additionally, we now need `package.json` files for all versions of all -- packages. For new packages we add these when the package is uploaded, -- but for previously uploaded packages we need to add them. -- @@ -299,13 +299,13 @@ initCoreFeature env@ServerEnv{serverStateDir, serverCacheDelay, -- we can use the check for the existence of the update log to see if we -- need any other kind of migration. - migrateUpdateLog <- (isLeft . packageUpdateLog) <$> - queryState packagesState GetPackagesState + migrateUpdateLog <- (isLeft . Acid.packageUpdateLog) <$> + queryState packagesState Acid.GetPackagesState when migrateUpdateLog $ do - -- Migrate PackagesState (introduce package update log) + -- Migrate Acid.PackagesState (introduce package update log) logTiming verbosity "migrating package update log" $ do userdb <- queryGetUserDb users - updateState packagesState (MigrateAddUpdateLog userdb) + updateState packagesState (Acid.MigrateAddUpdateLog userdb) -- Migrate PkgTarball logTiming verbosity "migrating PkgTarball" $ @@ -354,21 +354,21 @@ initCoreFeature env@ServerEnv{serverStateDir, serverCacheDelay, PackageChangeAdd _ -> return () _ -> do additionalEntries <- concat <$> runHook preIndexUpdateHook packageChange - forM_ additionalEntries $ updateState packagesState . AddOtherIndexEntry + forM_ additionalEntries $ updateState packagesState . Acid.AddOtherIndexEntry prodAsyncCache indexTar "package change" return feature -packagesStateComponent :: Verbosity -> Bool -> FilePath -> IO (StateComponent AcidState PackagesState) +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 (initialPackagesState freshDB) + openLocalStateFrom stateFile (Acid.initialPackagesState freshDB) return StateComponent { stateDesc = "Main package database" , stateHandle = st - , getState = query st GetPackagesState - , putState = update st . ReplacePackagesState + , getState = query st Acid.GetPackagesState + , putState = update st . Acid.ReplacePackagesState , backupState = \_ -> indexToAllVersions , restoreState = packagesBackup , resetState = packagesStateComponent verbosity True @@ -376,7 +376,7 @@ packagesStateComponent verbosity freshDB stateDir = do coreFeature :: ServerEnv -> UserFeature - -> StateComponent AcidState PackagesState + -> StateComponent AcidState Acid.PackagesState -> AsyncCache IndexTarballInfo -> Hook PackageChange () -> Hook PackageChange [TarIndexEntry] @@ -505,7 +505,7 @@ coreFeature ServerEnv{serverBlobStore = store} UserFeature{..} -- Queries -- queryGetPackageIndex :: MonadIO m => m (PackageIndex PkgInfo) - queryGetPackageIndex = packageIndex <$> queryState packagesState GetPackagesState + queryGetPackageIndex = Acid.packageIndex <$> queryState packagesState Acid.GetPackagesState queryGetIndexTarballInfo :: MonadIO m => m IndexTarballInfo queryGetIndexTarballInfo = readAsyncCache cacheIndexTarball @@ -523,11 +523,11 @@ coreFeature ServerEnv{serverBlobStore = store} UserFeature{..} usersdb <- queryGetUserDb let Just userInfo = lookupUserId uid usersdb - let pkginfo = mkPackageInfo pkgid cabalFile uploadinfo mtarball + let pkginfo = Acid.mkPackageInfo pkgid cabalFile uploadinfo mtarball additionalEntries <- concat `liftM` runHook preIndexUpdateHook (PackageChangeAdd pkginfo) successFlag <- updateState packagesState $ - AddPackage3 + Acid.AddPackage3 pkginfo uploadinfo (userName userInfo) @@ -541,7 +541,7 @@ coreFeature ServerEnv{serverBlobStore = store} UserFeature{..} updateDeletePackage :: MonadIO m => PackageId -> m Bool updateDeletePackage pkgid = logTiming maxBound ("updateDeletePackage " ++ display pkgid) $ do - mpkginfo <- updateState packagesState (DeletePackage pkgid) + mpkginfo <- updateState packagesState (Acid.DeletePackage pkgid) case mpkginfo of Nothing -> return False Just pkginfo -> do @@ -553,7 +553,7 @@ coreFeature ServerEnv{serverBlobStore = store} UserFeature{..} usersdb <- queryGetUserDb let Just userInfo = lookupUserId uid usersdb (moldpkginfo, newpkginfo) <- updateState packagesState $ - AddPackageRevision2 + Acid.AddPackageRevision2 pkgid cabalfile uploadinfo @@ -567,7 +567,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 (AddPackageTarball pkgid tarball uploadinfo) + mpkginfo <- updateState packagesState (Acid.AddPackageTarball pkgid tarball uploadinfo) case mpkginfo of Nothing -> return False @@ -576,7 +576,7 @@ coreFeature ServerEnv{serverBlobStore = store} UserFeature{..} return True updateSetPackageUploader pkgid userid = do - mpkginfo <- updateState packagesState (SetPackageUploader pkgid userid) + mpkginfo <- updateState packagesState (Acid.SetPackageUploader pkgid userid) case mpkginfo of Nothing -> return False Just (oldpkginfo, newpkginfo) -> do @@ -584,7 +584,7 @@ coreFeature ServerEnv{serverBlobStore = store} UserFeature{..} return True updateSetPackageUploadTime pkgid time = do - mpkginfo <- updateState packagesState (SetPackageUploadTime pkgid time) + mpkginfo <- updateState packagesState (Acid.SetPackageUploadTime pkgid time) case mpkginfo of Nothing -> return False Just (oldpkginfo, newpkginfo) -> do @@ -594,7 +594,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 $ - AddOtherIndexEntry $ ExtraEntry entryName entryData entryTime + Acid.AddOtherIndexEntry $ ExtraEntry entryName entryData entryTime runHook_ packageChangeHook (PackageChangeIndexExtra entryName entryData entryTime) -- Cache updates @@ -603,7 +603,7 @@ coreFeature ServerEnv{serverBlobStore = store} UserFeature{..} getIndexTarball = do users <- queryGetUserDb -- note, changes here don't automatically propagate time <- getCurrentTime - PackagesState index (Right updateSeq) <- queryState packagesState GetPackagesState + Acid.PackagesState index (Right updateSeq) <- queryState packagesState Acid.GetPackagesState let updateLog = Foldable.toList updateSeq legacyTarball = Packages.Index.writeLegacy users From 4c6df0dbe88944fabd5c941b25644ad3a5aa229b Mon Sep 17 00:00:00 2001 From: Sandy Maguire Date: Wed, 15 Apr 2026 14:53:04 -0700 Subject: [PATCH 17/32] Deacidify userdetails --- hackage-server.cabal | 3 + .../Server/Features/UserDetails.hs | 160 +++--------------- .../Server/Features/UserDetails/Acid.hs | 96 +++++++++++ .../Server/Features/UserDetails/Types.hs | 44 +++++ 4 files changed, 170 insertions(+), 133 deletions(-) create mode 100644 src/Distribution/Server/Features/UserDetails/Acid.hs create mode 100644 src/Distribution/Server/Features/UserDetails/Types.hs diff --git a/hackage-server.cabal b/hackage-server.cabal index 049d7e948..ae1999154 100644 --- a/hackage-server.cabal +++ b/hackage-server.cabal @@ -398,6 +398,9 @@ library Distribution.Server.Features.AnalyticsPixels.State Distribution.Server.Features.AnalyticsPixels.Types Distribution.Server.Features.UserDetails + Distribution.Server.Features.UserDetails.Acid + Distribution.Server.Features.UserDetails.Backup + Distribution.Server.Features.UserDetails.Types Distribution.Server.Features.UserSignup Distribution.Server.Features.StaticFiles Distribution.Server.Features.ServerIntrospect diff --git a/src/Distribution/Server/Features/UserDetails.hs b/src/Distribution/Server/Features/UserDetails.hs index 0156cfcb9..faafebc5b 100644 --- a/src/Distribution/Server/Features/UserDetails.hs +++ b/src/Distribution/Server/Features/UserDetails.hs @@ -1,5 +1,8 @@ -{-# LANGUAGE DeriveDataTypeable, TypeFamilies, TemplateHaskell, RankNTypes, - NamedFieldPuns, RecordWildCards, RecursiveDo, BangPatterns, OverloadedStrings #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} + module Distribution.Server.Features.UserDetails ( initUserDetailsFeature, UserDetailsFeature(..), @@ -8,6 +11,8 @@ module Distribution.Server.Features.UserDetails ( AccountKind(..) ) where +import qualified Distribution.Server.Features.UserDetails.Acid as Acid +import Distribution.Server.Features.UserDetails.Types import Distribution.Server.Framework import Distribution.Server.Framework.BackupDump import Distribution.Server.Framework.BackupRestore @@ -20,17 +25,9 @@ import Distribution.Server.Features.Core import Distribution.Server.Users.Types import Distribution.Server.Util.Validators (guardValidLookingEmail, guardValidLookingName) -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 qualified Data.Aeson as Aeson -import Data.Aeson.TH - -import Control.Monad.Reader (ask) -import Control.Monad.State (get, put) import Distribution.Text (display) import Data.Version @@ -50,121 +47,18 @@ instance IsHackageFeature UserDetailsFeature where getFeatureInterface = userDetailsFeatureInterface -------------------------- --- Types of stored data --- - -data AccountDetails = AccountDetails { - accountName :: !Text, - accountContactEmail :: !Text, - accountKind :: Maybe AccountKind, - accountAdminNotes :: !Text - } - deriving (Eq, Show) - - -data AccountKind = AccountKindRealUser | AccountKindSpecial - deriving (Eq, Show, Enum, Bounded) - -newtype UserDetailsTable = UserDetailsTable (IntMap AccountDetails) - deriving (Eq, Show) - -data NameAndContact = NameAndContact { ui_name :: Text, ui_contactEmailAddress :: Text } -data AdminInfo = AdminInfo { ui_accountKind :: Maybe AccountKind, ui_notes :: Text } - -deriveJSON (compatAesonOptionsDropPrefix "ui_") ''NameAndContact -deriveJSON compatAesonOptions ''AccountKind -deriveJSON (compatAesonOptionsDropPrefix "ui_") ''AdminInfo - -emptyAccountDetails :: AccountDetails -emptyAccountDetails = AccountDetails T.empty T.empty Nothing T.empty - -emptyUserDetailsTable :: UserDetailsTable -emptyUserDetailsTable = UserDetailsTable IntMap.empty - -$(deriveSafeCopy 0 'base ''AccountKind) -$(deriveSafeCopy 0 'base ''AccountDetails) -$(deriveSafeCopy 0 'base ''UserDetailsTable) - -instance MemSize AccountDetails where - memSize (AccountDetails a b c d) = memSize4 a b c d - -instance MemSize AccountKind where - memSize _ = memSize0 - -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 } - -makeAcidic ''UserDetailsTable [ - --queries - 'getUserDetailsTable, - 'lookupUserDetails, - --updates - 'replaceUserDetailsTable, - 'setUserDetails, - 'setUserNameContact, - 'setUserAdminInfo, - 'deleteUserDetails - ] - - --------------------- -- State components -- -userDetailsStateComponent :: FilePath -> IO (StateComponent AcidState UserDetailsTable) +userDetailsStateComponent :: FilePath -> IO (StateComponent AcidState Acid.UserDetailsTable) userDetailsStateComponent stateDir = do - st <- openLocalStateFrom (stateDir "db" "UserDetails") emptyUserDetailsTable + st <- openLocalStateFrom (stateDir "db" "UserDetails") Acid.emptyUserDetailsTable return StateComponent { stateDesc = "Extra details associated with user accounts, email addresses etc" , stateHandle = st - , getState = query st GetUserDetailsTable - , putState = update st . ReplaceUserDetailsTable + , getState = query st Acid.GetUserDetailsTable + , putState = update st . Acid.ReplaceUserDetailsTable , backupState = \backuptype users -> [csvToBackup ["users.csv"] (userDetailsToCSV backuptype users)] , restoreState = userDetailsBackup @@ -175,10 +69,10 @@ userDetailsStateComponent stateDir = do -- Data backup and restore -- -userDetailsBackup :: RestoreBackup UserDetailsTable -userDetailsBackup = updateUserBackup emptyUserDetailsTable +userDetailsBackup :: RestoreBackup Acid.UserDetailsTable +userDetailsBackup = updateUserBackup Acid.emptyUserDetailsTable -updateUserBackup :: UserDetailsTable -> RestoreBackup UserDetailsTable +updateUserBackup :: Acid.UserDetailsTable -> RestoreBackup Acid.UserDetailsTable updateUserBackup users = RestoreBackup { restoreEntry = \entry -> case entry of BackupByteString ["users.csv"] bs -> do @@ -191,11 +85,11 @@ updateUserBackup users = RestoreBackup { return users } -importUserDetails :: CSV -> UserDetailsTable -> Restore UserDetailsTable +importUserDetails :: CSV -> Acid.UserDetailsTable -> Restore Acid.UserDetailsTable importUserDetails = concatM . map fromRecord . drop 2 where - fromRecord :: Record -> UserDetailsTable -> Restore UserDetailsTable - fromRecord [idStr, nameStr, emailStr, kindStr, notesStr] (UserDetailsTable tbl) = do + fromRecord :: Record -> Acid.UserDetailsTable -> Restore Acid.UserDetailsTable + fromRecord [idStr, nameStr, emailStr, kindStr, notesStr] (Acid.UserDetailsTable tbl) = do UserId uid <- parseText "user id" idStr akind <- parseKind kindStr let udetails = AccountDetails { @@ -204,7 +98,7 @@ importUserDetails = concatM . map fromRecord . drop 2 accountKind = akind, accountAdminNotes = T.pack notesStr } - return $! UserDetailsTable (IntMap.insert uid udetails tbl) + return $! Acid.UserDetailsTable (IntMap.insert uid udetails tbl) fromRecord x _ = fail $ "Error processing user details record: " ++ show x @@ -213,8 +107,8 @@ importUserDetails = concatM . map fromRecord . drop 2 parseKind "special" = return (Just AccountKindSpecial) parseKind sts = fail $ "unable to parse account kind: " ++ sts -userDetailsToCSV :: BackupType -> UserDetailsTable -> CSV -userDetailsToCSV backuptype (UserDetailsTable tbl) +userDetailsToCSV :: BackupType -> Acid.UserDetailsTable -> CSV +userDetailsToCSV backuptype (Acid.UserDetailsTable tbl) = ([showVersion userCSVVer]:) $ (userdetailsCSVKey:) $ @@ -271,7 +165,7 @@ initUserDetailsFeature ServerEnv{serverStateDir, serverTemplatesDir, serverTempl userDetailsFeature :: Templates - -> StateComponent AcidState UserDetailsTable + -> StateComponent AcidState Acid.UserDetailsTable -> UserFeature -> CoreFeature -> UploadFeature @@ -318,11 +212,11 @@ userDetailsFeature templates userDetailsState UserFeature{..} CoreFeature{..} Up -- queryUserDetails :: MonadIO m => UserId -> m (Maybe AccountDetails) - queryUserDetails uid = queryState userDetailsState (LookupUserDetails uid) + queryUserDetails uid = queryState userDetailsState (Acid.LookupUserDetails uid) updateUserDetails :: MonadIO m => UserId -> AccountDetails -> m () updateUserDetails uid udetails = do - updateState userDetailsState (SetUserDetails uid udetails) + updateState userDetailsState (Acid.SetUserDetails uid udetails) -- Request handlers -- @@ -374,14 +268,14 @@ userDetailsFeature templates userDetailsState UserFeature{..} CoreFeature{..} Up NameAndContact name email <- expectAesonContent guardValidLookingName name guardValidLookingEmail email - updateState userDetailsState (SetUserNameContact uid name email) + updateState userDetailsState (Acid.SetUserNameContact uid name email) noContent $ toResponse () handlerDeleteUserNameContact :: DynamicPath -> ServerPartE Response handlerDeleteUserNameContact dpath = do uid <- lookupUserName =<< userNameInPath dpath guardAuthorised_ [IsUserId uid, InGroup adminGroup] - updateState userDetailsState (SetUserNameContact uid T.empty T.empty) + updateState userDetailsState (Acid.SetUserNameContact uid T.empty T.empty) noContent $ toResponse () handlerGetAdminInfo :: DynamicPath -> ServerPartE Response @@ -403,12 +297,12 @@ userDetailsFeature templates userDetailsState UserFeature{..} CoreFeature{..} Up guardAuthorised_ [InGroup adminGroup] uid <- lookupUserName =<< userNameInPath dpath AdminInfo akind notes <- expectAesonContent - updateState userDetailsState (SetUserAdminInfo uid akind notes) + updateState userDetailsState (Acid.SetUserAdminInfo uid akind notes) noContent $ toResponse () handlerDeleteAdminInfo :: DynamicPath -> ServerPartE Response handlerDeleteAdminInfo dpath = do guardAuthorised_ [InGroup adminGroup] uid <- lookupUserName =<< userNameInPath dpath - updateState userDetailsState (SetUserAdminInfo uid Nothing T.empty) + updateState userDetailsState (Acid.SetUserAdminInfo uid Nothing T.empty) noContent $ toResponse () diff --git a/src/Distribution/Server/Features/UserDetails/Acid.hs b/src/Distribution/Server/Features/UserDetails/Acid.hs new file mode 100644 index 000000000..9d218805f --- /dev/null +++ b/src/Distribution/Server/Features/UserDetails/Acid.hs @@ -0,0 +1,96 @@ +{-# LANGUAGE DeriveDataTypeable, TypeFamilies, TemplateHaskell, + NamedFieldPuns, RecordWildCards #-} +module Distribution.Server.Features.UserDetails.Acid where + +import Distribution.Server.Features.UserDetails.Types +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 +-- + +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 } + +makeAcidic ''UserDetailsTable [ + --queries + 'getUserDetailsTable, + 'lookupUserDetails, + --updates + 'replaceUserDetailsTable, + 'setUserDetails, + 'setUserNameContact, + 'setUserAdminInfo, + 'deleteUserDetails + ] + + diff --git a/src/Distribution/Server/Features/UserDetails/Types.hs b/src/Distribution/Server/Features/UserDetails/Types.hs new file mode 100644 index 000000000..d4d3bd310 --- /dev/null +++ b/src/Distribution/Server/Features/UserDetails/Types.hs @@ -0,0 +1,44 @@ +{-# LANGUAGE DeriveDataTypeable, TypeFamilies, TemplateHaskell #-} +module Distribution.Server.Features.UserDetails.Types where + +import Distribution.Server.Framework + +import Data.SafeCopy (base, deriveSafeCopy) + +import Data.Text (Text) +import Data.Aeson.TH + + +------------------------- +-- Types of stored data +-- + +data AccountDetails = AccountDetails { + accountName :: !Text, + accountContactEmail :: !Text, + accountKind :: Maybe AccountKind, + accountAdminNotes :: !Text + } + deriving (Eq, Show) + + + +data AccountKind = AccountKindRealUser | AccountKindSpecial + deriving (Eq, Show, Enum, Bounded) + +data NameAndContact = NameAndContact { ui_name :: Text, ui_contactEmailAddress :: Text } +data AdminInfo = AdminInfo { ui_accountKind :: Maybe AccountKind, ui_notes :: Text } + + +instance MemSize AccountDetails where + memSize (AccountDetails a b c d) = memSize4 a b c d + +instance MemSize AccountKind where + memSize _ = memSize0 + +deriveJSON (compatAesonOptionsDropPrefix "ui_") ''NameAndContact +deriveJSON compatAesonOptions ''AccountKind +deriveJSON (compatAesonOptionsDropPrefix "ui_") ''AdminInfo + +$(deriveSafeCopy 0 'base ''AccountKind) +$(deriveSafeCopy 0 'base ''AccountDetails) From 4292f0617c0d4733c6f7f49d45b6cf0b432f66c1 Mon Sep 17 00:00:00 2001 From: Sandy Maguire Date: Wed, 15 Apr 2026 15:00:16 -0700 Subject: [PATCH 18/32] Deacidify adminlog --- hackage-server.cabal | 3 + src/Distribution/Server/Features/AdminLog.hs | 88 +++++-------------- .../Server/Features/AdminLog/Acid.hs | 42 +++++++++ .../Server/Features/AdminLog/Types.hs | 25 ++++++ .../Server/Features/UserNotify.hs | 4 +- 5 files changed, 95 insertions(+), 67 deletions(-) create mode 100644 src/Distribution/Server/Features/AdminLog/Acid.hs create mode 100644 src/Distribution/Server/Features/AdminLog/Types.hs diff --git a/hackage-server.cabal b/hackage-server.cabal index ae1999154..e31d80329 100644 --- a/hackage-server.cabal +++ b/hackage-server.cabal @@ -336,6 +336,9 @@ library Distribution.Server.Features.PackageContents Distribution.Server.Features.AdminFrontend Distribution.Server.Features.AdminLog + Distribution.Server.Features.AdminLog.Acid + Distribution.Server.Features.AdminLog.Backup + Distribution.Server.Features.AdminLog.Types Distribution.Server.Features.BuildReports Distribution.Server.Features.BuildReports.BuildReport Distribution.Server.Features.BuildReports.BuildReports diff --git a/src/Distribution/Server/Features/AdminLog.hs b/src/Distribution/Server/Features/AdminLog.hs index 2e2a7ff8d..01eaa9f9b 100755 --- a/src/Distribution/Server/Features/AdminLog.hs +++ b/src/Distribution/Server/Features/AdminLog.hs @@ -1,9 +1,11 @@ -{-# LANGUAGE DeriveDataTypeable, TypeFamilies, TemplateHaskell, BangPatterns, +{-# LANGUAGE DeriveDataTypeable, TypeFamilies, BangPatterns, GeneralizedNewtypeDeriving, NamedFieldPuns, RecordWildCards, PatternGuards, RankNTypes #-} module Distribution.Server.Features.AdminLog where +import qualified Distribution.Server.Features.AdminLog.Acid as Acid +import Distribution.Server.Features.AdminLog.Types import Distribution.Server.Users.Types (UserId) import Distribution.Server.Users.Group import Distribution.Server.Framework @@ -12,32 +14,13 @@ import Distribution.Server.Framework.BackupRestore import Distribution.Server.Pages.AdminLog import Distribution.Server.Features.Users -import Data.SafeCopy (base, deriveSafeCopy) import Data.Maybe(mapMaybe) -import Control.Monad.Reader -import qualified Control.Monad.State as State import Data.Time (UTCTime) import Data.Time.Clock (getCurrentTime) import qualified Data.ByteString.Lazy.Char8 as BS import Text.Read (readMaybe) import Distribution.Server.Util.Parse -data GroupDesc = MaintainerGroup BS.ByteString | AdminGroup | TrusteeGroup | OtherGroup BS.ByteString deriving (Eq, Ord, Read, Show) - -deriveSafeCopy 0 'base ''GroupDesc - -instance MemSize GroupDesc where - memSize (MaintainerGroup x) = memSize x - memSize _ = 0 - -data AdminAction = Admin_GroupAddUser UserId GroupDesc | Admin_GroupDelUser UserId GroupDesc deriving (Eq, Ord, Read, Show) - -instance MemSize AdminAction where - memSize (Admin_GroupAddUser x y) = memSize2 x y - memSize (Admin_GroupDelUser x y) = memSize2 x y - -deriveSafeCopy 0 'base ''AdminAction - --TODO Maybe Reason mkAdminAction :: GroupDescription -> Bool -> UserId -> AdminAction @@ -47,36 +30,9 @@ mkAdminAction gd isAdd uid = (if isAdd then Admin_GroupAddUser else Admin_GroupD | Just (pn,_) <- groupEntity gd, groupTitle gd == "Maintainers" = MaintainerGroup (packUTF8 pn) | otherwise = OtherGroup $ packUTF8 (groupTitle gd ++ maybe "" ((' ':) . fst) (groupEntity gd)) -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 - -makeAcidic ''AdminLog ['getAdminLog - ,'replaceAdminLog - ,'addAdminLog] - data AdminLogFeature = AdminLogFeature { adminLogFeatureInterface :: HackageFeature - , queryGetAdminLog :: forall m. MonadIO m => m AdminLog + , queryGetAdminLog :: forall m. MonadIO m => m Acid.AdminLog } instance IsHackageFeature AdminLogFeature where @@ -91,13 +47,13 @@ initAdminLogFeature ServerEnv{serverStateDir} = do registerHook groupChangedHook $ \(gd,addOrDel,actorUid,targetUid,reason) -> do now <- getCurrentTime - updateState adminLogState $ AddAdminLog + updateState adminLogState $ Acid.AddAdminLog (now, actorUid, mkAdminAction gd addOrDel targetUid, packUTF8 reason) return feature adminLogFeature :: UserFeature - -> StateComponent AcidState AdminLog + -> StateComponent AcidState Acid.AdminLog -> AdminLogFeature adminLogFeature UserFeature{..} adminLogState = AdminLogFeature {..} @@ -117,41 +73,41 @@ adminLogFeature UserFeature{..} adminLogState resourceGet = [("html", serveAdminLogGet)] } - queryGetAdminLog :: MonadIO m => m AdminLog - queryGetAdminLog = queryState adminLogState GetAdminLog + queryGetAdminLog :: MonadIO m => m Acid.AdminLog + queryGetAdminLog = queryState adminLogState Acid.GetAdminLog serveAdminLogGet _ = do - aLog <- queryState adminLogState GetAdminLog + aLog <- queryState adminLogState Acid.GetAdminLog users <- queryGetUserDb - return . toResponse . adminLogPage users . map mkRow . adminLog $ aLog + return . toResponse . adminLogPage users . map mkRow . Acid.adminLog $ aLog mkRow (time, actorId, Admin_GroupDelUser targetId group, reason) = - (time, actorId, "Delete", targetId, nameIt group, unpackUTF8 reason) + (time, actorId, "Acid.Delete", targetId, nameIt group, unpackUTF8 reason) mkRow (time, actorId, Admin_GroupAddUser targetId group, reason) = - (time, actorId, "Add", targetId, nameIt group, unpackUTF8 reason) + (time, actorId, "Acid.Add", targetId, nameIt group, unpackUTF8 reason) nameIt (MaintainerGroup pn) = "Maintainers for " ++ unpackUTF8 pn nameIt AdminGroup = "Administrators" nameIt TrusteeGroup = "Trustees" nameIt (OtherGroup s) = unpackUTF8 s -adminLogStateComponent :: FilePath -> IO (StateComponent AcidState AdminLog) +adminLogStateComponent :: FilePath -> IO (StateComponent AcidState Acid.AdminLog) adminLogStateComponent stateDir = do - st <- openLocalStateFrom (stateDir "db" "AdminLog") initialAdminLog + st <- openLocalStateFrom (stateDir "db" "AdminLog") Acid.initialAdminLog return StateComponent { stateDesc = "AdminLog" , stateHandle = st - , getState = query st GetAdminLog - , putState = update st . ReplaceAdminLog - , backupState = \_ (AdminLog xs) -> + , getState = query st Acid.GetAdminLog + , putState = update st . Acid.ReplaceAdminLog + , backupState = \_ (Acid.AdminLog xs) -> [BackupByteString ["adminLog.txt"] . backupLogEntries $ xs] , restoreState = restoreAdminLogBackup , resetState = adminLogStateComponent } -restoreAdminLogBackup :: RestoreBackup AdminLog +restoreAdminLogBackup :: RestoreBackup Acid.AdminLog restoreAdminLogBackup = - go (AdminLog []) + go (Acid.AdminLog []) where go logs = RestoreBackup { @@ -162,9 +118,9 @@ restoreAdminLogBackup = , restoreFinalize = return logs } -importLogs :: AdminLog -> BS.ByteString -> AdminLog -importLogs (AdminLog ls) = - AdminLog . (++ls) . mapMaybe fromRecord . lines . unpackUTF8 +importLogs :: Acid.AdminLog -> BS.ByteString -> Acid.AdminLog +importLogs (Acid.AdminLog ls) = + Acid.AdminLog . (++ls) . mapMaybe fromRecord . lines . unpackUTF8 where fromRecord :: String -> Maybe (UTCTime,UserId,AdminAction,BS.ByteString) fromRecord = readMaybe diff --git a/src/Distribution/Server/Features/AdminLog/Acid.hs b/src/Distribution/Server/Features/AdminLog/Acid.hs new file mode 100644 index 000000000..9847c2db9 --- /dev/null +++ b/src/Distribution/Server/Features/AdminLog/Acid.hs @@ -0,0 +1,42 @@ +{-# LANGUAGE DeriveDataTypeable, TypeFamilies, TemplateHaskell, BangPatterns, + GeneralizedNewtypeDeriving, NamedFieldPuns, RecordWildCards, + PatternGuards, RankNTypes #-} + +module Distribution.Server.Features.AdminLog.Acid where + +import Distribution.Server.Features.AdminLog.Types +import Distribution.Server.Users.Types (UserId) +import Distribution.Server.Framework + +import Data.SafeCopy (base, deriveSafeCopy) +import Control.Monad.Reader +import qualified Control.Monad.State as State +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 + +makeAcidic ''AdminLog ['getAdminLog + ,'replaceAdminLog + ,'addAdminLog] diff --git a/src/Distribution/Server/Features/AdminLog/Types.hs b/src/Distribution/Server/Features/AdminLog/Types.hs new file mode 100644 index 000000000..e5966a6bc --- /dev/null +++ b/src/Distribution/Server/Features/AdminLog/Types.hs @@ -0,0 +1,25 @@ +{-# LANGUAGE DeriveDataTypeable, TypeFamilies, TemplateHaskell #-} + +module Distribution.Server.Features.AdminLog.Types where + +import Distribution.Server.Users.Types (UserId) +import Distribution.Server.Framework + +import Data.SafeCopy (base, deriveSafeCopy) +import qualified Data.ByteString.Lazy.Char8 as BS + +data GroupDesc = MaintainerGroup BS.ByteString | AdminGroup | TrusteeGroup | OtherGroup BS.ByteString deriving (Eq, Ord, Read, Show) + +deriveSafeCopy 0 'base ''GroupDesc + +instance MemSize GroupDesc where + memSize (MaintainerGroup x) = memSize x + memSize _ = 0 + +data AdminAction = Admin_GroupAddUser UserId GroupDesc | Admin_GroupDelUser UserId GroupDesc deriving (Eq, Ord, Read, Show) + +instance MemSize AdminAction where + memSize (Admin_GroupAddUser x y) = memSize2 x y + memSize (Admin_GroupDelUser x y) = memSize2 x y + +deriveSafeCopy 0 'base ''AdminAction diff --git a/src/Distribution/Server/Features/UserNotify.hs b/src/Distribution/Server/Features/UserNotify.hs index 454302ec7..118caca72 100644 --- a/src/Distribution/Server/Features/UserNotify.hs +++ b/src/Distribution/Server/Features/UserNotify.hs @@ -43,6 +43,8 @@ import Distribution.Server.Framework.BackupRestore 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 import Distribution.Server.Features.Core @@ -736,7 +738,7 @@ userNotifyFeature UserFeature{..} return $ filter isRecent $ (PackageIndex.allPackages pkgIndex) collectAdminActions earlier now = do - aLog <- adminLog <$> queryGetAdminLog + aLog <- Acid.adminLog <$> queryGetAdminLog let isRecent (t,_,_,_) = t > earlier && t <= now return $ filter isRecent $ aLog From ed3073a3a7cb290ae5196dd492dfe3b94073daf8 Mon Sep 17 00:00:00 2001 From: Sandy Maguire Date: Wed, 15 Apr 2026 15:05:16 -0700 Subject: [PATCH 19/32] Deacidify legacypasswds --- hackage-server.cabal | 2 + .../Server/Features/AdminFrontend.hs | 5 +- .../Server/Features/LegacyPasswds.hs | 106 ++++-------------- .../Server/Features/LegacyPasswds/Acid.hs | 76 +++++++++++++ 4 files changed, 103 insertions(+), 86 deletions(-) create mode 100644 src/Distribution/Server/Features/LegacyPasswds/Acid.hs diff --git a/hackage-server.cabal b/hackage-server.cabal index e31d80329..0aca94336 100644 --- a/hackage-server.cabal +++ b/hackage-server.cabal @@ -332,7 +332,9 @@ library Distribution.Server.Features.TarIndexCache.State Distribution.Server.Features.LegacyRedirects Distribution.Server.Features.LegacyPasswds + Distribution.Server.Features.LegacyPasswds.Acid Distribution.Server.Features.LegacyPasswds.Auth + Distribution.Server.Features.LegacyPasswds.Backup Distribution.Server.Features.PackageContents Distribution.Server.Features.AdminFrontend Distribution.Server.Features.AdminLog diff --git a/src/Distribution/Server/Features/AdminFrontend.hs b/src/Distribution/Server/Features/AdminFrontend.hs index 9261f3b51..e77eacba3 100644 --- a/src/Distribution/Server/Features/AdminFrontend.hs +++ b/src/Distribution/Server/Features/AdminFrontend.hs @@ -12,6 +12,7 @@ import Distribution.Server.Features.Users import Distribution.Server.Features.UserDetails import Distribution.Server.Features.UserSignup import Distribution.Server.Features.LegacyPasswds +import qualified Distribution.Server.Features.LegacyPasswds.Acid as Acid import Distribution.Server.Users.Types import qualified Distribution.Server.Users.Users as Users @@ -201,7 +202,7 @@ adminFrontendFeature _env templates cacheControlWithoutETag [Private] template <- getTemplate templates "legacy.html" usersdb <- queryGetUserDb - legacyUsers <- enumerateAllUserLegacyPasswd <$> queryLegacyPasswds + legacyUsers <- Acid.enumerateAllUserLegacyPasswd <$> queryLegacyPasswds ok $ toResponse $ template [ "accounts" $= [ accountBasicInfoToTemplate uid uinfo | uid <- legacyUsers @@ -226,7 +227,7 @@ adminFrontendFeature _env templates uinfo <- lookupUserInfo uid mudetails <- queryUserDetails uid resetInfo <- lookupPasswordReset uid <$> queryAllSignupResetInfo - mlegacy <- lookupUserLegacyPasswd uid <$> queryLegacyPasswds + mlegacy <- Acid.lookupUserLegacyPasswd uid <$> queryLegacyPasswds ok $ toResponse $ template [ "account" $= accountBasicInfoToTemplate uid uinfo diff --git a/src/Distribution/Server/Features/LegacyPasswds.hs b/src/Distribution/Server/Features/LegacyPasswds.hs index 17ec8a757..86454aa75 100644 --- a/src/Distribution/Server/Features/LegacyPasswds.hs +++ b/src/Distribution/Server/Features/LegacyPasswds.hs @@ -1,14 +1,13 @@ -{-# LANGUAGE DeriveDataTypeable, TypeFamilies, TemplateHaskell, +{-# LANGUAGE DeriveDataTypeable, TypeFamilies, RankNTypes, NamedFieldPuns, RecordWildCards, RecursiveDo, BangPatterns #-} module Distribution.Server.Features.LegacyPasswds ( initLegacyPasswdsFeature, LegacyPasswdsFeature(..), - LegacyPasswdsTable, - lookupUserLegacyPasswd, - enumerateAllUserLegacyPasswd, ) where +import qualified Distribution.Server.Features.LegacyPasswds.Acid as Acid + import Prelude hiding (abs) import Distribution.Server.Framework @@ -25,14 +24,9 @@ import qualified Distribution.Server.Users.Types as Users import qualified Distribution.Server.Users.Users as Users import qualified Distribution.Server.Framework.Auth as Auth -import Data.IntMap (IntMap) import qualified Data.IntMap as IntMap import qualified Data.ByteString.Lazy.Char8 as LBS -- ASCII data only (password hashes) -import Data.SafeCopy (base, deriveSafeCopy) -import Control.Monad.Reader (ask) -import Control.Monad.State (get, put) - import Distribution.Text (display) import Data.Version import Text.CSV (CSV, Record) @@ -45,82 +39,26 @@ import Network.URI (URI(..), uriToString) data LegacyPasswdsFeature = LegacyPasswdsFeature { legacyPasswdsFeatureInterface :: HackageFeature, - queryLegacyPasswds :: forall m. MonadIO m => m LegacyPasswdsTable, + queryLegacyPasswds :: forall m. MonadIO m => m Acid.LegacyPasswdsTable, updateDeleteLegacyPasswd :: forall m. MonadIO m => UserId -> m Bool } instance IsHackageFeature LegacyPasswdsFeature where getFeatureInterface = legacyPasswdsFeatureInterface -------------------------- --- Types of stored data --- - -newtype LegacyPasswdsTable = LegacyPasswdsTable (IntMap LegacyAuth.HtPasswdHash) - deriving (Eq, Show) - -emptyLegacyPasswdsTable :: LegacyPasswdsTable -emptyLegacyPasswdsTable = LegacyPasswdsTable IntMap.empty - -lookupUserLegacyPasswd :: UserId -> LegacyPasswdsTable -> Maybe LegacyAuth.HtPasswdHash -lookupUserLegacyPasswd (UserId uid) (LegacyPasswdsTable tbl) = - IntMap.lookup uid tbl - -enumerateAllUserLegacyPasswd :: LegacyPasswdsTable -> [UserId] -enumerateAllUserLegacyPasswd (LegacyPasswdsTable tbl) = - map UserId (IntMap.keys tbl) - -$(deriveSafeCopy 0 'base ''LegacyPasswdsTable) - -instance MemSize LegacyPasswdsTable where - memSize (LegacyPasswdsTable a) = memSize1 a - ------------------------------- --- State queries and updates --- - -getLegacyPasswdsTable :: Query LegacyPasswdsTable LegacyPasswdsTable -getLegacyPasswdsTable = ask - -replaceLegacyPasswdsTable :: LegacyPasswdsTable -> Update LegacyPasswdsTable () -replaceLegacyPasswdsTable = put - -setUserLegacyPasswd :: UserId -> LegacyAuth.HtPasswdHash -> Update LegacyPasswdsTable () -setUserLegacyPasswd (UserId uid) udetails = do - LegacyPasswdsTable tbl <- get - put $! LegacyPasswdsTable (IntMap.insert uid udetails tbl) - -deleteUserLegacyPasswd :: UserId -> Update LegacyPasswdsTable Bool -deleteUserLegacyPasswd (UserId uid) = do - LegacyPasswdsTable tbl <- get - if IntMap.member uid tbl - then do put $! LegacyPasswdsTable (IntMap.delete uid tbl) - return True - else return False - - -makeAcidic ''LegacyPasswdsTable [ - --queries - 'getLegacyPasswdsTable, - --updates - 'replaceLegacyPasswdsTable, - 'setUserLegacyPasswd, - 'deleteUserLegacyPasswd - ] - --------------------- -- State components -- -legacyPasswdsStateComponent :: FilePath -> IO (StateComponent AcidState LegacyPasswdsTable) +legacyPasswdsStateComponent :: FilePath -> IO (StateComponent AcidState Acid.LegacyPasswdsTable) legacyPasswdsStateComponent stateDir = do - st <- openLocalStateFrom (stateDir "db" "LegacyPasswds") emptyLegacyPasswdsTable + st <- openLocalStateFrom (stateDir "db" "LegacyPasswds") Acid.emptyLegacyPasswdsTable return StateComponent { stateDesc = "Support for upgrading accounts from htpasswd-style passwords" , stateHandle = st - , getState = query st GetLegacyPasswdsTable - , putState = update st . ReplaceLegacyPasswdsTable + , getState = query st Acid.GetLegacyPasswdsTable + , putState = update st . Acid.ReplaceLegacyPasswdsTable , backupState = \backuptype users -> [csvToBackup ["htpasswd.csv"] (legacyPasswdsToCSV backuptype users)] , restoreState = legacyPasswdsBackup @@ -131,10 +69,10 @@ legacyPasswdsStateComponent stateDir = do -- Data backup and restore -- -legacyPasswdsBackup :: RestoreBackup LegacyPasswdsTable +legacyPasswdsBackup :: RestoreBackup Acid.LegacyPasswdsTable legacyPasswdsBackup = updatePasswdsBackup [] -updatePasswdsBackup :: [(UserId, LegacyAuth.HtPasswdHash)] -> RestoreBackup LegacyPasswdsTable +updatePasswdsBackup :: [(UserId, LegacyAuth.HtPasswdHash)] -> RestoreBackup Acid.LegacyPasswdsTable updatePasswdsBackup upasswds = RestoreBackup { restoreEntry = \entry -> case entry of BackupByteString ["htpasswd.csv"] bs -> do @@ -147,7 +85,7 @@ updatePasswdsBackup upasswds = RestoreBackup { , restoreFinalize = let tbl = IntMap.fromList [ (uid, htpasswd) | (UserId uid, htpasswd) <- upasswds ] in - return $! LegacyPasswdsTable tbl + return $! Acid.LegacyPasswdsTable tbl } importHtPasswds :: CSV -> Restore [(UserId, LegacyAuth.HtPasswdHash)] @@ -160,8 +98,8 @@ importHtPasswds = mapM fromRecord . drop 2 fromRecord x = fail $ "Error processing user details record: " ++ show x -legacyPasswdsToCSV :: BackupType -> LegacyPasswdsTable -> CSV -legacyPasswdsToCSV backuptype (LegacyPasswdsTable tbl) +legacyPasswdsToCSV :: BackupType -> Acid.LegacyPasswdsTable -> CSV +legacyPasswdsToCSV backuptype (Acid.LegacyPasswdsTable tbl) = ([showVersion version]:) $ (headers:) $ @@ -198,7 +136,7 @@ initLegacyPasswdsFeature env@ServerEnv{serverStateDir, serverTemplatesDir, return feature legacyPasswdsFeature :: ServerEnv - -> StateComponent AcidState LegacyPasswdsTable + -> StateComponent AcidState Acid.LegacyPasswdsTable -> Templates -> UserFeature -> LegacyPasswdsFeature @@ -233,12 +171,12 @@ legacyPasswdsFeature env legacyPasswdsState templates UserFeature{..} -- Queries and updates -- - queryLegacyPasswds :: MonadIO m => m LegacyPasswdsTable - queryLegacyPasswds = queryState legacyPasswdsState GetLegacyPasswdsTable + queryLegacyPasswds :: MonadIO m => m Acid.LegacyPasswdsTable + queryLegacyPasswds = queryState legacyPasswdsState Acid.GetLegacyPasswdsTable updateDeleteLegacyPasswd :: MonadIO m => UserId -> m Bool updateDeleteLegacyPasswd uid = - updateState legacyPasswdsState (DeleteUserLegacyPasswd uid) + updateState legacyPasswdsState (Acid.DeleteUserLegacyPasswd uid) -- Request handlers -- @@ -258,7 +196,7 @@ legacyPasswdsFeature env legacyPasswdsState templates UserFeature{..} passwdhash <- expectTextPlain when (not $ validHtpasswd passwdhash) errBadHash let htpasswd = LegacyAuth.HtPasswdHash (LBS.unpack passwdhash) - updateState legacyPasswdsState $ SetUserLegacyPasswd uid htpasswd + updateState legacyPasswdsState $ Acid.SetUserLegacyPasswd uid htpasswd noContent $ toResponse () where validHtpasswd str = LBS.length str == 13 @@ -270,7 +208,7 @@ legacyPasswdsFeature env legacyPasswdsState templates UserFeature{..} handleUserHtpasswdDelete dpath = do guardAuthorised_ [InGroup adminGroup] uid <- lookupUserName =<< userNameInPath dpath - deleted <- updateState legacyPasswdsState (DeleteUserLegacyPasswd uid) + deleted <- updateState legacyPasswdsState (Acid.DeleteUserLegacyPasswd uid) when (not deleted) errNoHtpasswd noContent $ toResponse () where @@ -283,12 +221,12 @@ legacyPasswdsFeature env legacyPasswdsState templates UserFeature{..} (uid, uinfo, passwd) <- LegacyAuth.guardAuthenticated (RealmName "Old Hackage site") users - (flip lookupUserLegacyPasswd legacyPasswds) + (flip Acid.lookupUserLegacyPasswd legacyPasswds) when (userStatus uinfo /= Users.AccountDisabled Nothing) errHasAuth let auth = Users.UserAuth (Auth.newPasswdHash Auth.hackageRealm (userName uinfo) passwd) updateSetUserAuth uid auth updateSetUserEnabledStatus uid True - updateState legacyPasswdsState (DeleteUserLegacyPasswd uid) + updateState legacyPasswdsState (Acid.DeleteUserLegacyPasswd uid) template <- getTemplate templates "htpasswd-upgrade-success.html" ok $ toResponse $ template [] where @@ -312,7 +250,7 @@ legacyPasswdsFeature env legacyPasswdsState templates UserFeature{..} onAuthFail (Auth.UserStatusError uid UserInfo { userStatus = AccountDisabled Nothing }) = do legacyPasswds <- queryLegacyPasswds - case lookupUserLegacyPasswd uid legacyPasswds of + case Acid.lookupUserLegacyPasswd uid legacyPasswds of Nothing -> return Nothing Just _ -> return (Just err) where diff --git a/src/Distribution/Server/Features/LegacyPasswds/Acid.hs b/src/Distribution/Server/Features/LegacyPasswds/Acid.hs new file mode 100644 index 000000000..acc438428 --- /dev/null +++ b/src/Distribution/Server/Features/LegacyPasswds/Acid.hs @@ -0,0 +1,76 @@ +{-# LANGUAGE DeriveDataTypeable, TypeFamilies, TemplateHaskell, + RankNTypes, NamedFieldPuns, RecordWildCards, + RecursiveDo, BangPatterns #-} +module Distribution.Server.Features.LegacyPasswds.Acid where + +import Prelude + +import Distribution.Server.Framework + +import qualified Distribution.Server.Features.LegacyPasswds.Auth as LegacyAuth + +import Distribution.Server.Users.Types + +import Data.IntMap (IntMap) +import qualified Data.IntMap as IntMap + +import Data.SafeCopy (base, deriveSafeCopy) +import Control.Monad.Reader (ask) +import Control.Monad.State (get, put) + +------------------------- +-- Types of stored data +-- + +newtype LegacyPasswdsTable = LegacyPasswdsTable (IntMap LegacyAuth.HtPasswdHash) + deriving (Eq, Show) + +emptyLegacyPasswdsTable :: LegacyPasswdsTable +emptyLegacyPasswdsTable = LegacyPasswdsTable IntMap.empty + +lookupUserLegacyPasswd :: UserId -> LegacyPasswdsTable -> Maybe LegacyAuth.HtPasswdHash +lookupUserLegacyPasswd (UserId uid) (LegacyPasswdsTable tbl) = + IntMap.lookup uid tbl + +enumerateAllUserLegacyPasswd :: LegacyPasswdsTable -> [UserId] +enumerateAllUserLegacyPasswd (LegacyPasswdsTable tbl) = + map UserId (IntMap.keys tbl) + +$(deriveSafeCopy 0 'base ''LegacyPasswdsTable) + +instance MemSize LegacyPasswdsTable where + memSize (LegacyPasswdsTable a) = memSize1 a + +------------------------------ +-- State queries and updates +-- + +getLegacyPasswdsTable :: Query LegacyPasswdsTable LegacyPasswdsTable +getLegacyPasswdsTable = ask + +replaceLegacyPasswdsTable :: LegacyPasswdsTable -> Update LegacyPasswdsTable () +replaceLegacyPasswdsTable = put + +setUserLegacyPasswd :: UserId -> LegacyAuth.HtPasswdHash -> Update LegacyPasswdsTable () +setUserLegacyPasswd (UserId uid) udetails = do + LegacyPasswdsTable tbl <- get + put $! LegacyPasswdsTable (IntMap.insert uid udetails tbl) + +deleteUserLegacyPasswd :: UserId -> Update LegacyPasswdsTable Bool +deleteUserLegacyPasswd (UserId uid) = do + LegacyPasswdsTable tbl <- get + if IntMap.member uid tbl + then do put $! LegacyPasswdsTable (IntMap.delete uid tbl) + return True + else return False + + +makeAcidic ''LegacyPasswdsTable [ + --queries + 'getLegacyPasswdsTable, + --updates + 'replaceLegacyPasswdsTable, + 'setUserLegacyPasswd, + 'deleteUserLegacyPasswd + ] + From e65e32719ef892237b25adea2f7b01605c3978a3 Mon Sep 17 00:00:00 2001 From: Sandy Maguire Date: Wed, 15 Apr 2026 15:12:27 -0700 Subject: [PATCH 20/32] Deacidify usernotify --- hackage-server.cabal | 3 + .../Server/Features/UserNotify.hs | 223 ++++-------------- .../Server/Features/UserNotify/Acid.hs | 126 ++++++++++ .../Server/Features/UserNotify/Types.hs | 96 ++++++++ 4 files changed, 269 insertions(+), 179 deletions(-) create mode 100644 src/Distribution/Server/Features/UserNotify/Acid.hs create mode 100644 src/Distribution/Server/Features/UserNotify/Types.hs diff --git a/hackage-server.cabal b/hackage-server.cabal index 0aca94336..6ad4c417f 100644 --- a/hackage-server.cabal +++ b/hackage-server.cabal @@ -322,6 +322,9 @@ library Distribution.Server.Features.Upload.Backup Distribution.Server.Features.Users Distribution.Server.Features.UserNotify + Distribution.Server.Features.UserNotify.Acid + Distribution.Server.Features.UserNotify.Backup + Distribution.Server.Features.UserNotify.Types if flag(minimal) diff --git a/src/Distribution/Server/Features/UserNotify.hs b/src/Distribution/Server/Features/UserNotify.hs index 118caca72..4aa5e8e7a 100644 --- a/src/Distribution/Server/Features/UserNotify.hs +++ b/src/Distribution/Server/Features/UserNotify.hs @@ -7,12 +7,11 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-} module Distribution.Server.Features.UserNotify ( - NotifyData(..), - NotifyPref(..), + Acid.NotifyData(..), + Acid.NotifyPref(..), NotifyRevisionRange(..), NotifyTriggerBounds(..), UserNotifyFeature(..), - defaultNotifyPrefs, getUserNotificationsOnRelease, importNotifyPref, initUserNotifyFeature, @@ -24,6 +23,10 @@ module Distribution.Server.Features.UserNotify ( getNotificationEmails, ) where +import Distribution.Server.Features.UserDetails.Types +import qualified Distribution.Server.Features.UserNotify.Acid as Acid +import Distribution.Server.Features.UserNotify.Acid (NotifyPref(..)) +import Distribution.Server.Features.UserNotify.Types import Prelude hiding (lookup) import Distribution.Package import Distribution.Pretty @@ -64,9 +67,7 @@ import Data.Set (Set) import qualified Data.Set as Set import Control.Concurrent (threadDelay) -import Control.Monad.Reader (ask) -import Control.Monad.State (get, put) -import Data.Aeson.TH (defaultOptions, deriveJSON) +import Data.Aeson.TH (deriveJSON) import Data.Bifunctor (Bifunctor(second)) import Data.Bimap (lookup, lookupR) import Data.Graph (Vertex) @@ -74,7 +75,6 @@ import Data.Hashable (Hashable(..)) import Data.List (maximumBy, sortOn) import Data.Maybe (fromJust, fromMaybe, listToMaybe, mapMaybe, maybeToList) import Data.Ord (Down(..), comparing) -import Data.SafeCopy (Migrate(migrate), MigrateFrom, base, deriveSafeCopy, extension) import Data.Time (UTCTime(..), addUTCTime, defaultTimeLocale, diffUTCTime, formatTime, getCurrentTime) import Data.Time.Format.Internal (buildTime) import Distribution.Text (display) @@ -104,109 +104,13 @@ Some missing features: data UserNotifyFeature = UserNotifyFeature { userNotifyFeatureInterface :: HackageFeature, - queryGetUserNotifyPref :: forall m. MonadIO m => UserId -> m (Maybe NotifyPref), - updateSetUserNotifyPref :: forall m. MonadIO m => UserId -> NotifyPref -> m () + queryGetUserNotifyPref :: forall m. MonadIO m => UserId -> m (Maybe Acid.NotifyPref), + updateSetUserNotifyPref :: forall m. MonadIO m => UserId -> Acid.NotifyPref -> m () } instance IsHackageFeature UserNotifyFeature where getFeatureInterface = userNotifyFeatureInterface -------------------------- --- Types of stored data --- -data NotifyPref_v0 = NotifyPref_v0 - { - v0notifyOptOut :: Bool, - v0notifyRevisionRange :: NotifyRevisionRange, - v0notifyUpload :: Bool, - v0notifyMaintainerGroup :: Bool, - v0notifyDocBuilderReport :: Bool, - v0notifyPendingTags :: Bool - } - deriving (Eq, Read, Show) -data NotifyPref = NotifyPref - { - notifyOptOut :: Bool, - notifyRevisionRange :: NotifyRevisionRange, - notifyUpload :: Bool, - notifyMaintainerGroup :: Bool, - notifyDocBuilderReport :: Bool, - notifyPendingTags :: Bool, - notifyDependencyForMaintained :: Bool, - notifyDependencyTriggerBounds :: NotifyTriggerBounds - } - deriving (Eq, Read, Show) - -defaultNotifyPrefs :: NotifyPref -defaultNotifyPrefs = NotifyPref { - notifyOptOut = True, -- TODO when we're comfortable with this we can change to False. - notifyRevisionRange = NotifyAllVersions, - notifyUpload = True, - notifyMaintainerGroup = True, - notifyDocBuilderReport = True, - notifyPendingTags = True, - notifyDependencyForMaintained = True, - notifyDependencyTriggerBounds = NewIncompatibility - } - -data NotifyRevisionRange = NotifyAllVersions | NotifyNewestVersion | NoNotifyRevisions deriving (Bounded, Enum, Eq, Read, Show) -instance MemSize NotifyRevisionRange where - memSize _ = 1 - -instance Pretty NotifyRevisionRange where - pretty NoNotifyRevisions = text "No" - pretty NotifyAllVersions = text "All Versions" - pretty NotifyNewestVersion = text "Newest Version" - -instance Hashable NotifyRevisionRange where - hash = fromEnum - hashWithSalt s x = s `hashWithSalt` hash x - -data NotifyTriggerBounds - = Always - | BoundsOutOfRange - | NewIncompatibility - deriving (Bounded, Enum, Eq, Read, Show) - -instance MemSize NotifyTriggerBounds where - memSize _ = 1 - -instance Hashable NotifyTriggerBounds where - hash = fromEnum - hashWithSalt s x = s `hashWithSalt` hash x - -instance MemSize NotifyPref_v0 where memSize _ = memSize ((True,True,True),(True,True, True)) -instance MemSize NotifyPref where memSize NotifyPref{..} = memSize8 notifyOptOut notifyRevisionRange notifyUpload notifyMaintainerGroup - notifyDocBuilderReport notifyPendingTags notifyDependencyForMaintained - notifyDependencyTriggerBounds - -data NotifyData = NotifyData {unNotifyData :: (Map.Map UserId NotifyPref, UTCTime)} deriving (Eq, Show) - -instance MemSize NotifyData where memSize (NotifyData x) = memSize x - -emptyNotifyData :: IO NotifyData -emptyNotifyData = getCurrentTime >>= \x-> return (NotifyData (Map.empty, x)) - -$(deriveSafeCopy 0 'base ''NotifyTriggerBounds) -$(deriveSafeCopy 0 'base ''NotifyRevisionRange) -$(deriveSafeCopy 0 'base ''NotifyPref_v0) - -instance Migrate NotifyPref where - type MigrateFrom NotifyPref = NotifyPref_v0 - migrate (NotifyPref_v0 f0 f1 f2 f3 f4 f5) = - NotifyPref f0 f1 f2 f3 f4 f5 - False -- Users that already have opted in to notifications - -- did so at at a time when it did not include - -- reverse dependency emails. - -- So let's assume they don't want these. - -- Note that this differs from defaultNotifyPrefs. - NewIncompatibility - -$(deriveSafeCopy 1 'extension ''NotifyPref) -$(deriveSafeCopy 0 'base ''NotifyData) -$(deriveJSON defaultOptions ''NotifyRevisionRange) -$(deriveJSON defaultOptions ''NotifyTriggerBounds) - ------------------------------ -- UI -- @@ -263,8 +167,8 @@ instance Hashable NotifyPrefUI where `hashWithSalt` hash ui_notifyDocBuilderReport `hashWithSalt` hash ui_notifyPendingTags -notifyPrefToUI :: NotifyPref -> NotifyPrefUI -notifyPrefToUI NotifyPref{..} = NotifyPrefUI +notifyPrefToUI :: Acid.NotifyPref -> NotifyPrefUI +notifyPrefToUI Acid.NotifyPref{..} = NotifyPrefUI { ui_notifyEnabled = OK (not notifyOptOut) , ui_notifyRevisionRange = notifyRevisionRange , ui_notifyUpload = OK notifyUpload @@ -275,9 +179,9 @@ notifyPrefToUI NotifyPref{..} = NotifyPrefUI , ui_notifyDependencyTriggerBounds = notifyDependencyTriggerBounds } -notifyPrefFromUI :: NotifyPrefUI -> NotifyPref +notifyPrefFromUI :: NotifyPrefUI -> Acid.NotifyPref notifyPrefFromUI NotifyPrefUI{..} - = NotifyPref + = Acid.NotifyPref { notifyOptOut = not (unOK ui_notifyEnabled) , notifyRevisionRange = ui_notifyRevisionRange , notifyUpload = unOK ui_notifyUpload @@ -313,54 +217,15 @@ instance ToRadioButtons NotifyRevisionRange where instance ToRadioButtons OK where toRadioButtons = renderRadioButtons [OK True, OK False] ------------------------------- --- State queries and updates --- - -getNotifyData :: Query NotifyData NotifyData -getNotifyData = ask - -replaceNotifyData :: NotifyData -> Update NotifyData () -replaceNotifyData = put - -getNotifyTime :: Query NotifyData UTCTime -getNotifyTime = fmap (snd . unNotifyData) ask - -setNotifyTime :: UTCTime -> Update NotifyData () -setNotifyTime t = do - NotifyData (m,_) <- get - put $! NotifyData (m,t) - -lookupNotifyPref :: UserId -> Query NotifyData (Maybe NotifyPref) -lookupNotifyPref uid = do - NotifyData (m,_) <- ask - return $! Map.lookup uid m - -addNotifyPref :: UserId -> NotifyPref -> Update NotifyData () -addNotifyPref uid info = do - NotifyData (m,t) <- get - put $! NotifyData (Map.insert uid info m,t) - -makeAcidic ''NotifyData [ - --queries - 'getNotifyData, - 'lookupNotifyPref, - 'getNotifyTime, - --updates - 'replaceNotifyData, - 'addNotifyPref, - 'setNotifyTime - ] - ---------------------------- -- Data backup and restore -- -userNotifyBackup :: RestoreBackup NotifyData +userNotifyBackup :: RestoreBackup Acid.NotifyData userNotifyBackup = go [] where - go :: [(UserId, NotifyPref)] -> RestoreBackup NotifyData + go :: [(UserId, Acid.NotifyPref)] -> RestoreBackup Acid.NotifyData go st = RestoreBackup { restoreEntry = \entry -> case entry of @@ -372,13 +237,13 @@ userNotifyBackup = go [] _ -> return (go st) , restoreFinalize = - return (NotifyData (Map.fromList st, fromJust (buildTime defaultTimeLocale []))) -- defaults to unixstart time + return (Acid.NotifyData (Map.fromList st, fromJust (buildTime defaultTimeLocale []))) -- defaults to unixstart time } -importNotifyPref :: CSV -> Restore [(UserId, NotifyPref)] +importNotifyPref :: CSV -> Restore [(UserId, Acid.NotifyPref)] importNotifyPref = sequence . map fromRecord . drop 2 where - fromRecord :: Record -> Restore (UserId, NotifyPref) + fromRecord :: Record -> Restore (UserId, Acid.NotifyPref) fromRecord [uid,o,rr,ul,g,db,t,dep1,dep2] = do puid <- parseText "user id" uid po <- parseRead "notify opt out" o @@ -389,11 +254,11 @@ importNotifyPref = sequence . map fromRecord . drop 2 pt <- parseRead "notify pending tags" t pdep1 <- parseRead "notify dependency for maintained" dep1 pdep2 <- parseRead "notify dependency trigger bounds" dep2 - return (puid, NotifyPref po prr pul pg pd pt pdep1 pdep2) + return (puid, Acid.NotifyPref po prr pul pg pd pt pdep1 pdep2) fromRecord x = fail $ "Error processing notify record: " ++ show x -notifyDataToCSV :: BackupType -> NotifyData -> CSV -notifyDataToCSV _backuptype (NotifyData (tbl,_)) +notifyDataToCSV :: BackupType -> Acid.NotifyData -> CSV +notifyDataToCSV _backuptype (Acid.NotifyData (tbl,_)) = ["0.1"] : [ "uid","freq","revisionrange","upload","group","pending_tags","dep_for_maintained","dep_trigger_bounds"] : flip map (Map.toList tbl) (\(uid,np) -> @@ -413,14 +278,14 @@ notifyDataToCSV _backuptype (NotifyData (tbl,_)) -- State Component -- -notifyStateComponent :: FilePath -> IO (StateComponent AcidState NotifyData) +notifyStateComponent :: FilePath -> IO (StateComponent AcidState Acid.NotifyData) notifyStateComponent stateDir = do - st <- openLocalStateFrom (stateDir "db" "UserNotify") =<< emptyNotifyData + st <- openLocalStateFrom (stateDir "db" "UserNotify") =<< Acid.emptyNotifyData return StateComponent { stateDesc = "State to keep track of revision notifications" , stateHandle = st - , getState = query st GetNotifyData - , putState = update st . ReplaceNotifyData + , getState = query st Acid.GetNotifyData + , putState = update st . Acid.ReplaceNotifyData , backupState = \backuptype tbl -> [csvToBackup ["notifydata.csv"] (notifyDataToCSV backuptype tbl)] , restoreState = userNotifyBackup @@ -460,7 +325,7 @@ initUserNotifyFeature ServerEnv{ serverStateDir, serverTemplatesDir, data InRange = InRange | OutOfRange --- | Get the users to notify when a new package has been released. +-- | Acid.Get the users to notify when a new package has been released. -- The new package (PackageId) must already be in the indexes. -- The keys in the returned map are the user to notify, and the values are -- the packages the user maintains that depend on the new package (i.e. the @@ -470,7 +335,7 @@ getUserNotificationsOnRelease => (PackageName -> m UserIdSet) -> PackageIndex.PackageIndex PkgInfo -> ReverseIndex - -> (UserId -> m (Maybe NotifyPref)) + -> (UserId -> m (Maybe Acid.NotifyPref)) -> PackageId -> m (Map.Map UserId [PackageId]) getUserNotificationsOnRelease _ index _ _ pkgId @@ -508,12 +373,12 @@ getUserNotificationsOnRelease userSetIdForPackage index (ReverseIndex revs nodem let idsAndTriggers :: [UserId] idsAndTriggers = do - (userId, Just NotifyPref{..}) <- zip ids mPrefs + (userId, Just Acid.NotifyPref{..}) <- zip ids mPrefs guard $ not notifyOptOut guard notifyDependencyForMaintained Just depListWithCollisions <- [mDepList] - -- Remove collisions on the same PackageName, amassed e.g. across + -- Acid.Remove collisions on the same PackageName, amassed e.g. across -- multiple conditional branches. The branches could be from either -- side of an 'if' block conditioned on a flag. If either of them -- permits the newly released version, avoid sending the notification. @@ -586,7 +451,7 @@ userNotifyFeature :: UserFeature -> TagsFeature -> ReverseFeature -> VouchFeature - -> StateComponent AcidState NotifyData + -> StateComponent AcidState Acid.NotifyData -> Templates -> UserNotifyFeature userNotifyFeature UserFeature{..} @@ -629,24 +494,24 @@ userNotifyFeature UserFeature{..} -- Queries and updates -- - queryGetUserNotifyPref :: MonadIO m => UserId -> m (Maybe NotifyPref) - queryGetUserNotifyPref uid = queryState notifyState (LookupNotifyPref uid) + queryGetUserNotifyPref :: MonadIO m => UserId -> m (Maybe Acid.NotifyPref) + queryGetUserNotifyPref uid = queryState notifyState (Acid.LookupNotifyPref uid) - updateSetUserNotifyPref :: MonadIO m => UserId -> NotifyPref -> m () - updateSetUserNotifyPref uid np = updateState notifyState (AddNotifyPref uid np) + updateSetUserNotifyPref :: MonadIO m => UserId -> Acid.NotifyPref -> m () + updateSetUserNotifyPref uid np = updateState notifyState (Acid.AddNotifyPref uid np) -- Request handlers -- handlerGetUserNotify dpath = do uid <- lookupUserName =<< userNameInPath dpath guardAuthorised_ [IsUserId uid, InGroup adminGroup] - nprefui <- notifyPrefToUI . fromMaybe defaultNotifyPrefs <$> queryGetUserNotifyPref uid + nprefui <- notifyPrefToUI . fromMaybe Acid.defaultNotifyPrefs <$> queryGetUserNotifyPref uid return $ toResponse (Aeson.toJSON nprefui) handlerGetUserNotifyHtml dpath = do (uid, uinfo) <- lookupUserNameFull =<< userNameInPath dpath guardAuthorised_ [IsUserId uid, InGroup adminGroup] - NotifyPrefUI{..} <- notifyPrefToUI . fromMaybe defaultNotifyPrefs <$> queryGetUserNotifyPref uid + NotifyPrefUI{..} <- notifyPrefToUI . fromMaybe Acid.defaultNotifyPrefs <$> queryGetUserNotifyPref uid showConfirmationOfSave <- not . Prelude.null <$> queryString (lookBSs "showConfirmationOfSave") template <- getTemplate templates "user-notify-form.html" cacheControlWithoutETag [NoCache] @@ -691,7 +556,7 @@ userNotifyFeature UserFeature{..} } notifyCronAction = do - (notifyPrefs, lastNotifyTime) <- unNotifyData <$> queryState notifyState GetNotifyData + (notifyPrefs, lastNotifyTime) <- Acid.unNotifyData <$> queryState notifyState Acid.GetNotifyData now <- getCurrentTime let trimLastTime = if diffUTCTime now lastNotifyTime > (60*60*6) -- cap at 6hr then addUTCTime (negate $ (60*60*6)) now @@ -728,7 +593,7 @@ userNotifyFeature UserFeature{..} ] mapM_ sendNotifyEmailAndDelay emails - updateState notifyState (SetNotifyTime now) + updateState notifyState (Acid.SetNotifyTime now) collectRevisionsAndUploads earlier now = do pkgIndex <- queryGetPackageIndex @@ -770,7 +635,7 @@ userNotifyFeature UserFeature{..} maintainers <- queryUserGroup $ maintainersGroup (packageName . pkgInfoId $ pkg) pure . flip mapMaybe (toList maintainers) $ \uid -> fmap (uid,) $ do - let NotifyPref{..} = fromMaybe defaultNotifyPrefs (Map.lookup uid notifyPrefs) + let Acid.NotifyPref{..} = fromMaybe Acid.defaultNotifyPrefs (Map.lookup uid notifyPrefs) guard $ uid /= actor guard $ not notifyOptOut if isRevision @@ -798,7 +663,7 @@ userNotifyFeature UserFeature{..} let notifyAllMaintainers actor pkg notif = do maintainers <- queryUserGroup $ maintainersGroup (mkPackageName $ BS.unpack pkg) pure . flip mapMaybe (toList maintainers) $ \uid -> do - let NotifyPref{..} = fromMaybe defaultNotifyPrefs (Map.lookup uid notifyPrefs) + let Acid.NotifyPref{..} = fromMaybe Acid.defaultNotifyPrefs (Map.lookup uid notifyPrefs) guard $ uid /= actor guard $ not notifyOptOut Just (uid, notif) @@ -829,7 +694,7 @@ userNotifyFeature UserFeature{..} maintainers <- queryUserGroup $ maintainersGroup (packageName $ pkgInfoId pkg) pure . flip mapMaybe (toList maintainers) $ \uid -> fmap (uid,) $ do - let NotifyPref{..} = fromMaybe defaultNotifyPrefs (Map.lookup uid notifyPrefs) + let Acid.NotifyPref{..} = fromMaybe Acid.defaultNotifyPrefs (Map.lookup uid notifyPrefs) guard $ not notifyOptOut guard notifyDocBuilderReport Just @@ -842,7 +707,7 @@ userNotifyFeature UserFeature{..} maintainers <- queryUserGroup $ maintainersGroup pkg pure . flip mapMaybe (toList maintainers) $ \uid -> fmap (uid,) $ do - let NotifyPref{..} = fromMaybe defaultNotifyPrefs (Map.lookup uid notifyPrefs) + let Acid.NotifyPref{..} = fromMaybe Acid.defaultNotifyPrefs (Map.lookup uid notifyPrefs) guard $ not notifyOptOut guard notifyPendingTags Just @@ -859,7 +724,7 @@ userNotifyFeature UserFeature{..} , notifyWatchedPackages = watchedPkgs , notifyTriggerBounds = notifyDependencyTriggerBounds $ - fromMaybe defaultNotifyPrefs (Map.lookup uid notifyPrefs) + fromMaybe Acid.defaultNotifyPrefs (Map.lookup uid notifyPrefs) } Map.toList . Map.mapWithKey toNotif <$> getUserNotificationsOnRelease (queryUserGroup . maintainersGroup) idx revIdx queryGetUserNotifyPref pkg @@ -920,7 +785,7 @@ data NotificationGroup | DependencyNotification PackageId deriving (Eq, Ord) --- | Get all the emails to send for the given notifications. +-- | Acid.Get all the emails to send for the given notifications. getNotificationEmails :: ServerEnv -> UserDetailsFeature diff --git a/src/Distribution/Server/Features/UserNotify/Acid.hs b/src/Distribution/Server/Features/UserNotify/Acid.hs new file mode 100644 index 000000000..0dd913c0e --- /dev/null +++ b/src/Distribution/Server/Features/UserNotify/Acid.hs @@ -0,0 +1,126 @@ +{-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving, + TypeFamilies, TemplateHaskell, + RankNTypes, NamedFieldPuns, RecordWildCards, BangPatterns, + DefaultSignatures, OverloadedStrings #-} +module Distribution.Server.Features.UserNotify.Acid where + +import Distribution.Server.Features.UserNotify.Types +import Prelude hiding (lookup) + +import Distribution.Server.Users.Types (UserId) + +import Distribution.Server.Framework + +import qualified Data.Map as Map + +import Control.Monad.Reader (ask) +import Control.Monad.State (get, put) +import Data.SafeCopy (Migrate(migrate), MigrateFrom, base, deriveSafeCopy, extension) +import Data.Time (UTCTime(..), getCurrentTime) + + +------------------------- +-- Types of stored data +-- +data NotifyPref_v0 = NotifyPref_v0 + { + v0notifyOptOut :: Bool, + v0notifyRevisionRange :: NotifyRevisionRange, + v0notifyUpload :: Bool, + v0notifyMaintainerGroup :: Bool, + v0notifyDocBuilderReport :: Bool, + v0notifyPendingTags :: Bool + } + deriving (Eq, Read, Show) +data NotifyPref = NotifyPref + { + notifyOptOut :: Bool, + notifyRevisionRange :: NotifyRevisionRange, + notifyUpload :: Bool, + notifyMaintainerGroup :: Bool, + notifyDocBuilderReport :: Bool, + notifyPendingTags :: Bool, + notifyDependencyForMaintained :: Bool, + notifyDependencyTriggerBounds :: NotifyTriggerBounds + } + deriving (Eq, Read, Show) + +defaultNotifyPrefs :: NotifyPref +defaultNotifyPrefs = NotifyPref { + notifyOptOut = True, -- TODO when we're comfortable with this we can change to False. + notifyRevisionRange = NotifyAllVersions, + notifyUpload = True, + notifyMaintainerGroup = True, + notifyDocBuilderReport = True, + notifyPendingTags = True, + notifyDependencyForMaintained = True, + notifyDependencyTriggerBounds = NewIncompatibility + } + +instance MemSize NotifyPref_v0 where memSize _ = memSize ((True,True,True),(True,True, True)) +instance MemSize NotifyPref where memSize NotifyPref{..} = memSize8 notifyOptOut notifyRevisionRange notifyUpload notifyMaintainerGroup + notifyDocBuilderReport notifyPendingTags notifyDependencyForMaintained + notifyDependencyTriggerBounds + +data NotifyData = NotifyData {unNotifyData :: (Map.Map UserId NotifyPref, UTCTime)} deriving (Eq, Show) + +instance MemSize NotifyData where memSize (NotifyData x) = memSize x + +emptyNotifyData :: IO NotifyData +emptyNotifyData = getCurrentTime >>= \x-> return (NotifyData (Map.empty, x)) + +$(deriveSafeCopy 0 'base ''NotifyPref_v0) + +instance Migrate NotifyPref where + type MigrateFrom NotifyPref = NotifyPref_v0 + migrate (NotifyPref_v0 f0 f1 f2 f3 f4 f5) = + NotifyPref f0 f1 f2 f3 f4 f5 + False -- Users that already have opted in to notifications + -- did so at at a time when it did not include + -- reverse dependency emails. + -- So let's assume they don't want these. + -- Note that this differs from defaultNotifyPrefs. + NewIncompatibility + +$(deriveSafeCopy 1 'extension ''NotifyPref) +$(deriveSafeCopy 0 'base ''NotifyData) + +------------------------------ +-- State queries and updates +-- + +getNotifyData :: Query NotifyData NotifyData +getNotifyData = ask + +replaceNotifyData :: NotifyData -> Update NotifyData () +replaceNotifyData = put + +getNotifyTime :: Query NotifyData UTCTime +getNotifyTime = fmap (snd . unNotifyData) ask + +setNotifyTime :: UTCTime -> Update NotifyData () +setNotifyTime t = do + NotifyData (m,_) <- get + put $! NotifyData (m,t) + +lookupNotifyPref :: UserId -> Query NotifyData (Maybe NotifyPref) +lookupNotifyPref uid = do + NotifyData (m,_) <- ask + return $! Map.lookup uid m + +addNotifyPref :: UserId -> NotifyPref -> Update NotifyData () +addNotifyPref uid info = do + NotifyData (m,t) <- get + put $! NotifyData (Map.insert uid info m,t) + +makeAcidic ''NotifyData [ + --queries + 'getNotifyData, + 'lookupNotifyPref, + 'getNotifyTime, + --updates + 'replaceNotifyData, + 'addNotifyPref, + 'setNotifyTime + ] + diff --git a/src/Distribution/Server/Features/UserNotify/Types.hs b/src/Distribution/Server/Features/UserNotify/Types.hs new file mode 100644 index 000000000..f6c172a02 --- /dev/null +++ b/src/Distribution/Server/Features/UserNotify/Types.hs @@ -0,0 +1,96 @@ +{-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving, + TypeFamilies, TemplateHaskell, + RankNTypes, NamedFieldPuns, RecordWildCards, BangPatterns, + DefaultSignatures, OverloadedStrings #-} +module Distribution.Server.Features.UserNotify.Types where + + +import Prelude hiding (lookup) +import Distribution.Pretty + +import Distribution.Server.Features.Tags.Types +import Distribution.Server.Framework +import Distribution.Server.Packages.Types (UploadInfo, PkgInfo) +import Distribution.Server.Users.Types (UserId) + +import Data.Aeson.TH (defaultOptions, deriveJSON) +import Data.Hashable (Hashable(..)) +import Data.SafeCopy (base, deriveSafeCopy) +import Text.PrettyPrint hiding ((<>)) +import Data.Set (Set) +import Data.Time (UTCTime) +import Data.Text (Text) +import Distribution.Package + + +data NotifyRevisionRange = NotifyAllVersions | NotifyNewestVersion | NoNotifyRevisions deriving (Bounded, Enum, Eq, Read, Show) +instance MemSize NotifyRevisionRange where + memSize _ = 1 + +instance Pretty NotifyRevisionRange where + pretty NoNotifyRevisions = text "No" + pretty NotifyAllVersions = text "All Versions" + pretty NotifyNewestVersion = text "Newest Version" + +instance Hashable NotifyRevisionRange where + hash = fromEnum + hashWithSalt s x = s `hashWithSalt` hash x + +data NotifyTriggerBounds + = Always + | BoundsOutOfRange + | NewIncompatibility + deriving (Bounded, Enum, Eq, Read, Show) + +instance MemSize NotifyTriggerBounds where + memSize _ = 1 + +instance Hashable NotifyTriggerBounds where + hash = fromEnum + hashWithSalt s x = s `hashWithSalt` hash x + +$(deriveSafeCopy 0 'base ''NotifyTriggerBounds) +$(deriveSafeCopy 0 'base ''NotifyRevisionRange) + +$(deriveJSON defaultOptions ''NotifyRevisionRange) +$(deriveJSON defaultOptions ''NotifyTriggerBounds) + + +data Notification + = NotifyNewVersion + { notifyPackageInfo :: PkgInfo + } + | NotifyNewRevision + { notifyPackageId :: PackageId + , notifyRevisions :: [UploadInfo] + } + | NotifyMaintainerUpdate + { notifyMaintainerUpdateType :: NotifyMaintainerUpdateType + , notifyUserActor :: UserId + , notifyUserSubject :: UserId + , notifyPackageName :: PackageName + , notifyReason :: Text + , notifyUpdatedAt :: UTCTime + } + | NotifyDocsBuild + { notifyPackageId :: PackageId + , notifyBuildSuccess :: Bool + } + | NotifyUpdateTags + { notifyPackageName :: PackageName + , notifyAddedTags :: Set Tag + , notifyDeletedTags :: Set Tag + } + | NotifyDependencyUpdate + { notifyPackageId :: PackageId + -- ^ Dependency that was updated + , notifyWatchedPackages :: [PackageId] + -- ^ Packages maintained by user that depend on updated dep + , notifyTriggerBounds :: NotifyTriggerBounds + } + | NotifyVouchingCompleted + deriving (Show) + +data NotifyMaintainerUpdateType = MaintainerAdded | MaintainerRemoved + deriving (Show) + From 2ef78c891a26305c5650648db9135a5fcf683dd0 Mon Sep 17 00:00:00 2001 From: Sandy Maguire Date: Wed, 15 Apr 2026 15:24:26 -0700 Subject: [PATCH 21/32] Deacidify UserSignup --- hackage-server.cabal | 3 + .../Server/Features/UserSignup.hs | 138 ++++-------------- .../Server/Features/UserSignup/Acid.hs | 77 ++++++++++ 3 files changed, 110 insertions(+), 108 deletions(-) create mode 100644 src/Distribution/Server/Features/UserSignup/Acid.hs diff --git a/hackage-server.cabal b/hackage-server.cabal index 6ad4c417f..443ae18c8 100644 --- a/hackage-server.cabal +++ b/hackage-server.cabal @@ -410,6 +410,9 @@ library Distribution.Server.Features.UserDetails.Backup Distribution.Server.Features.UserDetails.Types Distribution.Server.Features.UserSignup + Distribution.Server.Features.UserSignup.Acid + Distribution.Server.Features.UserSignup.Backup + Distribution.Server.Features.UserSignup.Types Distribution.Server.Features.StaticFiles Distribution.Server.Features.ServerIntrospect Distribution.Server.Features.Sitemap diff --git a/src/Distribution/Server/Features/UserSignup.hs b/src/Distribution/Server/Features/UserSignup.hs index 65c29f9e5..ab313c679 100644 --- a/src/Distribution/Server/Features/UserSignup.hs +++ b/src/Distribution/Server/Features/UserSignup.hs @@ -5,11 +5,12 @@ module Distribution.Server.Features.UserSignup ( initUserSignupFeature, UserSignupFeature(..), - SignupResetInfo(..), accountSuitableForPasswordReset ) where +import qualified Distribution.Server.Features.UserSignup.Acid as Acid + import Distribution.Server.Framework import Distribution.Server.Framework.Templating import Distribution.Server.Framework.BackupDump @@ -25,16 +26,12 @@ import Distribution.Server.Util.Nonce import Distribution.Server.Util.Validators import qualified Distribution.Server.Users.Users as Users -import Data.Map (Map) import qualified Data.Map as Map import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.Encoding as T import qualified Data.ByteString.Char8 as BS -- Only used for ASCII data import qualified Data.ByteString.Lazy as BSL -import Control.Monad.Reader (ask) -import Control.Monad.State (get, put, modify) -import Data.SafeCopy (base, deriveSafeCopy) import Distribution.Text (display) import Data.Time @@ -90,93 +87,18 @@ instance IsHackageFeature UserSignupFeature where -- set new password -- -------------------------- --- Types of stored data --- - -data SignupResetInfo = SignupInfo { - signupUserName :: !Text, - signupRealName :: !Text, - signupContactEmail :: !Text, - nonceTimestamp :: !UTCTime - } - | ResetInfo { - resetUserId :: !UserId, - nonceTimestamp :: !UTCTime - } - deriving (Eq, Show) - -newtype SignupResetTable = SignupResetTable (Map Nonce SignupResetInfo) - deriving (Eq, Show, MemSize) - -emptySignupResetTable :: SignupResetTable -emptySignupResetTable = SignupResetTable Map.empty - -instance MemSize SignupResetInfo where - memSize (SignupInfo a b c d) = memSize4 a b c d - memSize (ResetInfo a b) = memSize2 a b - -$(deriveSafeCopy 0 'base ''SignupResetInfo) -$(deriveSafeCopy 0 'base ''SignupResetTable) - ------------------------------- --- State queries and updates --- - -getSignupResetTable :: Query SignupResetTable SignupResetTable -getSignupResetTable = ask - -replaceSignupResetTable :: SignupResetTable -> Update SignupResetTable () -replaceSignupResetTable = put - -lookupSignupResetInfo :: Nonce -> Query SignupResetTable (Maybe SignupResetInfo) -lookupSignupResetInfo nonce = do - SignupResetTable tbl <- ask - return $! Map.lookup nonce tbl - -addSignupResetInfo :: Nonce -> SignupResetInfo -> Update SignupResetTable Bool -addSignupResetInfo nonce info = do - SignupResetTable tbl <- get - if not (Map.member nonce tbl) - then do put $! SignupResetTable (Map.insert nonce info tbl) - return True - else return False - -deleteSignupResetInfo :: Nonce -> Update SignupResetTable () -deleteSignupResetInfo nonce = do - SignupResetTable tbl <- get - put $! SignupResetTable (Map.delete nonce tbl) - -deleteAllExpired :: UTCTime -> Update SignupResetTable () -deleteAllExpired expireTime = - modify $ \(SignupResetTable tbl) -> - SignupResetTable $ - Map.filter (\entry -> nonceTimestamp entry > expireTime) tbl - -makeAcidic ''SignupResetTable [ - --queries - 'getSignupResetTable, - 'lookupSignupResetInfo, - --updates - 'replaceSignupResetTable, - 'addSignupResetInfo, - 'deleteSignupResetInfo, - 'deleteAllExpired - ] - - --------------------- -- State components -- -signupResetStateComponent :: FilePath -> IO (StateComponent AcidState SignupResetTable) +signupResetStateComponent :: FilePath -> IO (StateComponent AcidState Acid.SignupResetTable) signupResetStateComponent stateDir = do - st <- openLocalStateFrom (stateDir "db" "UserSignupReset") emptySignupResetTable + st <- openLocalStateFrom (stateDir "db" "UserSignupReset") Acid.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 + , 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)] @@ -188,10 +110,10 @@ signupResetStateComponent stateDir = do -- Data backup and restore -- -signupResetBackup :: RestoreBackup SignupResetTable +signupResetBackup :: RestoreBackup Acid.SignupResetTable signupResetBackup = go [] where - go :: [(Nonce, SignupResetInfo)] -> RestoreBackup SignupResetTable + go :: [(Nonce, Acid.SignupResetInfo)] -> RestoreBackup Acid.SignupResetTable go st = RestoreBackup { restoreEntry = \entry -> case entry of @@ -208,17 +130,17 @@ signupResetBackup = go [] _ -> return (go st) , restoreFinalize = - return (SignupResetTable (Map.fromList st)) + return (Acid.SignupResetTable (Map.fromList st)) } -importSignupInfo :: CSV -> Restore [(Nonce, SignupResetInfo)] +importSignupInfo :: CSV -> Restore [(Nonce, Acid.SignupResetInfo)] importSignupInfo = mapM fromRecord . drop 2 where - fromRecord :: Record -> Restore (Nonce, SignupResetInfo) + fromRecord :: Record -> Restore (Nonce, Acid.SignupResetInfo) fromRecord [nonceStr, usernameStr, realnameStr, emailStr, timestampStr] = do timestamp <- parseUTCTime "timestamp" timestampStr nonce <- parseNonceM nonceStr - let signupinfo = SignupInfo { + let signupinfo = Acid.SignupInfo { signupUserName = T.pack usernameStr, signupRealName = T.pack realnameStr, signupContactEmail = T.pack emailStr, @@ -227,8 +149,8 @@ importSignupInfo = mapM fromRecord . drop 2 return (nonce, signupinfo) fromRecord x = fail $ "Error processing signup info record: " ++ show x -signupInfoToCSV :: BackupType -> SignupResetTable -> CSV -signupInfoToCSV backuptype (SignupResetTable tbl) +signupInfoToCSV :: BackupType -> Acid.SignupResetTable -> CSV +signupInfoToCSV backuptype (Acid.SignupResetTable tbl) = ["0.1"] : [ "token", "username", "realname", "email", "timestamp" ] : [ [ if backuptype == FullBackup @@ -241,25 +163,25 @@ signupInfoToCSV backuptype (SignupResetTable tbl) else "hidden-email@nowhere.org" , formatUTCTime nonceTimestamp ] - | (nonce, SignupInfo{..}) <- Map.toList tbl ] + | (nonce, Acid.SignupInfo{..}) <- Map.toList tbl ] -importResetInfo :: CSV -> Restore [(Nonce, SignupResetInfo)] +importResetInfo :: CSV -> Restore [(Nonce, Acid.SignupResetInfo)] importResetInfo = mapM fromRecord . drop 2 where - fromRecord :: Record -> Restore (Nonce, SignupResetInfo) + fromRecord :: Record -> Restore (Nonce, Acid.SignupResetInfo) fromRecord [nonceStr, useridStr, timestampStr] = do userid <- parseText "userid" useridStr timestamp <- parseUTCTime "timestamp" timestampStr nonce <- parseNonceM nonceStr - let signupinfo = ResetInfo { + let signupinfo = Acid.ResetInfo { resetUserId = userid, nonceTimestamp = timestamp } return (nonce, signupinfo) fromRecord x = fail $ "Error processing signup info record: " ++ show x -resetInfoToCSV :: BackupType -> SignupResetTable -> CSV -resetInfoToCSV backuptype (SignupResetTable tbl) +resetInfoToCSV :: BackupType -> Acid.SignupResetTable -> CSV +resetInfoToCSV backuptype (Acid.SignupResetTable tbl) = ["0.1"] : [ "token", "userid", "timestamp" ] : [ [ if backuptype == FullBackup @@ -268,7 +190,7 @@ resetInfoToCSV backuptype (SignupResetTable tbl) , display resetUserId , formatUTCTime nonceTimestamp ] - | (nonce, ResetInfo{..}) <- Map.toList tbl ] + | (nonce, Acid.ResetInfo{..}) <- Map.toList tbl ] ---------------------------------------- @@ -304,7 +226,7 @@ userSignupFeature :: ServerEnv -> UserFeature -> UserDetailsFeature -> UploadFeature - -> StateComponent AcidState SignupResetTable + -> StateComponent AcidState Acid.SignupResetTable -> Templates -> UserSignupFeature userSignupFeature ServerEnv{serverBaseURI, serverCron} @@ -339,7 +261,7 @@ userSignupFeature ServerEnv{serverBaseURI, serverCron} captchaResource = (resourceAt "/users/register/captcha") { - resourceDesc = [ (GET, "Get a new captcha") ] + resourceDesc = [ (GET, "Acid.Get a new captcha") ] , resourceGet = [ ("json", handlerGetCaptcha) ] } @@ -373,30 +295,30 @@ userSignupFeature ServerEnv{serverBaseURI, serverCron} queryAllSignupResetInfo :: MonadIO m => m [SignupResetInfo] queryAllSignupResetInfo = - queryState signupResetState GetSignupResetTable - >>= \(SignupResetTable tbl) -> return (Map.elems tbl) + queryState signupResetState Acid.GetSignupResetTable + >>= \(Acid.SignupResetTable tbl) -> return (Map.elems tbl) querySignupInfo :: Nonce -> MonadIO m => m (Maybe SignupResetInfo) querySignupInfo nonce = - justSignupInfo <$> queryState signupResetState (LookupSignupResetInfo nonce) + justSignupInfo <$> queryState signupResetState (Acid.LookupSignupResetInfo nonce) where justSignupInfo (Just info@SignupInfo{}) = Just info justSignupInfo _ = Nothing queryResetInfo :: Nonce -> MonadIO m => m (Maybe SignupResetInfo) queryResetInfo nonce = - justResetInfo <$> queryState signupResetState (LookupSignupResetInfo nonce) + justResetInfo <$> queryState signupResetState (Acid.LookupSignupResetInfo nonce) where justResetInfo (Just info@ResetInfo{}) = Just info justResetInfo _ = Nothing updateAddSignupResetInfo :: Nonce -> SignupResetInfo -> MonadIO m => m Bool updateAddSignupResetInfo nonce signupInfo = - updateState signupResetState (AddSignupResetInfo nonce signupInfo) + updateState signupResetState (Acid.AddSignupResetInfo nonce signupInfo) updateDeleteSignupResetInfo :: Nonce -> MonadIO m => m () updateDeleteSignupResetInfo nonce = - updateState signupResetState (DeleteSignupResetInfo nonce) + updateState signupResetState (Acid.DeleteSignupResetInfo nonce) -- Expiry -- @@ -408,7 +330,7 @@ userSignupFeature ServerEnv{serverBaseURI, serverCron} cronJobAction = do now <- getCurrentTime let expire = now { utctDay = addDays (-7) (utctDay now) } - updateState signupResetState (DeleteAllExpired expire) + updateState signupResetState (Acid.DeleteAllExpired expire) } -- Request handlers diff --git a/src/Distribution/Server/Features/UserSignup/Acid.hs b/src/Distribution/Server/Features/UserSignup/Acid.hs new file mode 100644 index 000000000..1ef4a49a2 --- /dev/null +++ b/src/Distribution/Server/Features/UserSignup/Acid.hs @@ -0,0 +1,77 @@ +{-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-} +{-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving, + TypeFamilies, TemplateHaskell, + RankNTypes, NamedFieldPuns, RecordWildCards, BangPatterns #-} +module Distribution.Server.Features.UserSignup.Acid where + +import Distribution.Server.Features.UserSignup.Types + +import Distribution.Server.Framework + +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.SafeCopy (base, deriveSafeCopy) + +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 +-- + +getSignupResetTable :: Query SignupResetTable SignupResetTable +getSignupResetTable = ask + +replaceSignupResetTable :: SignupResetTable -> Update SignupResetTable () +replaceSignupResetTable = put + +lookupSignupResetInfo :: Nonce -> Query SignupResetTable (Maybe SignupResetInfo) +lookupSignupResetInfo nonce = do + SignupResetTable tbl <- ask + return $! Map.lookup nonce tbl + +addSignupResetInfo :: Nonce -> SignupResetInfo -> Update SignupResetTable Bool +addSignupResetInfo nonce info = do + SignupResetTable tbl <- get + if not (Map.member nonce tbl) + then do put $! SignupResetTable (Map.insert nonce info tbl) + return True + else return False + +deleteSignupResetInfo :: Nonce -> Update SignupResetTable () +deleteSignupResetInfo nonce = do + SignupResetTable tbl <- get + put $! SignupResetTable (Map.delete nonce tbl) + +deleteAllExpired :: UTCTime -> Update SignupResetTable () +deleteAllExpired expireTime = + modify $ \(SignupResetTable tbl) -> + SignupResetTable $ + Map.filter (\entry -> nonceTimestamp entry > expireTime) tbl + +makeAcidic ''SignupResetTable [ + --queries + 'getSignupResetTable, + 'lookupSignupResetInfo, + --updates + 'replaceSignupResetTable, + 'addSignupResetInfo, + 'deleteSignupResetInfo, + 'deleteAllExpired + ] + From 09761c6d22f501e4a6c0ad3c37cb1137a2adb84f Mon Sep 17 00:00:00 2001 From: Sandy Maguire Date: Thu, 16 Apr 2026 09:12:14 -0700 Subject: [PATCH 22/32] Usersignup dump/restore --- .../Server/Features/UserSignup.hs | 89 +-------------- .../Server/Features/UserSignup/Backup.hs | 104 ++++++++++++++++++ 2 files changed, 105 insertions(+), 88 deletions(-) create mode 100644 src/Distribution/Server/Features/UserSignup/Backup.hs diff --git a/src/Distribution/Server/Features/UserSignup.hs b/src/Distribution/Server/Features/UserSignup.hs index ab313c679..7be30230d 100644 --- a/src/Distribution/Server/Features/UserSignup.hs +++ b/src/Distribution/Server/Features/UserSignup.hs @@ -10,11 +10,11 @@ module Distribution.Server.Features.UserSignup ( ) where import qualified Distribution.Server.Features.UserSignup.Acid as Acid +import Distribution.Server.Features.UserSignup.Backup import Distribution.Server.Framework import Distribution.Server.Framework.Templating import Distribution.Server.Framework.BackupDump -import Distribution.Server.Framework.BackupRestore import Distribution.Server.Features.Upload import Distribution.Server.Features.Users @@ -35,7 +35,6 @@ import qualified Data.ByteString.Lazy as BSL import Distribution.Text (display) import Data.Time -import Text.CSV (CSV, Record) import Network.Mail.Mime import Network.URI (URI(..), URIAuth(..)) import Graphics.Captcha @@ -106,92 +105,6 @@ signupResetStateComponent stateDir = do , resetState = signupResetStateComponent } ----------------------------- --- Data backup and restore --- - -signupResetBackup :: RestoreBackup Acid.SignupResetTable -signupResetBackup = go [] - where - go :: [(Nonce, Acid.SignupResetInfo)] -> RestoreBackup Acid.SignupResetTable - go st = - RestoreBackup { - restoreEntry = \entry -> case entry of - BackupByteString ["signups.csv"] bs -> do - csv <- importCSV "signups.csv" bs - signups <- importSignupInfo csv - return (go (signups ++ st)) - - BackupByteString ["resets.csv"] bs -> do - csv <- importCSV "resets.csv" bs - resets <- importResetInfo csv - return (go (resets ++ st)) - - _ -> return (go st) - - , restoreFinalize = - return (Acid.SignupResetTable (Map.fromList st)) - } - -importSignupInfo :: CSV -> Restore [(Nonce, Acid.SignupResetInfo)] -importSignupInfo = mapM fromRecord . drop 2 - where - fromRecord :: Record -> Restore (Nonce, Acid.SignupResetInfo) - fromRecord [nonceStr, usernameStr, realnameStr, emailStr, timestampStr] = do - timestamp <- parseUTCTime "timestamp" timestampStr - nonce <- parseNonceM nonceStr - let signupinfo = Acid.SignupInfo { - signupUserName = T.pack usernameStr, - signupRealName = T.pack realnameStr, - signupContactEmail = T.pack emailStr, - nonceTimestamp = timestamp - } - return (nonce, signupinfo) - fromRecord x = fail $ "Error processing signup info record: " ++ show x - -signupInfoToCSV :: BackupType -> Acid.SignupResetTable -> CSV -signupInfoToCSV backuptype (Acid.SignupResetTable tbl) - = ["0.1"] - : [ "token", "username", "realname", "email", "timestamp" ] - : [ [ if backuptype == FullBackup - then renderNonce nonce - else "" - , T.unpack signupUserName - , T.unpack signupRealName - , if backuptype == FullBackup - then T.unpack signupContactEmail - else "hidden-email@nowhere.org" - , formatUTCTime nonceTimestamp - ] - | (nonce, Acid.SignupInfo{..}) <- Map.toList tbl ] - -importResetInfo :: CSV -> Restore [(Nonce, Acid.SignupResetInfo)] -importResetInfo = mapM fromRecord . drop 2 - where - fromRecord :: Record -> Restore (Nonce, Acid.SignupResetInfo) - fromRecord [nonceStr, useridStr, timestampStr] = do - userid <- parseText "userid" useridStr - timestamp <- parseUTCTime "timestamp" timestampStr - nonce <- parseNonceM nonceStr - let signupinfo = Acid.ResetInfo { - resetUserId = userid, - nonceTimestamp = timestamp - } - return (nonce, signupinfo) - fromRecord x = fail $ "Error processing signup info record: " ++ show x - -resetInfoToCSV :: BackupType -> Acid.SignupResetTable -> CSV -resetInfoToCSV backuptype (Acid.SignupResetTable tbl) - = ["0.1"] - : [ "token", "userid", "timestamp" ] - : [ [ if backuptype == FullBackup - then renderNonce nonce - else "" - , display resetUserId - , formatUTCTime nonceTimestamp - ] - | (nonce, Acid.ResetInfo{..}) <- Map.toList tbl ] - ---------------------------------------- -- Feature definition & initialisation diff --git a/src/Distribution/Server/Features/UserSignup/Backup.hs b/src/Distribution/Server/Features/UserSignup/Backup.hs new file mode 100644 index 000000000..abb20e35b --- /dev/null +++ b/src/Distribution/Server/Features/UserSignup/Backup.hs @@ -0,0 +1,104 @@ +{-# LANGUAGE RecordWildCards #-} + +module Distribution.Server.Features.UserSignup.Backup where + +import Distribution.Server.Features.UserSignup.Types +import qualified Distribution.Server.Features.UserSignup.Acid as Acid + +import Distribution.Server.Framework.BackupDump +import Distribution.Server.Framework.BackupRestore + +import Distribution.Server.Util.Nonce + +import qualified Data.Map as Map +import qualified Data.Text as T + +import Distribution.Text (display) +import Text.CSV (CSV, Record) + +---------------------------- +-- Data backup and restore +-- + +signupResetBackup :: RestoreBackup Acid.SignupResetTable +signupResetBackup = go [] + where + go :: [(Nonce, SignupResetInfo)] -> RestoreBackup Acid.SignupResetTable + go st = + RestoreBackup { + restoreEntry = \entry -> case entry of + BackupByteString ["signups.csv"] bs -> do + csv <- importCSV "signups.csv" bs + signups <- importSignupInfo csv + return (go (signups ++ st)) + + BackupByteString ["resets.csv"] bs -> do + csv <- importCSV "resets.csv" bs + resets <- importResetInfo csv + return (go (resets ++ st)) + + _ -> return (go st) + + , restoreFinalize = + return (Acid.SignupResetTable (Map.fromList st)) + } + +importSignupInfo :: CSV -> Restore [(Nonce, SignupResetInfo)] +importSignupInfo = mapM fromRecord . drop 2 + where + fromRecord :: Record -> Restore (Nonce, SignupResetInfo) + fromRecord [nonceStr, usernameStr, realnameStr, emailStr, timestampStr] = do + timestamp <- parseUTCTime "timestamp" timestampStr + nonce <- parseNonceM nonceStr + let signupinfo = SignupInfo { + signupUserName = T.pack usernameStr, + signupRealName = T.pack realnameStr, + signupContactEmail = T.pack emailStr, + nonceTimestamp = timestamp + } + return (nonce, signupinfo) + fromRecord x = fail $ "Error processing signup info record: " ++ show x + +signupInfoToCSV :: BackupType -> Acid.SignupResetTable -> CSV +signupInfoToCSV backuptype (Acid.SignupResetTable tbl) + = ["0.1"] + : [ "token", "username", "realname", "email", "timestamp" ] + : [ [ if backuptype == FullBackup + then renderNonce nonce + else "" + , T.unpack signupUserName + , T.unpack signupRealName + , if backuptype == FullBackup + then T.unpack signupContactEmail + else "hidden-email@nowhere.org" + , formatUTCTime nonceTimestamp + ] + | (nonce, SignupInfo{..}) <- Map.toList tbl ] + +importResetInfo :: CSV -> Restore [(Nonce, SignupResetInfo)] +importResetInfo = mapM fromRecord . drop 2 + where + fromRecord :: Record -> Restore (Nonce, SignupResetInfo) + fromRecord [nonceStr, useridStr, timestampStr] = do + userid <- parseText "userid" useridStr + timestamp <- parseUTCTime "timestamp" timestampStr + nonce <- parseNonceM nonceStr + let signupinfo = ResetInfo { + resetUserId = userid, + nonceTimestamp = timestamp + } + return (nonce, signupinfo) + fromRecord x = fail $ "Error processing signup info record: " ++ show x + +resetInfoToCSV :: BackupType -> Acid.SignupResetTable -> CSV +resetInfoToCSV backuptype (Acid.SignupResetTable tbl) + = ["0.1"] + : [ "token", "userid", "timestamp" ] + : [ [ if backuptype == FullBackup + then renderNonce nonce + else "" + , display resetUserId + , formatUTCTime nonceTimestamp + ] + | (nonce, ResetInfo{..}) <- Map.toList tbl ] + From 65f1a285c524d1711ed37ba9d3e556ed565d20a4 Mon Sep 17 00:00:00 2001 From: Sandy Maguire Date: Thu, 16 Apr 2026 09:14:52 -0700 Subject: [PATCH 23/32] UserNotify dump/restore --- .../Server/Features/UserNotify.hs | 63 +-------------- .../Server/Features/UserNotify/Backup.hs | 76 +++++++++++++++++++ 2 files changed, 78 insertions(+), 61 deletions(-) create mode 100644 src/Distribution/Server/Features/UserNotify/Backup.hs diff --git a/src/Distribution/Server/Features/UserNotify.hs b/src/Distribution/Server/Features/UserNotify.hs index 4aa5e8e7a..46d413ca8 100644 --- a/src/Distribution/Server/Features/UserNotify.hs +++ b/src/Distribution/Server/Features/UserNotify.hs @@ -26,6 +26,7 @@ module Distribution.Server.Features.UserNotify ( import Distribution.Server.Features.UserDetails.Types import qualified Distribution.Server.Features.UserNotify.Acid as Acid import Distribution.Server.Features.UserNotify.Acid (NotifyPref(..)) +import Distribution.Server.Features.UserNotify.Backup import Distribution.Server.Features.UserNotify.Types import Prelude hiding (lookup) import Distribution.Package @@ -42,7 +43,6 @@ import qualified Distribution.Server.Packages.PackageIndex as PackageIndex import Distribution.Server.Framework import Distribution.Server.Framework.BackupDump -import Distribution.Server.Framework.BackupRestore import Distribution.Server.Framework.Templating import Distribution.Server.Features.AdminLog @@ -73,14 +73,12 @@ import Data.Bimap (lookup, lookupR) import Data.Graph (Vertex) import Data.Hashable (Hashable(..)) import Data.List (maximumBy, sortOn) -import Data.Maybe (fromJust, fromMaybe, listToMaybe, mapMaybe, maybeToList) +import Data.Maybe (fromMaybe, listToMaybe, mapMaybe, maybeToList) import Data.Ord (Down(..), comparing) import Data.Time (UTCTime(..), addUTCTime, defaultTimeLocale, diffUTCTime, formatTime, getCurrentTime) -import Data.Time.Format.Internal (buildTime) import Distribution.Text (display) import Network.Mail.Mime import Network.URI (uriAuthority, uriPath, uriRegName) -import Text.CSV (CSV, Record) import Text.PrettyPrint hiding ((<>)) import Text.XHtml hiding (base, text, ()) @@ -217,63 +215,6 @@ instance ToRadioButtons NotifyRevisionRange where instance ToRadioButtons OK where toRadioButtons = renderRadioButtons [OK True, OK False] - ----------------------------- --- Data backup and restore --- - -userNotifyBackup :: RestoreBackup Acid.NotifyData -userNotifyBackup = go [] - where - go :: [(UserId, Acid.NotifyPref)] -> RestoreBackup Acid.NotifyData - go st = - RestoreBackup { - restoreEntry = \entry -> case entry of - BackupByteString ["notifydata.csv"] bs -> do - csv <- importCSV "notifydata.csv" bs - prefs <- importNotifyPref csv - return (go (prefs ++ st)) - - _ -> return (go st) - - , restoreFinalize = - return (Acid.NotifyData (Map.fromList st, fromJust (buildTime defaultTimeLocale []))) -- defaults to unixstart time - } - -importNotifyPref :: CSV -> Restore [(UserId, Acid.NotifyPref)] -importNotifyPref = sequence . map fromRecord . drop 2 - where - fromRecord :: Record -> Restore (UserId, Acid.NotifyPref) - fromRecord [uid,o,rr,ul,g,db,t,dep1,dep2] = do - puid <- parseText "user id" uid - po <- parseRead "notify opt out" o - prr <- parseRead "notify revsion" rr - pul <- parseRead "notify upload" ul - pg <- parseRead "notify group mod" g - pd <- parseRead "notify docbuilder" db - pt <- parseRead "notify pending tags" t - pdep1 <- parseRead "notify dependency for maintained" dep1 - pdep2 <- parseRead "notify dependency trigger bounds" dep2 - return (puid, Acid.NotifyPref po prr pul pg pd pt pdep1 pdep2) - fromRecord x = fail $ "Error processing notify record: " ++ show x - -notifyDataToCSV :: BackupType -> Acid.NotifyData -> CSV -notifyDataToCSV _backuptype (Acid.NotifyData (tbl,_)) - = ["0.1"] - : [ "uid","freq","revisionrange","upload","group","pending_tags","dep_for_maintained","dep_trigger_bounds"] - : flip map (Map.toList tbl) (\(uid,np) -> - [ display uid - , show (notifyOptOut np) - , show (notifyRevisionRange np) - , show (notifyUpload np) - , show (notifyMaintainerGroup np) - , show (notifyDocBuilderReport np) - , show (notifyPendingTags np) - , show (notifyDependencyForMaintained np) - , show (notifyDependencyTriggerBounds np) - ] - ) - ---------------------------- -- State Component -- diff --git a/src/Distribution/Server/Features/UserNotify/Backup.hs b/src/Distribution/Server/Features/UserNotify/Backup.hs new file mode 100644 index 000000000..c6560a94e --- /dev/null +++ b/src/Distribution/Server/Features/UserNotify/Backup.hs @@ -0,0 +1,76 @@ +module Distribution.Server.Features.UserNotify.Backup where + +import qualified Distribution.Server.Features.UserNotify.Acid as Acid +import Distribution.Server.Features.UserNotify.Acid (NotifyPref(..)) +import Prelude + +import Distribution.Server.Users.Types (UserId) + +import Distribution.Server.Framework.BackupDump +import Distribution.Server.Framework.BackupRestore + +import qualified Data.Map as Map + +import Data.Maybe (fromJust) +import Data.Time (defaultTimeLocale) +import Data.Time.Format.Internal (buildTime) +import Distribution.Text (display) +import Text.CSV (CSV, Record) + + + +---------------------------- +-- Data backup and restore +-- + +userNotifyBackup :: RestoreBackup Acid.NotifyData +userNotifyBackup = go [] + where + go :: [(UserId, Acid.NotifyPref)] -> RestoreBackup Acid.NotifyData + go st = + RestoreBackup { + restoreEntry = \entry -> case entry of + BackupByteString ["notifydata.csv"] bs -> do + csv <- importCSV "notifydata.csv" bs + prefs <- importNotifyPref csv + return (go (prefs ++ st)) + + _ -> return (go st) + + , restoreFinalize = + return (Acid.NotifyData (Map.fromList st, fromJust (buildTime defaultTimeLocale []))) -- defaults to unixstart time + } + +importNotifyPref :: CSV -> Restore [(UserId, Acid.NotifyPref)] +importNotifyPref = sequence . map fromRecord . drop 2 + where + fromRecord :: Record -> Restore (UserId, Acid.NotifyPref) + fromRecord [uid,o,rr,ul,g,db,t,dep1,dep2] = do + puid <- parseText "user id" uid + po <- parseRead "notify opt out" o + prr <- parseRead "notify revsion" rr + pul <- parseRead "notify upload" ul + pg <- parseRead "notify group mod" g + pd <- parseRead "notify docbuilder" db + pt <- parseRead "notify pending tags" t + pdep1 <- parseRead "notify dependency for maintained" dep1 + pdep2 <- parseRead "notify dependency trigger bounds" dep2 + return (puid, Acid.NotifyPref po prr pul pg pd pt pdep1 pdep2) + fromRecord x = fail $ "Error processing notify record: " ++ show x + +notifyDataToCSV :: BackupType -> Acid.NotifyData -> CSV +notifyDataToCSV _backuptype (Acid.NotifyData (tbl,_)) + = ["0.1"] + : [ "uid","freq","revisionrange","upload","group","pending_tags","dep_for_maintained","dep_trigger_bounds"] + : flip map (Map.toList tbl) (\(uid,np) -> + [ display uid + , show (notifyOptOut np) + , show (notifyRevisionRange np) + , show (notifyUpload np) + , show (notifyMaintainerGroup np) + , show (notifyDocBuilderReport np) + , show (notifyPendingTags np) + , show (notifyDependencyForMaintained np) + , show (notifyDependencyTriggerBounds np) + ] + ) From ef36f6e280c1001345fcde4a23316d95bdaaccc7 Mon Sep 17 00:00:00 2001 From: Sandy Maguire Date: Thu, 16 Apr 2026 09:18:11 -0700 Subject: [PATCH 24/32] LegacyPasswds dump/restore --- .../Server/Features/LegacyPasswds.hs | 54 +-------------- .../Server/Features/LegacyPasswds/Backup.hs | 67 +++++++++++++++++++ 2 files changed, 68 insertions(+), 53 deletions(-) create mode 100644 src/Distribution/Server/Features/LegacyPasswds/Backup.hs diff --git a/src/Distribution/Server/Features/LegacyPasswds.hs b/src/Distribution/Server/Features/LegacyPasswds.hs index 86454aa75..737c44722 100644 --- a/src/Distribution/Server/Features/LegacyPasswds.hs +++ b/src/Distribution/Server/Features/LegacyPasswds.hs @@ -7,13 +7,13 @@ module Distribution.Server.Features.LegacyPasswds ( ) where import qualified Distribution.Server.Features.LegacyPasswds.Acid as Acid +import Distribution.Server.Features.LegacyPasswds.Backup import Prelude hiding (abs) import Distribution.Server.Framework import Distribution.Server.Framework.Templating import Distribution.Server.Framework.BackupDump -import Distribution.Server.Framework.BackupRestore import qualified Distribution.Server.Features.LegacyPasswds.Auth as LegacyAuth @@ -24,12 +24,8 @@ import qualified Distribution.Server.Users.Types as Users import qualified Distribution.Server.Users.Users as Users import qualified Distribution.Server.Framework.Auth as Auth -import qualified Data.IntMap as IntMap import qualified Data.ByteString.Lazy.Char8 as LBS -- ASCII data only (password hashes) -import Distribution.Text (display) -import Data.Version -import Text.CSV (CSV, Record) import Network.URI (URI(..), uriToString) @@ -65,54 +61,6 @@ legacyPasswdsStateComponent stateDir = do , resetState = legacyPasswdsStateComponent } ----------------------------- --- Data backup and restore --- - -legacyPasswdsBackup :: RestoreBackup Acid.LegacyPasswdsTable -legacyPasswdsBackup = updatePasswdsBackup [] - -updatePasswdsBackup :: [(UserId, LegacyAuth.HtPasswdHash)] -> RestoreBackup Acid.LegacyPasswdsTable -updatePasswdsBackup upasswds = RestoreBackup { - restoreEntry = \entry -> case entry of - BackupByteString ["htpasswd.csv"] bs -> do - when (not (null upasswds)) (fail "legacyPasswdsBackup: found multiple htpasswd.csv files") - csv <- importCSV "htpasswd.csv" bs - upasswds' <- importHtPasswds csv - return (updatePasswdsBackup upasswds') - _ -> - return (updatePasswdsBackup upasswds) - , restoreFinalize = - let tbl = IntMap.fromList [ (uid, htpasswd) - | (UserId uid, htpasswd) <- upasswds ] in - return $! Acid.LegacyPasswdsTable tbl - } - -importHtPasswds :: CSV -> Restore [(UserId, LegacyAuth.HtPasswdHash)] -importHtPasswds = mapM fromRecord . drop 2 - where - fromRecord :: Record -> Restore (UserId, LegacyAuth.HtPasswdHash) - fromRecord [idStr, htpasswdStr] = do - uid <- parseText "user id" idStr - return (uid, LegacyAuth.HtPasswdHash htpasswdStr) - - fromRecord x = fail $ "Error processing user details record: " ++ show x - -legacyPasswdsToCSV :: BackupType -> Acid.LegacyPasswdsTable -> CSV -legacyPasswdsToCSV backuptype (Acid.LegacyPasswdsTable tbl) - = ([showVersion version]:) $ - (headers:) $ - - flip map (IntMap.toList tbl) $ \(uid, LegacyAuth.HtPasswdHash passwdhash) -> - [ display (UserId uid) - , if backuptype == FullBackup - then passwdhash - else "" - ] - where - headers = ["uid", "htpasswd"] - version = Version [0,1] [] - ---------------------------------------- -- Feature definition & initialisation -- diff --git a/src/Distribution/Server/Features/LegacyPasswds/Backup.hs b/src/Distribution/Server/Features/LegacyPasswds/Backup.hs new file mode 100644 index 000000000..feb56d763 --- /dev/null +++ b/src/Distribution/Server/Features/LegacyPasswds/Backup.hs @@ -0,0 +1,67 @@ +module Distribution.Server.Features.LegacyPasswds.Backup where + +import qualified Distribution.Server.Features.LegacyPasswds.Acid as Acid + +import Prelude hiding (abs) + +import Distribution.Server.Framework +import Distribution.Server.Framework.BackupDump +import Distribution.Server.Framework.BackupRestore + +import qualified Distribution.Server.Features.LegacyPasswds.Auth as LegacyAuth + +import Distribution.Server.Users.Types + +import qualified Data.IntMap as IntMap + +import Distribution.Text (display) +import Data.Version +import Text.CSV (CSV, Record) + +---------------------------- +-- Data backup and restore +-- + +legacyPasswdsBackup :: RestoreBackup Acid.LegacyPasswdsTable +legacyPasswdsBackup = updatePasswdsBackup [] + +updatePasswdsBackup :: [(UserId, LegacyAuth.HtPasswdHash)] -> RestoreBackup Acid.LegacyPasswdsTable +updatePasswdsBackup upasswds = RestoreBackup { + restoreEntry = \entry -> case entry of + BackupByteString ["htpasswd.csv"] bs -> do + when (not (null upasswds)) (fail "legacyPasswdsBackup: found multiple htpasswd.csv files") + csv <- importCSV "htpasswd.csv" bs + upasswds' <- importHtPasswds csv + return (updatePasswdsBackup upasswds') + _ -> + return (updatePasswdsBackup upasswds) + , restoreFinalize = + let tbl = IntMap.fromList [ (uid, htpasswd) + | (UserId uid, htpasswd) <- upasswds ] in + return $! Acid.LegacyPasswdsTable tbl + } + +importHtPasswds :: CSV -> Restore [(UserId, LegacyAuth.HtPasswdHash)] +importHtPasswds = mapM fromRecord . drop 2 + where + fromRecord :: Record -> Restore (UserId, LegacyAuth.HtPasswdHash) + fromRecord [idStr, htpasswdStr] = do + uid <- parseText "user id" idStr + return (uid, LegacyAuth.HtPasswdHash htpasswdStr) + + fromRecord x = fail $ "Error processing user details record: " ++ show x + +legacyPasswdsToCSV :: BackupType -> Acid.LegacyPasswdsTable -> CSV +legacyPasswdsToCSV backuptype (Acid.LegacyPasswdsTable tbl) + = ([showVersion version]:) $ + (headers:) $ + + flip map (IntMap.toList tbl) $ \(uid, LegacyAuth.HtPasswdHash passwdhash) -> + [ display (UserId uid) + , if backuptype == FullBackup + then passwdhash + else "" + ] + where + headers = ["uid", "htpasswd"] + version = Version [0,1] [] From f45bd9daaab69a98c03ec4d9ad1599f91c4c5942 Mon Sep 17 00:00:00 2001 From: Sandy Maguire Date: Thu, 16 Apr 2026 09:19:51 -0700 Subject: [PATCH 25/32] AdminLog dump/restore --- src/Distribution/Server/Features/AdminLog.hs | 27 +------------- .../Server/Features/AdminLog/Backup.hs | 36 +++++++++++++++++++ 2 files changed, 37 insertions(+), 26 deletions(-) create mode 100644 src/Distribution/Server/Features/AdminLog/Backup.hs diff --git a/src/Distribution/Server/Features/AdminLog.hs b/src/Distribution/Server/Features/AdminLog.hs index 01eaa9f9b..f1ec16533 100755 --- a/src/Distribution/Server/Features/AdminLog.hs +++ b/src/Distribution/Server/Features/AdminLog.hs @@ -5,6 +5,7 @@ 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.Types import Distribution.Server.Users.Types (UserId) import Distribution.Server.Users.Group @@ -14,11 +15,7 @@ import Distribution.Server.Framework.BackupRestore import Distribution.Server.Pages.AdminLog import Distribution.Server.Features.Users -import Data.Maybe(mapMaybe) -import Data.Time (UTCTime) import Data.Time.Clock (getCurrentTime) -import qualified Data.ByteString.Lazy.Char8 as BS -import Text.Read (readMaybe) import Distribution.Server.Util.Parse --TODO Maybe Reason @@ -105,25 +102,3 @@ adminLogStateComponent stateDir = do , resetState = adminLogStateComponent } -restoreAdminLogBackup :: RestoreBackup Acid.AdminLog -restoreAdminLogBackup = - go (Acid.AdminLog []) - where - go logs = - RestoreBackup { - restoreEntry = \entry -> case entry of - BackupByteString ["adminLog.txt"] bs - -> return . go $ importLogs logs bs - _ -> return (go logs) - , restoreFinalize = return logs - } - -importLogs :: Acid.AdminLog -> BS.ByteString -> Acid.AdminLog -importLogs (Acid.AdminLog ls) = - Acid.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/Backup.hs b/src/Distribution/Server/Features/AdminLog/Backup.hs new file mode 100644 index 000000000..6713c3cd6 --- /dev/null +++ b/src/Distribution/Server/Features/AdminLog/Backup.hs @@ -0,0 +1,36 @@ +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 Distribution.Server.Framework.BackupRestore + +import Data.Maybe(mapMaybe) +import Data.Time (UTCTime) +import qualified Data.ByteString.Lazy.Char8 as BS +import Text.Read (readMaybe) +import Distribution.Server.Util.Parse + +restoreAdminLogBackup :: RestoreBackup Acid.AdminLog +restoreAdminLogBackup = + go (Acid.AdminLog []) + where + go logs = + RestoreBackup { + restoreEntry = \entry -> case entry of + BackupByteString ["adminLog.txt"] bs + -> return . go $ importLogs logs bs + _ -> return (go logs) + , restoreFinalize = return logs + } + +importLogs :: Acid.AdminLog -> BS.ByteString -> Acid.AdminLog +importLogs (Acid.AdminLog ls) = + Acid.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 + From 5dc2610b743f038ee54e8e64867d87a14ea5d72d Mon Sep 17 00:00:00 2001 From: Sandy Maguire Date: Thu, 16 Apr 2026 09:21:48 -0700 Subject: [PATCH 26/32] UserDetails dump/restore --- .../Server/Features/UserDetails.hs | 79 +--------------- .../Server/Features/UserDetails/Backup.hs | 90 +++++++++++++++++++ 2 files changed, 91 insertions(+), 78 deletions(-) create mode 100644 src/Distribution/Server/Features/UserDetails/Backup.hs diff --git a/src/Distribution/Server/Features/UserDetails.hs b/src/Distribution/Server/Features/UserDetails.hs index faafebc5b..82483616a 100644 --- a/src/Distribution/Server/Features/UserDetails.hs +++ b/src/Distribution/Server/Features/UserDetails.hs @@ -12,10 +12,10 @@ module Distribution.Server.Features.UserDetails ( ) where import qualified Distribution.Server.Features.UserDetails.Acid as Acid +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.BackupRestore import Distribution.Server.Framework.Templating import Distribution.Server.Features.Users @@ -25,13 +25,10 @@ import Distribution.Server.Features.Core import Distribution.Server.Users.Types import Distribution.Server.Util.Validators (guardValidLookingEmail, guardValidLookingName) -import qualified Data.IntMap as IntMap import qualified Data.Text as T import qualified Data.Aeson as Aeson import Distribution.Text (display) -import Data.Version -import Text.CSV (CSV, Record) -- | A feature to store extra information about users like email addresses. @@ -65,80 +62,6 @@ userDetailsStateComponent stateDir = do , resetState = userDetailsStateComponent } ----------------------------- --- Data backup and restore --- - -userDetailsBackup :: RestoreBackup Acid.UserDetailsTable -userDetailsBackup = updateUserBackup Acid.emptyUserDetailsTable - -updateUserBackup :: Acid.UserDetailsTable -> RestoreBackup Acid.UserDetailsTable -updateUserBackup users = RestoreBackup { - restoreEntry = \entry -> case entry of - BackupByteString ["users.csv"] bs -> do - csv <- importCSV "users.csv" bs - users' <- importUserDetails csv users - return (updateUserBackup users') - _ -> - return (updateUserBackup users) - , restoreFinalize = - return users - } - -importUserDetails :: CSV -> Acid.UserDetailsTable -> Restore Acid.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 - UserId uid <- parseText "user id" idStr - akind <- parseKind kindStr - let udetails = AccountDetails { - accountName = T.pack nameStr, - accountContactEmail = T.pack emailStr, - accountKind = akind, - accountAdminNotes = T.pack notesStr - } - return $! Acid.UserDetailsTable (IntMap.insert uid udetails tbl) - - fromRecord x _ = fail $ "Error processing user details record: " ++ show x - - parseKind "" = return Nothing - parseKind "real" = return (Just AccountKindRealUser) - parseKind "special" = return (Just AccountKindSpecial) - parseKind sts = fail $ "unable to parse account kind: " ++ sts - -userDetailsToCSV :: BackupType -> Acid.UserDetailsTable -> CSV -userDetailsToCSV backuptype (Acid.UserDetailsTable tbl) - = ([showVersion userCSVVer]:) $ - (userdetailsCSVKey:) $ - - flip map (IntMap.toList tbl) $ \(uid, udetails) -> - [ display (UserId uid) - , T.unpack (accountName udetails) --FIXME: apparently the csv lib doesn't do unicode properly - , if backuptype == FullBackup - then T.unpack (accountContactEmail udetails) - else "hidden-email@nowhere.org" - , infoToAccountKind udetails - , T.unpack (accountAdminNotes udetails) - ] - - where - userdetailsCSVKey = - [ "uid" - , "realname" - , "email" - , "kind" - , "notes" - ] - userCSVVer = Version [0,2] [] - - -- one of "enabled" "disabled" or "deleted" - infoToAccountKind :: AccountDetails -> String - infoToAccountKind udetails = case accountKind udetails of - Nothing -> "" - Just AccountKindRealUser -> "real" - Just AccountKindSpecial -> "special" - ---------------------------------------- -- Feature definition & initialisation -- diff --git a/src/Distribution/Server/Features/UserDetails/Backup.hs b/src/Distribution/Server/Features/UserDetails/Backup.hs new file mode 100644 index 000000000..d759fce78 --- /dev/null +++ b/src/Distribution/Server/Features/UserDetails/Backup.hs @@ -0,0 +1,90 @@ +module Distribution.Server.Features.UserDetails.Backup where + +import qualified Distribution.Server.Features.UserDetails.Acid as Acid +import Distribution.Server.Features.UserDetails.Types +import Distribution.Server.Framework.BackupDump +import Distribution.Server.Framework.BackupRestore + +import Distribution.Server.Users.Types + +import qualified Data.IntMap as IntMap +import qualified Data.Text as T + +import Distribution.Text (display) +import Data.Version +import Text.CSV (CSV, Record) + +---------------------------- +-- Data backup and restore +-- + +userDetailsBackup :: RestoreBackup Acid.UserDetailsTable +userDetailsBackup = updateUserBackup Acid.emptyUserDetailsTable + +updateUserBackup :: Acid.UserDetailsTable -> RestoreBackup Acid.UserDetailsTable +updateUserBackup users = RestoreBackup { + restoreEntry = \entry -> case entry of + BackupByteString ["users.csv"] bs -> do + csv <- importCSV "users.csv" bs + users' <- importUserDetails csv users + return (updateUserBackup users') + _ -> + return (updateUserBackup users) + , restoreFinalize = + return users + } + +importUserDetails :: CSV -> Acid.UserDetailsTable -> Restore Acid.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 + UserId uid <- parseText "user id" idStr + akind <- parseKind kindStr + let udetails = AccountDetails { + accountName = T.pack nameStr, + accountContactEmail = T.pack emailStr, + accountKind = akind, + accountAdminNotes = T.pack notesStr + } + return $! Acid.UserDetailsTable (IntMap.insert uid udetails tbl) + + fromRecord x _ = fail $ "Error processing user details record: " ++ show x + + parseKind "" = return Nothing + parseKind "real" = return (Just AccountKindRealUser) + parseKind "special" = return (Just AccountKindSpecial) + parseKind sts = fail $ "unable to parse account kind: " ++ sts + +userDetailsToCSV :: BackupType -> Acid.UserDetailsTable -> CSV +userDetailsToCSV backuptype (Acid.UserDetailsTable tbl) + = ([showVersion userCSVVer]:) $ + (userdetailsCSVKey:) $ + + flip map (IntMap.toList tbl) $ \(uid, udetails) -> + [ display (UserId uid) + , T.unpack (accountName udetails) --FIXME: apparently the csv lib doesn't do unicode properly + , if backuptype == FullBackup + then T.unpack (accountContactEmail udetails) + else "hidden-email@nowhere.org" + , infoToAccountKind udetails + , T.unpack (accountAdminNotes udetails) + ] + + where + userdetailsCSVKey = + [ "uid" + , "realname" + , "email" + , "kind" + , "notes" + ] + userCSVVer = Version [0,2] [] + + -- one of "enabled" "disabled" or "deleted" + infoToAccountKind :: AccountDetails -> String + infoToAccountKind udetails = case accountKind udetails of + Nothing -> "" + Just AccountKindRealUser -> "real" + Just AccountKindSpecial -> "special" + From 7fcf19554dabaeb80cef00174f9725f327659ffe Mon Sep 17 00:00:00 2001 From: Sandy Maguire Date: Thu, 16 Apr 2026 15:38:07 -0700 Subject: [PATCH 27/32] Downstream fixes --- .../Server/Features/AdminFrontend.hs | 2 + src/Distribution/Server/Features/Html.hs | 1 + .../Server/Features/UserDetails.hs | 3 -- .../Server/Features/UserNotify.hs | 47 +------------------ .../Server/Features/UserSignup.hs | 2 + .../Server/Features/UserSignup/Types.hs | 35 ++++++++++++++ src/Distribution/Server/Features/Vouch.hs | 11 ----- .../Server/Features/Vouch/Types.hs | 12 +++++ 8 files changed, 53 insertions(+), 60 deletions(-) create mode 100644 src/Distribution/Server/Features/UserSignup/Types.hs create mode 100644 src/Distribution/Server/Features/Vouch/Types.hs diff --git a/src/Distribution/Server/Features/AdminFrontend.hs b/src/Distribution/Server/Features/AdminFrontend.hs index e77eacba3..2c23a9adb 100644 --- a/src/Distribution/Server/Features/AdminFrontend.hs +++ b/src/Distribution/Server/Features/AdminFrontend.hs @@ -7,9 +7,11 @@ module Distribution.Server.Features.AdminFrontend ( import Distribution.Server.Framework import Distribution.Server.Framework.Templating +import Distribution.Server.Features.UserSignup.Types import Distribution.Server.Features.Users import Distribution.Server.Features.UserDetails +import Distribution.Server.Features.UserDetails.Types import Distribution.Server.Features.UserSignup import Distribution.Server.Features.LegacyPasswds import qualified Distribution.Server.Features.LegacyPasswds.Acid as Acid diff --git a/src/Distribution/Server/Features/Html.hs b/src/Distribution/Server/Features/Html.hs index 84cdb9882..49d355e91 100644 --- a/src/Distribution/Server/Features/Html.hs +++ b/src/Distribution/Server/Features/Html.hs @@ -33,6 +33,7 @@ import Distribution.Server.Features.Distro import Distribution.Server.Features.Documentation import Distribution.Server.Features.TarIndexCache import Distribution.Server.Features.UserDetails +import Distribution.Server.Features.UserDetails.Types import Distribution.Server.Features.EditCabalFiles import Distribution.Server.Features.Html.HtmlUtilities import Distribution.Server.Features.Security.SHA256 diff --git a/src/Distribution/Server/Features/UserDetails.hs b/src/Distribution/Server/Features/UserDetails.hs index 82483616a..6d67d44c6 100644 --- a/src/Distribution/Server/Features/UserDetails.hs +++ b/src/Distribution/Server/Features/UserDetails.hs @@ -6,9 +6,6 @@ module Distribution.Server.Features.UserDetails ( initUserDetailsFeature, UserDetailsFeature(..), - - AccountDetails(..), - AccountKind(..) ) where import qualified Distribution.Server.Features.UserDetails.Acid as Acid diff --git a/src/Distribution/Server/Features/UserNotify.hs b/src/Distribution/Server/Features/UserNotify.hs index 46d413ca8..04d4f0e89 100644 --- a/src/Distribution/Server/Features/UserNotify.hs +++ b/src/Distribution/Server/Features/UserNotify.hs @@ -7,10 +7,6 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-} module Distribution.Server.Features.UserNotify ( - Acid.NotifyData(..), - Acid.NotifyPref(..), - NotifyRevisionRange(..), - NotifyTriggerBounds(..), UserNotifyFeature(..), getUserNotificationsOnRelease, importNotifyPref, @@ -18,8 +14,6 @@ module Distribution.Server.Features.UserNotify ( notifyDataToCSV, -- * getNotificationEmails - Notification(..), - NotifyMaintainerUpdateType(..), getNotificationEmails, ) where @@ -75,7 +69,7 @@ import Data.Hashable (Hashable(..)) import Data.List (maximumBy, sortOn) import Data.Maybe (fromMaybe, listToMaybe, mapMaybe, maybeToList) import Data.Ord (Down(..), comparing) -import Data.Time (UTCTime(..), addUTCTime, defaultTimeLocale, diffUTCTime, formatTime, getCurrentTime) +import Data.Time (addUTCTime, defaultTimeLocale, diffUTCTime, formatTime, getCurrentTime) import Distribution.Text (display) import Network.Mail.Mime import Network.URI (uriAuthority, uriPath, uriRegName) @@ -85,7 +79,6 @@ import Text.XHtml hiding (base, text, ()) import qualified Data.Aeson as Aeson import qualified Data.Aeson.Types as Aeson import qualified Data.ByteString.Lazy.Char8 as BS -import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.Lazy as TL import qualified Data.Text.Lazy.Encoding as TL @@ -679,44 +672,6 @@ userNotifyFeature UserFeature{..} -- send out too many emails threadDelay 250000 -data Notification - = NotifyNewVersion - { notifyPackageInfo :: PkgInfo - } - | NotifyNewRevision - { notifyPackageId :: PackageId - , notifyRevisions :: [UploadInfo] - } - | NotifyMaintainerUpdate - { notifyMaintainerUpdateType :: NotifyMaintainerUpdateType - , notifyUserActor :: UserId - , notifyUserSubject :: UserId - , notifyPackageName :: PackageName - , notifyReason :: Text - , notifyUpdatedAt :: UTCTime - } - | NotifyDocsBuild - { notifyPackageId :: PackageId - , notifyBuildSuccess :: Bool - } - | NotifyUpdateTags - { notifyPackageName :: PackageName - , notifyAddedTags :: Set Tag - , notifyDeletedTags :: Set Tag - } - | NotifyDependencyUpdate - { notifyPackageId :: PackageId - -- ^ Dependency that was updated - , notifyWatchedPackages :: [PackageId] - -- ^ Packages maintained by user that depend on updated dep - , notifyTriggerBounds :: NotifyTriggerBounds - } - | NotifyVouchingCompleted - deriving (Show) - -data NotifyMaintainerUpdateType = MaintainerAdded | MaintainerRemoved - deriving (Show) - -- | Notifications in the same group are batched in the same email. -- -- TODO: How often do multiple notifications come in at once? Maybe it's diff --git a/src/Distribution/Server/Features/UserSignup.hs b/src/Distribution/Server/Features/UserSignup.hs index 7be30230d..5e4e79692 100644 --- a/src/Distribution/Server/Features/UserSignup.hs +++ b/src/Distribution/Server/Features/UserSignup.hs @@ -11,6 +11,7 @@ module Distribution.Server.Features.UserSignup ( import qualified Distribution.Server.Features.UserSignup.Acid as Acid import Distribution.Server.Features.UserSignup.Backup +import Distribution.Server.Features.UserSignup.Types import Distribution.Server.Framework import Distribution.Server.Framework.Templating @@ -19,6 +20,7 @@ import Distribution.Server.Framework.BackupDump import Distribution.Server.Features.Upload import Distribution.Server.Features.Users import Distribution.Server.Features.UserDetails +import Distribution.Server.Features.UserDetails.Types import Distribution.Server.Users.Group import Distribution.Server.Users.Types diff --git a/src/Distribution/Server/Features/UserSignup/Types.hs b/src/Distribution/Server/Features/UserSignup/Types.hs new file mode 100644 index 000000000..40f630ca1 --- /dev/null +++ b/src/Distribution/Server/Features/UserSignup/Types.hs @@ -0,0 +1,35 @@ +{-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving, + TypeFamilies, TemplateHaskell, + RankNTypes, NamedFieldPuns, RecordWildCards, BangPatterns #-} +module Distribution.Server.Features.UserSignup.Types where + +import Distribution.Server.Framework + +import Distribution.Server.Users.Types + +import Data.Text (Text) +import Data.SafeCopy (base, deriveSafeCopy) + +import Data.Time + +------------------------- +-- Types of stored data +-- + +data SignupResetInfo = SignupInfo { + signupUserName :: !Text, + signupRealName :: !Text, + signupContactEmail :: !Text, + nonceTimestamp :: !UTCTime + } + | ResetInfo { + resetUserId :: !UserId, + nonceTimestamp :: !UTCTime + } + deriving (Eq, Show) + +instance MemSize SignupResetInfo where + memSize (SignupInfo a b c d) = memSize4 a b c d + memSize (ResetInfo a b) = memSize2 a b + +$(deriveSafeCopy 0 'base ''SignupResetInfo) diff --git a/src/Distribution/Server/Features/Vouch.hs b/src/Distribution/Server/Features/Vouch.hs index 46a296e08..3d3658171 100644 --- a/src/Distribution/Server/Features/Vouch.hs +++ b/src/Distribution/Server/Features/Vouch.hs @@ -67,17 +67,6 @@ isWithinLastMonth :: UTCTime -> (UserId, UTCTime) -> Bool isWithinLastMonth now (_, vouchTime) = addUTCTime (30 * nominalDay) vouchTime >= now -data VouchError - = NotAnUploader - | You'reTooNew - | VoucheeAlreadyUploader - | AlreadySufficientlyVouched - | YouAlreadyVouched - deriving stock (Show, Eq) - -data VouchSuccess = AddVouchComplete | AddVouchIncomplete Int - deriving stock (Show, Eq) - judgeVouch :: Group.UserIdSet -> UTCTime diff --git a/src/Distribution/Server/Features/Vouch/Types.hs b/src/Distribution/Server/Features/Vouch/Types.hs new file mode 100644 index 000000000..9dc421ab7 --- /dev/null +++ b/src/Distribution/Server/Features/Vouch/Types.hs @@ -0,0 +1,12 @@ +module Distribution.Server.Features.Vouch.Types where + +data VouchError + = NotAnUploader + | You'reTooNew + | VoucheeAlreadyUploader + | AlreadySufficientlyVouched + | YouAlreadyVouched + deriving (Show, Eq) + +data VouchSuccess = AddVouchComplete | AddVouchIncomplete Int + deriving (Show, Eq) From 9ad7f949d0b7c7a2a33374d4b4b82f397ab7cb9e Mon Sep 17 00:00:00 2001 From: Sandy Maguire Date: Thu, 16 Apr 2026 16:09:08 -0700 Subject: [PATCH 28/32] Remove unused pragmas --- src/Distribution/Server/Features/AdminLog.hs | 6 +++--- src/Distribution/Server/Features/LegacyPasswds.hs | 7 ++++--- src/Distribution/Server/Features/UserSignup.hs | 8 +++++--- src/Distribution/Server/Features/Vouch.hs | 4 ---- 4 files changed, 12 insertions(+), 13 deletions(-) diff --git a/src/Distribution/Server/Features/AdminLog.hs b/src/Distribution/Server/Features/AdminLog.hs index f1ec16533..8c6a39330 100755 --- a/src/Distribution/Server/Features/AdminLog.hs +++ b/src/Distribution/Server/Features/AdminLog.hs @@ -1,6 +1,6 @@ -{-# LANGUAGE DeriveDataTypeable, TypeFamilies, BangPatterns, - GeneralizedNewtypeDeriving, NamedFieldPuns, RecordWildCards, - PatternGuards, RankNTypes #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} module Distribution.Server.Features.AdminLog where diff --git a/src/Distribution/Server/Features/LegacyPasswds.hs b/src/Distribution/Server/Features/LegacyPasswds.hs index 737c44722..80291c159 100644 --- a/src/Distribution/Server/Features/LegacyPasswds.hs +++ b/src/Distribution/Server/Features/LegacyPasswds.hs @@ -1,6 +1,7 @@ -{-# LANGUAGE DeriveDataTypeable, TypeFamilies, - RankNTypes, NamedFieldPuns, RecordWildCards, - RecursiveDo, BangPatterns #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} + module Distribution.Server.Features.LegacyPasswds ( initLegacyPasswdsFeature, LegacyPasswdsFeature(..), diff --git a/src/Distribution/Server/Features/UserSignup.hs b/src/Distribution/Server/Features/UserSignup.hs index 5e4e79692..fb771c078 100644 --- a/src/Distribution/Server/Features/UserSignup.hs +++ b/src/Distribution/Server/Features/UserSignup.hs @@ -1,7 +1,9 @@ +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} + {-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-} -{-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving, - TypeFamilies, TemplateHaskell, - RankNTypes, NamedFieldPuns, RecordWildCards, BangPatterns #-} + module Distribution.Server.Features.UserSignup ( initUserSignupFeature, UserSignupFeature(..), diff --git a/src/Distribution/Server/Features/Vouch.hs b/src/Distribution/Server/Features/Vouch.hs index 3d3658171..af4b99fff 100644 --- a/src/Distribution/Server/Features/Vouch.hs +++ b/src/Distribution/Server/Features/Vouch.hs @@ -1,8 +1,4 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE RankNTypes #-} module Distribution.Server.Features.Vouch (VouchFeature(..), initVouchFeature, judgeVouch) where From c4ba69ea0b942c19487214ed1f52b614bfe66616 Mon Sep 17 00:00:00 2001 From: Sandy Maguire Date: Thu, 16 Apr 2026 16:22:42 -0700 Subject: [PATCH 29/32] Fix build --- tests/ReverseDependenciesTest.hs | 17 ++++------------- tests/VouchTest.hs | 3 ++- 2 files changed, 6 insertions(+), 14 deletions(-) diff --git a/tests/ReverseDependenciesTest.hs b/tests/ReverseDependenciesTest.hs index 82f3100b8..c1d150239 100644 --- a/tests/ReverseDependenciesTest.hs +++ b/tests/ReverseDependenciesTest.hs @@ -27,20 +27,11 @@ import Distribution.Server.Features.PreferredVersions.State (PreferredVersions(. import Distribution.Server.Features.ReverseDependencies (ReverseFeature(..), ReverseCount(..), reverseFeature) import Distribution.Server.Features.ReverseDependencies.State (ReverseIndex(..), addPackage, constructReverseIndex, emptyReverseIndex, getDependenciesFlat, getDependencies, getDependenciesFlatRaw, getDependenciesRaw) import Distribution.Server.Features.Tags (Tag(..)) -import Distribution.Server.Features.UserDetails (AccountDetails(..), UserDetailsFeature(..)) +import Distribution.Server.Features.UserDetails (UserDetailsFeature(..)) +import Distribution.Server.Features.UserDetails.Types (AccountDetails(..)) import Distribution.Server.Features.UserNotify - ( Notification(..) - , NotifyMaintainerUpdateType(..) - , NotifyData(..) - , NotifyPref(..) - , NotifyRevisionRange(..) - , NotifyTriggerBounds(..) - , defaultNotifyPrefs - , getNotificationEmails - , getUserNotificationsOnRelease - , importNotifyPref - , notifyDataToCSV - ) +import Distribution.Server.Features.UserNotify.Acid +import Distribution.Server.Features.UserNotify.Types import Distribution.Server.Framework.BackupRestore (runRestore) import Distribution.Server.Framework.Hook (newHook) import Distribution.Server.Framework.MemState (newMemStateWHNF) diff --git a/tests/VouchTest.hs b/tests/VouchTest.hs index ece72d578..67d625474 100644 --- a/tests/VouchTest.hs +++ b/tests/VouchTest.hs @@ -2,7 +2,8 @@ module Main where import Data.Time (UTCTime(UTCTime), fromGregorian) -import Distribution.Server.Features.Vouch (VouchError(..), VouchSuccess(..), judgeVouch) +import Distribution.Server.Features.Vouch (judgeVouch) +import Distribution.Server.Features.Vouch.Types (VouchError(..), VouchSuccess(..)) import Distribution.Server.Users.UserIdSet (fromList) import Distribution.Server.Users.Types (UserId(UserId)) From 12794662dfd919d8853c955f7294febab2f54b9c Mon Sep 17 00:00:00 2001 From: Sandy Maguire Date: Fri, 17 Apr 2026 09:44:08 -0700 Subject: [PATCH 30/32] Data.Acid.Compat --- hackage-server.cabal | 3 +++ src/Data/Acid/Compat.hs | 57 +++++++++++++++++++++++++++++++++++++++++ 2 files changed, 60 insertions(+) create mode 100644 src/Data/Acid/Compat.hs diff --git a/hackage-server.cabal b/hackage-server.cabal index 443ae18c8..1db7e91f6 100644 --- a/hackage-server.cabal +++ b/hackage-server.cabal @@ -218,6 +218,8 @@ library Paths_hackage_server exposed-modules: + Data.Acid.Compat + Distribution.Server Distribution.Server.Prelude @@ -435,6 +437,7 @@ library , http-types >= 0.10 && < 0.13 , QuickCheck >= 2.14 && < 2.16 , acid-state ^>= 0.16 + , safecopy >= 0.6 && < 0.11 , async ^>= 2.2.1 -- requires bumping http-io-streams , attoparsec ^>= 0.14.4 diff --git a/src/Data/Acid/Compat.hs b/src/Data/Acid/Compat.hs new file mode 100644 index 000000000..1b1984328 --- /dev/null +++ b/src/Data/Acid/Compat.hs @@ -0,0 +1,57 @@ +-- | This module re-exports enough of "Data.Acid" to give manual(ish) instances +-- of 'IsAcidic' and related classes. The only reason to give manual instances +-- is so that we can implement 'methodTag' via 'movedMethodTag'. +-- +-- Among its many flaws, 'makeAcidic' gives an implementation of 'methodTag' +-- which in turn bakes the /module name/ into the serialisation schema. This +-- means calls to 'makeAcidic' are not referentially transparent, thus changing +-- the defining module will prevent deserialisation. +-- +-- Unfortunately, as part of #1486, it's very desirable to move these instances +-- out of the main library component and into a deprecatable migration +-- component. +module Data.Acid.Compat + ( module Data.Acid.Compat + , module Data.Acid.Common + , module Data.Acid.Core + , module Data.SafeCopy + ) where + +import Data.Acid.Common +import Data.Acid.Core +import Data.ByteString.Lazy as Lazy (ByteString) +import Data.ByteString.Lazy.Char8 as Lazy ( pack ) +import Data.Typeable +import Data.SafeCopy + +-- Note [Acid Migration] +-- ~~~~~~~~~~~~~~~~~~~~~ +-- +-- Due to silly technical reasons deep within @acid-state@, it's impossible to +-- move a call to 'makeAcidic' into a different module. If you found +-- a reference to this Note, it means we have /manually/ moved this +-- 'makeAcidic' call. +-- +-- If you find yourself needing to update one of these, uncomment the call to +-- 'makeAcidic', turn on @-ddump-splices@, and then manually inline the +-- resulting splice. You MUST change the splice and give a non-default +-- implementation of 'methodTag': +-- +-- @methodTag = 'movedMethodTag' "Original.Qualified.Module.Name"@ +-- +-- where @My.Qualified.Module@ is the full module name of the /original/ +-- location of the call to 'makeAcidic'. The original module name should be +-- found in the reference to this note. + + +-- | Generate a @Data.Acid.Core.Tag@ for some type @a@, explicitly overriding +-- its module path to trick @acid-state@ into doing the right thing. +movedMethodTag + :: Typeable a + => String + -- ^ Qualified module name where 'makeAcidic' used to be called. + -> a + -> Lazy.ByteString +movedMethodTag modul = Lazy.pack . showQualifiedTypeRep . typeOf + where + showQualifiedTypeRep tr = modul <> "." <> show tr From 878db22728229327d3f169ce8aaec92cdc954ee3 Mon Sep 17 00:00:00 2001 From: Sandy Maguire Date: Fri, 17 Apr 2026 09:44:08 -0700 Subject: [PATCH 31/32] Fix stupid acid stuff --- .../Server/Features/AdminLog/Acid.hs | 62 +++++++- .../Server/Features/UserNotify/Acid.hs | 123 +++++++++++++-- .../Server/Features/UserSignup/Acid.hs | 149 ++++++++++++++++-- .../Server/Features/Vouch/State.hs | 89 +++++++++-- 4 files changed, 381 insertions(+), 42 deletions(-) diff --git a/src/Distribution/Server/Features/AdminLog/Acid.hs b/src/Distribution/Server/Features/AdminLog/Acid.hs index 9847c2db9..4c03477fb 100644 --- a/src/Distribution/Server/Features/AdminLog/Acid.hs +++ b/src/Distribution/Server/Features/AdminLog/Acid.hs @@ -8,11 +8,11 @@ import Distribution.Server.Features.AdminLog.Types import Distribution.Server.Users.Types (UserId) import Distribution.Server.Framework -import Data.SafeCopy (base, deriveSafeCopy) 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)] @@ -37,6 +37,60 @@ instance Eq AdminLog where replaceAdminLog :: AdminLog -> Update AdminLog () replaceAdminLog = State.put -makeAcidic ''AdminLog ['getAdminLog - ,'replaceAdminLog - ,'addAdminLog] +------------------------------ +-- 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 diff --git a/src/Distribution/Server/Features/UserNotify/Acid.hs b/src/Distribution/Server/Features/UserNotify/Acid.hs index 0dd913c0e..38e56cb9e 100644 --- a/src/Distribution/Server/Features/UserNotify/Acid.hs +++ b/src/Distribution/Server/Features/UserNotify/Acid.hs @@ -15,8 +15,8 @@ import qualified Data.Map as Map import Control.Monad.Reader (ask) import Control.Monad.State (get, put) -import Data.SafeCopy (Migrate(migrate), MigrateFrom, base, deriveSafeCopy, extension) import Data.Time (UTCTime(..), getCurrentTime) +import Data.Acid.Compat ------------------------- @@ -113,14 +113,115 @@ addNotifyPref uid info = do NotifyData (m,t) <- get put $! NotifyData (Map.insert uid info m,t) -makeAcidic ''NotifyData [ - --queries - 'getNotifyData, - 'lookupNotifyPref, - 'getNotifyTime, - --updates - 'replaceNotifyData, - 'addNotifyPref, - 'setNotifyTime - ] +------------------------------ +-- IsAcidic machinery +-- +-- See Note [Acid Migration] in "Data.Acid.Compat" +-- original module name was Distribution.Server.Features.UserNotify" + +--makeAcidic ''NotifyData [ +-- --queries +-- 'getNotifyData, +-- 'lookupNotifyPref, +-- 'getNotifyTime, +-- --updates +-- 'replaceNotifyData, +-- 'addNotifyPref, +-- 'setNotifyTime +-- ] + +instance IsAcidic NotifyData where + acidEvents + = [QueryEvent + (\ GetNotifyData -> getNotifyData) safeCopyMethodSerialiser, + QueryEvent + (\ (LookupNotifyPref arg_aDhJ) -> lookupNotifyPref arg_aDhJ) + safeCopyMethodSerialiser, + QueryEvent + (\ GetNotifyTime -> getNotifyTime) safeCopyMethodSerialiser, + UpdateEvent + (\ (ReplaceNotifyData arg_aDhK) -> replaceNotifyData arg_aDhK) + safeCopyMethodSerialiser, + UpdateEvent + (\ (AddNotifyPref arg_aDhL arg_aDhM) + -> addNotifyPref arg_aDhL arg_aDhM) + safeCopyMethodSerialiser, + UpdateEvent + (\ (SetNotifyTime arg_aDhN) -> setNotifyTime arg_aDhN) + safeCopyMethodSerialiser] +data GetNotifyData = GetNotifyData +instance SafeCopy GetNotifyData where + putCopy GetNotifyData = contain (do return ()) + getCopy = contain (return GetNotifyData) + errorTypeName _ = "Data.SafeCopy.SafeCopy.SafeCopy GetNotifyData" +instance Data.Acid.Compat.Method GetNotifyData where + type MethodResult GetNotifyData = NotifyData + type MethodState GetNotifyData = NotifyData + methodTag = movedMethodTag "Distribution.Server.Features.UserNotify" +instance QueryEvent GetNotifyData +newtype LookupNotifyPref = LookupNotifyPref UserId +instance SafeCopy LookupNotifyPref where + putCopy (LookupNotifyPref arg_aDgW) + = contain + (do safePut arg_aDgW + return ()) + getCopy = contain (return LookupNotifyPref <*> safeGet) + errorTypeName _ + = "Data.SafeCopy.SafeCopy.SafeCopy LookupNotifyPref" +instance Data.Acid.Compat.Method LookupNotifyPref where + type MethodResult LookupNotifyPref = Maybe NotifyPref + type MethodState LookupNotifyPref = NotifyData + methodTag = movedMethodTag "Distribution.Server.Features.UserNotify" +instance QueryEvent LookupNotifyPref +data GetNotifyTime = GetNotifyTime +instance SafeCopy GetNotifyTime where + putCopy GetNotifyTime = contain (do return ()) + getCopy = contain (return GetNotifyTime) + errorTypeName _ = "Data.SafeCopy.SafeCopy.SafeCopy GetNotifyTime" +instance Data.Acid.Compat.Method GetNotifyTime where + type MethodResult GetNotifyTime = UTCTime + type MethodState GetNotifyTime = NotifyData + methodTag = movedMethodTag "Distribution.Server.Features.UserNotify" +instance QueryEvent GetNotifyTime +newtype ReplaceNotifyData = ReplaceNotifyData NotifyData +instance SafeCopy ReplaceNotifyData where + putCopy (ReplaceNotifyData arg_aDh5) + = contain + (do safePut arg_aDh5 + return ()) + getCopy = contain (return ReplaceNotifyData <*> safeGet) + errorTypeName _ + = "Data.SafeCopy.SafeCopy.SafeCopy ReplaceNotifyData" +instance Data.Acid.Compat.Method ReplaceNotifyData where + type MethodResult ReplaceNotifyData = () + type MethodState ReplaceNotifyData = NotifyData + methodTag = movedMethodTag "Distribution.Server.Features.UserNotify" +instance UpdateEvent ReplaceNotifyData +data AddNotifyPref = AddNotifyPref UserId NotifyPref +instance SafeCopy AddNotifyPref where + putCopy (AddNotifyPref arg_aDha arg_aDhb) + = contain + (do safePut arg_aDha + safePut arg_aDhb + return ()) + getCopy = contain ((return AddNotifyPref <*> safeGet) <*> safeGet) + errorTypeName _ = "Data.SafeCopy.SafeCopy.SafeCopy AddNotifyPref" +instance Data.Acid.Compat.Method AddNotifyPref where + type MethodResult AddNotifyPref = () + type MethodState AddNotifyPref = NotifyData + methodTag = movedMethodTag "Distribution.Server.Features.UserNotify" +instance UpdateEvent AddNotifyPref +newtype SetNotifyTime = SetNotifyTime UTCTime +instance SafeCopy SetNotifyTime where + putCopy (SetNotifyTime arg_aDhg) + = contain + (do safePut arg_aDhg + return ()) + getCopy = contain (return SetNotifyTime <*> safeGet) + errorTypeName _ = "Data.SafeCopy.SafeCopy.SafeCopy SetNotifyTime" +instance Data.Acid.Compat.Method SetNotifyTime where + type MethodResult SetNotifyTime = () + type MethodState SetNotifyTime = NotifyData + methodTag = movedMethodTag "Distribution.Server.Features.UserNotify" +instance UpdateEvent SetNotifyTime diff --git a/src/Distribution/Server/Features/UserSignup/Acid.hs b/src/Distribution/Server/Features/UserSignup/Acid.hs index 1ef4a49a2..cdd9badae 100644 --- a/src/Distribution/Server/Features/UserSignup/Acid.hs +++ b/src/Distribution/Server/Features/UserSignup/Acid.hs @@ -1,12 +1,12 @@ -{-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-} -{-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving, - TypeFamilies, TemplateHaskell, - RankNTypes, NamedFieldPuns, RecordWildCards, BangPatterns #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} + module Distribution.Server.Features.UserSignup.Acid where import Distribution.Server.Features.UserSignup.Types -import Distribution.Server.Framework +import Distribution.Server.Framework hiding (Method) import Distribution.Server.Util.Nonce @@ -14,7 +14,8 @@ import Data.Map (Map) import qualified Data.Map as Map import Control.Monad.Reader (ask) import Control.Monad.State (get, put, modify) -import Data.SafeCopy (base, deriveSafeCopy) +import Data.Acid.Compat +import Data.SafeCopy import Data.Time @@ -64,14 +65,128 @@ deleteAllExpired expireTime = SignupResetTable $ Map.filter (\entry -> nonceTimestamp entry > expireTime) tbl -makeAcidic ''SignupResetTable [ - --queries - 'getSignupResetTable, - 'lookupSignupResetInfo, - --updates - 'replaceSignupResetTable, - 'addSignupResetInfo, - 'deleteSignupResetInfo, - 'deleteAllExpired - ] - +------------------------------ +-- IsAcidic machinery +-- +-- See Note [Acid Migration] in "Data.Acid.Compat" +-- original module name was Distribution.Server.Features.UserSignup" + +-- makeAcidic ''SignupResetTable [ +-- --queries +-- 'getSignupResetTable, +-- 'lookupSignupResetInfo, +-- --updates +-- 'replaceSignupResetTable, +-- 'addSignupResetInfo, +-- 'deleteSignupResetInfo, +-- 'deleteAllExpired +-- ] + +instance IsAcidic SignupResetTable where + acidEvents + = [QueryEvent + (\ GetSignupResetTable -> getSignupResetTable) + safeCopyMethodSerialiser, + QueryEvent + (\ (LookupSignupResetInfo arg_a30zB) + -> lookupSignupResetInfo arg_a30zB) + safeCopyMethodSerialiser, + UpdateEvent + (\ (ReplaceSignupResetTable arg_a30zC) + -> replaceSignupResetTable arg_a30zC) + safeCopyMethodSerialiser, + UpdateEvent + (\ (AddSignupResetInfo arg_a30zD arg_a30zE) + -> addSignupResetInfo arg_a30zD arg_a30zE) + safeCopyMethodSerialiser, + UpdateEvent + (\ (DeleteSignupResetInfo arg_a30zF) + -> deleteSignupResetInfo arg_a30zF) + safeCopyMethodSerialiser, + UpdateEvent + (\ (DeleteAllExpired arg_a30zG) -> deleteAllExpired arg_a30zG) + safeCopyMethodSerialiser] +data GetSignupResetTable = GetSignupResetTable +instance SafeCopy GetSignupResetTable where + putCopy GetSignupResetTable = contain (do return ()) + getCopy = contain (return GetSignupResetTable) + errorTypeName _ + = "Data.SafeCopy.SafeCopy.SafeCopy GetSignupResetTable" +instance Method GetSignupResetTable where + type MethodResult GetSignupResetTable = SignupResetTable + type MethodState GetSignupResetTable = SignupResetTable + methodTag = movedMethodTag "Distribution.Server.Features.UserSignup" +instance QueryEvent GetSignupResetTable +newtype LookupSignupResetInfo = LookupSignupResetInfo Nonce +instance SafeCopy LookupSignupResetInfo where + putCopy (LookupSignupResetInfo arg_a30yN) + = contain + (do safePut arg_a30yN + return ()) + getCopy = contain (return LookupSignupResetInfo <*> safeGet) + errorTypeName _ + = "Data.SafeCopy.SafeCopy.SafeCopy LookupSignupResetInfo" +instance Method LookupSignupResetInfo where + type MethodResult LookupSignupResetInfo = Maybe SignupResetInfo + type MethodState LookupSignupResetInfo = SignupResetTable + methodTag = movedMethodTag "Distribution.Server.Features.UserSignup" +instance QueryEvent LookupSignupResetInfo +newtype ReplaceSignupResetTable + = ReplaceSignupResetTable SignupResetTable +instance SafeCopy ReplaceSignupResetTable where + putCopy (ReplaceSignupResetTable arg_a30yS) + = contain + (do safePut arg_a30yS + return ()) + getCopy = contain (return ReplaceSignupResetTable <*> safeGet) + errorTypeName _ + = "Data.SafeCopy.SafeCopy.SafeCopy ReplaceSignupResetTable" +instance Method ReplaceSignupResetTable where + type MethodResult ReplaceSignupResetTable = () + type MethodState ReplaceSignupResetTable = SignupResetTable + methodTag = movedMethodTag "Distribution.Server.Features.UserSignup" +instance UpdateEvent ReplaceSignupResetTable +data AddSignupResetInfo = AddSignupResetInfo Nonce SignupResetInfo +instance SafeCopy AddSignupResetInfo where + putCopy (AddSignupResetInfo arg_a30yX arg_a30yY) + = contain + (do safePut arg_a30yX + safePut arg_a30yY + return ()) + getCopy + = contain ((return AddSignupResetInfo <*> safeGet) <*> safeGet) + errorTypeName _ + = "Data.SafeCopy.SafeCopy.SafeCopy AddSignupResetInfo" +instance Method AddSignupResetInfo where + type MethodResult AddSignupResetInfo = Bool + type MethodState AddSignupResetInfo = SignupResetTable + methodTag = movedMethodTag "Distribution.Server.Features.UserSignup" +instance UpdateEvent AddSignupResetInfo +newtype DeleteSignupResetInfo = DeleteSignupResetInfo Nonce +instance SafeCopy DeleteSignupResetInfo where + putCopy (DeleteSignupResetInfo arg_a30z3) + = contain + (do safePut arg_a30z3 + return ()) + getCopy = contain (return DeleteSignupResetInfo <*> safeGet) + errorTypeName _ + = "Data.SafeCopy.SafeCopy.SafeCopy DeleteSignupResetInfo" +instance Method DeleteSignupResetInfo where + type MethodResult DeleteSignupResetInfo = () + type MethodState DeleteSignupResetInfo = SignupResetTable + methodTag = movedMethodTag "Distribution.Server.Features.UserSignup" +instance UpdateEvent DeleteSignupResetInfo +newtype DeleteAllExpired = DeleteAllExpired UTCTime +instance SafeCopy DeleteAllExpired where + putCopy (DeleteAllExpired arg_a30z8) + = contain + (do safePut arg_a30z8 + return ()) + getCopy = contain (return DeleteAllExpired <*> safeGet) + errorTypeName _ + = "Data.SafeCopy.SafeCopy.SafeCopy DeleteAllExpired" +instance Method DeleteAllExpired where + type MethodResult DeleteAllExpired = () + type MethodState DeleteAllExpired = SignupResetTable + methodTag = movedMethodTag "Distribution.Server.Features.UserSignup" +instance UpdateEvent DeleteAllExpired diff --git a/src/Distribution/Server/Features/Vouch/State.hs b/src/Distribution/Server/Features/Vouch/State.hs index 176136b8d..be2272896 100644 --- a/src/Distribution/Server/Features/Vouch/State.hs +++ b/src/Distribution/Server/Features/Vouch/State.hs @@ -10,10 +10,8 @@ import qualified Data.Set as Set import Data.Maybe (fromMaybe) import Data.Time (UTCTime(..)) -import Data.SafeCopy (base, deriveSafeCopy) +import Data.Acid.Compat import Distribution.Server.Framework (MemSize(..), memSize2) -import Distribution.Server.Framework (Query, Update) -import Distribution.Server.Framework (makeAcidic) import Distribution.Server.Users.Types (UserId(..)) data VouchData = @@ -46,10 +44,81 @@ replaceVouchesData = put $(deriveSafeCopy 0 'base ''VouchData) -makeAcidic ''VouchData - [ 'putVouch - , 'getVouchesFor - -- Stock - , 'getVouchesData - , 'replaceVouchesData - ] +------------------------------ +-- IsAcidic machinery +-- +-- See Note [Acid Migration] in "Data.Acid.Compat" +-- original module name was Distribution.Server.Features.Vouch" + +-- makeAcidic ''VouchData +-- [ 'putVouch +-- , 'getVouchesFor +-- -- Stock +-- , 'getVouchesData +-- , 'replaceVouchesData +-- ] + +instance IsAcidic VouchData where + acidEvents + = [UpdateEvent + (\ (PutVouch arg_aumY arg_aumZ) -> putVouch arg_aumY arg_aumZ) + safeCopyMethodSerialiser, + QueryEvent + (\ (GetVouchesFor arg_aun0) -> getVouchesFor arg_aun0) + safeCopyMethodSerialiser, + QueryEvent + (\ GetVouchesData -> getVouchesData) safeCopyMethodSerialiser, + UpdateEvent + (\ (ReplaceVouchesData arg_aun1) -> replaceVouchesData arg_aun1) + safeCopyMethodSerialiser] +data PutVouch = PutVouch UserId (UserId, UTCTime) +instance SafeCopy PutVouch where + putCopy (PutVouch arg_aumn arg_aumo) + = contain + (do safePut arg_aumn + safePut arg_aumo + return ()) + getCopy = contain ((return PutVouch <*> safeGet) <*> safeGet) + errorTypeName _ = "Data.SafeCopy.SafeCopy.SafeCopy PutVouch" +instance Method PutVouch where + type MethodResult PutVouch = () + type MethodState PutVouch = VouchData + methodTag = movedMethodTag "Distribution.Server.Features.Vouch" +instance UpdateEvent PutVouch +newtype GetVouchesFor = GetVouchesFor UserId +instance SafeCopy GetVouchesFor where + putCopy (GetVouchesFor arg_aumy) + = contain + (do safePut arg_aumy + return ()) + getCopy = contain (return GetVouchesFor <*> safeGet) + errorTypeName _ = "Data.SafeCopy.SafeCopy.SafeCopy GetVouchesFor" +instance Method GetVouchesFor where + type MethodResult GetVouchesFor = [(UserId, UTCTime)] + type MethodState GetVouchesFor = VouchData + methodTag = movedMethodTag "Distribution.Server.Features.Vouch" +instance QueryEvent GetVouchesFor +data GetVouchesData = GetVouchesData +instance SafeCopy GetVouchesData where + putCopy GetVouchesData = contain (do return ()) + getCopy = contain (return GetVouchesData) + errorTypeName _ = "Data.SafeCopy.SafeCopy.SafeCopy GetVouchesData" +instance Method GetVouchesData where + type MethodResult GetVouchesData = VouchData + type MethodState GetVouchesData = VouchData + methodTag = movedMethodTag "Distribution.Server.Features.Vouch" +instance QueryEvent GetVouchesData +newtype ReplaceVouchesData = ReplaceVouchesData VouchData +instance SafeCopy ReplaceVouchesData where + putCopy (ReplaceVouchesData arg_aumH) + = contain + (do safePut arg_aumH + return ()) + getCopy = contain (return ReplaceVouchesData <*> safeGet) + errorTypeName _ + = "Data.SafeCopy.SafeCopy.SafeCopy ReplaceVouchesData" +instance Method ReplaceVouchesData where + type MethodResult ReplaceVouchesData = () + type MethodState ReplaceVouchesData = VouchData + methodTag = movedMethodTag "Distribution.Server.Features.Vouch" +instance UpdateEvent ReplaceVouchesData From 256d2172a002bb75c7c61cd22d08f8efe54be30c Mon Sep 17 00:00:00 2001 From: Sandy Maguire Date: Thu, 16 Apr 2026 08:53:48 -0700 Subject: [PATCH 32/32] refactor: deacidify