From 8bb80d3511c1f8a0f66a7c3c8486db1af6c8df20 Mon Sep 17 00:00:00 2001
From: "Brian J. Cardiff" <bcardiff@gmail.com>
Date: Sat, 7 Feb 2026 16:34:06 -0500
Subject: [PATCH 01/34] Wiring of a Feature.Database

---
 hackage-server.cabal                          |  1 +
 src/Distribution/Server.hs                    | 11 +++++---
 src/Distribution/Server/Features.hs           |  6 +++++
 src/Distribution/Server/Features/Database.hs  | 27 +++++++++++++++++++
 .../Server/Framework/ServerEnv.hs             |  2 ++
 5 files changed, 43 insertions(+), 4 deletions(-)
 create mode 100644 src/Distribution/Server/Features/Database.hs

diff --git a/hackage-server.cabal b/hackage-server.cabal
index 0b3a43bb5..34d4a6968 100644
--- a/hackage-server.cabal
+++ b/hackage-server.cabal
@@ -306,6 +306,7 @@ library
     Distribution.Server.Features.Core
     Distribution.Server.Features.Core.State
     Distribution.Server.Features.Core.Backup
+    Distribution.Server.Features.Database
     Distribution.Server.Features.Security
     Distribution.Server.Features.Security.Backup
     Distribution.Server.Features.Security.FileInfo
diff --git a/src/Distribution/Server.hs b/src/Distribution/Server.hs
index fe422e208..550a27569 100644
--- a/src/Distribution/Server.hs
+++ b/src/Distribution/Server.hs
@@ -75,7 +75,8 @@ data ServerConfig = ServerConfig {
   confStaticDir :: FilePath,
   confTmpDir    :: FilePath,
   confCacheDelay:: Int,
-  confLiveTemplates :: Bool
+  confLiveTemplates :: Bool,
+  confServerDatabase :: String
 } deriving (Show)
 
 confDbStateDir, confBlobStoreDir :: ServerConfig -> FilePath
@@ -108,7 +109,8 @@ defaultServerConfig = do
     confStaticDir = dataDir,
     confTmpDir    = "state" </> "tmp",
     confCacheDelay= 0,
-    confLiveTemplates = False
+    confLiveTemplates = False,
+    confServerDatabase = "hackage.db"
   }
 
 data Server = Server {
@@ -128,7 +130,7 @@ hasSavedState = doesDirectoryExist . confDbStateDir
 mkServerEnv :: ServerConfig -> IO ServerEnv
 mkServerEnv config@(ServerConfig verbosity hostURI userContentURI requiredBaseHostHeader _
                                     stateDir _ tmpDir
-                                    cacheDelay liveTemplates) = do
+                                    cacheDelay liveTemplates _) = do
     createDirectoryIfMissing False stateDir
     let blobStoreDir  = confBlobStoreDir   config
         staticDir     = confStaticFilesDir config
@@ -153,7 +155,8 @@ mkServerEnv config@(ServerConfig verbosity hostURI userContentURI requiredBaseHo
             serverBaseURI       = hostURI,
             serverUserContentBaseURI = userContentURI,
             serverRequiredBaseHostHeader = requiredBaseHostHeader,
-            serverVerbosity     = verbosity
+            serverVerbosity     = verbosity,
+            serverDatabase      = confServerDatabase config
          }
     return env
 
diff --git a/src/Distribution/Server/Features.hs b/src/Distribution/Server/Features.hs
index 9755fce2d..dd6b742de 100644
--- a/src/Distribution/Server/Features.hs
+++ b/src/Distribution/Server/Features.hs
@@ -19,6 +19,7 @@ import Distribution.Server.Features.Core     (initCoreFeature, coreResource, que
 import Distribution.Server.Features.Security (initSecurityFeature)
 import Distribution.Server.Features.Upload   (initUploadFeature)
 import Distribution.Server.Features.Mirror   (initMirrorFeature)
+import Distribution.Server.Features.Database   (initDatabaseFeature)
 
 #ifndef MINIMAL
 import Distribution.Server.Features.Browse              (initBrowseFeature)
@@ -101,6 +102,8 @@ initHackageFeatures env@ServerEnv{serverVerbosity = verbosity} = do
                             initMirrorFeature env
     mkUploadFeature      <- logStartup "upload" $
                             initUploadFeature env
+    mkDatabaseFeature    <- logStartup "database" $
+                            initDatabaseFeature env
 #ifndef MINIMAL
     mkTarIndexCacheFeature   <- logStartup "tar index" $
                                 initTarIndexCacheFeature env
@@ -190,6 +193,8 @@ initHackageFeatures env@ServerEnv{serverVerbosity = verbosity} = do
                          usersFeature
                          coreFeature
 
+    databaseFeature <- mkDatabaseFeature
+
 #ifndef MINIMAL
     tarIndexCacheFeature <- mkTarIndexCacheFeature
                               usersFeature
@@ -392,6 +397,7 @@ initHackageFeatures env@ServerEnv{serverVerbosity = verbosity} = do
          , getFeatureInterface securityFeature
          , getFeatureInterface mirrorFeature
          , getFeatureInterface uploadFeature
+         , getFeatureInterface databaseFeature
 #ifndef MINIMAL
          , getFeatureInterface tarIndexCacheFeature
          , getFeatureInterface packageContentsFeature
diff --git a/src/Distribution/Server/Features/Database.hs b/src/Distribution/Server/Features/Database.hs
new file mode 100644
index 000000000..ae52b7f87
--- /dev/null
+++ b/src/Distribution/Server/Features/Database.hs
@@ -0,0 +1,27 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE TypeFamilies #-}
+
+module Distribution.Server.Features.Database where
+
+import Distribution.Server.Framework
+
+-- | A feature to store extra information about users like email addresses.
+newtype DatabaseFeature = DatabaseFeature
+  { databaseFeatureInterface :: HackageFeature
+  }
+
+instance IsHackageFeature DatabaseFeature where
+  getFeatureInterface = databaseFeatureInterface
+
+initDatabaseFeature :: ServerEnv -> IO (IO DatabaseFeature)
+initDatabaseFeature env =
+  pure (pure DatabaseFeature {..})
+  where
+    databaseFeatureInterface =
+      (emptyHackageFeature "database")
+        { featureDesc = "A feature to store information in a SQL database.",
+          featurePostInit =
+            putStrLn ("Database feature initialized using " <> serverDatabase env)
+        }
\ No newline at end of file
diff --git a/src/Distribution/Server/Framework/ServerEnv.hs b/src/Distribution/Server/Framework/ServerEnv.hs
index 9e4cfdeef..3b207a5b2 100644
--- a/src/Distribution/Server/Framework/ServerEnv.hs
+++ b/src/Distribution/Server/Framework/ServerEnv.hs
@@ -73,6 +73,8 @@ data ServerEnv = ServerEnv {
     -- increasing the time taken to update the cache we can push this further.
     serverCacheDelay :: Int,
 
+    serverDatabase :: String,
+
     serverVerbosity  :: Verbosity
 }
 

From 020798f2749d7c31cbb21daf5d5233222b7f89a3 Mon Sep 17 00:00:00 2001
From: "Brian J. Cardiff" <bcardiff@gmail.com>
Date: Sat, 7 Feb 2026 20:56:47 -0500
Subject: [PATCH 02/34] Move database initialization to the top

---
 src/Distribution/Server/Features.hs | 8 ++++----
 1 file changed, 4 insertions(+), 4 deletions(-)

diff --git a/src/Distribution/Server/Features.hs b/src/Distribution/Server/Features.hs
index dd6b742de..cbcc2bb30 100644
--- a/src/Distribution/Server/Features.hs
+++ b/src/Distribution/Server/Features.hs
@@ -90,6 +90,8 @@ initHackageFeatures env@ServerEnv{serverVerbosity = verbosity} = do
 
     loginfo verbosity "Initialising features, part 1"
 
+    mkDatabaseFeature    <- logStartup "database" $
+                            initDatabaseFeature env
     mkStaticFilesFeature <- logStartup "static files" $
                             initStaticFilesFeature env
     mkUserFeature        <- logStartup "user" $
@@ -102,8 +104,6 @@ initHackageFeatures env@ServerEnv{serverVerbosity = verbosity} = do
                             initMirrorFeature env
     mkUploadFeature      <- logStartup "upload" $
                             initUploadFeature env
-    mkDatabaseFeature    <- logStartup "database" $
-                            initDatabaseFeature env
 #ifndef MINIMAL
     mkTarIndexCacheFeature   <- logStartup "tar index" $
                                 initTarIndexCacheFeature env
@@ -175,6 +175,8 @@ initHackageFeatures env@ServerEnv{serverVerbosity = verbosity} = do
 
     -- Arguments denote feature dependencies.
     -- What follows is a topological sort along those lines
+    databaseFeature <- mkDatabaseFeature
+
     staticFilesFeature <- mkStaticFilesFeature
 
     usersFeature    <- mkUserFeature
@@ -193,8 +195,6 @@ initHackageFeatures env@ServerEnv{serverVerbosity = verbosity} = do
                          usersFeature
                          coreFeature
 
-    databaseFeature <- mkDatabaseFeature
-
 #ifndef MINIMAL
     tarIndexCacheFeature <- mkTarIndexCacheFeature
                               usersFeature

From 3a018dcf752bdb0a2b628c8c6e3cb844ab595fd7 Mon Sep 17 00:00:00 2001
From: "Brian J. Cardiff" <bcardiff@gmail.com>
Date: Sat, 7 Feb 2026 22:42:09 -0500
Subject: [PATCH 03/34] Read user details from database

---
 src/Distribution/Server/Features.hs           |  1 +
 src/Distribution/Server/Features/Database.hs  | 82 ++++++++++++++++---
 .../Server/Features/UserDetails.hs            | 23 ++++--
 3 files changed, 91 insertions(+), 15 deletions(-)

diff --git a/src/Distribution/Server/Features.hs b/src/Distribution/Server/Features.hs
index cbcc2bb30..d2a444c30 100644
--- a/src/Distribution/Server/Features.hs
+++ b/src/Distribution/Server/Features.hs
@@ -209,6 +209,7 @@ initHackageFeatures env@ServerEnv{serverVerbosity = verbosity} = do
                          coreFeature
 
     userDetailsFeature <- mkUserDetailsFeature
+                            databaseFeature
                             usersFeature
                             coreFeature
                             uploadFeature
diff --git a/src/Distribution/Server/Features/Database.hs b/src/Distribution/Server/Features/Database.hs
index ae52b7f87..f0d8fa01b 100644
--- a/src/Distribution/Server/Features/Database.hs
+++ b/src/Distribution/Server/Features/Database.hs
@@ -1,27 +1,89 @@
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE StandaloneDeriving #-}
 {-# LANGUAGE TypeFamilies #-}
 
 module Distribution.Server.Features.Database where
 
+import Data.Int (Int32)
+import Data.Text (Text)
+import Database.Beam
+import Database.Beam.Sqlite
+import Database.SQLite.Simple
 import Distribution.Server.Framework
+import Distribution.Server.Users.Types (UserId (..))
 
 -- | A feature to store extra information about users like email addresses.
-newtype DatabaseFeature = DatabaseFeature
-  { databaseFeatureInterface :: HackageFeature
+data DatabaseFeature = DatabaseFeature
+  { databaseFeatureInterface :: HackageFeature,
+    accountDetailsFindByUserId :: forall m. (MonadIO m) => UserId -> m (Maybe AccountDetails)
   }
 
 instance IsHackageFeature DatabaseFeature where
   getFeatureInterface = databaseFeatureInterface
 
 initDatabaseFeature :: ServerEnv -> IO (IO DatabaseFeature)
-initDatabaseFeature env =
-  pure (pure DatabaseFeature {..})
+initDatabaseFeature env = pure $ do
+  conn <- open (serverDatabase env)
+  pure $ mkDatabaseFeature conn
   where
-    databaseFeatureInterface =
-      (emptyHackageFeature "database")
-        { featureDesc = "A feature to store information in a SQL database.",
-          featurePostInit =
-            putStrLn ("Database feature initialized using " <> serverDatabase env)
-        }
\ No newline at end of file
+    mkDatabaseFeature :: Connection -> DatabaseFeature
+    mkDatabaseFeature conn = DatabaseFeature {..}
+      where
+        databaseFeatureInterface =
+          (emptyHackageFeature "database")
+            { featureDesc = "A feature to store information in a SQL database.",
+              featurePostInit = pure (),
+              featureState = [] -- CHECK: should probably do a dump of the database here and perform an import somewhere else?
+            }
+
+        accountDetailsFindByUserId :: forall m. (MonadIO m) => UserId -> m (Maybe AccountDetails)
+        accountDetailsFindByUserId (UserId userId) =
+          liftIO $
+            runBeamSqlite conn $
+              runSelectReturningOne $
+                select $
+                  filter_ (\ad -> _adUserId ad ==. val_ (fromIntegral userId)) $
+                    all_ (_accountDetails hackageDb)
+
+newtype HackageDb f = HackageDb
+  {_accountDetails :: f (TableEntity AccountDetailsT)}
+  deriving (Generic, Database be)
+
+hackageDb :: DatabaseSettings be HackageDb
+hackageDb =
+  defaultDbSettings
+    `withDbModification` dbModification
+      { _accountDetails = setEntityName "account_details"
+      }
+
+-- Tables
+
+-- AccountDetails
+
+data AccountDetailsT f
+  = AccountDetails
+  { _adUserId :: Columnar f Int32, -- CHECK: Can we user Distribution.Server.Users.Types.UserId here instead?
+    _adName :: Columnar f Text,
+    _adContactEmail :: Columnar f Text,
+    _adKind :: Columnar f (Maybe Text), -- NOTE: valid values are real_user, special.
+    _adAdminNotes :: Columnar f Text
+  }
+  deriving (Generic, Beamable)
+
+type AccountDetails = AccountDetailsT Identity
+
+deriving instance Show AccountDetails
+
+deriving instance Eq AccountDetails
+
+type AccountDetailsId = PrimaryKey AccountDetailsT Identity
+
+instance Table AccountDetailsT where
+  data PrimaryKey AccountDetailsT f = AccountDetailsId (Columnar f Int32) deriving (Generic, Beamable)
+  primaryKey = AccountDetailsId . _adUserId
\ No newline at end of file
diff --git a/src/Distribution/Server/Features/UserDetails.hs b/src/Distribution/Server/Features/UserDetails.hs
index 0156cfcb9..4a1aa5db6 100644
--- a/src/Distribution/Server/Features/UserDetails.hs
+++ b/src/Distribution/Server/Features/UserDetails.hs
@@ -16,6 +16,8 @@ import Distribution.Server.Framework.Templating
 import Distribution.Server.Features.Users
 import Distribution.Server.Features.Upload
 import Distribution.Server.Features.Core
+import Distribution.Server.Features.Database (DatabaseFeature (..))
+import qualified Distribution.Server.Features.Database as Database
 
 import Distribution.Server.Users.Types
 import Distribution.Server.Util.Validators (guardValidLookingEmail, guardValidLookingName)
@@ -250,7 +252,8 @@ userDetailsToCSV backuptype (UserDetailsTable tbl)
 --
 
 initUserDetailsFeature :: ServerEnv
-                       -> IO (UserFeature
+                       -> IO (DatabaseFeature
+                           -> UserFeature
                            -> CoreFeature
                            -> UploadFeature
                            -> IO UserDetailsFeature)
@@ -265,18 +268,19 @@ initUserDetailsFeature ServerEnv{serverStateDir, serverTemplatesDir, serverTempl
       [serverTemplatesDir, serverTemplatesDir </> "UserDetails"]
       [ "user-details-form.html" ]
 
-    return $ \users core upload -> do
-      let feature = userDetailsFeature templates usersDetailsState users core upload
+    return $ \database users core upload -> do
+      let feature = userDetailsFeature templates usersDetailsState database users core upload
       return feature
 
 
 userDetailsFeature :: Templates
                    -> StateComponent AcidState UserDetailsTable
+                   -> DatabaseFeature
                    -> UserFeature
                    -> CoreFeature
                    -> UploadFeature
                    -> UserDetailsFeature
-userDetailsFeature templates userDetailsState UserFeature{..} CoreFeature{..} UploadFeature{uploadersGroup}
+userDetailsFeature templates userDetailsState DatabaseFeature{..} UserFeature{..} CoreFeature{..} UploadFeature{uploadersGroup}
   = UserDetailsFeature {..}
 
   where
@@ -318,7 +322,7 @@ userDetailsFeature templates userDetailsState UserFeature{..} CoreFeature{..} Up
     --
 
     queryUserDetails :: MonadIO m => UserId -> m (Maybe AccountDetails)
-    queryUserDetails uid = queryState userDetailsState (LookupUserDetails uid)
+    queryUserDetails uid = fmap toUserDetails <$> accountDetailsFindByUserId uid
 
     updateUserDetails :: MonadIO m => UserId -> AccountDetails -> m ()
     updateUserDetails uid udetails = do
@@ -412,3 +416,12 @@ userDetailsFeature templates userDetailsState UserFeature{..} CoreFeature{..} Up
         uid <- lookupUserName =<< userNameInPath dpath
         updateState userDetailsState (SetUserAdminInfo uid Nothing T.empty)
         noContent $ toResponse ()
+
+toUserDetails :: Database.AccountDetails -> AccountDetails
+toUserDetails Database.AccountDetails {..} =
+  AccountDetails
+    { accountName = _adName,
+      accountContactEmail = _adContactEmail,
+      accountKind = Nothing, -- PENDING
+      accountAdminNotes = _adAdminNotes
+    }
\ No newline at end of file

From e18dea882c33e5392eaadcfac372a29511d91381 Mon Sep 17 00:00:00 2001
From: "Brian J. Cardiff" <bcardiff@gmail.com>
Date: Sat, 7 Feb 2026 23:19:57 -0500
Subject: [PATCH 04/34] Update user details

---
 src/Distribution/Server/Features/Database.hs  | 23 +++++++++++++-
 .../Server/Features/UserDetails.hs            | 31 ++++++++++++++++---
 2 files changed, 49 insertions(+), 5 deletions(-)

diff --git a/src/Distribution/Server/Features/Database.hs b/src/Distribution/Server/Features/Database.hs
index f0d8fa01b..9a4747ad8 100644
--- a/src/Distribution/Server/Features/Database.hs
+++ b/src/Distribution/Server/Features/Database.hs
@@ -13,6 +13,7 @@ module Distribution.Server.Features.Database where
 import Data.Int (Int32)
 import Data.Text (Text)
 import Database.Beam
+import Database.Beam.Backend.SQL.BeamExtensions
 import Database.Beam.Sqlite
 import Database.SQLite.Simple
 import Distribution.Server.Framework
@@ -21,7 +22,8 @@ import Distribution.Server.Users.Types (UserId (..))
 -- | A feature to store extra information about users like email addresses.
 data DatabaseFeature = DatabaseFeature
   { databaseFeatureInterface :: HackageFeature,
-    accountDetailsFindByUserId :: forall m. (MonadIO m) => UserId -> m (Maybe AccountDetails)
+    accountDetailsFindByUserId :: forall m. (MonadIO m) => UserId -> m (Maybe AccountDetails),
+    accountDetailsUpsert :: forall m. (MonadIO m) => AccountDetails -> m ()
   }
 
 instance IsHackageFeature DatabaseFeature where
@@ -51,6 +53,25 @@ initDatabaseFeature env = pure $ do
                   filter_ (\ad -> _adUserId ad ==. val_ (fromIntegral userId)) $
                     all_ (_accountDetails hackageDb)
 
+        -- Use the values from the INSERT that caused the conflict
+        accountDetailsUpsert :: forall m. (MonadIO m) => AccountDetails -> m ()
+        accountDetailsUpsert details =
+          liftIO $
+            runBeamSqlite conn $
+              runInsert $
+                insertOnConflict
+                  (_accountDetails hackageDb)
+                  (insertValues [details])
+                  (conflictingFields primaryKey)
+                  ( onConflictUpdateSet $ \fields _oldRow ->
+                      mconcat
+                        [ _adName fields <-. val_ (_adName details),
+                          _adContactEmail fields <-. val_ (_adContactEmail details),
+                          _adKind fields <-. val_ (_adKind details),
+                          _adAdminNotes fields <-. val_ (_adAdminNotes details)
+                        ]
+                  )
+
 newtype HackageDb f = HackageDb
   {_accountDetails :: f (TableEntity AccountDetailsT)}
   deriving (Generic, Database be)
diff --git a/src/Distribution/Server/Features/UserDetails.hs b/src/Distribution/Server/Features/UserDetails.hs
index 4a1aa5db6..9f3c1c15b 100644
--- a/src/Distribution/Server/Features/UserDetails.hs
+++ b/src/Distribution/Server/Features/UserDetails.hs
@@ -27,6 +27,7 @@ import Data.SafeCopy (base, deriveSafeCopy)
 import Data.IntMap (IntMap)
 import qualified Data.IntMap as IntMap
 import Data.Text (Text)
+import Data.Maybe (fromMaybe)
 import qualified Data.Text as T
 import qualified Data.Aeson as Aeson
 import Data.Aeson.TH
@@ -325,8 +326,30 @@ userDetailsFeature templates userDetailsState DatabaseFeature{..} UserFeature{..
     queryUserDetails uid = fmap toUserDetails <$> accountDetailsFindByUserId uid
 
     updateUserDetails :: MonadIO m => UserId -> AccountDetails -> m ()
-    updateUserDetails uid udetails = do
-      updateState userDetailsState (SetUserDetails uid udetails)
+    updateUserDetails uid@(UserId _uid) udetails = modifyAccountDetails uid (const udetails)
+
+    -- convenient helper to update only part of the record.
+    -- We use the same record for information that is editable by the user and information that is only editable by admins.
+    modifyAccountDetails :: MonadIO m => UserId -> (AccountDetails -> AccountDetails) -> m ()
+    modifyAccountDetails uid@(UserId _uid) change = do
+      -- NOTE: we need to query the current value because we are updating only some of the fields.
+      madetails <- queryUserDetails uid
+      -- NOTE: We could assume that the record exist since updateUserDetails is called from UserSignup
+      let adetails = fromMaybe AccountDetails {
+                        accountName = "",
+                        accountContactEmail = "",
+                        accountKind = Nothing,
+                        accountAdminNotes = ""
+                      } madetails
+      let cdetails = change adetails
+
+      accountDetailsUpsert Database.AccountDetails {
+          _adUserId = fromIntegral _uid,
+          _adName = accountName cdetails,
+          _adContactEmail = accountContactEmail cdetails,
+          _adKind = Nothing, -- PENDING: we don't support this yet 
+          _adAdminNotes = accountAdminNotes cdetails
+      }      
 
     -- Request handlers
     --
@@ -378,14 +401,14 @@ userDetailsFeature templates userDetailsState DatabaseFeature{..} UserFeature{..
         NameAndContact name email <- expectAesonContent
         guardValidLookingName name
         guardValidLookingEmail email
-        updateState userDetailsState (SetUserNameContact uid name email)
+        modifyAccountDetails uid (\adetails -> adetails { accountName = name, accountContactEmail = 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)
+        modifyAccountDetails uid (\adetails -> adetails { accountName = "", accountContactEmail = "" })
         noContent $ toResponse ()
 
     handlerGetAdminInfo :: DynamicPath -> ServerPartE Response

From 868640b670b282fb088dea2e406b7c505cac9455 Mon Sep 17 00:00:00 2001
From: "Brian J. Cardiff" <bcardiff@gmail.com>
Date: Sat, 7 Feb 2026 23:31:11 -0500
Subject: [PATCH 05/34] Manual AccountKind decoding/encoding from text

---
 .../Server/Features/UserDetails.hs            | 22 ++++++++++++++++---
 1 file changed, 19 insertions(+), 3 deletions(-)

diff --git a/src/Distribution/Server/Features/UserDetails.hs b/src/Distribution/Server/Features/UserDetails.hs
index 9f3c1c15b..d2fe2f7a0 100644
--- a/src/Distribution/Server/Features/UserDetails.hs
+++ b/src/Distribution/Server/Features/UserDetails.hs
@@ -347,7 +347,7 @@ userDetailsFeature templates userDetailsState DatabaseFeature{..} UserFeature{..
           _adUserId = fromIntegral _uid,
           _adName = accountName cdetails,
           _adContactEmail = accountContactEmail cdetails,
-          _adKind = Nothing, -- PENDING: we don't support this yet 
+          _adKind = fromAccountKind (accountKind cdetails),
           _adAdminNotes = accountAdminNotes cdetails
       }      
 
@@ -445,6 +445,22 @@ toUserDetails Database.AccountDetails {..} =
   AccountDetails
     { accountName = _adName,
       accountContactEmail = _adContactEmail,
-      accountKind = Nothing, -- PENDING
+      accountKind = 
+        -- NOTE: Should we fail to convert instead?
+        toAccountKind _adKind,
       accountAdminNotes = _adAdminNotes
-    }
\ No newline at end of file
+    }
+
+toAccountKind :: Maybe Text -> Maybe AccountKind
+toAccountKind adKind =
+  case adKind of
+    Just "real_user" -> Just AccountKindRealUser
+    Just "special" -> Just AccountKindSpecial
+    _ -> Nothing
+
+fromAccountKind :: Maybe AccountKind -> Maybe Text
+fromAccountKind adKind =
+  case adKind of
+    Just AccountKindRealUser -> Just "real_user"
+    Just AccountKindSpecial -> Just "special"
+    _ -> Nothing

From ac15c363f06f32cdbefeca4923fa99e622bb1587 Mon Sep 17 00:00:00 2001
From: "Brian J. Cardiff" <bcardiff@gmail.com>
Date: Sat, 7 Feb 2026 23:31:24 -0500
Subject: [PATCH 06/34] Add dependencies

---
 hackage-server.cabal | 5 +++++
 1 file changed, 5 insertions(+)

diff --git a/hackage-server.cabal b/hackage-server.cabal
index 34d4a6968..14822900f 100644
--- a/hackage-server.cabal
+++ b/hackage-server.cabal
@@ -176,6 +176,11 @@ common defaults
     , unordered-containers  ^>= 0.2.10
     , vector                ^>= 0.12 || ^>= 0.13.0.0
     , zlib                  ^>= 0.6.2  || ^>= 0.7.0.0
+  -- database dependencies
+  build-depends:
+    , beam-core             ^>= 0.10.4.0
+    , beam-sqlite           ^>= 0.5.5.0
+    , sqlite-simple         ^>= 0.4.19.0
 
 
 library

From 0830a12607691d295969a8b3f3b9d82cca40f680 Mon Sep 17 00:00:00 2001
From: "Brian J. Cardiff" <bcardiff@gmail.com>
Date: Sat, 7 Feb 2026 23:31:59 -0500
Subject: [PATCH 07/34] Initialize db schema script

---
 init_db.sql | 12 ++++++++++++
 1 file changed, 12 insertions(+)
 create mode 100644 init_db.sql

diff --git a/init_db.sql b/init_db.sql
new file mode 100644
index 000000000..1b8cd4b74
--- /dev/null
+++ b/init_db.sql
@@ -0,0 +1,12 @@
+-- Initialize SQLite3 database for hackage-server
+--
+-- sqlite3 hackage.db < init_db.sql
+--
+
+CREATE TABLE IF NOT EXISTS account_details (
+    user_id INTEGER PRIMARY KEY,
+    name TEXT NOT NULL,
+    contact_email TEXT NOT NULL,
+    kind TEXT,
+    admin_notes TEXT NOT NULL
+);

From 9ece470200db12256b83ced7df41b41fb56ca020 Mon Sep 17 00:00:00 2001
From: "Brian J. Cardiff" <bcardiff@gmail.com>
Date: Sat, 7 Feb 2026 23:38:58 -0500
Subject: [PATCH 08/34] Update admin info

---
 src/Distribution/Server/Features/UserDetails.hs | 4 ++--
 1 file changed, 2 insertions(+), 2 deletions(-)

diff --git a/src/Distribution/Server/Features/UserDetails.hs b/src/Distribution/Server/Features/UserDetails.hs
index d2fe2f7a0..02bfff80a 100644
--- a/src/Distribution/Server/Features/UserDetails.hs
+++ b/src/Distribution/Server/Features/UserDetails.hs
@@ -430,14 +430,14 @@ userDetailsFeature templates userDetailsState DatabaseFeature{..} UserFeature{..
         guardAuthorised_ [InGroup adminGroup]
         uid <- lookupUserName =<< userNameInPath dpath
         AdminInfo akind notes <- expectAesonContent
-        updateState userDetailsState (SetUserAdminInfo uid akind notes)
+        modifyAccountDetails uid (\adetails -> adetails { accountKind = akind, accountAdminNotes = notes })
         noContent $ toResponse ()
 
     handlerDeleteAdminInfo :: DynamicPath -> ServerPartE Response
     handlerDeleteAdminInfo dpath = do
         guardAuthorised_ [InGroup adminGroup]
         uid <- lookupUserName =<< userNameInPath dpath
-        updateState userDetailsState (SetUserAdminInfo uid Nothing T.empty)
+        modifyAccountDetails uid (\adetails -> adetails { accountKind = Nothing, accountAdminNotes = "" })
         noContent $ toResponse ()
 
 toUserDetails :: Database.AccountDetails -> AccountDetails

From 990a0a84ce40a3b8ec840b046f7a9437b54aa05c Mon Sep 17 00:00:00 2001
From: "Brian J. Cardiff" <bcardiff@gmail.com>
Date: Sun, 8 Feb 2026 00:04:28 -0500
Subject: [PATCH 09/34] Migrate data from acid to database

---
 .../Server/Features/UserDetails.hs            | 23 +++++++++++++++++--
 1 file changed, 21 insertions(+), 2 deletions(-)

diff --git a/src/Distribution/Server/Features/UserDetails.hs b/src/Distribution/Server/Features/UserDetails.hs
index 02bfff80a..8ccb1da93 100644
--- a/src/Distribution/Server/Features/UserDetails.hs
+++ b/src/Distribution/Server/Features/UserDetails.hs
@@ -27,7 +27,7 @@ import Data.SafeCopy (base, deriveSafeCopy)
 import Data.IntMap (IntMap)
 import qualified Data.IntMap as IntMap
 import Data.Text (Text)
-import Data.Maybe (fromMaybe)
+import Data.Maybe (fromMaybe, isNothing)
 import qualified Data.Text as T
 import qualified Data.Aeson as Aeson
 import Data.Aeson.TH
@@ -270,9 +270,28 @@ initUserDetailsFeature ServerEnv{serverStateDir, serverTemplatesDir, serverTempl
       [ "user-details-form.html" ]
 
     return $ \database users core upload -> do
+      migrateStateToDatabase usersDetailsState database
+      
       let feature = userDetailsFeature templates usersDetailsState database users core upload
       return feature
 
+migrateStateToDatabase :: StateComponent AcidState UserDetailsTable 
+                       -> DatabaseFeature 
+                       -> IO ()
+migrateStateToDatabase userDetailsState DatabaseFeature{..} = do
+  (UserDetailsTable tbl) <- queryState userDetailsState GetUserDetailsTable
+  forM_ (IntMap.toList tbl) $ \(uid, details) -> do
+    -- NOTE: This is actually performing a merge
+    --       by inserting records of user ids we know nothing about.
+    r <- accountDetailsFindByUserId (UserId uid)
+    when (isNothing r) $
+      accountDetailsUpsert Database.AccountDetails {
+          _adUserId = fromIntegral uid,
+          _adName = accountName details,
+          _adContactEmail = accountContactEmail details,
+          _adKind = fromAccountKind (accountKind details),
+          _adAdminNotes = accountAdminNotes details
+        }
 
 userDetailsFeature :: Templates
                    -> StateComponent AcidState UserDetailsTable
@@ -349,7 +368,7 @@ userDetailsFeature templates userDetailsState DatabaseFeature{..} UserFeature{..
           _adContactEmail = accountContactEmail cdetails,
           _adKind = fromAccountKind (accountKind cdetails),
           _adAdminNotes = accountAdminNotes cdetails
-      }      
+      }
 
     -- Request handlers
     --

From 3454536ebbdacfa8b311f0a5a103797533d82f50 Mon Sep 17 00:00:00 2001
From: "Brian J. Cardiff" <bcardiff@gmail.com>
Date: Sun, 8 Feb 2026 15:49:11 -0500
Subject: [PATCH 10/34] Add connection pool, reorganize, introduce Transaction
 monad

---
 hackage-server.cabal                          |   3 +-
 src/Distribution/Server/Features.hs           |   4 +
 .../Server/Features/AdminFrontend.hs          |  12 +-
 src/Distribution/Server/Features/Database.hs  | 119 ++++++++----------
 src/Distribution/Server/Features/Html.hs      |  18 +--
 .../Server/Features/UserDetails.hs            |  91 +++++++++-----
 .../Server/Features/UserDetails/State.hs      |  35 ++++++
 .../Server/Features/UserNotify.hs             |  22 ++--
 .../Server/Features/UserSignup.hs             |  18 +--
 9 files changed, 200 insertions(+), 122 deletions(-)
 create mode 100644 src/Distribution/Server/Features/UserDetails/State.hs

diff --git a/hackage-server.cabal b/hackage-server.cabal
index 14822900f..5f58e903a 100644
--- a/hackage-server.cabal
+++ b/hackage-server.cabal
@@ -181,7 +181,7 @@ common defaults
     , beam-core             ^>= 0.10.4.0
     , beam-sqlite           ^>= 0.5.5.0
     , sqlite-simple         ^>= 0.4.19.0
-
+    , resource-pool         ^>= 0.5.0.0
 
 library
   import: defaults
@@ -399,6 +399,7 @@ library
       Distribution.Server.Features.AnalyticsPixels
       Distribution.Server.Features.AnalyticsPixels.State
       Distribution.Server.Features.UserDetails
+      Distribution.Server.Features.UserDetails.State
       Distribution.Server.Features.UserSignup
       Distribution.Server.Features.StaticFiles
       Distribution.Server.Features.ServerIntrospect
diff --git a/src/Distribution/Server/Features.hs b/src/Distribution/Server/Features.hs
index d2a444c30..3f362c0ad 100644
--- a/src/Distribution/Server/Features.hs
+++ b/src/Distribution/Server/Features.hs
@@ -215,6 +215,7 @@ initHackageFeatures env@ServerEnv{serverVerbosity = verbosity} = do
                             uploadFeature
 
     userSignupFeature <- mkUserSignupFeature
+                           databaseFeature
                            usersFeature
                            userDetailsFeature
                            uploadFeature
@@ -305,6 +306,7 @@ initHackageFeatures env@ServerEnv{serverVerbosity = verbosity} = do
     platformFeature <- mkPlatformFeature
 
     htmlFeature     <- mkHtmlFeature
+                         databaseFeature
                          usersFeature
                          coreFeature
                          packageContentsFeature
@@ -334,6 +336,7 @@ initHackageFeatures env@ServerEnv{serverVerbosity = verbosity} = do
                           uploadFeature
 
     adminFrontendFeature <- mkAdminFrontendFeature
+                              databaseFeature
                               usersFeature
                               userDetailsFeature
                               userSignupFeature
@@ -358,6 +361,7 @@ initHackageFeatures env@ServerEnv{serverVerbosity = verbosity} = do
                       uploadFeature
 
     userNotifyFeature <- mkUserNotifyFeature
+                           databaseFeature
                            usersFeature
                            coreFeature
                            uploadFeature
diff --git a/src/Distribution/Server/Features/AdminFrontend.hs b/src/Distribution/Server/Features/AdminFrontend.hs
index 9261f3b51..0f0a0eff5 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 Distribution.Server.Features.Database (DatabaseFeature(..))
 
 import Distribution.Server.Users.Types
 import qualified Distribution.Server.Users.Users as Users
@@ -27,7 +28,8 @@ import Data.Maybe (isJust)
 -- | An HTML UI for various server admin tasks, mostly user accounts
 --
 initAdminFrontendFeature :: ServerEnv
-                         -> IO (UserFeature
+                         -> IO (DatabaseFeature
+                             -> UserFeature
                              -> UserDetailsFeature
                              -> UserSignupFeature
                              -> LegacyPasswdsFeature
@@ -40,8 +42,9 @@ initAdminFrontendFeature env@ServerEnv{ serverTemplatesDir,
                    [ "admin.html", "accounts.html", "account.html"
                    , "signups.html", "resets.html", "legacy.html" ]
 
-    return $ \user userdetails usersignup legacypasswds -> do
+    return $ \database user userdetails usersignup legacypasswds -> do
       let feature = adminFrontendFeature env templates
+                                         database
                                          user userdetails
                                          usersignup legacypasswds
 
@@ -49,12 +52,13 @@ initAdminFrontendFeature env@ServerEnv{ serverTemplatesDir,
 
 
 adminFrontendFeature :: ServerEnv -> Templates
+                     -> DatabaseFeature
                      -> UserFeature
                      -> UserDetailsFeature
                      -> UserSignupFeature
                      -> LegacyPasswdsFeature
                      -> HackageFeature
-adminFrontendFeature _env templates
+adminFrontendFeature _env templates DatabaseFeature{..}
                      UserFeature{..} UserDetailsFeature{..}
                      UserSignupFeature{..} LegacyPasswdsFeature{..} =
   (emptyHackageFeature "admin-frontend") {
@@ -224,7 +228,7 @@ adminFrontendFeature _env templates
         template  <- getTemplate templates "account.html"
         uid       <- maybe mzero return (simpleParse =<< lookup "uid" dpath)
         uinfo     <- lookupUserInfo uid
-        mudetails <- queryUserDetails uid
+        mudetails <- withTransaction $ queryUserDetails uid
         resetInfo <- lookupPasswordReset uid <$> queryAllSignupResetInfo
         mlegacy   <- lookupUserLegacyPasswd uid <$> queryLegacyPasswds
 
diff --git a/src/Distribution/Server/Features/Database.hs b/src/Distribution/Server/Features/Database.hs
index 9a4747ad8..cef9ecb40 100644
--- a/src/Distribution/Server/Features/Database.hs
+++ b/src/Distribution/Server/Features/Database.hs
@@ -1,29 +1,50 @@
-{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DeriveFunctor #-}
 {-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GADTs #-}
+{-# HLINT ignore "Avoid lambda" #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE RecordWildCards #-}
-{-# LANGUAGE StandaloneDeriving #-}
 {-# LANGUAGE TypeFamilies #-}
+{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
 
 module Distribution.Server.Features.Database where
 
-import Data.Int (Int32)
-import Data.Text (Text)
-import Database.Beam
-import Database.Beam.Backend.SQL.BeamExtensions
+import Control.Monad.Reader
+import Data.Kind
+import Data.Pool
+import Database.Beam hiding (runSelectReturningOne)
+import qualified Database.Beam
 import Database.Beam.Sqlite
-import Database.SQLite.Simple
+import qualified Database.SQLite.Simple
+import Distribution.Server.Features.UserDetails.State
 import Distribution.Server.Framework
-import Distribution.Server.Users.Types (UserId (..))
+
+newtype Connection = SqlLiteConnection Database.SQLite.Simple.Connection
+
+runSelectReturningOne :: forall a. (FromBackendRow Sqlite a) => SqlSelect Sqlite a -> Transaction (Maybe a)
+runSelectReturningOne q =
+  Transaction $ ReaderT $ \(SqlLiteConnection conn) -> runBeamSqlite conn $ Database.Beam.runSelectReturningOne q
+
+runInsert :: forall (table :: (Type -> Type) -> Type). SqlInsert Sqlite table -> Transaction ()
+runInsert q =
+  Transaction $ ReaderT $ \(SqlLiteConnection conn) -> runBeamSqlite conn $ Database.Beam.runInsert q
+
+newtype Transaction a = Transaction {unTransaction :: ReaderT Connection IO a} -- TODO: don't expose the internals of this
+  deriving (Functor, Applicative, Monad)
+
+runTransaction :: Transaction a -> Connection -> IO a
+runTransaction (Transaction t) = runReaderT t
 
 -- | A feature to store extra information about users like email addresses.
 data DatabaseFeature = DatabaseFeature
   { databaseFeatureInterface :: HackageFeature,
-    accountDetailsFindByUserId :: forall m. (MonadIO m) => UserId -> m (Maybe AccountDetails),
-    accountDetailsUpsert :: forall m. (MonadIO m) => AccountDetails -> m ()
+    withTransaction :: forall a m. (MonadIO m) => Transaction a -> m a
   }
 
 instance IsHackageFeature DatabaseFeature where
@@ -31,11 +52,17 @@ instance IsHackageFeature DatabaseFeature where
 
 initDatabaseFeature :: ServerEnv -> IO (IO DatabaseFeature)
 initDatabaseFeature env = pure $ do
-  conn <- open (serverDatabase env)
-  pure $ mkDatabaseFeature conn
+  dbpool <-
+    newPool $
+      defaultPoolConfig
+        (Database.SQLite.Simple.open (serverDatabase env))
+        Database.SQLite.Simple.close
+        (5 {- time in seconds before unused connection is closed -})
+        (20 {- number of connections -})
+  pure $ mkDatabaseFeature dbpool
   where
-    mkDatabaseFeature :: Connection -> DatabaseFeature
-    mkDatabaseFeature conn = DatabaseFeature {..}
+    mkDatabaseFeature :: Pool Database.SQLite.Simple.Connection -> DatabaseFeature
+    mkDatabaseFeature dbpool = DatabaseFeature {..}
       where
         databaseFeatureInterface =
           (emptyHackageFeature "database")
@@ -44,37 +71,19 @@ initDatabaseFeature env = pure $ do
               featureState = [] -- CHECK: should probably do a dump of the database here and perform an import somewhere else?
             }
 
-        accountDetailsFindByUserId :: forall m. (MonadIO m) => UserId -> m (Maybe AccountDetails)
-        accountDetailsFindByUserId (UserId userId) =
-          liftIO $
-            runBeamSqlite conn $
-              runSelectReturningOne $
-                select $
-                  filter_ (\ad -> _adUserId ad ==. val_ (fromIntegral userId)) $
-                    all_ (_accountDetails hackageDb)
-
-        -- Use the values from the INSERT that caused the conflict
-        accountDetailsUpsert :: forall m. (MonadIO m) => AccountDetails -> m ()
-        accountDetailsUpsert details =
-          liftIO $
-            runBeamSqlite conn $
-              runInsert $
-                insertOnConflict
-                  (_accountDetails hackageDb)
-                  (insertValues [details])
-                  (conflictingFields primaryKey)
-                  ( onConflictUpdateSet $ \fields _oldRow ->
-                      mconcat
-                        [ _adName fields <-. val_ (_adName details),
-                          _adContactEmail fields <-. val_ (_adContactEmail details),
-                          _adKind fields <-. val_ (_adKind details),
-                          _adAdminNotes fields <-. val_ (_adAdminNotes details)
-                        ]
-                  )
+        withTransaction :: forall a m. (MonadIO m) => Transaction a -> m a
+        withTransaction action =
+          liftIO $ withResource dbpool $ \conn ->
+            Database.SQLite.Simple.withTransaction conn $
+              runTransaction
+                action
+                (SqlLiteConnection conn)
 
 newtype HackageDb f = HackageDb
   {_accountDetails :: f (TableEntity AccountDetailsT)}
-  deriving (Generic, Database be)
+  deriving stock (Generic)
+
+instance Database be HackageDb
 
 hackageDb :: DatabaseSettings be HackageDb
 hackageDb =
@@ -82,29 +91,3 @@ hackageDb =
     `withDbModification` dbModification
       { _accountDetails = setEntityName "account_details"
       }
-
--- Tables
-
--- AccountDetails
-
-data AccountDetailsT f
-  = AccountDetails
-  { _adUserId :: Columnar f Int32, -- CHECK: Can we user Distribution.Server.Users.Types.UserId here instead?
-    _adName :: Columnar f Text,
-    _adContactEmail :: Columnar f Text,
-    _adKind :: Columnar f (Maybe Text), -- NOTE: valid values are real_user, special.
-    _adAdminNotes :: Columnar f Text
-  }
-  deriving (Generic, Beamable)
-
-type AccountDetails = AccountDetailsT Identity
-
-deriving instance Show AccountDetails
-
-deriving instance Eq AccountDetails
-
-type AccountDetailsId = PrimaryKey AccountDetailsT Identity
-
-instance Table AccountDetailsT where
-  data PrimaryKey AccountDetailsT f = AccountDetailsId (Columnar f Int32) deriving (Generic, Beamable)
-  primaryKey = AccountDetailsId . _adUserId
\ No newline at end of file
diff --git a/src/Distribution/Server/Features/Html.hs b/src/Distribution/Server/Features/Html.hs
index bea915425..4073ae7a8 100644
--- a/src/Distribution/Server/Features/Html.hs
+++ b/src/Distribution/Server/Features/Html.hs
@@ -14,6 +14,7 @@ import qualified Distribution.Server.Framework.ResponseContentTypes as Resource
 import Distribution.Server.Framework.Templating
 
 import Distribution.Server.Features.Core
+import Distribution.Server.Features.Database (DatabaseFeature(..))
 import Distribution.Server.Features.Upload
 import Distribution.Server.Features.BuildReports
 import Distribution.Server.Features.BuildReports.Render
@@ -103,7 +104,8 @@ instance IsHackageFeature HtmlFeature where
 -- This means of generating HTML is somewhat temporary, in that a more advanced
 -- (and better-looking) HTML ajaxy scheme should come about later on.
 initHtmlFeature :: ServerEnv
-                -> IO (UserFeature
+                -> IO (DatabaseFeature
+                    -> UserFeature
                     -> CoreFeature
                     -> PackageContentsFeature
                     -> UploadFeature -> PackageCandidatesFeature
@@ -147,7 +149,7 @@ initHtmlFeature env@ServerEnv{serverTemplatesDir, serverTemplatesMode,
                    ]
 
 
-    return $ \user core@CoreFeature{packageChangeHook}
+    return $ \database user core@CoreFeature{packageChangeHook}
               packages upload
               candidates versions
               reversef
@@ -163,7 +165,7 @@ initHtmlFeature env@ServerEnv{serverTemplatesDir, serverTemplatesMode,
               recentPackagesFeature -> do
       -- do rec, tie the knot
       rec let (feature, packageIndex, packagesPage) =
-                htmlFeature env user core
+                htmlFeature env database user core
                             packages upload
                             candidates versions
                             reversef
@@ -207,6 +209,7 @@ initHtmlFeature env@ServerEnv{serverTemplatesDir, serverTemplatesMode,
       return feature
 
 htmlFeature :: ServerEnv
+            -> DatabaseFeature
             -> UserFeature
             -> CoreFeature
             -> PackageContentsFeature
@@ -236,6 +239,7 @@ htmlFeature :: ServerEnv
             -> (HtmlFeature, IO Response, IO Response)
 
 htmlFeature env@ServerEnv{..}
+            database
             user
             core@CoreFeature{queryGetPackageIndex}
             packages upload
@@ -299,7 +303,7 @@ htmlFeature env@ServerEnv{..}
                                       names
                                       candidates
                                       recentPackagesFeature
-    htmlUsers      = mkHtmlUsers      user usersdetails
+    htmlUsers      = mkHtmlUsers      database user usersdetails
     htmlUploads    = mkHtmlUploads    utilities upload
     htmlDocUploads = mkHtmlDocUploads utilities core docsCore templates
     htmlDownloads  = mkHtmlDownloads  utilities download
@@ -864,8 +868,8 @@ data HtmlUsers = HtmlUsers {
     htmlUsersResources :: [Resource]
   }
 
-mkHtmlUsers :: UserFeature -> UserDetailsFeature -> HtmlUsers
-mkHtmlUsers UserFeature{..} UserDetailsFeature{..} = HtmlUsers{..}
+mkHtmlUsers :: DatabaseFeature -> UserFeature -> UserDetailsFeature -> HtmlUsers
+mkHtmlUsers DatabaseFeature{..} UserFeature{..} UserDetailsFeature{..} = HtmlUsers{..}
   where
     users = userResource
 
@@ -911,7 +915,7 @@ mkHtmlUsers UserFeature{..} UserDetailsFeature{..} = HtmlUsers{..}
     serveUserPage dpath = do
       uname    <- userNameInPath dpath
       uid      <- lookupUserName uname
-      udetails <- queryUserDetails uid
+      udetails <- withTransaction $ queryUserDetails uid
       let realname = maybe (display uname) (T.unpack . accountName) udetails
       uris     <- getGroupIndex uid
       uriPairs <- forM uris $ \uri -> do
diff --git a/src/Distribution/Server/Features/UserDetails.hs b/src/Distribution/Server/Features/UserDetails.hs
index 8ccb1da93..758d71d51 100644
--- a/src/Distribution/Server/Features/UserDetails.hs
+++ b/src/Distribution/Server/Features/UserDetails.hs
@@ -14,9 +14,10 @@ import Distribution.Server.Framework.BackupRestore
 import Distribution.Server.Framework.Templating
 
 import Distribution.Server.Features.Users
+import Distribution.Server.Features.UserDetails.State
 import Distribution.Server.Features.Upload
 import Distribution.Server.Features.Core
-import Distribution.Server.Features.Database (DatabaseFeature (..))
+import Distribution.Server.Features.Database (DatabaseFeature (..), HackageDb (..))
 import qualified Distribution.Server.Features.Database as Database
 
 import Distribution.Server.Users.Types
@@ -38,6 +39,8 @@ import Control.Monad.State (get, put)
 import Distribution.Text (display)
 import Data.Version
 import Text.CSV (CSV, Record)
+import Database.Beam hiding (update)
+import Database.Beam.Backend.SQL.BeamExtensions
 
 
 -- | A feature to store extra information about users like email addresses.
@@ -45,8 +48,8 @@ import Text.CSV (CSV, Record)
 data UserDetailsFeature = UserDetailsFeature {
     userDetailsFeatureInterface :: HackageFeature,
 
-    queryUserDetails  :: forall m. MonadIO m => UserId -> m (Maybe AccountDetails),
-    updateUserDetails :: forall m. MonadIO m => UserId -> AccountDetails -> m ()
+    queryUserDetails  :: UserId -> Database.Transaction (Maybe AccountDetails),
+    updateUserDetails :: UserId -> AccountDetails -> Database.Transaction ()
 }
 
 instance IsHackageFeature UserDetailsFeature where
@@ -280,18 +283,19 @@ migrateStateToDatabase :: StateComponent AcidState UserDetailsTable
                        -> IO ()
 migrateStateToDatabase userDetailsState DatabaseFeature{..} = do
   (UserDetailsTable tbl) <- queryState userDetailsState GetUserDetailsTable
-  forM_ (IntMap.toList tbl) $ \(uid, details) -> do
-    -- NOTE: This is actually performing a merge
-    --       by inserting records of user ids we know nothing about.
-    r <- accountDetailsFindByUserId (UserId uid)
-    when (isNothing r) $
-      accountDetailsUpsert Database.AccountDetails {
-          _adUserId = fromIntegral uid,
-          _adName = accountName details,
-          _adContactEmail = accountContactEmail details,
-          _adKind = fromAccountKind (accountKind details),
-          _adAdminNotes = accountAdminNotes details
-        }
+  withTransaction $ do
+    forM_ (IntMap.toList tbl) $ \(uid, details) -> do
+      -- NOTE: This is actually performing a merge
+      --       by inserting records of user ids we know nothing about.
+      r <- accountDetailsFindByUserId (UserId uid)
+      when (isNothing r) $
+        accountDetailsUpsert AccountDetailsRow {
+            _adUserId = fromIntegral uid,
+            _adName = accountName details,
+            _adContactEmail = accountContactEmail details,
+            _adKind = fromAccountKind (accountKind details),
+            _adAdminNotes = accountAdminNotes details
+          }
 
 userDetailsFeature :: Templates
                    -> StateComponent AcidState UserDetailsTable
@@ -338,18 +342,22 @@ userDetailsFeature templates userDetailsState DatabaseFeature{..} UserFeature{..
       , resourceDelete = [ ("", handlerDeleteAdminInfo) ]
       }
 
+    -- handlerWithConnection :: (Database.Connection -> DynamicPath -> ServerPartE Response) -> DynamicPath -> ServerPartE Response
+    -- handlerWithConnection handler dpath =
+    --   Database.withConnection $ \conn -> _ handler conn dpath
+
     -- Queries and updates
     --
 
-    queryUserDetails :: MonadIO m => UserId -> m (Maybe AccountDetails)
+    queryUserDetails :: UserId -> Database.Transaction (Maybe AccountDetails)
     queryUserDetails uid = fmap toUserDetails <$> accountDetailsFindByUserId uid
 
-    updateUserDetails :: MonadIO m => UserId -> AccountDetails -> m ()
+    updateUserDetails :: UserId -> AccountDetails -> Database.Transaction ()
     updateUserDetails uid@(UserId _uid) udetails = modifyAccountDetails uid (const udetails)
 
     -- convenient helper to update only part of the record.
     -- We use the same record for information that is editable by the user and information that is only editable by admins.
-    modifyAccountDetails :: MonadIO m => UserId -> (AccountDetails -> AccountDetails) -> m ()
+    modifyAccountDetails :: UserId -> (AccountDetails -> AccountDetails) -> Database.Transaction ()
     modifyAccountDetails uid@(UserId _uid) change = do
       -- NOTE: we need to query the current value because we are updating only some of the fields.
       madetails <- queryUserDetails uid
@@ -362,7 +370,7 @@ userDetailsFeature templates userDetailsState DatabaseFeature{..} UserFeature{..
                       } madetails
       let cdetails = change adetails
 
-      accountDetailsUpsert Database.AccountDetails {
+      accountDetailsUpsert AccountDetailsRow {
           _adUserId = fromIntegral _uid,
           _adName = accountName cdetails,
           _adContactEmail = accountContactEmail cdetails,
@@ -377,7 +385,7 @@ userDetailsFeature templates userDetailsState DatabaseFeature{..} UserFeature{..
       (uid, uinfo) <- lookupUserNameFull =<< userNameInPath dpath
       guardAuthorised_ [IsUserId uid, InGroup adminGroup]
       template <- getTemplate templates "user-details-form.html"
-      udetails <- queryUserDetails uid
+      udetails <- withTransaction $ queryUserDetails uid
       showConfirmationOfSave <- not . null <$> queryString (lookBSs "showConfirmationOfSave")
       let
         emailTxt = maybe "" accountContactEmail udetails
@@ -402,7 +410,7 @@ userDetailsFeature templates userDetailsState DatabaseFeature{..} UserFeature{..
     handlerGetUserNameContact dpath = do
         uid <- lookupUserName =<< userNameInPath dpath
         guardAuthorised_ [IsUserId uid, InGroup adminGroup]
-        udetails <- queryUserDetails uid
+        udetails <- withTransaction $ queryUserDetails uid
         return $ toResponse (Aeson.toJSON (render udetails))
       where
         render Nothing = NameAndContact T.empty T.empty
@@ -420,21 +428,21 @@ userDetailsFeature templates userDetailsState DatabaseFeature{..} UserFeature{..
         NameAndContact name email <- expectAesonContent
         guardValidLookingName name
         guardValidLookingEmail email
-        modifyAccountDetails uid (\adetails -> adetails { accountName = name, accountContactEmail = email })
+        withTransaction $ modifyAccountDetails uid (\adetails -> adetails { accountName = name, accountContactEmail = email })
         noContent $ toResponse ()
 
     handlerDeleteUserNameContact :: DynamicPath -> ServerPartE Response
     handlerDeleteUserNameContact dpath = do
         uid <- lookupUserName =<< userNameInPath dpath
         guardAuthorised_ [IsUserId uid, InGroup adminGroup]
-        modifyAccountDetails uid (\adetails -> adetails { accountName = "", accountContactEmail = "" })
+        withTransaction $ modifyAccountDetails uid (\adetails -> adetails { accountName = "", accountContactEmail = "" })
         noContent $ toResponse ()
 
     handlerGetAdminInfo :: DynamicPath -> ServerPartE Response
     handlerGetAdminInfo dpath = do
         guardAuthorised_ [InGroup adminGroup]
         uid <- lookupUserName =<< userNameInPath dpath
-        udetails <- queryUserDetails uid
+        udetails <- withTransaction $ queryUserDetails uid
         return $ toResponse (Aeson.toJSON (render udetails))
       where
         render Nothing = AdminInfo Nothing T.empty
@@ -449,18 +457,45 @@ userDetailsFeature templates userDetailsState DatabaseFeature{..} UserFeature{..
         guardAuthorised_ [InGroup adminGroup]
         uid <- lookupUserName =<< userNameInPath dpath
         AdminInfo akind notes <- expectAesonContent
-        modifyAccountDetails uid (\adetails -> adetails { accountKind = akind, accountAdminNotes = notes })
+        withTransaction $ modifyAccountDetails uid (\adetails -> adetails { accountKind = akind, accountAdminNotes = notes })
         noContent $ toResponse ()
 
     handlerDeleteAdminInfo :: DynamicPath -> ServerPartE Response
     handlerDeleteAdminInfo dpath = do
         guardAuthorised_ [InGroup adminGroup]
         uid <- lookupUserName =<< userNameInPath dpath
-        modifyAccountDetails uid (\adetails -> adetails { accountKind = Nothing, accountAdminNotes = "" })
+        withTransaction $ modifyAccountDetails uid (\adetails -> adetails { accountKind = Nothing, accountAdminNotes = "" })
         noContent $ toResponse ()
 
-toUserDetails :: Database.AccountDetails -> AccountDetails
-toUserDetails Database.AccountDetails {..} =
+
+-- Database
+
+accountDetailsFindByUserId :: UserId -> Database.Transaction (Maybe AccountDetailsRow)
+accountDetailsFindByUserId (UserId userId) =
+  Database.runSelectReturningOne $
+    select $
+      filter_ (\ad -> _adUserId ad ==. val_ (fromIntegral userId)) $
+        all_ (_accountDetails Database.hackageDb)
+
+-- Use the values from the INSERT that caused the conflict
+accountDetailsUpsert :: AccountDetailsRow -> Database.Transaction ()
+accountDetailsUpsert details =
+  Database.runInsert $
+    insertOnConflict
+      (_accountDetails Database.hackageDb)
+      (insertValues [details])
+      (conflictingFields primaryKey)
+      ( onConflictUpdateSet $ \fields _oldRow ->
+          mconcat
+            [ _adName fields <-. val_ (_adName details),
+              _adContactEmail fields <-. val_ (_adContactEmail details),
+              _adKind fields <-. val_ (_adKind details),
+              _adAdminNotes fields <-. val_ (_adAdminNotes details)
+            ]
+      )
+
+toUserDetails :: AccountDetailsRow -> AccountDetails
+toUserDetails AccountDetailsRow {..} =
   AccountDetails
     { accountName = _adName,
       accountContactEmail = _adContactEmail,
diff --git a/src/Distribution/Server/Features/UserDetails/State.hs b/src/Distribution/Server/Features/UserDetails/State.hs
new file mode 100644
index 000000000..a4cf9dc31
--- /dev/null
+++ b/src/Distribution/Server/Features/UserDetails/State.hs
@@ -0,0 +1,35 @@
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE TypeFamilies #-}
+
+module Distribution.Server.Features.UserDetails.State where
+
+import Data.Int (Int32)
+import Data.Text (Text)
+import Database.Beam
+
+data AccountDetailsT f
+  = AccountDetailsRow
+  { _adUserId :: Columnar f Int32, -- CHECK: Can we user Distribution.Server.Users.Types.UserId here instead?
+    _adName :: Columnar f Text,
+    _adContactEmail :: Columnar f Text,
+    _adKind :: Columnar f (Maybe Text), -- NOTE: valid values are real_user, special.
+    _adAdminNotes :: Columnar f Text
+  }
+  deriving (Generic, Beamable)
+
+type AccountDetailsRow = AccountDetailsT Identity
+
+deriving instance Show AccountDetailsRow
+
+deriving instance Eq AccountDetailsRow
+
+type AccountDetailsId = PrimaryKey AccountDetailsT Identity
+
+instance Table AccountDetailsT where
+  data PrimaryKey AccountDetailsT f = AccountDetailsId (Columnar f Int32) deriving (Generic, Beamable)
+  primaryKey = AccountDetailsId . _adUserId
diff --git a/src/Distribution/Server/Features/UserNotify.hs b/src/Distribution/Server/Features/UserNotify.hs
index 454302ec7..940b34faa 100644
--- a/src/Distribution/Server/Features/UserNotify.hs
+++ b/src/Distribution/Server/Features/UserNotify.hs
@@ -44,6 +44,7 @@ import Distribution.Server.Framework.Templating
 
 import Distribution.Server.Features.AdminLog
 import Distribution.Server.Features.BuildReports
+import Distribution.Server.Features.Database (DatabaseFeature(..))
 import qualified Distribution.Server.Features.BuildReports.BuildReport as BuildReport
 import Distribution.Server.Features.Core
 import Distribution.Server.Features.ReverseDependencies (ReverseFeature(..))
@@ -430,7 +431,8 @@ notifyStateComponent stateDir = do
 --
 
 initUserNotifyFeature :: ServerEnv
-                      -> IO (UserFeature
+                      -> IO (DatabaseFeature
+                          -> UserFeature
                           -> CoreFeature
                           -> UploadFeature
                           -> AdminLogFeature
@@ -450,9 +452,9 @@ initUserNotifyFeature ServerEnv{ serverStateDir, serverTemplatesDir,
                    [serverTemplatesDir, serverTemplatesDir </> "UserNotify"]
                    [ "user-notify-form.html", "endorsements-complete.txt" ]
 
-    return $ \users core uploadfeature adminlog userdetails reports tags revers vouch -> do
+    return $ \database users core uploadfeature adminlog userdetails reports tags revers vouch -> do
       let feature = userNotifyFeature
-                      users core uploadfeature adminlog userdetails reports tags
+                      database users core uploadfeature adminlog userdetails reports tags
                       revers vouch notifyState templates
       return feature
 
@@ -575,7 +577,8 @@ pkgInfoToPkgId :: PkgInfo -> PackageIdentifier
 pkgInfoToPkgId pkgInfo =
   PackageIdentifier (packageName pkgInfo) (packageVersion pkgInfo)
 
-userNotifyFeature :: UserFeature
+userNotifyFeature :: DatabaseFeature
+                  -> UserFeature
                   -> CoreFeature
                   -> UploadFeature
                   -> AdminLogFeature
@@ -587,7 +590,8 @@ userNotifyFeature :: UserFeature
                   -> StateComponent AcidState NotifyData
                   -> Templates
                   -> UserNotifyFeature
-userNotifyFeature UserFeature{..}
+userNotifyFeature database
+                  UserFeature{..}
                   CoreFeature{..}
                   UploadFeature{..}
                   AdminLogFeature{..}
@@ -714,8 +718,10 @@ userNotifyFeature UserFeature{..}
 
         vouchNotifications <- fmap (, NotifyVouchingCompleted) <$> drainQueuedNotifications
 
+        -- CHECK: maybe the transaction should be initialized in a different place
+        --        currently it is done in getNotificationEmails.
         emails <-
-          getNotificationEmails userFeatureServerEnv userDetailsFeature users templates $
+          getNotificationEmails userFeatureServerEnv database userDetailsFeature users templates $
             concat
               [ revisionUploadNotifications
               , groupActionNotifications
@@ -921,6 +927,7 @@ data NotificationGroup
 -- | Get all the emails to send for the given notifications.
 getNotificationEmails
   :: ServerEnv
+  -> DatabaseFeature
   -> UserDetailsFeature
   -> Users.Users
   -> Templates
@@ -928,12 +935,13 @@ getNotificationEmails
   -> IO [Mail]
 getNotificationEmails
   ServerEnv{serverBaseURI}
+  DatabaseFeature{withTransaction}
   UserDetailsFeature{queryUserDetails}
   allUsers
   templates
   notifications = do
     let userIds = Set.fromList $ map fst notifications
-    userIdToDetails <- Map.mapMaybe id <$> fromSetM queryUserDetails userIds
+    userIdToDetails <- withTransaction $ Map.mapMaybe id <$> fromSetM queryUserDetails userIds
     vouchTemplate <- renderTemplate . ($ []) <$> getTemplate templates "endorsements-complete.txt"
     pure $
       let emails = groupNotifications $ map (fmap (renderNotification vouchTemplate)) notifications
diff --git a/src/Distribution/Server/Features/UserSignup.hs b/src/Distribution/Server/Features/UserSignup.hs
index 65c29f9e5..e8867a5b9 100644
--- a/src/Distribution/Server/Features/UserSignup.hs
+++ b/src/Distribution/Server/Features/UserSignup.hs
@@ -15,6 +15,7 @@ import Distribution.Server.Framework.Templating
 import Distribution.Server.Framework.BackupDump
 import Distribution.Server.Framework.BackupRestore
 
+import Distribution.Server.Features.Database (DatabaseFeature (..))
 import Distribution.Server.Features.Upload
 import Distribution.Server.Features.Users
 import Distribution.Server.Features.UserDetails
@@ -276,7 +277,8 @@ resetInfoToCSV backuptype (SignupResetTable tbl)
 --
 
 initUserSignupFeature :: ServerEnv
-                      -> IO (UserFeature
+                      -> IO (DatabaseFeature
+                          -> UserFeature
                           -> UserDetailsFeature
                           -> UploadFeature
                           -> IO UserSignupFeature)
@@ -293,14 +295,15 @@ initUserSignupFeature env@ServerEnv{ serverStateDir, serverTemplatesDir,
                    , "ResetRequest.html", "ResetConfirmation.email"
                    , "ResetEmailSent.html", "ResetConfirm.html" ]
 
-    return $ \users userdetails upload -> do
+    return $ \database users userdetails upload -> do
       let feature = userSignupFeature env
-                      users userdetails upload
+                      database users userdetails upload
                       signupResetState templates
       return feature
 
 
 userSignupFeature :: ServerEnv
+                  -> DatabaseFeature
                   -> UserFeature
                   -> UserDetailsFeature
                   -> UploadFeature
@@ -308,6 +311,7 @@ userSignupFeature :: ServerEnv
                   -> Templates
                   -> UserSignupFeature
 userSignupFeature ServerEnv{serverBaseURI, serverCron}
+                  DatabaseFeature{..}
                   UserFeature{..} UserDetailsFeature{..}
                   UploadFeature{uploadersGroup} signupResetState templates
   = UserSignupFeature {..}
@@ -562,7 +566,7 @@ userSignupFeature ServerEnv{serverBaseURI, serverCron}
             }
         uid <- updateAddUser username userauth
            >>= either errNameClash return
-        updateUserDetails uid acctDetails
+        withTransaction $ updateUserDetails uid acctDetails
         liftIO $ addUserToGroup uploadersGroup uid
         seeOther (userPageUri userResource "" username) (toResponse ())
       where
@@ -593,7 +597,7 @@ userSignupFeature ServerEnv{serverBaseURI, serverCron}
 
         (supplied_username, supplied_useremail) <- lookUserNameEmail
         (uid, uinfo) <- lookupUserNameFull supplied_username
-        mudetails    <- queryUserDetails uid
+        mudetails    <- withTransaction $ queryUserDetails uid
 
         guardEmailMatches mudetails supplied_useremail
         AccountDetails{..} <- guardSuitableAccountType uinfo mudetails
@@ -658,7 +662,7 @@ userSignupFeature ServerEnv{serverBaseURI, serverCron}
         nonce                    <- nonceInPath dpath
         ResetInfo{resetUserId}   <- lookupResetInfo nonce
         uinfo@UserInfo{userName} <- lookupUserInfo resetUserId
-        mudetails                <- queryUserDetails resetUserId
+        mudetails                <- withTransaction $ queryUserDetails resetUserId
         AccountDetails{..}       <- guardSuitableAccountType uinfo mudetails
 
         template <- getTemplate templates "ResetConfirm.html"
@@ -676,7 +680,7 @@ userSignupFeature ServerEnv{serverBaseURI, serverCron}
         nonce                    <- nonceInPath dpath
         ResetInfo{resetUserId}   <- lookupResetInfo nonce
         uinfo@UserInfo{userName} <- lookupUserInfo resetUserId
-        mudetails                <- queryUserDetails resetUserId
+        mudetails                <- withTransaction $ queryUserDetails resetUserId
         AccountDetails{..}       <- guardSuitableAccountType uinfo mudetails
 
         (passwd, passwdRepeat) <- lookPasswd

From a3f796e9a02a0c6c4c18d41fb763ee55ffe446cc Mon Sep 17 00:00:00 2001
From: "Brian J. Cardiff" <bcardiff@gmail.com>
Date: Sun, 8 Feb 2026 22:17:40 -0500
Subject: [PATCH 11/34] Update test to use :memory: db

---
 tests/ReverseDependenciesTest.hs | 287 ++++++++++++++++++-------------
 1 file changed, 172 insertions(+), 115 deletions(-)

diff --git a/tests/ReverseDependenciesTest.hs b/tests/ReverseDependenciesTest.hs
index fe78692e3..e89d92343 100644
--- a/tests/ReverseDependenciesTest.hs
+++ b/tests/ReverseDependenciesTest.hs
@@ -59,7 +59,7 @@ import Distribution.Server.Users.UserIdSet as UserIdSet
 import qualified Distribution.Server.Users.Users as Users
 import Distribution.Version (mkVersion, version0)
 
-import Test.Tasty (TestName, TestTree, defaultMain, testGroup)
+import Test.Tasty (TestName, TestTree, defaultMain, testGroup, withResource)
 import Test.Tasty.Golden (goldenVsString)
 import Test.Tasty.Hedgehog (testProperty)
 import Test.Tasty.HUnit
@@ -74,6 +74,7 @@ import           Hedgehog
   , PropertyT
   , Range
   , checkSequential
+  , evalIO
   , forAll
   , property
   , withTests
@@ -81,6 +82,11 @@ import           Hedgehog
 
 import RevDepCommon (Package(..), TestPackage(..), mkPackage, mkPackageWithCabalFileSuffix, packToPkgInfo)
 
+import Data.String (fromString)
+import Distribution.Server.Features.Database
+import qualified Database.SQLite.Simple
+import Control.Exception (bracket)
+
 mtlBeelineLens :: [PkgInfo]
 mtlBeelineLens =
   [ mkPackage "base" [4,15] []
@@ -321,130 +327,178 @@ allTests = testGroup "ReverseDependenciesTest"
       assertEqual "hedgehog test pass" True res
   ]
 
+withTestDatabase :: (IO DatabaseFeature -> TestTree) -> TestTree
+withTestDatabase action = do
+  withResource
+    (do
+        conn <- Database.SQLite.Simple.open ":memory:"
+        sql <- readFile "init_db.sql"
+        Database.SQLite.Simple.execute_ conn (fromString sql)
+        pure (conn, DatabaseFeature { 
+            databaseFeatureInterface = undefined, -- not needed for these tests
+            withTransaction = \transaction -> 
+                  liftIO $ Database.SQLite.Simple.withTransaction conn $
+                                runTransaction
+                                  transaction
+                                  (SqlLiteConnection conn)
+        })
+    )
+    (\ (conn, _) -> Database.SQLite.Simple.close conn)
+    (\ ioResource -> action (snd <$> ioResource))
+
 getNotificationEmailsTests :: TestTree
 getNotificationEmailsTests =
   testGroup "getNotificationEmails"
-    [ testProperty "All general notifications batched in one email" . withTests 30 . property $ do
-        notifs <- forAll $ Gen.list (Range.linear 1 10) $ Gen.filterT isGeneral genNotification
-        emails <- liftIO $ getNotificationEmailsMocked $ map (userWatcher,) notifs
-        length emails === 1
-    , testGolden "Render NotifyNewVersion" "getNotificationEmails-NotifyNewVersion.golden" $
-        fmap renderMail . getNotificationEmailMocked userWatcher $
-          NotifyNewVersion
-            { notifyPackageInfo =
-                PkgInfo
-                  { pkgInfoId = PackageIdentifier "base" (mkVersion [4, 18, 0, 0])
-                  , pkgMetadataRevisions = Vector.singleton (CabalFileText "", (timestamp, userActor))
-                  , pkgTarballRevisions = mempty
-                  }
-            }
-    , testGolden "Render NotifyNewRevision" "getNotificationEmails-NotifyNewRevision.golden" $ do
-        let mkRev rev = (CabalFileText "", (rev, userActor))
-            rev0 = (0 * Time.nominalDay) `Time.addUTCTime` timestamp
-            rev1 = (1 * Time.nominalDay) `Time.addUTCTime` timestamp
-            rev2 = (2 * Time.nominalDay) `Time.addUTCTime` timestamp
-        fmap renderMail . getNotificationEmailMocked userWatcher $
-          NotifyNewRevision
-            { notifyPackageId = PackageIdentifier "base" (mkVersion [4, 18, 0, 0])
-            , notifyRevisions = map (, userActor) [rev1, rev2]
-            }
-    , testGolden "Render NotifyMaintainerUpdate-MaintainerAdded" "getNotificationEmails-NotifyMaintainerUpdate-MaintainerAdded.golden" $
-        fmap renderMail . getNotificationEmailMocked userWatcher $
-          NotifyMaintainerUpdate
-            { notifyMaintainerUpdateType = MaintainerAdded
-            , notifyUserActor = userActor
-            , notifyUserSubject = userSubject
-            , notifyPackageName = "base"
-            , notifyReason = "User is cool"
-            , notifyUpdatedAt = timestamp
-            }
-    , testGolden "Render NotifyMaintainerUpdate-MaintainerRemoved" "getNotificationEmails-NotifyMaintainerUpdate-MaintainerRemoved.golden" $
-        fmap renderMail . getNotificationEmailMocked userWatcher $
-          NotifyMaintainerUpdate
-            { notifyMaintainerUpdateType = MaintainerRemoved
-            , notifyUserActor = userActor
-            , notifyUserSubject = userSubject
-            , notifyPackageName = "base"
-            , notifyReason = "User is no longer cool"
-            , notifyUpdatedAt = timestamp
-            }
-    , testGolden "Render NotifyDocsBuild-success" "getNotificationEmails-NotifyDocsBuild-success.golden" $
-        fmap renderMail . getNotificationEmailMocked userWatcher $
-          NotifyDocsBuild
-            { notifyPackageId = PackageIdentifier "base" (mkVersion [4, 18, 0, 0])
-            , notifyBuildSuccess = True
-            }
-    , testGolden "Render NotifyDocsBuild-failure" "getNotificationEmails-NotifyDocsBuild-failure.golden" $
-        fmap renderMail . getNotificationEmailMocked userWatcher $
-          NotifyDocsBuild
-            { notifyPackageId = PackageIdentifier "base" (mkVersion [4, 18, 0, 0])
-            , notifyBuildSuccess = False
-            }
-    , testGolden "Render NotifyUpdateTags" "getNotificationEmails-NotifyUpdateTags.golden" $
-        fmap renderMail . getNotificationEmailMocked userWatcher $
-          NotifyUpdateTags
-            { notifyPackageName = "base"
-            , notifyAddedTags = Set.fromList . map Tag $ ["bsd3", "library", "prelude"]
-            , notifyDeletedTags = Set.fromList . map Tag $ ["example", "bad", "foo"]
-            }
-    , testGolden "Render NotifyDependencyUpdate-Always" "getNotificationEmails-NotifyDependencyUpdate-Always.golden" $
-        fmap renderMail
-          . getNotificationEmail
-              testServerEnv
-              testUserDetailsFeature
-              allUsers
-              userWatcher
-          $ NotifyDependencyUpdate
+    [ withTestDatabase $ \getDatabase ->
+        testProperty "All general notifications batched in one email" . withTests 30 . property $ do
+          database <- evalIO getDatabase
+          notifs <- forAll $ Gen.list (Range.linear 1 10) $ Gen.filterT isGeneral genNotification
+          emails <- liftIO $ getNotificationEmailsMocked database $ map (userWatcher,) notifs
+          length emails === 1
+    , withTestDatabase $ \getDatabase ->
+        testGolden "Render NotifyNewVersion" "getNotificationEmails-NotifyNewVersion.golden" $ do
+          database <- getDatabase
+          fmap renderMail . getNotificationEmailMocked database userWatcher $
+            NotifyNewVersion
+              { notifyPackageInfo =
+                  PkgInfo
+                    { pkgInfoId = PackageIdentifier "base" (mkVersion [4, 18, 0, 0])
+                    , pkgMetadataRevisions = Vector.singleton (CabalFileText "", (timestamp, userActor))
+                    , pkgTarballRevisions = mempty
+                    }
+              }
+    , withTestDatabase $ \getDatabase ->
+        testGolden "Render NotifyNewRevision" "getNotificationEmails-NotifyNewRevision.golden" $ do
+          database <- getDatabase
+          let mkRev rev = (CabalFileText "", (rev, userActor))
+              rev0 = (0 * Time.nominalDay) `Time.addUTCTime` timestamp
+              rev1 = (1 * Time.nominalDay) `Time.addUTCTime` timestamp
+              rev2 = (2 * Time.nominalDay) `Time.addUTCTime` timestamp
+          fmap renderMail . getNotificationEmailMocked database userWatcher $
+            NotifyNewRevision
               { notifyPackageId = PackageIdentifier "base" (mkVersion [4, 18, 0, 0])
-              , notifyWatchedPackages = [PackageIdentifier "mtl" (mkVersion [2, 3])]
-              , notifyTriggerBounds = Always
+              , notifyRevisions = map (, userActor) [rev1, rev2]
               }
-    , testGolden "Render NotifyDependencyUpdate-NewIncompatibility" "getNotificationEmails-NotifyDependencyUpdate-NewIncompatibility.golden" $
-        fmap renderMail
-          . getNotificationEmail
-              testServerEnv
-              testUserDetailsFeature
-              allUsers
-              userWatcher
-          $ NotifyDependencyUpdate
+    , withTestDatabase $ \getDatabase ->
+        testGolden "Render NotifyMaintainerUpdate-MaintainerAdded" "getNotificationEmails-NotifyMaintainerUpdate-MaintainerAdded.golden" $ do
+          database <- getDatabase
+          fmap renderMail . getNotificationEmailMocked database userWatcher $
+            NotifyMaintainerUpdate
+              { notifyMaintainerUpdateType = MaintainerAdded
+              , notifyUserActor = userActor
+              , notifyUserSubject = userSubject
+              , notifyPackageName = "base"
+              , notifyReason = "User is cool"
+              , notifyUpdatedAt = timestamp
+              }
+    , withTestDatabase $ \getDatabase ->
+        testGolden "Render NotifyMaintainerUpdate-MaintainerRemoved" "getNotificationEmails-NotifyMaintainerUpdate-MaintainerRemoved.golden" $ do
+          database <- getDatabase
+          fmap renderMail . getNotificationEmailMocked database userWatcher $
+            NotifyMaintainerUpdate
+              { notifyMaintainerUpdateType = MaintainerRemoved
+              , notifyUserActor = userActor
+              , notifyUserSubject = userSubject
+              , notifyPackageName = "base"
+              , notifyReason = "User is no longer cool"
+              , notifyUpdatedAt = timestamp
+              }
+    , withTestDatabase $ \getDatabase ->
+        testGolden "Render NotifyDocsBuild-success" "getNotificationEmails-NotifyDocsBuild-success.golden" $ do
+          database <- getDatabase
+          fmap renderMail . getNotificationEmailMocked database userWatcher $
+            NotifyDocsBuild
               { notifyPackageId = PackageIdentifier "base" (mkVersion [4, 18, 0, 0])
-              , notifyWatchedPackages = [PackageIdentifier "mtl" (mkVersion [2, 3])]
-              , notifyTriggerBounds = NewIncompatibility
+              , notifyBuildSuccess = True
               }
-    , testGolden "Render NotifyDependencyUpdate-BoundsOutOfRange" "getNotificationEmails-NotifyDependencyUpdate-BoundsOutOfRange.golden" $
-        fmap renderMail
-          . getNotificationEmail
-              testServerEnv
-              testUserDetailsFeature
-              allUsers
-              userWatcher
-          $ NotifyDependencyUpdate
+    , withTestDatabase $ \getDatabase ->
+        testGolden "Render NotifyDocsBuild-failure" "getNotificationEmails-NotifyDocsBuild-failure.golden" $ do
+          database <- getDatabase
+          fmap renderMail . getNotificationEmailMocked database userWatcher $
+            NotifyDocsBuild
               { notifyPackageId = PackageIdentifier "base" (mkVersion [4, 18, 0, 0])
-              , notifyWatchedPackages = [PackageIdentifier "mtl" (mkVersion [2, 3])]
-              , notifyTriggerBounds = BoundsOutOfRange
+              , notifyBuildSuccess = False
+              }
+    , withTestDatabase $ \getDatabase ->
+        testGolden "Render NotifyUpdateTags" "getNotificationEmails-NotifyUpdateTags.golden" $ do
+          database <- getDatabase
+          fmap renderMail . getNotificationEmailMocked database userWatcher $
+            NotifyUpdateTags
+              { notifyPackageName = "base"
+              , notifyAddedTags = Set.fromList . map Tag $ ["bsd3", "library", "prelude"]
+              , notifyDeletedTags = Set.fromList . map Tag $ ["example", "bad", "foo"]
               }
-    , testGolden "Render NotifyVouchingCompleted" "getNotificationEmails-NotifyVouchingCompleted.golden" $
-        fmap renderMail $ getNotificationEmailMocked userWatcher NotifyVouchingCompleted
-    , testGolden "Render general notifications in single batched email" "getNotificationEmails-batched.golden" $ do
-        emails <-
-          getNotificationEmailsMocked . map (userWatcher,) $
-            [ NotifyNewRevision
+    , withTestDatabase $ \getDatabase ->
+        testGolden "Render NotifyDependencyUpdate-Always" "getNotificationEmails-NotifyDependencyUpdate-Always.golden" $ do
+          database <- getDatabase
+          fmap renderMail
+            . getNotificationEmail
+                testServerEnv
+                database
+                testUserDetailsFeature
+                allUsers
+                userWatcher
+            $ NotifyDependencyUpdate
                 { notifyPackageId = PackageIdentifier "base" (mkVersion [4, 18, 0, 0])
-                , notifyRevisions = [(timestamp, userActor)]
+                , notifyWatchedPackages = [PackageIdentifier "mtl" (mkVersion [2, 3])]
+                , notifyTriggerBounds = Always
                 }
-            , NotifyDocsBuild
+    , withTestDatabase $ \getDatabase ->
+        testGolden "Render NotifyDependencyUpdate-NewIncompatibility" "getNotificationEmails-NotifyDependencyUpdate-NewIncompatibility.golden" $ do
+          database <- getDatabase
+          fmap renderMail
+            . getNotificationEmail
+                testServerEnv
+                database
+                testUserDetailsFeature
+                allUsers
+                userWatcher
+            $ NotifyDependencyUpdate
                 { notifyPackageId = PackageIdentifier "base" (mkVersion [4, 18, 0, 0])
-                , notifyBuildSuccess = True
+                , notifyWatchedPackages = [PackageIdentifier "mtl" (mkVersion [2, 3])]
+                , notifyTriggerBounds = NewIncompatibility
                 }
-            , NotifyUpdateTags
-                { notifyPackageName = "base"
-                , notifyAddedTags = Set.fromList [Tag "newtag"]
-                , notifyDeletedTags = Set.fromList [Tag "oldtag"]
+    , withTestDatabase $ \getDatabase ->
+        testGolden "Render NotifyDependencyUpdate-BoundsOutOfRange" "getNotificationEmails-NotifyDependencyUpdate-BoundsOutOfRange.golden" $ do
+          database <- getDatabase
+          fmap renderMail
+            . getNotificationEmail
+                testServerEnv
+                database
+                testUserDetailsFeature
+                allUsers
+                userWatcher
+            $ NotifyDependencyUpdate
+                { notifyPackageId = PackageIdentifier "base" (mkVersion [4, 18, 0, 0])
+                , notifyWatchedPackages = [PackageIdentifier "mtl" (mkVersion [2, 3])]
+                , notifyTriggerBounds = BoundsOutOfRange
                 }
-            ]
-        case emails of
-          [email] -> pure $ renderMail email
-          _ -> error $ "Emails were not batched: " ++ show emails
+    , withTestDatabase $ \getDatabase ->
+        testGolden "Render NotifyVouchingCompleted" "getNotificationEmails-NotifyVouchingCompleted.golden" $ do
+          database <- getDatabase
+          fmap renderMail $ getNotificationEmailMocked database userWatcher NotifyVouchingCompleted
+    , withTestDatabase $ \getDatabase ->
+        testGolden "Render general notifications in single batched email" "getNotificationEmails-batched.golden" $ do
+          database <- getDatabase
+          emails <-
+            getNotificationEmailsMocked database . map (userWatcher,) $
+              [ NotifyNewRevision
+                  { notifyPackageId = PackageIdentifier "base" (mkVersion [4, 18, 0, 0])
+                  , notifyRevisions = [(timestamp, userActor)]
+                  }
+              , NotifyDocsBuild
+                  { notifyPackageId = PackageIdentifier "base" (mkVersion [4, 18, 0, 0])
+                  , notifyBuildSuccess = True
+                  }
+              , NotifyUpdateTags
+                  { notifyPackageName = "base"
+                  , notifyAddedTags = Set.fromList [Tag "newtag"]
+                  , notifyDeletedTags = Set.fromList [Tag "oldtag"]
+                  }
+              ]
+          case emails of
+            [email] -> pure $ renderMail email
+            _ -> error $ "Emails were not batched: " ++ show emails
     ]
   where
     -- If adding a new constructor here, make sure to do the following:
@@ -483,8 +537,8 @@ getNotificationEmailsTests =
           <*> addUser "user-actor"
           <*> addUser "user-subject"
 
-    getNotificationEmail env details users uid notif =
-      getNotificationEmails env details users (mockTemplates ["datafiles/templates/UserNotify"] ["endorsements-complete.txt"]) [(uid, notif)] >>= \case
+    getNotificationEmail env database details users uid notif =
+      getNotificationEmails env database details users (mockTemplates ["datafiles/templates/UserNotify"] ["endorsements-complete.txt"]) [(uid, notif)] >>= \case
         [email] -> pure email
         _ -> error "Did not get exactly one email"
 
@@ -492,6 +546,7 @@ getNotificationEmailsTests =
       ServerEnv
         { serverBaseURI = fromJust $ parseURI "https://hackage.haskell.org"
         }
+
     testUserDetailsFeature =
       UserDetailsFeature
         { queryUserDetails = \uid ->
@@ -505,15 +560,17 @@ getNotificationEmailsTests =
                   , accountAdminNotes = ""
                   }
         }
-    getNotificationEmailsMocked =
+    getNotificationEmailsMocked database =
       getNotificationEmails
         testServerEnv
+        database
         testUserDetailsFeature
         allUsers
         (mockTemplates ["datafiles/templates/UserNotify"] ["endorsements-complete.txt"])
-    getNotificationEmailMocked =
+    getNotificationEmailMocked database =
       getNotificationEmail
         testServerEnv
+        database
         testUserDetailsFeature
         allUsers
 

From e9ddf63fe0d47382a8794391731dc3d5021268fd Mon Sep 17 00:00:00 2001
From: "Brian J. Cardiff" <bcardiff@gmail.com>
Date: Sun, 8 Feb 2026 22:25:39 -0500
Subject: [PATCH 12/34] Refactor: testGolden is defined locally and used always
 in the same way

---
 tests/ReverseDependenciesTest.hs | 252 ++++++++++++++-----------------
 1 file changed, 117 insertions(+), 135 deletions(-)

diff --git a/tests/ReverseDependenciesTest.hs b/tests/ReverseDependenciesTest.hs
index e89d92343..80416baf5 100644
--- a/tests/ReverseDependenciesTest.hs
+++ b/tests/ReverseDependenciesTest.hs
@@ -355,150 +355,126 @@ getNotificationEmailsTests =
           notifs <- forAll $ Gen.list (Range.linear 1 10) $ Gen.filterT isGeneral genNotification
           emails <- liftIO $ getNotificationEmailsMocked database $ map (userWatcher,) notifs
           length emails === 1
-    , withTestDatabase $ \getDatabase ->
-        testGolden "Render NotifyNewVersion" "getNotificationEmails-NotifyNewVersion.golden" $ do
-          database <- getDatabase
-          fmap renderMail . getNotificationEmailMocked database userWatcher $
-            NotifyNewVersion
-              { notifyPackageInfo =
-                  PkgInfo
-                    { pkgInfoId = PackageIdentifier "base" (mkVersion [4, 18, 0, 0])
-                    , pkgMetadataRevisions = Vector.singleton (CabalFileText "", (timestamp, userActor))
-                    , pkgTarballRevisions = mempty
-                    }
-              }
-    , withTestDatabase $ \getDatabase ->
-        testGolden "Render NotifyNewRevision" "getNotificationEmails-NotifyNewRevision.golden" $ do
-          database <- getDatabase
-          let mkRev rev = (CabalFileText "", (rev, userActor))
-              rev0 = (0 * Time.nominalDay) `Time.addUTCTime` timestamp
-              rev1 = (1 * Time.nominalDay) `Time.addUTCTime` timestamp
-              rev2 = (2 * Time.nominalDay) `Time.addUTCTime` timestamp
-          fmap renderMail . getNotificationEmailMocked database userWatcher $
-            NotifyNewRevision
+    , testGolden "Render NotifyNewVersion" "getNotificationEmails-NotifyNewVersion.golden" $ \database -> do
+        fmap renderMail . getNotificationEmailMocked database userWatcher $
+          NotifyNewVersion
+            { notifyPackageInfo =
+                PkgInfo
+                  { pkgInfoId = PackageIdentifier "base" (mkVersion [4, 18, 0, 0])
+                  , pkgMetadataRevisions = Vector.singleton (CabalFileText "", (timestamp, userActor))
+                  , pkgTarballRevisions = mempty
+                  }
+            }
+    , testGolden "Render NotifyNewRevision" "getNotificationEmails-NotifyNewRevision.golden" $ \database -> do
+        let mkRev rev = (CabalFileText "", (rev, userActor))
+            rev0 = (0 * Time.nominalDay) `Time.addUTCTime` timestamp
+            rev1 = (1 * Time.nominalDay) `Time.addUTCTime` timestamp
+            rev2 = (2 * Time.nominalDay) `Time.addUTCTime` timestamp
+        fmap renderMail . getNotificationEmailMocked database userWatcher $
+          NotifyNewRevision
+            { notifyPackageId = PackageIdentifier "base" (mkVersion [4, 18, 0, 0])
+            , notifyRevisions = map (, userActor) [rev1, rev2]
+            }
+    , testGolden "Render NotifyMaintainerUpdate-MaintainerAdded" "getNotificationEmails-NotifyMaintainerUpdate-MaintainerAdded.golden" $ \database -> do
+        fmap renderMail . getNotificationEmailMocked database userWatcher $
+          NotifyMaintainerUpdate
+            { notifyMaintainerUpdateType = MaintainerAdded
+            , notifyUserActor = userActor
+            , notifyUserSubject = userSubject
+            , notifyPackageName = "base"
+            , notifyReason = "User is cool"
+            , notifyUpdatedAt = timestamp
+            }
+    , testGolden "Render NotifyMaintainerUpdate-MaintainerRemoved" "getNotificationEmails-NotifyMaintainerUpdate-MaintainerRemoved.golden" $ \database -> do
+        fmap renderMail . getNotificationEmailMocked database userWatcher $
+          NotifyMaintainerUpdate
+            { notifyMaintainerUpdateType = MaintainerRemoved
+            , notifyUserActor = userActor
+            , notifyUserSubject = userSubject
+            , notifyPackageName = "base"
+            , notifyReason = "User is no longer cool"
+            , notifyUpdatedAt = timestamp
+            }
+    , testGolden "Render NotifyDocsBuild-success" "getNotificationEmails-NotifyDocsBuild-success.golden" $ \database -> do
+        fmap renderMail . getNotificationEmailMocked database userWatcher $
+          NotifyDocsBuild
+            { notifyPackageId = PackageIdentifier "base" (mkVersion [4, 18, 0, 0])
+            , notifyBuildSuccess = True
+            }
+    , testGolden "Render NotifyDocsBuild-failure" "getNotificationEmails-NotifyDocsBuild-failure.golden" $ \database -> do
+        fmap renderMail . getNotificationEmailMocked database userWatcher $
+          NotifyDocsBuild
+            { notifyPackageId = PackageIdentifier "base" (mkVersion [4, 18, 0, 0])
+            , notifyBuildSuccess = False
+            }
+    , testGolden "Render NotifyUpdateTags" "getNotificationEmails-NotifyUpdateTags.golden" $ \database -> do
+        fmap renderMail . getNotificationEmailMocked database userWatcher $
+          NotifyUpdateTags
+            { notifyPackageName = "base"
+            , notifyAddedTags = Set.fromList . map Tag $ ["bsd3", "library", "prelude"]
+            , notifyDeletedTags = Set.fromList . map Tag $ ["example", "bad", "foo"]
+            }
+    , testGolden "Render NotifyDependencyUpdate-Always" "getNotificationEmails-NotifyDependencyUpdate-Always.golden" $ \database -> do
+        fmap renderMail
+          . getNotificationEmail
+              testServerEnv
+              database
+              testUserDetailsFeature
+              allUsers
+              userWatcher
+          $ NotifyDependencyUpdate
               { notifyPackageId = PackageIdentifier "base" (mkVersion [4, 18, 0, 0])
-              , notifyRevisions = map (, userActor) [rev1, rev2]
-              }
-    , withTestDatabase $ \getDatabase ->
-        testGolden "Render NotifyMaintainerUpdate-MaintainerAdded" "getNotificationEmails-NotifyMaintainerUpdate-MaintainerAdded.golden" $ do
-          database <- getDatabase
-          fmap renderMail . getNotificationEmailMocked database userWatcher $
-            NotifyMaintainerUpdate
-              { notifyMaintainerUpdateType = MaintainerAdded
-              , notifyUserActor = userActor
-              , notifyUserSubject = userSubject
-              , notifyPackageName = "base"
-              , notifyReason = "User is cool"
-              , notifyUpdatedAt = timestamp
+              , notifyWatchedPackages = [PackageIdentifier "mtl" (mkVersion [2, 3])]
+              , notifyTriggerBounds = Always
               }
-    , withTestDatabase $ \getDatabase ->
-        testGolden "Render NotifyMaintainerUpdate-MaintainerRemoved" "getNotificationEmails-NotifyMaintainerUpdate-MaintainerRemoved.golden" $ do
-          database <- getDatabase
-          fmap renderMail . getNotificationEmailMocked database userWatcher $
-            NotifyMaintainerUpdate
-              { notifyMaintainerUpdateType = MaintainerRemoved
-              , notifyUserActor = userActor
-              , notifyUserSubject = userSubject
-              , notifyPackageName = "base"
-              , notifyReason = "User is no longer cool"
-              , notifyUpdatedAt = timestamp
-              }
-    , withTestDatabase $ \getDatabase ->
-        testGolden "Render NotifyDocsBuild-success" "getNotificationEmails-NotifyDocsBuild-success.golden" $ do
-          database <- getDatabase
-          fmap renderMail . getNotificationEmailMocked database userWatcher $
-            NotifyDocsBuild
+    , testGolden "Render NotifyDependencyUpdate-NewIncompatibility" "getNotificationEmails-NotifyDependencyUpdate-NewIncompatibility.golden" $ \database -> do
+        fmap renderMail
+          . getNotificationEmail
+              testServerEnv
+              database
+              testUserDetailsFeature
+              allUsers
+              userWatcher
+          $ NotifyDependencyUpdate
               { notifyPackageId = PackageIdentifier "base" (mkVersion [4, 18, 0, 0])
-              , notifyBuildSuccess = True
+              , notifyWatchedPackages = [PackageIdentifier "mtl" (mkVersion [2, 3])]
+              , notifyTriggerBounds = NewIncompatibility
               }
-    , withTestDatabase $ \getDatabase ->
-        testGolden "Render NotifyDocsBuild-failure" "getNotificationEmails-NotifyDocsBuild-failure.golden" $ do
-          database <- getDatabase
-          fmap renderMail . getNotificationEmailMocked database userWatcher $
-            NotifyDocsBuild
+    , testGolden "Render NotifyDependencyUpdate-BoundsOutOfRange" "getNotificationEmails-NotifyDependencyUpdate-BoundsOutOfRange.golden" $ \database -> do
+        fmap renderMail
+          . getNotificationEmail
+              testServerEnv
+              database
+              testUserDetailsFeature
+              allUsers
+              userWatcher
+          $ NotifyDependencyUpdate
               { notifyPackageId = PackageIdentifier "base" (mkVersion [4, 18, 0, 0])
-              , notifyBuildSuccess = False
-              }
-    , withTestDatabase $ \getDatabase ->
-        testGolden "Render NotifyUpdateTags" "getNotificationEmails-NotifyUpdateTags.golden" $ do
-          database <- getDatabase
-          fmap renderMail . getNotificationEmailMocked database userWatcher $
-            NotifyUpdateTags
-              { notifyPackageName = "base"
-              , notifyAddedTags = Set.fromList . map Tag $ ["bsd3", "library", "prelude"]
-              , notifyDeletedTags = Set.fromList . map Tag $ ["example", "bad", "foo"]
+              , notifyWatchedPackages = [PackageIdentifier "mtl" (mkVersion [2, 3])]
+              , notifyTriggerBounds = BoundsOutOfRange
               }
-    , withTestDatabase $ \getDatabase ->
-        testGolden "Render NotifyDependencyUpdate-Always" "getNotificationEmails-NotifyDependencyUpdate-Always.golden" $ do
-          database <- getDatabase
-          fmap renderMail
-            . getNotificationEmail
-                testServerEnv
-                database
-                testUserDetailsFeature
-                allUsers
-                userWatcher
-            $ NotifyDependencyUpdate
+    , testGolden "Render NotifyVouchingCompleted" "getNotificationEmails-NotifyVouchingCompleted.golden" $ \database -> do
+        fmap renderMail $ getNotificationEmailMocked database userWatcher NotifyVouchingCompleted
+    , testGolden "Render general notifications in single batched email" "getNotificationEmails-batched.golden" $ \database -> do
+        emails <-
+          getNotificationEmailsMocked database . map (userWatcher,) $
+            [ NotifyNewRevision
                 { notifyPackageId = PackageIdentifier "base" (mkVersion [4, 18, 0, 0])
-                , notifyWatchedPackages = [PackageIdentifier "mtl" (mkVersion [2, 3])]
-                , notifyTriggerBounds = Always
+                , notifyRevisions = [(timestamp, userActor)]
                 }
-    , withTestDatabase $ \getDatabase ->
-        testGolden "Render NotifyDependencyUpdate-NewIncompatibility" "getNotificationEmails-NotifyDependencyUpdate-NewIncompatibility.golden" $ do
-          database <- getDatabase
-          fmap renderMail
-            . getNotificationEmail
-                testServerEnv
-                database
-                testUserDetailsFeature
-                allUsers
-                userWatcher
-            $ NotifyDependencyUpdate
+            , NotifyDocsBuild
                 { notifyPackageId = PackageIdentifier "base" (mkVersion [4, 18, 0, 0])
-                , notifyWatchedPackages = [PackageIdentifier "mtl" (mkVersion [2, 3])]
-                , notifyTriggerBounds = NewIncompatibility
+                , notifyBuildSuccess = True
                 }
-    , withTestDatabase $ \getDatabase ->
-        testGolden "Render NotifyDependencyUpdate-BoundsOutOfRange" "getNotificationEmails-NotifyDependencyUpdate-BoundsOutOfRange.golden" $ do
-          database <- getDatabase
-          fmap renderMail
-            . getNotificationEmail
-                testServerEnv
-                database
-                testUserDetailsFeature
-                allUsers
-                userWatcher
-            $ NotifyDependencyUpdate
-                { notifyPackageId = PackageIdentifier "base" (mkVersion [4, 18, 0, 0])
-                , notifyWatchedPackages = [PackageIdentifier "mtl" (mkVersion [2, 3])]
-                , notifyTriggerBounds = BoundsOutOfRange
+            , NotifyUpdateTags
+                { notifyPackageName = "base"
+                , notifyAddedTags = Set.fromList [Tag "newtag"]
+                , notifyDeletedTags = Set.fromList [Tag "oldtag"]
                 }
-    , withTestDatabase $ \getDatabase ->
-        testGolden "Render NotifyVouchingCompleted" "getNotificationEmails-NotifyVouchingCompleted.golden" $ do
-          database <- getDatabase
-          fmap renderMail $ getNotificationEmailMocked database userWatcher NotifyVouchingCompleted
-    , withTestDatabase $ \getDatabase ->
-        testGolden "Render general notifications in single batched email" "getNotificationEmails-batched.golden" $ do
-          database <- getDatabase
-          emails <-
-            getNotificationEmailsMocked database . map (userWatcher,) $
-              [ NotifyNewRevision
-                  { notifyPackageId = PackageIdentifier "base" (mkVersion [4, 18, 0, 0])
-                  , notifyRevisions = [(timestamp, userActor)]
-                  }
-              , NotifyDocsBuild
-                  { notifyPackageId = PackageIdentifier "base" (mkVersion [4, 18, 0, 0])
-                  , notifyBuildSuccess = True
-                  }
-              , NotifyUpdateTags
-                  { notifyPackageName = "base"
-                  , notifyAddedTags = Set.fromList [Tag "newtag"]
-                  , notifyDeletedTags = Set.fromList [Tag "oldtag"]
-                  }
-              ]
-          case emails of
-            [email] -> pure $ renderMail email
-            _ -> error $ "Emails were not batched: " ++ show emails
+            ]
+        case emails of
+          [email] -> pure $ renderMail email
+          _ -> error $ "Emails were not batched: " ++ show emails
     ]
   where
     -- If adding a new constructor here, make sure to do the following:
@@ -722,8 +698,14 @@ hedgehogTests =
     , ("prop_csvBackupRoundtrips", prop_csvBackupRoundtrips)
     ]
 
-testGolden :: TestName -> FilePath -> IO Lazy.ByteString -> TestTree
-testGolden name fp = goldenVsString name ("tests/golden/ReverseDependenciesTest/" <> fp)
+testGolden :: TestName -> FilePath -> (DatabaseFeature -> IO Lazy.ByteString) -> TestTree
+testGolden name fp body = 
+  withTestDatabase $ \getDatabase ->
+    goldenVsString name ("tests/golden/ReverseDependenciesTest/" <> fp) (do
+      database <- getDatabase
+      body database
+    )
+  
 
 main :: IO ()
 main = defaultMain allTests

From 82047c681c0d08dae184118d3c9ac35af813c00b Mon Sep 17 00:00:00 2001
From: "Brian J. Cardiff" <bcardiff@gmail.com>
Date: Sun, 8 Feb 2026 23:26:52 -0500
Subject: [PATCH 13/34] Make testUserDetailsFeature reach the database

seed the database
---
 .../Server/Features/UserDetails.hs            | 69 ++++++++------
 tests/ReverseDependenciesTest.hs              | 95 ++++++++++++-------
 2 files changed, 100 insertions(+), 64 deletions(-)

diff --git a/src/Distribution/Server/Features/UserDetails.hs b/src/Distribution/Server/Features/UserDetails.hs
index 758d71d51..0e8c5645e 100644
--- a/src/Distribution/Server/Features/UserDetails.hs
+++ b/src/Distribution/Server/Features/UserDetails.hs
@@ -5,7 +5,10 @@ module Distribution.Server.Features.UserDetails (
     UserDetailsFeature(..),
 
     AccountDetails(..),
-    AccountKind(..)
+    AccountKind(..),
+
+    -- Exposed to setup features in test context that use the database
+    dbQueryUserDetails
   ) where
 
 import Distribution.Server.Framework
@@ -350,33 +353,10 @@ userDetailsFeature templates userDetailsState DatabaseFeature{..} UserFeature{..
     --
 
     queryUserDetails :: UserId -> Database.Transaction (Maybe AccountDetails)
-    queryUserDetails uid = fmap toUserDetails <$> accountDetailsFindByUserId uid
+    queryUserDetails = dbQueryUserDetails
 
     updateUserDetails :: UserId -> AccountDetails -> Database.Transaction ()
-    updateUserDetails uid@(UserId _uid) udetails = modifyAccountDetails uid (const udetails)
-
-    -- convenient helper to update only part of the record.
-    -- We use the same record for information that is editable by the user and information that is only editable by admins.
-    modifyAccountDetails :: UserId -> (AccountDetails -> AccountDetails) -> Database.Transaction ()
-    modifyAccountDetails uid@(UserId _uid) change = do
-      -- NOTE: we need to query the current value because we are updating only some of the fields.
-      madetails <- queryUserDetails uid
-      -- NOTE: We could assume that the record exist since updateUserDetails is called from UserSignup
-      let adetails = fromMaybe AccountDetails {
-                        accountName = "",
-                        accountContactEmail = "",
-                        accountKind = Nothing,
-                        accountAdminNotes = ""
-                      } madetails
-      let cdetails = change adetails
-
-      accountDetailsUpsert AccountDetailsRow {
-          _adUserId = fromIntegral _uid,
-          _adName = accountName cdetails,
-          _adContactEmail = accountContactEmail cdetails,
-          _adKind = fromAccountKind (accountKind cdetails),
-          _adAdminNotes = accountAdminNotes cdetails
-      }
+    updateUserDetails = dbUpdateUserDetails
 
     -- Request handlers
     --
@@ -428,14 +408,14 @@ userDetailsFeature templates userDetailsState DatabaseFeature{..} UserFeature{..
         NameAndContact name email <- expectAesonContent
         guardValidLookingName name
         guardValidLookingEmail email
-        withTransaction $ modifyAccountDetails uid (\adetails -> adetails { accountName = name, accountContactEmail = email })
+        withTransaction $ dbModifyAccountDetails uid (\adetails -> adetails { accountName = name, accountContactEmail = email })
         noContent $ toResponse ()
 
     handlerDeleteUserNameContact :: DynamicPath -> ServerPartE Response
     handlerDeleteUserNameContact dpath = do
         uid <- lookupUserName =<< userNameInPath dpath
         guardAuthorised_ [IsUserId uid, InGroup adminGroup]
-        withTransaction $ modifyAccountDetails uid (\adetails -> adetails { accountName = "", accountContactEmail = "" })
+        withTransaction $ dbModifyAccountDetails uid (\adetails -> adetails { accountName = "", accountContactEmail = "" })
         noContent $ toResponse ()
 
     handlerGetAdminInfo :: DynamicPath -> ServerPartE Response
@@ -457,19 +437,48 @@ userDetailsFeature templates userDetailsState DatabaseFeature{..} UserFeature{..
         guardAuthorised_ [InGroup adminGroup]
         uid <- lookupUserName =<< userNameInPath dpath
         AdminInfo akind notes <- expectAesonContent
-        withTransaction $ modifyAccountDetails uid (\adetails -> adetails { accountKind = akind, accountAdminNotes = notes })
+        withTransaction $ dbModifyAccountDetails uid (\adetails -> adetails { accountKind = akind, accountAdminNotes = notes })
         noContent $ toResponse ()
 
     handlerDeleteAdminInfo :: DynamicPath -> ServerPartE Response
     handlerDeleteAdminInfo dpath = do
         guardAuthorised_ [InGroup adminGroup]
         uid <- lookupUserName =<< userNameInPath dpath
-        withTransaction $ modifyAccountDetails uid (\adetails -> adetails { accountKind = Nothing, accountAdminNotes = "" })
+        withTransaction $ dbModifyAccountDetails uid (\adetails -> adetails { accountKind = Nothing, accountAdminNotes = "" })
         noContent $ toResponse ()
 
 
 -- Database
 
+dbQueryUserDetails :: UserId -> Database.Transaction (Maybe AccountDetails)
+dbQueryUserDetails uid = fmap toUserDetails <$> accountDetailsFindByUserId uid
+
+dbUpdateUserDetails :: UserId -> AccountDetails -> Database.Transaction ()
+dbUpdateUserDetails uid@(UserId _uid) udetails = dbModifyAccountDetails uid (const udetails)
+
+-- convenient helper to update only part of the record.
+-- We use the same record for information that is editable by the user and information that is only editable by admins.
+dbModifyAccountDetails :: UserId -> (AccountDetails -> AccountDetails) -> Database.Transaction ()
+dbModifyAccountDetails uid@(UserId _uid) change = do
+  -- NOTE: we need to query the current value because we are updating only some of the fields.
+  madetails <- dbQueryUserDetails uid
+  -- NOTE: We could assume that the record exist since updateUserDetails is called from UserSignup
+  let adetails = fromMaybe AccountDetails {
+                    accountName = "",
+                    accountContactEmail = "",
+                    accountKind = Nothing,
+                    accountAdminNotes = ""
+                  } madetails
+  let cdetails = change adetails
+
+  accountDetailsUpsert AccountDetailsRow {
+      _adUserId = fromIntegral _uid,
+      _adName = accountName cdetails,
+      _adContactEmail = accountContactEmail cdetails,
+      _adKind = fromAccountKind (accountKind cdetails),
+      _adAdminNotes = accountAdminNotes cdetails
+  }
+
 accountDetailsFindByUserId :: UserId -> Database.Transaction (Maybe AccountDetailsRow)
 accountDetailsFindByUserId (UserId userId) =
   Database.runSelectReturningOne $
diff --git a/tests/ReverseDependenciesTest.hs b/tests/ReverseDependenciesTest.hs
index 80416baf5..1c9ae5591 100644
--- a/tests/ReverseDependenciesTest.hs
+++ b/tests/ReverseDependenciesTest.hs
@@ -28,7 +28,7 @@ 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 (AccountDetails(..), UserDetailsFeature(..), dbQueryUserDetails)
 import Distribution.Server.Features.UserNotify
   ( Notification(..)
   , NotifyMaintainerUpdateType(..)
@@ -46,7 +46,8 @@ import Distribution.Server.Framework.BackupRestore (runRestore)
 import Distribution.Server.Framework.Hook (newHook)
 import Distribution.Server.Framework.MemState (newMemStateWHNF)
 import Distribution.Server.Framework.ServerEnv (ServerEnv(..))
-import Distribution.Server.Packages.PackageIndex as PackageIndex
+import Distribution.Server.Packages.PackageIndex (PackageIndex)
+import qualified Distribution.Server.Packages.PackageIndex as PackageIndex
 import Distribution.Server.Packages.Types (CabalFileText(..), PkgInfo(..))
 import Distribution.Server.Framework.Templating
 import Distribution.Server.Users.Types
@@ -55,7 +56,7 @@ import Distribution.Server.Users.Types
   , UserId(..)
   , UserName(..)
   )
-import Distribution.Server.Users.UserIdSet as UserIdSet
+import qualified Distribution.Server.Users.UserIdSet as UserIdSet
 import qualified Distribution.Server.Users.Users as Users
 import Distribution.Version (mkVersion, version0)
 
@@ -84,7 +85,9 @@ import RevDepCommon (Package(..), TestPackage(..), mkPackage, mkPackageWithCabal
 
 import Data.String (fromString)
 import Distribution.Server.Features.Database
+import Distribution.Server.Features.UserDetails.State
 import qualified Database.SQLite.Simple
+import Database.Beam
 import Control.Exception (bracket)
 
 mtlBeelineLens :: [PkgInfo]
@@ -327,35 +330,41 @@ allTests = testGroup "ReverseDependenciesTest"
       assertEqual "hedgehog test pass" True res
   ]
 
+setupTestDatabase :: IO (Database.SQLite.Simple.Connection, DatabaseFeature)
+setupTestDatabase = do
+  conn <- Database.SQLite.Simple.open ":memory:"
+  sql <- readFile "init_db.sql"
+  Database.SQLite.Simple.execute_ conn (fromString sql)
+  pure (conn, DatabaseFeature { 
+      databaseFeatureInterface = undefined, -- not needed for these tests
+      withTransaction = \transaction -> 
+            liftIO $ Database.SQLite.Simple.withTransaction conn $
+                          runTransaction
+                            transaction
+                            (SqlLiteConnection conn)
+  })
+
+tearDownTestDatabase :: (Database.SQLite.Simple.Connection, DatabaseFeature) -> IO ()
+tearDownTestDatabase (conn, _) = Database.SQLite.Simple.close conn
+  
 withTestDatabase :: (IO DatabaseFeature -> TestTree) -> TestTree
 withTestDatabase action = do
-  withResource
-    (do
-        conn <- Database.SQLite.Simple.open ":memory:"
-        sql <- readFile "init_db.sql"
-        Database.SQLite.Simple.execute_ conn (fromString sql)
-        pure (conn, DatabaseFeature { 
-            databaseFeatureInterface = undefined, -- not needed for these tests
-            withTransaction = \transaction -> 
-                  liftIO $ Database.SQLite.Simple.withTransaction conn $
-                                runTransaction
-                                  transaction
-                                  (SqlLiteConnection conn)
-        })
-    )
-    (\ (conn, _) -> Database.SQLite.Simple.close conn)
+  withResource setupTestDatabase tearDownTestDatabase
     (\ ioResource -> action (snd <$> ioResource))
 
 getNotificationEmailsTests :: TestTree
 getNotificationEmailsTests =
   testGroup "getNotificationEmails"
-    [ withTestDatabase $ \getDatabase ->
-        testProperty "All general notifications batched in one email" . withTests 30 . property $ do
-          database <- evalIO getDatabase
-          notifs <- forAll $ Gen.list (Range.linear 1 10) $ Gen.filterT isGeneral genNotification
-          emails <- liftIO $ getNotificationEmailsMocked database $ map (userWatcher,) notifs
-          length emails === 1
+    [ testProperty "All general notifications batched in one email" . withTests 30 . property $ do
+        notifs <- forAll $ Gen.list (Range.linear 1 10) $ Gen.filterT isGeneral genNotification
+        emails <- evalIO $ bracket setupTestDatabase tearDownTestDatabase
+                    (\ (_, database) -> do
+                      withTransaction database seedDatabase
+                      getNotificationEmailsMocked database $ map (userWatcher,) notifs
+                    )
+        length emails === 1
     , testGolden "Render NotifyNewVersion" "getNotificationEmails-NotifyNewVersion.golden" $ \database -> do
+        withTransaction database seedDatabase
         fmap renderMail . getNotificationEmailMocked database userWatcher $
           NotifyNewVersion
             { notifyPackageInfo =
@@ -366,6 +375,7 @@ getNotificationEmailsTests =
                   }
             }
     , testGolden "Render NotifyNewRevision" "getNotificationEmails-NotifyNewRevision.golden" $ \database -> do
+        withTransaction database seedDatabase
         let mkRev rev = (CabalFileText "", (rev, userActor))
             rev0 = (0 * Time.nominalDay) `Time.addUTCTime` timestamp
             rev1 = (1 * Time.nominalDay) `Time.addUTCTime` timestamp
@@ -376,6 +386,7 @@ getNotificationEmailsTests =
             , notifyRevisions = map (, userActor) [rev1, rev2]
             }
     , testGolden "Render NotifyMaintainerUpdate-MaintainerAdded" "getNotificationEmails-NotifyMaintainerUpdate-MaintainerAdded.golden" $ \database -> do
+        withTransaction database seedDatabase
         fmap renderMail . getNotificationEmailMocked database userWatcher $
           NotifyMaintainerUpdate
             { notifyMaintainerUpdateType = MaintainerAdded
@@ -386,6 +397,7 @@ getNotificationEmailsTests =
             , notifyUpdatedAt = timestamp
             }
     , testGolden "Render NotifyMaintainerUpdate-MaintainerRemoved" "getNotificationEmails-NotifyMaintainerUpdate-MaintainerRemoved.golden" $ \database -> do
+        withTransaction database seedDatabase
         fmap renderMail . getNotificationEmailMocked database userWatcher $
           NotifyMaintainerUpdate
             { notifyMaintainerUpdateType = MaintainerRemoved
@@ -396,18 +408,21 @@ getNotificationEmailsTests =
             , notifyUpdatedAt = timestamp
             }
     , testGolden "Render NotifyDocsBuild-success" "getNotificationEmails-NotifyDocsBuild-success.golden" $ \database -> do
+        withTransaction database seedDatabase
         fmap renderMail . getNotificationEmailMocked database userWatcher $
           NotifyDocsBuild
             { notifyPackageId = PackageIdentifier "base" (mkVersion [4, 18, 0, 0])
             , notifyBuildSuccess = True
             }
     , testGolden "Render NotifyDocsBuild-failure" "getNotificationEmails-NotifyDocsBuild-failure.golden" $ \database -> do
+        withTransaction database seedDatabase
         fmap renderMail . getNotificationEmailMocked database userWatcher $
           NotifyDocsBuild
             { notifyPackageId = PackageIdentifier "base" (mkVersion [4, 18, 0, 0])
             , notifyBuildSuccess = False
             }
     , testGolden "Render NotifyUpdateTags" "getNotificationEmails-NotifyUpdateTags.golden" $ \database -> do
+        withTransaction database seedDatabase
         fmap renderMail . getNotificationEmailMocked database userWatcher $
           NotifyUpdateTags
             { notifyPackageName = "base"
@@ -415,6 +430,7 @@ getNotificationEmailsTests =
             , notifyDeletedTags = Set.fromList . map Tag $ ["example", "bad", "foo"]
             }
     , testGolden "Render NotifyDependencyUpdate-Always" "getNotificationEmails-NotifyDependencyUpdate-Always.golden" $ \database -> do
+        withTransaction database seedDatabase
         fmap renderMail
           . getNotificationEmail
               testServerEnv
@@ -428,6 +444,7 @@ getNotificationEmailsTests =
               , notifyTriggerBounds = Always
               }
     , testGolden "Render NotifyDependencyUpdate-NewIncompatibility" "getNotificationEmails-NotifyDependencyUpdate-NewIncompatibility.golden" $ \database -> do
+        withTransaction database seedDatabase
         fmap renderMail
           . getNotificationEmail
               testServerEnv
@@ -441,6 +458,7 @@ getNotificationEmailsTests =
               , notifyTriggerBounds = NewIncompatibility
               }
     , testGolden "Render NotifyDependencyUpdate-BoundsOutOfRange" "getNotificationEmails-NotifyDependencyUpdate-BoundsOutOfRange.golden" $ \database -> do
+        withTransaction database seedDatabase
         fmap renderMail
           . getNotificationEmail
               testServerEnv
@@ -454,8 +472,10 @@ getNotificationEmailsTests =
               , notifyTriggerBounds = BoundsOutOfRange
               }
     , testGolden "Render NotifyVouchingCompleted" "getNotificationEmails-NotifyVouchingCompleted.golden" $ \database -> do
+        withTransaction database seedDatabase
         fmap renderMail $ getNotificationEmailMocked database userWatcher NotifyVouchingCompleted
     , testGolden "Render general notifications in single batched email" "getNotificationEmails-batched.golden" $ \database -> do
+        withTransaction database seedDatabase
         emails <-
           getNotificationEmailsMocked database . map (userWatcher,) $
             [ NotifyNewRevision
@@ -513,6 +533,20 @@ getNotificationEmailsTests =
           <*> addUser "user-actor"
           <*> addUser "user-subject"
 
+    seedDatabase :: Transaction ()
+    seedDatabase = do
+      Distribution.Server.Features.Database.runInsert $
+        insert (_accountDetails hackageDb) $
+          insertValues
+            [ AccountDetailsRow
+                { _adUserId = (\(UserId v) -> fromIntegral v) userWatcher
+                , _adName = "user-watcher"
+                , _adContactEmail = "user-watcher@example.com"
+                , _adKind = Nothing
+                , _adAdminNotes = ""
+                }
+            ]
+
     getNotificationEmail env database details users uid notif =
       getNotificationEmails env database details users (mockTemplates ["datafiles/templates/UserNotify"] ["endorsements-complete.txt"]) [(uid, notif)] >>= \case
         [email] -> pure email
@@ -525,16 +559,9 @@ getNotificationEmailsTests =
 
     testUserDetailsFeature =
       UserDetailsFeature
-        { queryUserDetails = \uid ->
-            pure $ do
-              guard $ uid == userWatcher
-              Just
-                AccountDetails
-                  { accountName = "user-watcher"
-                  , accountContactEmail = "user-watcher@example.com"
-                  , accountKind = Nothing
-                  , accountAdminNotes = ""
-                  }
+        { userDetailsFeatureInterface = undefined,
+          queryUserDetails = dbQueryUserDetails,
+          updateUserDetails = undefined
         }
     getNotificationEmailsMocked database =
       getNotificationEmails

From 59a005aa778e3a46ecc15c1c99833d5388f69762 Mon Sep 17 00:00:00 2001
From: "Brian J. Cardiff" <bcardiff@gmail.com>
Date: Sun, 8 Feb 2026 23:46:02 -0500
Subject: [PATCH 14/34] Add --database-path cli option for server

---
 exes/Main.hs                                   | 11 ++++++++++-
 src/Distribution/Server.hs                     |  6 +++---
 src/Distribution/Server/Features/Database.hs   |  2 +-
 src/Distribution/Server/Framework/ServerEnv.hs |  2 +-
 4 files changed, 15 insertions(+), 6 deletions(-)

diff --git a/exes/Main.hs b/exes/Main.hs
index 2e4723f11..02c52741d 100644
--- a/exes/Main.hs
+++ b/exes/Main.hs
@@ -206,6 +206,7 @@ data RunFlags = RunFlags {
     flagRunTemp            :: Flag Bool,
     flagRunCacheDelay      :: Flag String,
     flagRunLiveTemplates   :: Flag Bool,
+    flagRunDatabasePath    :: Flag FilePath,
     -- Online backup flags
     flagRunBackupOutputDir :: Flag FilePath,
     flagRunBackupLinkBlobs :: Flag Bool,
@@ -226,6 +227,7 @@ defaultRunFlags = RunFlags {
     flagRunTemp            = Flag False,
     flagRunCacheDelay      = NoFlag,
     flagRunLiveTemplates   = Flag False,
+    flagRunDatabasePath    = NoFlag,
     flagRunBackupOutputDir = Flag "backups",
     flagRunBackupLinkBlobs = Flag False,
     flagRunBackupScrubbed  = Flag False
@@ -311,6 +313,11 @@ runCommand =
           "Do not cache templates, for quicker feedback during development."
           flagRunLiveTemplates (\v flags -> flags { flagRunLiveTemplates = v })
           (noArg (Flag True))
+      , option [] ["database-path"]
+          "Path to the database file"
+          flagRunDatabasePath (\v flags -> flags { flagRunDatabasePath = v })
+          (reqArgFlag "FILE")
+          -- NOTE: How to make --database-path mandatory?
       ]
 
 runAction :: RunFlags -> IO ()
@@ -340,12 +347,14 @@ runAction opts = do
                         confTmpDir     = tmpDir,
                         confCacheDelay = cacheDelay,
                         confLiveTemplates = liveTemplates,
-                        confVerbosity  = verbosity
+                        confVerbosity  = verbosity,
+                        confDatabasePath = databasePath
                     }
         outputDir = fromFlag (flagRunBackupOutputDir opts)
         linkBlobs = fromFlag (flagRunBackupLinkBlobs opts)
         scrubbed  = fromFlag (flagRunBackupScrubbed  opts)
         liveTemplates = fromFlag (flagRunLiveTemplates opts)
+        databasePath = fromFlagOrDefault (confDatabasePath defaults) (flagRunDatabasePath opts)
 
     checkBlankServerState =<< Server.hasSavedState config
     checkStaticDir staticDir (flagRunStaticDir opts)
diff --git a/src/Distribution/Server.hs b/src/Distribution/Server.hs
index 550a27569..c60c2e892 100644
--- a/src/Distribution/Server.hs
+++ b/src/Distribution/Server.hs
@@ -76,7 +76,7 @@ data ServerConfig = ServerConfig {
   confTmpDir    :: FilePath,
   confCacheDelay:: Int,
   confLiveTemplates :: Bool,
-  confServerDatabase :: String
+  confDatabasePath :: String
 } deriving (Show)
 
 confDbStateDir, confBlobStoreDir :: ServerConfig -> FilePath
@@ -110,7 +110,7 @@ defaultServerConfig = do
     confTmpDir    = "state" </> "tmp",
     confCacheDelay= 0,
     confLiveTemplates = False,
-    confServerDatabase = "hackage.db"
+    confDatabasePath = "hackage.db"
   }
 
 data Server = Server {
@@ -156,7 +156,7 @@ mkServerEnv config@(ServerConfig verbosity hostURI userContentURI requiredBaseHo
             serverUserContentBaseURI = userContentURI,
             serverRequiredBaseHostHeader = requiredBaseHostHeader,
             serverVerbosity     = verbosity,
-            serverDatabase      = confServerDatabase config
+            serverDatabasePath  = confDatabasePath config
          }
     return env
 
diff --git a/src/Distribution/Server/Features/Database.hs b/src/Distribution/Server/Features/Database.hs
index cef9ecb40..32901abf5 100644
--- a/src/Distribution/Server/Features/Database.hs
+++ b/src/Distribution/Server/Features/Database.hs
@@ -55,7 +55,7 @@ initDatabaseFeature env = pure $ do
   dbpool <-
     newPool $
       defaultPoolConfig
-        (Database.SQLite.Simple.open (serverDatabase env))
+        (Database.SQLite.Simple.open (serverDatabasePath env))
         Database.SQLite.Simple.close
         (5 {- time in seconds before unused connection is closed -})
         (20 {- number of connections -})
diff --git a/src/Distribution/Server/Framework/ServerEnv.hs b/src/Distribution/Server/Framework/ServerEnv.hs
index 3b207a5b2..464097dc2 100644
--- a/src/Distribution/Server/Framework/ServerEnv.hs
+++ b/src/Distribution/Server/Framework/ServerEnv.hs
@@ -73,7 +73,7 @@ data ServerEnv = ServerEnv {
     -- increasing the time taken to update the cache we can push this further.
     serverCacheDelay :: Int,
 
-    serverDatabase :: String,
+    serverDatabasePath :: String,
 
     serverVerbosity  :: Verbosity
 }

From b68e4aa584976e94ef59b451b9668cc1c749342e Mon Sep 17 00:00:00 2001
From: "Brian J. Cardiff" <bcardiff@gmail.com>
Date: Sun, 8 Feb 2026 23:52:42 -0500
Subject: [PATCH 15/34] Initialize database schema

---
 src/Distribution/Server/Features/Database.hs | 10 ++++++++++
 1 file changed, 10 insertions(+)

diff --git a/src/Distribution/Server/Features/Database.hs b/src/Distribution/Server/Features/Database.hs
index 32901abf5..1c040a9ec 100644
--- a/src/Distribution/Server/Features/Database.hs
+++ b/src/Distribution/Server/Features/Database.hs
@@ -16,6 +16,7 @@
 module Distribution.Server.Features.Database where
 
 import Control.Monad.Reader
+import Data.String (fromString)
 import Data.Kind
 import Data.Pool
 import Database.Beam hiding (runSelectReturningOne)
@@ -59,6 +60,15 @@ initDatabaseFeature env = pure $ do
         Database.SQLite.Simple.close
         (5 {- time in seconds before unused connection is closed -})
         (20 {- number of connections -})
+
+  -- Initialize the database schema.
+  -- Script produce no changes if database is already initialized.
+  -- TODO: implement migrations or check how to embed or distribute the SQL script with the server.
+  -- CHECK: Should this be done in featurePostInit instead?
+  sql <- readFile "init_db.sql"
+  withResource dbpool $ \conn ->
+    Database.SQLite.Simple.execute_ conn (fromString sql)
+
   pure $ mkDatabaseFeature dbpool
   where
     mkDatabaseFeature :: Pool Database.SQLite.Simple.Connection -> DatabaseFeature

From 715a047d26a60018e3757e68bb9e250a6b07a715 Mon Sep 17 00:00:00 2001
From: "Brian J. Cardiff" <bcardiff@gmail.com>
Date: Mon, 9 Feb 2026 00:18:25 -0500
Subject: [PATCH 16/34] Embed the init_db.sql file. Test run on another
 directory

Depends on TemplateHaskell
---
 hackage-server.cabal                         |  1 +
 src/Distribution/Server/Features/Database.hs | 13 +++++++------
 tests/ReverseDependenciesTest.hs             |  3 +--
 3 files changed, 9 insertions(+), 8 deletions(-)

diff --git a/hackage-server.cabal b/hackage-server.cabal
index 5f58e903a..020370080 100644
--- a/hackage-server.cabal
+++ b/hackage-server.cabal
@@ -182,6 +182,7 @@ common defaults
     , beam-sqlite           ^>= 0.5.5.0
     , sqlite-simple         ^>= 0.4.19.0
     , resource-pool         ^>= 0.5.0.0
+    , file-embed            ^>= 0.0.16.0
 
 library
   import: defaults
diff --git a/src/Distribution/Server/Features/Database.hs b/src/Distribution/Server/Features/Database.hs
index 1c040a9ec..62edd350d 100644
--- a/src/Distribution/Server/Features/Database.hs
+++ b/src/Distribution/Server/Features/Database.hs
@@ -4,19 +4,18 @@
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE GADTs #-}
-{-# HLINT ignore "Avoid lambda" #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE TypeFamilies #-}
-{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
 
 module Distribution.Server.Features.Database where
 
 import Control.Monad.Reader
-import Data.String (fromString)
+import Data.FileEmbed (embedStringFile)
 import Data.Kind
 import Data.Pool
 import Database.Beam hiding (runSelectReturningOne)
@@ -51,6 +50,9 @@ data DatabaseFeature = DatabaseFeature
 instance IsHackageFeature DatabaseFeature where
   getFeatureInterface = databaseFeatureInterface
 
+initDbSql :: Database.SQLite.Simple.Query
+initDbSql = $(embedStringFile "init_db.sql")
+
 initDatabaseFeature :: ServerEnv -> IO (IO DatabaseFeature)
 initDatabaseFeature env = pure $ do
   dbpool <-
@@ -63,11 +65,10 @@ initDatabaseFeature env = pure $ do
 
   -- Initialize the database schema.
   -- Script produce no changes if database is already initialized.
-  -- TODO: implement migrations or check how to embed or distribute the SQL script with the server.
+  -- TODO: implement migrations
   -- CHECK: Should this be done in featurePostInit instead?
-  sql <- readFile "init_db.sql"
   withResource dbpool $ \conn ->
-    Database.SQLite.Simple.execute_ conn (fromString sql)
+    Database.SQLite.Simple.execute_ conn initDbSql
 
   pure $ mkDatabaseFeature dbpool
   where
diff --git a/tests/ReverseDependenciesTest.hs b/tests/ReverseDependenciesTest.hs
index 1c9ae5591..1e035d2d7 100644
--- a/tests/ReverseDependenciesTest.hs
+++ b/tests/ReverseDependenciesTest.hs
@@ -333,8 +333,7 @@ allTests = testGroup "ReverseDependenciesTest"
 setupTestDatabase :: IO (Database.SQLite.Simple.Connection, DatabaseFeature)
 setupTestDatabase = do
   conn <- Database.SQLite.Simple.open ":memory:"
-  sql <- readFile "init_db.sql"
-  Database.SQLite.Simple.execute_ conn (fromString sql)
+  Database.SQLite.Simple.execute_ conn initDbSql
   pure (conn, DatabaseFeature { 
       databaseFeatureInterface = undefined, -- not needed for these tests
       withTransaction = \transaction -> 

From b86b883027d7c00fbc1abe23f0c2c3844a294f6f Mon Sep 17 00:00:00 2001
From: "Brian J. Cardiff" <bcardiff@gmail.com>
Date: Mon, 9 Feb 2026 00:22:00 -0500
Subject: [PATCH 17/34] Specify the test directory

Not really needed since they run in a different directory
---
 tests/HackageClientUtils.hs | 1 +
 1 file changed, 1 insertion(+)

diff --git a/tests/HackageClientUtils.hs b/tests/HackageClientUtils.hs
index 53a4b3ece..579a0cc75 100644
--- a/tests/HackageClientUtils.hs
+++ b/tests/HackageClientUtils.hs
@@ -59,6 +59,7 @@ serverRunningArgs =
   , "--base-uri", "http://127.0.0.1:" <> show testPort
   , "--user-content-uri", "http://localhost:" <> show testPort
   , "--required-base-host-header", "127.0.0.1:" <> show testPort
+  , "--database-path", "hackageTest.db" -- NOTE: :memory: does not work for the HighLevelTest
   ]
 
 waitForServer :: IO ()

From 3eac6834ecb80beaed1ab3d1406801e9daccc301 Mon Sep 17 00:00:00 2001
From: "Brian J. Cardiff" <bcardiff@gmail.com>
Date: Mon, 9 Feb 2026 00:25:20 -0500
Subject: [PATCH 18/34] Change HackageDb table field

So there is no need to override the convention
---
 src/Distribution/Server/Features/Database.hs    | 8 ++------
 src/Distribution/Server/Features/UserDetails.hs | 4 ++--
 tests/ReverseDependenciesTest.hs                | 2 +-
 3 files changed, 5 insertions(+), 9 deletions(-)

diff --git a/src/Distribution/Server/Features/Database.hs b/src/Distribution/Server/Features/Database.hs
index 62edd350d..59d4c1e7a 100644
--- a/src/Distribution/Server/Features/Database.hs
+++ b/src/Distribution/Server/Features/Database.hs
@@ -91,14 +91,10 @@ initDatabaseFeature env = pure $ do
                 (SqlLiteConnection conn)
 
 newtype HackageDb f = HackageDb
-  {_accountDetails :: f (TableEntity AccountDetailsT)}
+  {_tblAccountDetails :: f (TableEntity AccountDetailsT)}
   deriving stock (Generic)
 
 instance Database be HackageDb
 
 hackageDb :: DatabaseSettings be HackageDb
-hackageDb =
-  defaultDbSettings
-    `withDbModification` dbModification
-      { _accountDetails = setEntityName "account_details"
-      }
+hackageDb = defaultDbSettings
diff --git a/src/Distribution/Server/Features/UserDetails.hs b/src/Distribution/Server/Features/UserDetails.hs
index 0e8c5645e..29fc09371 100644
--- a/src/Distribution/Server/Features/UserDetails.hs
+++ b/src/Distribution/Server/Features/UserDetails.hs
@@ -484,14 +484,14 @@ accountDetailsFindByUserId (UserId userId) =
   Database.runSelectReturningOne $
     select $
       filter_ (\ad -> _adUserId ad ==. val_ (fromIntegral userId)) $
-        all_ (_accountDetails Database.hackageDb)
+        all_ (_tblAccountDetails Database.hackageDb)
 
 -- Use the values from the INSERT that caused the conflict
 accountDetailsUpsert :: AccountDetailsRow -> Database.Transaction ()
 accountDetailsUpsert details =
   Database.runInsert $
     insertOnConflict
-      (_accountDetails Database.hackageDb)
+      (_tblAccountDetails Database.hackageDb)
       (insertValues [details])
       (conflictingFields primaryKey)
       ( onConflictUpdateSet $ \fields _oldRow ->
diff --git a/tests/ReverseDependenciesTest.hs b/tests/ReverseDependenciesTest.hs
index 1e035d2d7..a45b8f60d 100644
--- a/tests/ReverseDependenciesTest.hs
+++ b/tests/ReverseDependenciesTest.hs
@@ -535,7 +535,7 @@ getNotificationEmailsTests =
     seedDatabase :: Transaction ()
     seedDatabase = do
       Distribution.Server.Features.Database.runInsert $
-        insert (_accountDetails hackageDb) $
+        insert (_tblAccountDetails hackageDb) $
           insertValues
             [ AccountDetailsRow
                 { _adUserId = (\(UserId v) -> fromIntegral v) userWatcher

From cbc6479daca094359c1e9afe1caafe681d606b04 Mon Sep 17 00:00:00 2001
From: "Brian J. Cardiff" <bcardiff@gmail.com>
Date: Mon, 9 Feb 2026 00:28:49 -0500
Subject: [PATCH 19/34] Narrow interface of Database module

---
 src/Distribution/Server/Features/Database.hs | 18 ++++++++++++++----
 1 file changed, 14 insertions(+), 4 deletions(-)

diff --git a/src/Distribution/Server/Features/Database.hs b/src/Distribution/Server/Features/Database.hs
index 59d4c1e7a..a354c246e 100644
--- a/src/Distribution/Server/Features/Database.hs
+++ b/src/Distribution/Server/Features/Database.hs
@@ -12,13 +12,23 @@
 {-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE TypeFamilies #-}
 
-module Distribution.Server.Features.Database where
+module Distribution.Server.Features.Database
+  ( DatabaseFeature (..),
+    Transaction,
+    initDatabaseFeature,
+    runSelectReturningOne,
+    runInsert,
+    HackageDb (..),
+    hackageDb,
+    initDbSql, -- for tests
+  )
+where
 
 import Control.Monad.Reader
 import Data.FileEmbed (embedStringFile)
 import Data.Kind
 import Data.Pool
-import Database.Beam hiding (runSelectReturningOne)
+import Database.Beam hiding (runInsert, runSelectReturningOne)
 import qualified Database.Beam
 import Database.Beam.Sqlite
 import qualified Database.SQLite.Simple
@@ -35,11 +45,11 @@ runInsert :: forall (table :: (Type -> Type) -> Type). SqlInsert Sqlite table ->
 runInsert q =
   Transaction $ ReaderT $ \(SqlLiteConnection conn) -> runBeamSqlite conn $ Database.Beam.runInsert q
 
-newtype Transaction a = Transaction {unTransaction :: ReaderT Connection IO a} -- TODO: don't expose the internals of this
+newtype Transaction a = Transaction {unTransaction :: ReaderT Connection IO a}
   deriving (Functor, Applicative, Monad)
 
 runTransaction :: Transaction a -> Connection -> IO a
-runTransaction (Transaction t) = runReaderT t
+runTransaction t = runReaderT (unTransaction t)
 
 -- | A feature to store extra information about users like email addresses.
 data DatabaseFeature = DatabaseFeature

From 0de8d4115f1f85261edd68be528f68679952331b Mon Sep 17 00:00:00 2001
From: "Brian J. Cardiff" <bcardiff@gmail.com>
Date: Mon, 9 Feb 2026 10:39:16 -0500
Subject: [PATCH 20/34] Refactor to hide db initialization from tests

---
 src/Distribution/Server/Features/Database.hs | 42 +++++++++++++++++++-
 tests/ReverseDependenciesTest.hs             | 35 +++-------------
 2 files changed, 46 insertions(+), 31 deletions(-)

diff --git a/src/Distribution/Server/Features/Database.hs b/src/Distribution/Server/Features/Database.hs
index a354c246e..7138916fd 100644
--- a/src/Distribution/Server/Features/Database.hs
+++ b/src/Distribution/Server/Features/Database.hs
@@ -20,7 +20,9 @@ module Distribution.Server.Features.Database
     runInsert,
     HackageDb (..),
     hackageDb,
-    initDbSql, -- for tests
+    -- for tests
+    testDatabaseFeature,
+    testDatabaseFeatureIO,
   )
 where
 
@@ -108,3 +110,41 @@ instance Database be HackageDb
 
 hackageDb :: DatabaseSettings be HackageDb
 hackageDb = defaultDbSettings
+
+-- | For testing purposes, in memory single connection database.
+testDatabaseFeature ::
+  (forall r. IO r -> (r -> IO ()) -> (r -> b) -> b) ->
+  (DatabaseFeature -> b) ->
+  b
+testDatabaseFeature withResourceFn action =
+  withResourceFn
+    setupTestDatabase
+    (\(conn, _) -> Database.SQLite.Simple.close conn)
+    (\(_, database) -> action database)
+
+testDatabaseFeatureIO ::
+  (forall r. IO r -> (r -> IO ()) -> (IO r -> b) -> b) ->
+  (IO DatabaseFeature -> b) ->
+  b
+testDatabaseFeatureIO withResourceFn action =
+  withResourceFn
+    setupTestDatabase
+    (\(conn, _) -> Database.SQLite.Simple.close conn)
+    (\ioResource -> action (snd <$> ioResource))
+
+setupTestDatabase :: IO (Database.SQLite.Simple.Connection, DatabaseFeature)
+setupTestDatabase = do
+  conn <- Database.SQLite.Simple.open ":memory:"
+  Database.SQLite.Simple.execute_ conn initDbSql
+  pure
+    ( conn,
+      DatabaseFeature
+        { databaseFeatureInterface = undefined, -- not needed for these tests
+          withTransaction = \transaction ->
+            liftIO $
+              Database.SQLite.Simple.withTransaction conn $
+                runTransaction
+                  transaction
+                  (SqlLiteConnection conn)
+        }
+    )
diff --git a/tests/ReverseDependenciesTest.hs b/tests/ReverseDependenciesTest.hs
index a45b8f60d..2ecb8a7f5 100644
--- a/tests/ReverseDependenciesTest.hs
+++ b/tests/ReverseDependenciesTest.hs
@@ -83,10 +83,8 @@ import           Hedgehog
 
 import RevDepCommon (Package(..), TestPackage(..), mkPackage, mkPackageWithCabalFileSuffix, packToPkgInfo)
 
-import Data.String (fromString)
 import Distribution.Server.Features.Database
 import Distribution.Server.Features.UserDetails.State
-import qualified Database.SQLite.Simple
 import Database.Beam
 import Control.Exception (bracket)
 
@@ -330,37 +328,14 @@ allTests = testGroup "ReverseDependenciesTest"
       assertEqual "hedgehog test pass" True res
   ]
 
-setupTestDatabase :: IO (Database.SQLite.Simple.Connection, DatabaseFeature)
-setupTestDatabase = do
-  conn <- Database.SQLite.Simple.open ":memory:"
-  Database.SQLite.Simple.execute_ conn initDbSql
-  pure (conn, DatabaseFeature { 
-      databaseFeatureInterface = undefined, -- not needed for these tests
-      withTransaction = \transaction -> 
-            liftIO $ Database.SQLite.Simple.withTransaction conn $
-                          runTransaction
-                            transaction
-                            (SqlLiteConnection conn)
-  })
-
-tearDownTestDatabase :: (Database.SQLite.Simple.Connection, DatabaseFeature) -> IO ()
-tearDownTestDatabase (conn, _) = Database.SQLite.Simple.close conn
-  
-withTestDatabase :: (IO DatabaseFeature -> TestTree) -> TestTree
-withTestDatabase action = do
-  withResource setupTestDatabase tearDownTestDatabase
-    (\ ioResource -> action (snd <$> ioResource))
-
 getNotificationEmailsTests :: TestTree
 getNotificationEmailsTests =
   testGroup "getNotificationEmails"
     [ testProperty "All general notifications batched in one email" . withTests 30 . property $ do
         notifs <- forAll $ Gen.list (Range.linear 1 10) $ Gen.filterT isGeneral genNotification
-        emails <- evalIO $ bracket setupTestDatabase tearDownTestDatabase
-                    (\ (_, database) -> do
-                      withTransaction database seedDatabase
-                      getNotificationEmailsMocked database $ map (userWatcher,) notifs
-                    )
+        emails <- evalIO $ testDatabaseFeature bracket $ \ database -> do
+                    withTransaction database seedDatabase
+                    getNotificationEmailsMocked database $ map (userWatcher,) notifs
         length emails === 1
     , testGolden "Render NotifyNewVersion" "getNotificationEmails-NotifyNewVersion.golden" $ \database -> do
         withTransaction database seedDatabase
@@ -726,9 +701,9 @@ hedgehogTests =
 
 testGolden :: TestName -> FilePath -> (DatabaseFeature -> IO Lazy.ByteString) -> TestTree
 testGolden name fp body = 
-  withTestDatabase $ \getDatabase ->
+  testDatabaseFeatureIO withResource $ \ioDatabase ->
     goldenVsString name ("tests/golden/ReverseDependenciesTest/" <> fp) (do
-      database <- getDatabase
+      database <- ioDatabase
       body database
     )
   

From 75df49c10e3a1ca340e4d5a090d46d0f5d2cb95a Mon Sep 17 00:00:00 2001
From: "Brian J. Cardiff" <bcardiff@gmail.com>
Date: Mon, 9 Feb 2026 23:53:23 -0500
Subject: [PATCH 21/34] Expose whether the database is fresh

To have a more controlled migration
---
 src/Distribution/Server/Features/Database.hs  | 20 +++++++++++-----
 .../Server/Features/UserDetails.hs            | 23 ++++++++-----------
 2 files changed, 24 insertions(+), 19 deletions(-)

diff --git a/src/Distribution/Server/Features/Database.hs b/src/Distribution/Server/Features/Database.hs
index 7138916fd..e60cb3a23 100644
--- a/src/Distribution/Server/Features/Database.hs
+++ b/src/Distribution/Server/Features/Database.hs
@@ -56,7 +56,9 @@ runTransaction t = runReaderT (unTransaction t)
 -- | A feature to store extra information about users like email addresses.
 data DatabaseFeature = DatabaseFeature
   { databaseFeatureInterface :: HackageFeature,
-    withTransaction :: forall a m. (MonadIO m) => Transaction a -> m a
+    withTransaction :: forall a m. (MonadIO m) => Transaction a -> m a,
+    -- | whether the database is fresh and feature should migrate acid data
+    fresh :: Bool
   }
 
 instance IsHackageFeature DatabaseFeature where
@@ -79,13 +81,18 @@ initDatabaseFeature env = pure $ do
   -- Script produce no changes if database is already initialized.
   -- TODO: implement migrations
   -- CHECK: Should this be done in featurePostInit instead?
-  withResource dbpool $ \conn ->
+  tableExists <- withResource dbpool $ \conn -> do
+    [Database.SQLite.Simple.Only tableExists] <-
+      Database.SQLite.Simple.query_
+        conn
+        "SELECT EXISTS(SELECT 1 FROM sqlite_master WHERE type='table' AND name='account_details');"
     Database.SQLite.Simple.execute_ conn initDbSql
+    pure tableExists
 
-  pure $ mkDatabaseFeature dbpool
+  pure $ mkDatabaseFeature dbpool (not tableExists)
   where
-    mkDatabaseFeature :: Pool Database.SQLite.Simple.Connection -> DatabaseFeature
-    mkDatabaseFeature dbpool = DatabaseFeature {..}
+    mkDatabaseFeature :: Pool Database.SQLite.Simple.Connection -> Bool -> DatabaseFeature
+    mkDatabaseFeature dbpool fresh = DatabaseFeature {..}
       where
         databaseFeatureInterface =
           (emptyHackageFeature "database")
@@ -145,6 +152,7 @@ setupTestDatabase = do
               Database.SQLite.Simple.withTransaction conn $
                 runTransaction
                   transaction
-                  (SqlLiteConnection conn)
+                  (SqlLiteConnection conn),
+          fresh = True
         }
     )
diff --git a/src/Distribution/Server/Features/UserDetails.hs b/src/Distribution/Server/Features/UserDetails.hs
index 29fc09371..441775f8f 100644
--- a/src/Distribution/Server/Features/UserDetails.hs
+++ b/src/Distribution/Server/Features/UserDetails.hs
@@ -36,6 +36,7 @@ import qualified Data.Text as T
 import qualified Data.Aeson as Aeson
 import Data.Aeson.TH
 
+import Control.Monad (when)
 import Control.Monad.Reader (ask)
 import Control.Monad.State (get, put)
 
@@ -276,8 +277,8 @@ initUserDetailsFeature ServerEnv{serverStateDir, serverTemplatesDir, serverTempl
       [ "user-details-form.html" ]
 
     return $ \database users core upload -> do
-      migrateStateToDatabase usersDetailsState database
-      
+      when (fresh database) 
+        (migrateStateToDatabase usersDetailsState database)
       let feature = userDetailsFeature templates usersDetailsState database users core upload
       return feature
 
@@ -288,17 +289,13 @@ migrateStateToDatabase userDetailsState DatabaseFeature{..} = do
   (UserDetailsTable tbl) <- queryState userDetailsState GetUserDetailsTable
   withTransaction $ do
     forM_ (IntMap.toList tbl) $ \(uid, details) -> do
-      -- NOTE: This is actually performing a merge
-      --       by inserting records of user ids we know nothing about.
-      r <- accountDetailsFindByUserId (UserId uid)
-      when (isNothing r) $
-        accountDetailsUpsert AccountDetailsRow {
-            _adUserId = fromIntegral uid,
-            _adName = accountName details,
-            _adContactEmail = accountContactEmail details,
-            _adKind = fromAccountKind (accountKind details),
-            _adAdminNotes = accountAdminNotes details
-          }
+      accountDetailsUpsert AccountDetailsRow {
+        _adUserId = fromIntegral uid,
+        _adName = accountName details,
+        _adContactEmail = accountContactEmail details,
+        _adKind = fromAccountKind (accountKind details),
+        _adAdminNotes = accountAdminNotes details
+      }
 
 userDetailsFeature :: Templates
                    -> StateComponent AcidState UserDetailsTable

From 2de425d2da152c1e2f5fa24bbeaaafeb27426564 Mon Sep 17 00:00:00 2001
From: "Brian J. Cardiff" <bcardiff@gmail.com>
Date: Mon, 9 Feb 2026 23:57:11 -0500
Subject: [PATCH 22/34] Cleanup

---
 src/Distribution/Server/Features/UserDetails.hs | 3 +--
 1 file changed, 1 insertion(+), 2 deletions(-)

diff --git a/src/Distribution/Server/Features/UserDetails.hs b/src/Distribution/Server/Features/UserDetails.hs
index 441775f8f..a9aee44a4 100644
--- a/src/Distribution/Server/Features/UserDetails.hs
+++ b/src/Distribution/Server/Features/UserDetails.hs
@@ -31,12 +31,11 @@ import Data.SafeCopy (base, deriveSafeCopy)
 import Data.IntMap (IntMap)
 import qualified Data.IntMap as IntMap
 import Data.Text (Text)
-import Data.Maybe (fromMaybe, isNothing)
+import Data.Maybe (fromMaybe)
 import qualified Data.Text as T
 import qualified Data.Aeson as Aeson
 import Data.Aeson.TH
 
-import Control.Monad (when)
 import Control.Monad.Reader (ask)
 import Control.Monad.State (get, put)
 

From 7579f2556ace1ee506ff6c27552dc03a77fb26c0 Mon Sep 17 00:00:00 2001
From: "Brian J. Cardiff" <bcardiff@gmail.com>
Date: Tue, 10 Feb 2026 00:38:04 -0500
Subject: [PATCH 23/34] Use custom type for user id

To use UserId directly we need to change it to a non machine-dependent size for Beam. MemSize and Pretty are not defined on Int32. But other places start to complain after that
---
 .../Server/Features/UserDetails.hs            | 12 ++++++------
 .../Server/Features/UserDetails/State.hs      |  6 +++---
 src/Distribution/Server/Users/Types.hs        | 19 ++++++++++++++++++-
 tests/ReverseDependenciesTest.hs              |  4 ++--
 4 files changed, 29 insertions(+), 12 deletions(-)

diff --git a/src/Distribution/Server/Features/UserDetails.hs b/src/Distribution/Server/Features/UserDetails.hs
index a9aee44a4..ddf7cc7bc 100644
--- a/src/Distribution/Server/Features/UserDetails.hs
+++ b/src/Distribution/Server/Features/UserDetails.hs
@@ -289,7 +289,7 @@ migrateStateToDatabase userDetailsState DatabaseFeature{..} = do
   withTransaction $ do
     forM_ (IntMap.toList tbl) $ \(uid, details) -> do
       accountDetailsUpsert AccountDetailsRow {
-        _adUserId = fromIntegral uid,
+        _adUserId = toDBUserId (UserId uid),
         _adName = accountName details,
         _adContactEmail = accountContactEmail details,
         _adKind = fromAccountKind (accountKind details),
@@ -450,12 +450,12 @@ dbQueryUserDetails :: UserId -> Database.Transaction (Maybe AccountDetails)
 dbQueryUserDetails uid = fmap toUserDetails <$> accountDetailsFindByUserId uid
 
 dbUpdateUserDetails :: UserId -> AccountDetails -> Database.Transaction ()
-dbUpdateUserDetails uid@(UserId _uid) udetails = dbModifyAccountDetails uid (const udetails)
+dbUpdateUserDetails uid udetails = dbModifyAccountDetails uid (const udetails)
 
 -- convenient helper to update only part of the record.
 -- We use the same record for information that is editable by the user and information that is only editable by admins.
 dbModifyAccountDetails :: UserId -> (AccountDetails -> AccountDetails) -> Database.Transaction ()
-dbModifyAccountDetails uid@(UserId _uid) change = do
+dbModifyAccountDetails uid change = do
   -- NOTE: we need to query the current value because we are updating only some of the fields.
   madetails <- dbQueryUserDetails uid
   -- NOTE: We could assume that the record exist since updateUserDetails is called from UserSignup
@@ -468,7 +468,7 @@ dbModifyAccountDetails uid@(UserId _uid) change = do
   let cdetails = change adetails
 
   accountDetailsUpsert AccountDetailsRow {
-      _adUserId = fromIntegral _uid,
+      _adUserId = toDBUserId uid,
       _adName = accountName cdetails,
       _adContactEmail = accountContactEmail cdetails,
       _adKind = fromAccountKind (accountKind cdetails),
@@ -476,10 +476,10 @@ dbModifyAccountDetails uid@(UserId _uid) change = do
   }
 
 accountDetailsFindByUserId :: UserId -> Database.Transaction (Maybe AccountDetailsRow)
-accountDetailsFindByUserId (UserId userId) =
+accountDetailsFindByUserId uid =
   Database.runSelectReturningOne $
     select $
-      filter_ (\ad -> _adUserId ad ==. val_ (fromIntegral userId)) $
+      filter_ (\ad -> _adUserId ad ==. val_ (toDBUserId uid)) $
         all_ (_tblAccountDetails Database.hackageDb)
 
 -- Use the values from the INSERT that caused the conflict
diff --git a/src/Distribution/Server/Features/UserDetails/State.hs b/src/Distribution/Server/Features/UserDetails/State.hs
index a4cf9dc31..d23b1fdbb 100644
--- a/src/Distribution/Server/Features/UserDetails/State.hs
+++ b/src/Distribution/Server/Features/UserDetails/State.hs
@@ -8,13 +8,13 @@
 
 module Distribution.Server.Features.UserDetails.State where
 
-import Data.Int (Int32)
 import Data.Text (Text)
 import Database.Beam
+import Distribution.Server.Users.Types
 
 data AccountDetailsT f
   = AccountDetailsRow
-  { _adUserId :: Columnar f Int32, -- CHECK: Can we user Distribution.Server.Users.Types.UserId here instead?
+  { _adUserId :: Columnar f DBUserId,
     _adName :: Columnar f Text,
     _adContactEmail :: Columnar f Text,
     _adKind :: Columnar f (Maybe Text), -- NOTE: valid values are real_user, special.
@@ -31,5 +31,5 @@ deriving instance Eq AccountDetailsRow
 type AccountDetailsId = PrimaryKey AccountDetailsT Identity
 
 instance Table AccountDetailsT where
-  data PrimaryKey AccountDetailsT f = AccountDetailsId (Columnar f Int32) deriving (Generic, Beamable)
+  data PrimaryKey AccountDetailsT f = AccountDetailsId (Columnar f DBUserId) deriving (Generic, Beamable)
   primaryKey = AccountDetailsId . _adUserId
diff --git a/src/Distribution/Server/Users/Types.hs b/src/Distribution/Server/Users/Types.hs
index b297ab800..9d188fb43 100644
--- a/src/Distribution/Server/Users/Types.hs
+++ b/src/Distribution/Server/Users/Types.hs
@@ -1,4 +1,5 @@
 {-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving, TemplateHaskell #-}
+{-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE DerivingStrategies #-}
 module Distribution.Server.Users.Types (
@@ -23,15 +24,31 @@ import qualified Data.Text as T
 import qualified Data.Map as M
 import qualified Data.List as L
 
+import Data.Int
 import Data.Aeson (ToJSON, FromJSON)
 import Data.SafeCopy (base, extension, deriveSafeCopy, Migrate(..))
 import Data.Hashable
 import Data.Serialize (Serialize)
-
+import Database.Beam
+import Database.Beam.Backend
+import Database.Beam.Sqlite
+import Database.Beam.Sqlite.Syntax
 
 newtype UserId = UserId Int
   deriving newtype (Eq, Ord, Read, Show, MemSize, ToJSON, FromJSON, Pretty)
 
+-- NOTE: To use UserId directly we need to change it to a non machine-dependent size for Beam
+--       MemSize and Pretty are not defined on Int32
+--       but other places start to complain after that
+newtype DBUserId = DBUserId Int32
+  deriving newtype (Eq, Ord, Read, Show, FromBackendRow Sqlite, HasSqlValueSyntax SqliteValueSyntax, HasSqlEqualityCheck Sqlite)
+
+fromDBUserId :: DBUserId -> UserId
+fromDBUserId (DBUserId v) = UserId (fromIntegral v)
+
+toDBUserId :: UserId -> DBUserId
+toDBUserId (UserId v) = DBUserId (fromIntegral v)
+
 newtype UserName  = UserName String
   deriving newtype (Eq, Ord, Read, Show, MemSize, ToJSON, FromJSON, Hashable, Serialize)
 
diff --git a/tests/ReverseDependenciesTest.hs b/tests/ReverseDependenciesTest.hs
index 2ecb8a7f5..eff23adcc 100644
--- a/tests/ReverseDependenciesTest.hs
+++ b/tests/ReverseDependenciesTest.hs
@@ -54,7 +54,7 @@ import Distribution.Server.Users.Types
   ( PasswdHash(..)
   , UserAuth(..)
   , UserId(..)
-  , UserName(..)
+  , UserName(..), toDBUserId
   )
 import qualified Distribution.Server.Users.UserIdSet as UserIdSet
 import qualified Distribution.Server.Users.Users as Users
@@ -513,7 +513,7 @@ getNotificationEmailsTests =
         insert (_tblAccountDetails hackageDb) $
           insertValues
             [ AccountDetailsRow
-                { _adUserId = (\(UserId v) -> fromIntegral v) userWatcher
+                { _adUserId = toDBUserId userWatcher
                 , _adName = "user-watcher"
                 , _adContactEmail = "user-watcher@example.com"
                 , _adKind = Nothing

From 29610b7553238ded98b02fff0d2704249c3fcdfc Mon Sep 17 00:00:00 2001
From: "Brian J. Cardiff" <bcardiff@gmail.com>
Date: Tue, 10 Feb 2026 00:51:37 -0500
Subject: [PATCH 24/34] Add users table and types

---
 init_db.sql                            |  7 +++++++
 src/Distribution/Server/Users/State.hs | 29 +++++++++++++++++++++++++-
 2 files changed, 35 insertions(+), 1 deletion(-)

diff --git a/init_db.sql b/init_db.sql
index 1b8cd4b74..24cbfc752 100644
--- a/init_db.sql
+++ b/init_db.sql
@@ -2,6 +2,13 @@
 --
 -- sqlite3 hackage.db < init_db.sql
 --
+CREATE TABLE IF NOT EXISTS users (
+    id INTEGER PRIMARY KEY,
+    username TEXT NOT NULL UNIQUE, -- CHECK: should it be unique? what happens with deleted users?
+    status TEXT NOT NULL,
+    auth_info TEXT NOT NULL,
+    admin BOOLEAN NOT NULL
+);
 
 CREATE TABLE IF NOT EXISTS account_details (
     user_id INTEGER PRIMARY KEY,
diff --git a/src/Distribution/Server/Users/State.hs b/src/Distribution/Server/Users/State.hs
index 1d15c97e9..f451c092c 100644
--- a/src/Distribution/Server/Users/State.hs
+++ b/src/Distribution/Server/Users/State.hs
@@ -1,6 +1,6 @@
 {-# LANGUAGE DeriveDataTypeable, TypeFamilies, TemplateHaskell,
              FlexibleInstances, FlexibleContexts, MultiParamTypeClasses,
-             TypeOperators #-}
+             TypeOperators, StandaloneDeriving, DeriveGeneric, DeriveAnyClass #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 module Distribution.Server.Users.State where
 
@@ -19,6 +19,9 @@ import Control.Monad.Reader
 import qualified Control.Monad.State as State
 import qualified Data.Text as T
 
+import Data.Text
+import Database.Beam
+
 initialUsers :: Users.Users
 initialUsers = Users.emptyUsers
 
@@ -175,3 +178,27 @@ $(makeAcidic ''MirrorClients
                     ,'addMirrorClient
                     ,'removeMirrorClient
                     ,'replaceMirrorClients])
+
+-- Database
+
+data UsersT f
+  = UsersRow
+  { _uId :: Columnar f DBUserId,
+    _uUsername :: Columnar f Text,
+    _uStatus :: Columnar f Text, -- NOTE: valid values are enabled, disabled, deleted.
+    _uAuthInfo :: Columnar f Text, 
+    _uAdmin :: Columnar f Bool
+  }
+  deriving (Generic, Beamable)
+
+type UserRow = UsersT Identity
+
+deriving instance Show UserRow
+
+deriving instance Eq UserRow
+
+type UsersId = PrimaryKey UsersT Identity
+
+instance Table UsersT where
+  data PrimaryKey UsersT f = UsersId (Columnar f DBUserId) deriving (Generic, Beamable)
+  primaryKey = UsersId . _uId

From 433f9b48a759850281a730a161e430067bb4cac9 Mon Sep 17 00:00:00 2001
From: "Brian J. Cardiff" <bcardiff@gmail.com>
Date: Tue, 10 Feb 2026 01:05:40 -0500
Subject: [PATCH 25/34] Make DatabaseFeature a dependency of Users

---
 src/Distribution/Server/Features.hs       |  1 +
 src/Distribution/Server/Features/Users.hs | 10 +++++++---
 2 files changed, 8 insertions(+), 3 deletions(-)

diff --git a/src/Distribution/Server/Features.hs b/src/Distribution/Server/Features.hs
index 3f362c0ad..556e66c95 100644
--- a/src/Distribution/Server/Features.hs
+++ b/src/Distribution/Server/Features.hs
@@ -180,6 +180,7 @@ initHackageFeatures env@ServerEnv{serverVerbosity = verbosity} = do
     staticFilesFeature <- mkStaticFilesFeature
 
     usersFeature    <- mkUserFeature
+                         databaseFeature
 
     coreFeature     <- mkCoreFeature
                          usersFeature
diff --git a/src/Distribution/Server/Features/Users.hs b/src/Distribution/Server/Features/Users.hs
index 69b215b34..8a9a88c4b 100644
--- a/src/Distribution/Server/Features/Users.hs
+++ b/src/Distribution/Server/Features/Users.hs
@@ -14,6 +14,8 @@ import Distribution.Server.Framework.BackupDump
 import Distribution.Server.Framework.Templating
 import qualified Distribution.Server.Framework.Auth as Auth
 
+import Distribution.Server.Features.Database (DatabaseFeature (..), HackageDb (..))
+
 import Distribution.Server.Users.Types
 import Distribution.Server.Users.State
 import Distribution.Server.Users.Backup
@@ -227,7 +229,7 @@ deriveJSON (compatAesonOptionsDropPrefix "ui_")  ''EnabledResource
 deriveJSON (compatAesonOptionsDropPrefix "ui_")  ''UserGroupResource
 
 -- TODO: add renaming
-initUserFeature :: ServerEnv -> IO (IO UserFeature)
+initUserFeature :: ServerEnv -> IO (DatabaseFeature -> IO UserFeature)
 initUserFeature serverEnv@ServerEnv{serverStateDir, serverTemplatesDir, serverTemplatesMode} = do
   -- Canonical state
   usersState  <- usersStateComponent  serverStateDir
@@ -248,7 +250,7 @@ initUserFeature serverEnv@ServerEnv{serverStateDir, serverTemplatesDir, serverTe
       [ "manage.html", "token-created.html", "token-revoked.html"
       ]
 
-  return $ do
+  return $ \database -> do
     -- Slightly tricky: we have an almost recursive knot between the group
     -- resource management functions, and creating the admin group
     -- resource that is part of the user feature.
@@ -257,6 +259,7 @@ initUserFeature serverEnv@ServerEnv{serverStateDir, serverTemplatesDir, serverTe
     --
     rec let (feature@UserFeature{groupResourceAt}, adminGroupDesc)
               = userFeature templates
+                            database
                             usersState
                             adminsState
                             groupIndex
@@ -295,6 +298,7 @@ adminsStateComponent stateDir = do
     }
 
 userFeature :: Templates
+            -> DatabaseFeature
             -> StateComponent AcidState Users.Users
             -> StateComponent AcidState HackageAdmins
             -> MemState GroupIndex
@@ -305,7 +309,7 @@ userFeature :: Templates
             -> GroupResource
             -> ServerEnv
             -> (UserFeature, UserGroup)
-userFeature templates usersState adminsState
+userFeature templates database usersState adminsState
              groupIndex userAdded authFailHook groupChangedHook
              adminGroup adminResource userFeatureServerEnv
   = (UserFeature {..}, adminGroupDesc)

From 265529f75a18e6e0616c0c1c3efb21d8b2461fb7 Mon Sep 17 00:00:00 2001
From: "Brian J. Cardiff" <bcardiff@gmail.com>
Date: Tue, 10 Feb 2026 13:40:28 -0300
Subject: [PATCH 26/34] Fix db schema setup

Database.SQLite.Simple.execute_ is not able to run multiple statements at once
---
 hackage-server.cabal                         |  1 +
 src/Distribution/Server/Features/Database.hs | 28 +++++++++++---------
 2 files changed, 16 insertions(+), 13 deletions(-)

diff --git a/hackage-server.cabal b/hackage-server.cabal
index 020370080..fe1bf735d 100644
--- a/hackage-server.cabal
+++ b/hackage-server.cabal
@@ -181,6 +181,7 @@ common defaults
     , beam-core             ^>= 0.10.4.0
     , beam-sqlite           ^>= 0.5.5.0
     , sqlite-simple         ^>= 0.4.19.0
+    , direct-sqlite         ^>= 2.3.29
     , resource-pool         ^>= 0.5.0.0
     , file-embed            ^>= 0.0.16.0
 
diff --git a/src/Distribution/Server/Features/Database.hs b/src/Distribution/Server/Features/Database.hs
index e60cb3a23..169a5b5b1 100644
--- a/src/Distribution/Server/Features/Database.hs
+++ b/src/Distribution/Server/Features/Database.hs
@@ -34,6 +34,7 @@ import Database.Beam hiding (runInsert, runSelectReturningOne)
 import qualified Database.Beam
 import Database.Beam.Sqlite
 import qualified Database.SQLite.Simple
+import qualified Database.SQLite3
 import Distribution.Server.Features.UserDetails.State
 import Distribution.Server.Framework
 
@@ -64,8 +65,15 @@ data DatabaseFeature = DatabaseFeature
 instance IsHackageFeature DatabaseFeature where
   getFeatureInterface = databaseFeatureInterface
 
-initDbSql :: Database.SQLite.Simple.Query
-initDbSql = $(embedStringFile "init_db.sql")
+-- | Ensures the database schema is initialized. Returns 'True' if the database was just created, 'False' if it already existed.
+initSchema :: Database.SQLite.Simple.Connection -> IO Bool
+initSchema conn = do
+  [Database.SQLite.Simple.Only tableExists] <-
+    Database.SQLite.Simple.query_
+      conn
+      "SELECT EXISTS(SELECT 1 FROM sqlite_master WHERE type='table' AND name='account_details');"
+  Database.SQLite3.exec (Database.SQLite.Simple.connectionHandle conn) $(embedStringFile "init_db.sql")
+  pure (not tableExists)
 
 initDatabaseFeature :: ServerEnv -> IO (IO DatabaseFeature)
 initDatabaseFeature env = pure $ do
@@ -81,15 +89,9 @@ initDatabaseFeature env = pure $ do
   -- Script produce no changes if database is already initialized.
   -- TODO: implement migrations
   -- CHECK: Should this be done in featurePostInit instead?
-  tableExists <- withResource dbpool $ \conn -> do
-    [Database.SQLite.Simple.Only tableExists] <-
-      Database.SQLite.Simple.query_
-        conn
-        "SELECT EXISTS(SELECT 1 FROM sqlite_master WHERE type='table' AND name='account_details');"
-    Database.SQLite.Simple.execute_ conn initDbSql
-    pure tableExists
-
-  pure $ mkDatabaseFeature dbpool (not tableExists)
+  fresh <- withResource dbpool initSchema
+
+  pure $ mkDatabaseFeature dbpool fresh
   where
     mkDatabaseFeature :: Pool Database.SQLite.Simple.Connection -> Bool -> DatabaseFeature
     mkDatabaseFeature dbpool fresh = DatabaseFeature {..}
@@ -142,7 +144,7 @@ testDatabaseFeatureIO withResourceFn action =
 setupTestDatabase :: IO (Database.SQLite.Simple.Connection, DatabaseFeature)
 setupTestDatabase = do
   conn <- Database.SQLite.Simple.open ":memory:"
-  Database.SQLite.Simple.execute_ conn initDbSql
+  fresh <- initSchema conn -- NOTE: Always fresh since it's an in-memory database
   pure
     ( conn,
       DatabaseFeature
@@ -153,6 +155,6 @@ setupTestDatabase = do
                 runTransaction
                   transaction
                   (SqlLiteConnection conn),
-          fresh = True
+          fresh = fresh
         }
     )

From 58403d1cd57e6b6a84d1b7b1139653f2423e1893 Mon Sep 17 00:00:00 2001
From: "Brian J. Cardiff" <bcardiff@gmail.com>
Date: Tue, 10 Feb 2026 13:50:42 -0300
Subject: [PATCH 27/34] Update readme

---
 README.md | 11 +++++++++--
 1 file changed, 9 insertions(+), 2 deletions(-)

diff --git a/README.md b/README.md
index aca1791cb..45a024988 100644
--- a/README.md
+++ b/README.md
@@ -36,7 +36,8 @@ Alternatively, open the [`nix develop`](https://nixos.org/manual/nix/stable/comm
     $ cabal v2-run -- hackage-server run --static-dir=datafiles --state-dir=state \
         --base-uri=http://localhost:8080 \
         --required-base-host-header=localhost:8080 \
-        --user-content-uri=http://127.0.0.1:8080
+        --user-content-uri=http://127.0.0.1:8080 \
+        --database-path=path/to/hackage.db
     hackage-server: Ready! Point your browser at http://localhost:8080
 
 #### Populate the local package index
@@ -50,6 +51,11 @@ Then
 
      $ nix run .#mirror-hackage-server
 
+#### Database
+
+When hackage-server starts it will migrate data from the acid store to the specified database and
+will keep using that going forward.
+
 #### Not working
 
 Please note this App *cannot* be run [directly from GitHub](https://determinate.systems/posts/nix-run) like this:
@@ -224,7 +230,8 @@ once to initialise the state. After that you can run the server with
     cabal v2-run -- hackage-server run --static-dir=datafiles --state-dir=state \
         --base-uri=http://127.0.0.1:8080 \
         --required-base-host-header=localhost:8080 \
-        --user-content-uri=http://127.0.0.1:8080
+        --user-content-uri=http://127.0.0.1:8080 \
+        --database-path=path/to/hackage.db
 
 By default the server runs on port `8080` with the following settings:
 

From 9f90e363d63395e10f55e6ff04ba8672e53288a2 Mon Sep 17 00:00:00 2001
From: "Brian J. Cardiff" <bcardiff@gmail.com>
Date: Tue, 10 Feb 2026 15:29:00 -0300
Subject: [PATCH 28/34] Use enums for account kind

Enums are saved using Show and pared with Read
They currently abort the request if the data is malformed
---
 .../Server/Features/UserDetails.hs            | 22 ++++++++-----------
 .../Server/Features/UserDetails/State.hs      | 16 ++++++++++++--
 2 files changed, 23 insertions(+), 15 deletions(-)

diff --git a/src/Distribution/Server/Features/UserDetails.hs b/src/Distribution/Server/Features/UserDetails.hs
index ddf7cc7bc..856d665d5 100644
--- a/src/Distribution/Server/Features/UserDetails.hs
+++ b/src/Distribution/Server/Features/UserDetails.hs
@@ -292,7 +292,7 @@ migrateStateToDatabase userDetailsState DatabaseFeature{..} = do
         _adUserId = toDBUserId (UserId uid),
         _adName = accountName details,
         _adContactEmail = accountContactEmail details,
-        _adKind = fromAccountKind (accountKind details),
+        _adKind = fmap fromAccountKind (accountKind details),
         _adAdminNotes = accountAdminNotes details
       }
 
@@ -471,7 +471,7 @@ dbModifyAccountDetails uid change = do
       _adUserId = toDBUserId uid,
       _adName = accountName cdetails,
       _adContactEmail = accountContactEmail cdetails,
-      _adKind = fromAccountKind (accountKind cdetails),
+      _adKind = fmap fromAccountKind (accountKind cdetails),
       _adAdminNotes = accountAdminNotes cdetails
   }
 
@@ -504,22 +504,18 @@ toUserDetails AccountDetailsRow {..} =
   AccountDetails
     { accountName = _adName,
       accountContactEmail = _adContactEmail,
-      accountKind = 
-        -- NOTE: Should we fail to convert instead?
-        toAccountKind _adKind,
+      accountKind = fmap toAccountKind _adKind,
       accountAdminNotes = _adAdminNotes
     }
 
-toAccountKind :: Maybe Text -> Maybe AccountKind
+toAccountKind :: AccountDetailsKind -> AccountKind
 toAccountKind adKind =
   case adKind of
-    Just "real_user" -> Just AccountKindRealUser
-    Just "special" -> Just AccountKindSpecial
-    _ -> Nothing
+    RealUser -> AccountKindRealUser
+    Special -> AccountKindSpecial
 
-fromAccountKind :: Maybe AccountKind -> Maybe Text
+fromAccountKind :: AccountKind -> AccountDetailsKind
 fromAccountKind adKind =
   case adKind of
-    Just AccountKindRealUser -> Just "real_user"
-    Just AccountKindSpecial -> Just "special"
-    _ -> Nothing
+    AccountKindRealUser -> RealUser
+    AccountKindSpecial -> Special
diff --git a/src/Distribution/Server/Features/UserDetails/State.hs b/src/Distribution/Server/Features/UserDetails/State.hs
index d23b1fdbb..69b1e0849 100644
--- a/src/Distribution/Server/Features/UserDetails/State.hs
+++ b/src/Distribution/Server/Features/UserDetails/State.hs
@@ -8,8 +8,11 @@
 
 module Distribution.Server.Features.UserDetails.State where
 
-import Data.Text (Text)
+import Data.Text (Text, unpack)
 import Database.Beam
+import Database.Beam.Backend.SQL.SQL92 (HasSqlValueSyntax (..), autoSqlValueSyntax)
+import Database.Beam.Sqlite (Sqlite)
+import Database.Beam.Sqlite.Syntax (SqliteValueSyntax (..))
 import Distribution.Server.Users.Types
 
 data AccountDetailsT f
@@ -17,7 +20,7 @@ data AccountDetailsT f
   { _adUserId :: Columnar f DBUserId,
     _adName :: Columnar f Text,
     _adContactEmail :: Columnar f Text,
-    _adKind :: Columnar f (Maybe Text), -- NOTE: valid values are real_user, special.
+    _adKind :: Columnar f (Maybe AccountDetailsKind),
     _adAdminNotes :: Columnar f Text
   }
   deriving (Generic, Beamable)
@@ -33,3 +36,12 @@ type AccountDetailsId = PrimaryKey AccountDetailsT Identity
 instance Table AccountDetailsT where
   data PrimaryKey AccountDetailsT f = AccountDetailsId (Columnar f DBUserId) deriving (Generic, Beamable)
   primaryKey = AccountDetailsId . _adUserId
+
+data AccountDetailsKind = RealUser | Special
+  deriving (Eq, Show, Read, Enum, Bounded)
+
+instance HasSqlValueSyntax SqliteValueSyntax AccountDetailsKind where
+  sqlValueSyntax = autoSqlValueSyntax
+
+instance FromBackendRow Sqlite AccountDetailsKind where
+  fromBackendRow = read . unpack <$> fromBackendRow

From b51ecb5e71ce75487f8a21c10eec437936ddbb02 Mon Sep 17 00:00:00 2001
From: "Brian J. Cardiff" <bcardiff@gmail.com>
Date: Tue, 10 Feb 2026 16:52:06 -0300
Subject: [PATCH 29/34] Migrate users state to database

---
 init_db.sql                                  |  2 +-
 src/Distribution/Server/Features/Database.hs |  7 ++--
 src/Distribution/Server/Features/Users.hs    | 34 ++++++++++++++++++++
 src/Distribution/Server/Users/State.hs       | 24 +++++++++++---
 src/Distribution/Server/Users/Types.hs       | 14 +++++++-
 5 files changed, 73 insertions(+), 8 deletions(-)

diff --git a/init_db.sql b/init_db.sql
index 24cbfc752..0e549c675 100644
--- a/init_db.sql
+++ b/init_db.sql
@@ -6,7 +6,7 @@ CREATE TABLE IF NOT EXISTS users (
     id INTEGER PRIMARY KEY,
     username TEXT NOT NULL UNIQUE, -- CHECK: should it be unique? what happens with deleted users?
     status TEXT NOT NULL,
-    auth_info TEXT NOT NULL,
+    auth_info TEXT,
     admin BOOLEAN NOT NULL
 );
 
diff --git a/src/Distribution/Server/Features/Database.hs b/src/Distribution/Server/Features/Database.hs
index 169a5b5b1..1a55434c1 100644
--- a/src/Distribution/Server/Features/Database.hs
+++ b/src/Distribution/Server/Features/Database.hs
@@ -37,6 +37,7 @@ import qualified Database.SQLite.Simple
 import qualified Database.SQLite3
 import Distribution.Server.Features.UserDetails.State
 import Distribution.Server.Framework
+import Distribution.Server.Users.State
 
 newtype Connection = SqlLiteConnection Database.SQLite.Simple.Connection
 
@@ -111,8 +112,10 @@ initDatabaseFeature env = pure $ do
                 action
                 (SqlLiteConnection conn)
 
-newtype HackageDb f = HackageDb
-  {_tblAccountDetails :: f (TableEntity AccountDetailsT)}
+data HackageDb f = HackageDb
+  { _tblAccountDetails :: f (TableEntity AccountDetailsT),
+    _tblUsers :: f (TableEntity UsersT)
+  }
   deriving stock (Generic)
 
 instance Database be HackageDb
diff --git a/src/Distribution/Server/Features/Users.hs b/src/Distribution/Server/Features/Users.hs
index 8a9a88c4b..cc1cc5809 100644
--- a/src/Distribution/Server/Features/Users.hs
+++ b/src/Distribution/Server/Features/Users.hs
@@ -15,6 +15,7 @@ import Distribution.Server.Framework.Templating
 import qualified Distribution.Server.Framework.Auth as Auth
 
 import Distribution.Server.Features.Database (DatabaseFeature (..), HackageDb (..))
+import qualified Distribution.Server.Features.Database as Database
 
 import Distribution.Server.Users.Types
 import Distribution.Server.Users.State
@@ -41,6 +42,8 @@ import Distribution.Text (display, simpleParse)
 
 import Happstack.Server.Cookie (addCookie, mkCookie, CookieLife(Session))
 
+import Database.Beam hiding (update)
+
 -- | A feature to allow manipulation of the database of users.
 --
 -- TODO: clean up mismatched and duplicate functionality (some noted below).
@@ -251,6 +254,9 @@ initUserFeature serverEnv@ServerEnv{serverStateDir, serverTemplatesDir, serverTe
       ]
 
   return $ \database -> do
+    when (fresh database) 
+      (migrateStateToDatabase usersState adminsState database)
+
     -- Slightly tricky: we have an almost recursive knot between the group
     -- resource management functions, and creating the admin group
     -- resource that is part of the user feature.
@@ -271,6 +277,34 @@ initUserFeature serverEnv@ServerEnv{serverStateDir, serverTemplatesDir, serverTe
 
     return feature
 
+migrateStateToDatabase :: StateComponent AcidState Users.Users
+                       -> StateComponent AcidState HackageAdmins
+                       -> DatabaseFeature 
+                       -> IO ()
+migrateStateToDatabase usersState adminsState DatabaseFeature{..} = do
+  users <- queryState usersState GetUserDb
+  admins <- queryState adminsState GetAdminList
+
+  withTransaction $ do
+    forM_ (Users.enumerateAllUsers users) $ \(uid, uinfo) -> do
+      let (status, authInfo) = 
+            case userStatus uinfo of
+              AccountEnabled a -> (Enabled, Just a)
+              AccountDisabled ma -> (Disabled, ma)
+              AccountDeleted -> (Deleted, Nothing)
+
+      Database.runInsert $
+        insert
+          (_tblUsers Database.hackageDb)
+          (insertValues [UsersRow {
+            _uId = toDBUserId uid,
+            _uUsername = userName uinfo,
+            _uStatus = status,
+            _uAuthInfo = authInfo,
+            _uAdmin = Group.member uid admins
+          }])
+   
+
 usersStateComponent :: FilePath -> IO (StateComponent AcidState Users.Users)
 usersStateComponent stateDir = do
   st <- openLocalStateFrom (stateDir </> "db" </> "Users") initialUsers
diff --git a/src/Distribution/Server/Users/State.hs b/src/Distribution/Server/Users/State.hs
index f451c092c..29510be3f 100644
--- a/src/Distribution/Server/Users/State.hs
+++ b/src/Distribution/Server/Users/State.hs
@@ -1,6 +1,7 @@
 {-# LANGUAGE DeriveDataTypeable, TypeFamilies, TemplateHaskell,
              FlexibleInstances, FlexibleContexts, MultiParamTypeClasses,
-             TypeOperators, StandaloneDeriving, DeriveGeneric, DeriveAnyClass #-}
+             TypeOperators, StandaloneDeriving, DeriveGeneric, DeriveAnyClass, 
+             DerivingStrategies, GeneralisedNewtypeDeriving #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 module Distribution.Server.Users.State where
 
@@ -21,6 +22,9 @@ import qualified Data.Text as T
 
 import Data.Text
 import Database.Beam
+import Database.Beam.Backend.SQL.SQL92 (HasSqlValueSyntax (..), autoSqlValueSyntax)
+import Database.Beam.Sqlite (Sqlite)
+import Database.Beam.Sqlite.Syntax (SqliteValueSyntax (..))
 
 initialUsers :: Users.Users
 initialUsers = Users.emptyUsers
@@ -184,9 +188,9 @@ $(makeAcidic ''MirrorClients
 data UsersT f
   = UsersRow
   { _uId :: Columnar f DBUserId,
-    _uUsername :: Columnar f Text,
-    _uStatus :: Columnar f Text, -- NOTE: valid values are enabled, disabled, deleted.
-    _uAuthInfo :: Columnar f Text, 
+    _uUsername :: Columnar f UserName,
+    _uStatus :: Columnar f UsersStatus,
+    _uAuthInfo :: Columnar f (Maybe UserAuth), 
     _uAdmin :: Columnar f Bool
   }
   deriving (Generic, Beamable)
@@ -202,3 +206,15 @@ type UsersId = PrimaryKey UsersT Identity
 instance Table UsersT where
   data PrimaryKey UsersT f = UsersId (Columnar f DBUserId) deriving (Generic, Beamable)
   primaryKey = UsersId . _uId
+
+data UsersStatus = Enabled | Disabled | Deleted
+  deriving (Eq, Show, Read, Enum, Bounded)
+
+instance HasSqlValueSyntax SqliteValueSyntax UsersStatus where
+  sqlValueSyntax = autoSqlValueSyntax
+
+instance FromBackendRow Sqlite UsersStatus where
+  fromBackendRow = read . unpack <$> fromBackendRow
+
+newtype DBUserName = DBUserName Text
+  deriving newtype (Eq, Ord, Read, Show, FromBackendRow Sqlite, HasSqlValueSyntax SqliteValueSyntax)
\ No newline at end of file
diff --git a/src/Distribution/Server/Users/Types.hs b/src/Distribution/Server/Users/Types.hs
index 9d188fb43..5ee2cef2b 100644
--- a/src/Distribution/Server/Users/Types.hs
+++ b/src/Distribution/Server/Users/Types.hs
@@ -2,6 +2,7 @@
 {-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
 module Distribution.Server.Users.Types (
     module Distribution.Server.Users.Types,
     module Distribution.Server.Users.AuthToken,
@@ -24,6 +25,7 @@ import qualified Data.Text as T
 import qualified Data.Map as M
 import qualified Data.List as L
 
+import Data.Text (unpack)
 import Data.Int
 import Data.Aeson (ToJSON, FromJSON)
 import Data.SafeCopy (base, extension, deriveSafeCopy, Migrate(..))
@@ -31,6 +33,7 @@ import Data.Hashable
 import Data.Serialize (Serialize)
 import Database.Beam
 import Database.Beam.Backend
+import Database.Beam.Backend.SQL.SQL92 ()
 import Database.Beam.Sqlite
 import Database.Beam.Sqlite.Syntax
 
@@ -50,7 +53,10 @@ toDBUserId :: UserId -> DBUserId
 toDBUserId (UserId v) = DBUserId (fromIntegral v)
 
 newtype UserName  = UserName String
-  deriving newtype (Eq, Ord, Read, Show, MemSize, ToJSON, FromJSON, Hashable, Serialize)
+  deriving newtype (Eq, Ord, Read, Show, MemSize, ToJSON, FromJSON, Hashable, Serialize, HasSqlValueSyntax SqliteValueSyntax)
+
+instance FromBackendRow Sqlite UserName where
+  fromBackendRow = UserName . unpack <$> fromBackendRow
 
 data UserInfo = UserInfo {
                   userName   :: !UserName,
@@ -66,6 +72,12 @@ data UserStatus = AccountEnabled  UserAuth
 newtype UserAuth = UserAuth PasswdHash
     deriving (Show, Eq)
 
+instance HasSqlValueSyntax SqliteValueSyntax UserAuth where
+  sqlValueSyntax (UserAuth (PasswdHash v)) = sqlValueSyntax v
+
+instance FromBackendRow Sqlite UserAuth where
+  fromBackendRow = UserAuth . PasswdHash . unpack <$> fromBackendRow
+
 isActiveAccount :: UserStatus -> Bool
 isActiveAccount (AccountEnabled  _) = True
 isActiveAccount (AccountDisabled _) = True

From 3fee1dde833eefe8b0a3849f64fd0d290b45f9d2 Mon Sep 17 00:00:00 2001
From: "Brian J. Cardiff" <bcardiff@gmail.com>
Date: Tue, 10 Feb 2026 17:12:55 -0300
Subject: [PATCH 30/34] Use UserId, drop DBUserId

---
 .../Server/Features/UserDetails.hs            |  6 +++---
 .../Server/Features/UserDetails/State.hs      |  4 ++--
 src/Distribution/Server/Features/Users.hs     |  2 +-
 src/Distribution/Server/Users/State.hs        |  4 ++--
 src/Distribution/Server/Users/Types.hs        | 21 ++++++++++++-------
 tests/ReverseDependenciesTest.hs              |  4 ++--
 6 files changed, 23 insertions(+), 18 deletions(-)

diff --git a/src/Distribution/Server/Features/UserDetails.hs b/src/Distribution/Server/Features/UserDetails.hs
index 856d665d5..1cf2e0bf1 100644
--- a/src/Distribution/Server/Features/UserDetails.hs
+++ b/src/Distribution/Server/Features/UserDetails.hs
@@ -289,7 +289,7 @@ migrateStateToDatabase userDetailsState DatabaseFeature{..} = do
   withTransaction $ do
     forM_ (IntMap.toList tbl) $ \(uid, details) -> do
       accountDetailsUpsert AccountDetailsRow {
-        _adUserId = toDBUserId (UserId uid),
+        _adUserId = UserId uid,
         _adName = accountName details,
         _adContactEmail = accountContactEmail details,
         _adKind = fmap fromAccountKind (accountKind details),
@@ -468,7 +468,7 @@ dbModifyAccountDetails uid change = do
   let cdetails = change adetails
 
   accountDetailsUpsert AccountDetailsRow {
-      _adUserId = toDBUserId uid,
+      _adUserId = uid,
       _adName = accountName cdetails,
       _adContactEmail = accountContactEmail cdetails,
       _adKind = fmap fromAccountKind (accountKind cdetails),
@@ -479,7 +479,7 @@ accountDetailsFindByUserId :: UserId -> Database.Transaction (Maybe AccountDetai
 accountDetailsFindByUserId uid =
   Database.runSelectReturningOne $
     select $
-      filter_ (\ad -> _adUserId ad ==. val_ (toDBUserId uid)) $
+      filter_ (\ad -> _adUserId ad ==. val_ uid) $
         all_ (_tblAccountDetails Database.hackageDb)
 
 -- Use the values from the INSERT that caused the conflict
diff --git a/src/Distribution/Server/Features/UserDetails/State.hs b/src/Distribution/Server/Features/UserDetails/State.hs
index 69b1e0849..93933f51f 100644
--- a/src/Distribution/Server/Features/UserDetails/State.hs
+++ b/src/Distribution/Server/Features/UserDetails/State.hs
@@ -17,7 +17,7 @@ import Distribution.Server.Users.Types
 
 data AccountDetailsT f
   = AccountDetailsRow
-  { _adUserId :: Columnar f DBUserId,
+  { _adUserId :: Columnar f UserId,
     _adName :: Columnar f Text,
     _adContactEmail :: Columnar f Text,
     _adKind :: Columnar f (Maybe AccountDetailsKind),
@@ -34,7 +34,7 @@ deriving instance Eq AccountDetailsRow
 type AccountDetailsId = PrimaryKey AccountDetailsT Identity
 
 instance Table AccountDetailsT where
-  data PrimaryKey AccountDetailsT f = AccountDetailsId (Columnar f DBUserId) deriving (Generic, Beamable)
+  data PrimaryKey AccountDetailsT f = AccountDetailsId (Columnar f UserId) deriving (Generic, Beamable)
   primaryKey = AccountDetailsId . _adUserId
 
 data AccountDetailsKind = RealUser | Special
diff --git a/src/Distribution/Server/Features/Users.hs b/src/Distribution/Server/Features/Users.hs
index cc1cc5809..beaaa3300 100644
--- a/src/Distribution/Server/Features/Users.hs
+++ b/src/Distribution/Server/Features/Users.hs
@@ -297,7 +297,7 @@ migrateStateToDatabase usersState adminsState DatabaseFeature{..} = do
         insert
           (_tblUsers Database.hackageDb)
           (insertValues [UsersRow {
-            _uId = toDBUserId uid,
+            _uId = uid,
             _uUsername = userName uinfo,
             _uStatus = status,
             _uAuthInfo = authInfo,
diff --git a/src/Distribution/Server/Users/State.hs b/src/Distribution/Server/Users/State.hs
index 29510be3f..d131cea39 100644
--- a/src/Distribution/Server/Users/State.hs
+++ b/src/Distribution/Server/Users/State.hs
@@ -187,7 +187,7 @@ $(makeAcidic ''MirrorClients
 
 data UsersT f
   = UsersRow
-  { _uId :: Columnar f DBUserId,
+  { _uId :: Columnar f UserId,
     _uUsername :: Columnar f UserName,
     _uStatus :: Columnar f UsersStatus,
     _uAuthInfo :: Columnar f (Maybe UserAuth), 
@@ -204,7 +204,7 @@ deriving instance Eq UserRow
 type UsersId = PrimaryKey UsersT Identity
 
 instance Table UsersT where
-  data PrimaryKey UsersT f = UsersId (Columnar f DBUserId) deriving (Generic, Beamable)
+  data PrimaryKey UsersT f = UsersId (Columnar f UserId) deriving (Generic, Beamable)
   primaryKey = UsersId . _uId
 
 data UsersStatus = Enabled | Disabled | Deleted
diff --git a/src/Distribution/Server/Users/Types.hs b/src/Distribution/Server/Users/Types.hs
index 5ee2cef2b..52d8ab09b 100644
--- a/src/Distribution/Server/Users/Types.hs
+++ b/src/Distribution/Server/Users/Types.hs
@@ -1,6 +1,7 @@
 {-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving, TemplateHaskell #-}
 {-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE DerivingStrategies #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 module Distribution.Server.Users.Types (
@@ -25,6 +26,7 @@ import qualified Data.Text as T
 import qualified Data.Map as M
 import qualified Data.List as L
 
+import Data.Proxy
 import Data.Text (unpack)
 import Data.Int
 import Data.Aeson (ToJSON, FromJSON)
@@ -41,16 +43,19 @@ newtype UserId = UserId Int
   deriving newtype (Eq, Ord, Read, Show, MemSize, ToJSON, FromJSON, Pretty)
 
 -- NOTE: To use UserId directly we need to change it to a non machine-dependent size for Beam
---       MemSize and Pretty are not defined on Int32
---       but other places start to complain after that
-newtype DBUserId = DBUserId Int32
-  deriving newtype (Eq, Ord, Read, Show, FromBackendRow Sqlite, HasSqlValueSyntax SqliteValueSyntax, HasSqlEqualityCheck Sqlite)
+--       We force Beam to treat UserId as a Int32
 
-fromDBUserId :: DBUserId -> UserId
-fromDBUserId (DBUserId v) = UserId (fromIntegral v)
+instance FromBackendRow Sqlite UserId where
+  fromBackendRow = UserId . fromIntegral @Int32 <$> fromBackendRow
 
-toDBUserId :: UserId -> DBUserId
-toDBUserId (UserId v) = DBUserId (fromIntegral v)
+instance HasSqlValueSyntax SqliteValueSyntax UserId where
+  sqlValueSyntax (UserId v) = sqlValueSyntax (fromIntegral v :: Int32)
+
+instance HasSqlEqualityCheck Sqlite UserId where
+  sqlEqE _ = sqlEqE (Proxy :: Proxy Int32)
+  sqlNeqE _ = sqlNeqE (Proxy :: Proxy Int32)
+  sqlEqTriE _ = sqlEqTriE (Proxy :: Proxy Int32)
+  sqlNeqTriE _ = sqlNeqTriE (Proxy :: Proxy Int32)
 
 newtype UserName  = UserName String
   deriving newtype (Eq, Ord, Read, Show, MemSize, ToJSON, FromJSON, Hashable, Serialize, HasSqlValueSyntax SqliteValueSyntax)
diff --git a/tests/ReverseDependenciesTest.hs b/tests/ReverseDependenciesTest.hs
index eff23adcc..b20a23637 100644
--- a/tests/ReverseDependenciesTest.hs
+++ b/tests/ReverseDependenciesTest.hs
@@ -54,7 +54,7 @@ import Distribution.Server.Users.Types
   ( PasswdHash(..)
   , UserAuth(..)
   , UserId(..)
-  , UserName(..), toDBUserId
+  , UserName(..)
   )
 import qualified Distribution.Server.Users.UserIdSet as UserIdSet
 import qualified Distribution.Server.Users.Users as Users
@@ -513,7 +513,7 @@ getNotificationEmailsTests =
         insert (_tblAccountDetails hackageDb) $
           insertValues
             [ AccountDetailsRow
-                { _adUserId = toDBUserId userWatcher
+                { _adUserId = userWatcher
                 , _adName = "user-watcher"
                 , _adContactEmail = "user-watcher@example.com"
                 , _adKind = Nothing

From 5cd58fe4cb9ae2772dfa5b6fb487cc6dd9dc2493 Mon Sep 17 00:00:00 2001
From: "Brian J. Cardiff" <bcardiff@gmail.com>
Date: Wed, 11 Feb 2026 00:35:34 -0300
Subject: [PATCH 31/34] Migrate auth tokens

---
 init_db.sql                                  |  7 ++++++
 src/Distribution/Server/Features/Database.hs |  3 ++-
 src/Distribution/Server/Features/Users.hs    | 11 +++++++++
 src/Distribution/Server/Users/AuthToken.hs   | 12 ++++++++++
 src/Distribution/Server/Users/State.hs       | 24 +++++++++++++++++++-
 src/Distribution/Server/Users/Types.hs       |  1 -
 6 files changed, 55 insertions(+), 3 deletions(-)

diff --git a/init_db.sql b/init_db.sql
index 0e549c675..210cfae89 100644
--- a/init_db.sql
+++ b/init_db.sql
@@ -10,6 +10,13 @@ CREATE TABLE IF NOT EXISTS users (
     admin BOOLEAN NOT NULL
 );
 
+CREATE TABLE IF NOT EXISTS user_tokens (
+    id INTEGER PRIMARY KEY,
+    user_id INTEGER NOT NULL,
+    description TEXT NOT NULL,
+    token TEXT NOT NULL
+);
+
 CREATE TABLE IF NOT EXISTS account_details (
     user_id INTEGER PRIMARY KEY,
     name TEXT NOT NULL,
diff --git a/src/Distribution/Server/Features/Database.hs b/src/Distribution/Server/Features/Database.hs
index 1a55434c1..f417cdf4e 100644
--- a/src/Distribution/Server/Features/Database.hs
+++ b/src/Distribution/Server/Features/Database.hs
@@ -114,7 +114,8 @@ initDatabaseFeature env = pure $ do
 
 data HackageDb f = HackageDb
   { _tblAccountDetails :: f (TableEntity AccountDetailsT),
-    _tblUsers :: f (TableEntity UsersT)
+    _tblUsers :: f (TableEntity UsersT),
+    _tblUserTokens :: f (TableEntity UserTokensT)
   }
   deriving stock (Generic)
 
diff --git a/src/Distribution/Server/Features/Users.hs b/src/Distribution/Server/Features/Users.hs
index beaaa3300..050b527e4 100644
--- a/src/Distribution/Server/Features/Users.hs
+++ b/src/Distribution/Server/Features/Users.hs
@@ -303,6 +303,17 @@ migrateStateToDatabase usersState adminsState DatabaseFeature{..} = do
             _uAuthInfo = authInfo,
             _uAdmin = Group.member uid admins
           }])
+
+      forM_ (Map.toList (userTokens uinfo)) $ \(token, desc) -> do
+        Database.runInsert $
+          insert
+            (_tblUserTokens Database.hackageDb)
+            (insertExpressions [UserTokensRow {
+              _utId = default_,
+              _utUserId = val_ uid,
+              _utToken = val_ token,
+              _utDescription = val_ desc
+            }])
    
 
 usersStateComponent :: FilePath -> IO (StateComponent AcidState Users.Users)
diff --git a/src/Distribution/Server/Users/AuthToken.hs b/src/Distribution/Server/Users/AuthToken.hs
index 4a2174270..bae92360f 100644
--- a/src/Distribution/Server/Users/AuthToken.hs
+++ b/src/Distribution/Server/Users/AuthToken.hs
@@ -1,5 +1,6 @@
 {-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
 module Distribution.Server.Users.AuthToken
     ( AuthToken
     , parseAuthToken, parseAuthTokenM, renderAuthToken
@@ -25,6 +26,11 @@ import qualified Distribution.Compat.CharParsing as P
 
 import Data.SafeCopy
 
+import Database.Beam
+import Database.Beam.Backend
+import Database.Beam.Sqlite
+import Database.Beam.Sqlite.Syntax
+
 -- | Contains the original token which will be shown to the user
 -- once and is NOT stored on the server. The user is expected
 -- to provide this token on each request that should be
@@ -36,6 +42,12 @@ newtype OriginalToken = OriginalToken Nonce
 newtype AuthToken = AuthToken BSS.ShortByteString
     deriving (Eq, Ord, Read, Show, MemSize)
 
+instance FromBackendRow Sqlite AuthToken where
+  fromBackendRow = AuthToken . BSS.toShort <$> fromBackendRow
+
+instance HasSqlValueSyntax SqliteValueSyntax AuthToken where
+  sqlValueSyntax (AuthToken v) = sqlValueSyntax (BSS.fromShort v)
+
 convertToken :: OriginalToken -> AuthToken
 convertToken (OriginalToken bs) =
     AuthToken $ BSS.toShort $ SHA256.hash $ getRawNonceBytes bs
diff --git a/src/Distribution/Server/Users/State.hs b/src/Distribution/Server/Users/State.hs
index d131cea39..e5d2cc956 100644
--- a/src/Distribution/Server/Users/State.hs
+++ b/src/Distribution/Server/Users/State.hs
@@ -20,6 +20,7 @@ import Control.Monad.Reader
 import qualified Control.Monad.State as State
 import qualified Data.Text as T
 
+import Data.Int
 import Data.Text
 import Database.Beam
 import Database.Beam.Backend.SQL.SQL92 (HasSqlValueSyntax (..), autoSqlValueSyntax)
@@ -217,4 +218,25 @@ instance FromBackendRow Sqlite UsersStatus where
   fromBackendRow = read . unpack <$> fromBackendRow
 
 newtype DBUserName = DBUserName Text
-  deriving newtype (Eq, Ord, Read, Show, FromBackendRow Sqlite, HasSqlValueSyntax SqliteValueSyntax)
\ No newline at end of file
+  deriving newtype (Eq, Ord, Read, Show, FromBackendRow Sqlite, HasSqlValueSyntax SqliteValueSyntax)
+
+data UserTokensT f
+  = UserTokensRow
+  { _utId :: Columnar f Int32,
+    _utUserId :: Columnar f UserId,
+    _utDescription :: Columnar f Text,
+    _utToken :: Columnar f AuthToken
+  }
+  deriving (Generic, Beamable)
+
+type UserTokenRow = UserTokensT Identity
+
+deriving instance Show UserTokenRow
+
+deriving instance Eq UserTokenRow
+
+type UserTokensId = PrimaryKey UserTokensT Identity
+
+instance Table UserTokensT where
+  data PrimaryKey UserTokensT f = UserTokensId (Columnar f Int32) deriving (Generic, Beamable)
+  primaryKey = UserTokensId . _utId  
\ No newline at end of file
diff --git a/src/Distribution/Server/Users/Types.hs b/src/Distribution/Server/Users/Types.hs
index 52d8ab09b..611747eb9 100644
--- a/src/Distribution/Server/Users/Types.hs
+++ b/src/Distribution/Server/Users/Types.hs
@@ -35,7 +35,6 @@ import Data.Hashable
 import Data.Serialize (Serialize)
 import Database.Beam
 import Database.Beam.Backend
-import Database.Beam.Backend.SQL.SQL92 ()
 import Database.Beam.Sqlite
 import Database.Beam.Sqlite.Syntax
 

From bdb68fccaebf9d7beb6d947776d2c63cdfcd1e2a Mon Sep 17 00:00:00 2001
From: "Brian J. Cardiff" <bcardiff@gmail.com>
Date: Sat, 14 Feb 2026 22:07:12 -0300
Subject: [PATCH 32/34] Cleanup

---
 src/Distribution/Server/Features/UserDetails.hs | 4 ----
 1 file changed, 4 deletions(-)

diff --git a/src/Distribution/Server/Features/UserDetails.hs b/src/Distribution/Server/Features/UserDetails.hs
index 1cf2e0bf1..fb8dfdafe 100644
--- a/src/Distribution/Server/Features/UserDetails.hs
+++ b/src/Distribution/Server/Features/UserDetails.hs
@@ -341,10 +341,6 @@ userDetailsFeature templates userDetailsState DatabaseFeature{..} UserFeature{..
       , resourceDelete = [ ("", handlerDeleteAdminInfo) ]
       }
 
-    -- handlerWithConnection :: (Database.Connection -> DynamicPath -> ServerPartE Response) -> DynamicPath -> ServerPartE Response
-    -- handlerWithConnection handler dpath =
-    --   Database.withConnection $ \conn -> _ handler conn dpath
-
     -- Queries and updates
     --
 

From 42e5aab942453c68f4be0133448daac38fdd0767 Mon Sep 17 00:00:00 2001
From: "Brian J. Cardiff" <bcardiff@gmail.com>
Date: Sat, 14 Feb 2026 22:16:14 -0300
Subject: [PATCH 33/34] Use lookup_

---
 src/Distribution/Server/Features/UserDetails.hs | 4 +---
 1 file changed, 1 insertion(+), 3 deletions(-)

diff --git a/src/Distribution/Server/Features/UserDetails.hs b/src/Distribution/Server/Features/UserDetails.hs
index fb8dfdafe..1c83fca7c 100644
--- a/src/Distribution/Server/Features/UserDetails.hs
+++ b/src/Distribution/Server/Features/UserDetails.hs
@@ -474,9 +474,7 @@ dbModifyAccountDetails uid change = do
 accountDetailsFindByUserId :: UserId -> Database.Transaction (Maybe AccountDetailsRow)
 accountDetailsFindByUserId uid =
   Database.runSelectReturningOne $
-    select $
-      filter_ (\ad -> _adUserId ad ==. val_ uid) $
-        all_ (_tblAccountDetails Database.hackageDb)
+    lookup_ (_tblAccountDetails Database.hackageDb) (AccountDetailsId uid)
 
 -- Use the values from the INSERT that caused the conflict
 accountDetailsUpsert :: AccountDetailsRow -> Database.Transaction ()

From 79aacce7bbd1766b3a6184cc31e68e9d8cc48a0c Mon Sep 17 00:00:00 2001
From: "Brian J. Cardiff" <bcardiff@gmail.com>
Date: Sat, 14 Feb 2026 22:35:07 -0300
Subject: [PATCH 34/34] Insert multiple rows at once

---
 src/Distribution/Server/Features/Users.hs | 68 +++++++++++++----------
 1 file changed, 40 insertions(+), 28 deletions(-)

diff --git a/src/Distribution/Server/Features/Users.hs b/src/Distribution/Server/Features/Users.hs
index 050b527e4..bfa032aa8 100644
--- a/src/Distribution/Server/Features/Users.hs
+++ b/src/Distribution/Server/Features/Users.hs
@@ -285,35 +285,47 @@ migrateStateToDatabase usersState adminsState DatabaseFeature{..} = do
   users <- queryState usersState GetUserDb
   admins <- queryState adminsState GetAdminList
 
+  let usersAndTokens =
+        map (\(uid, uinfo) -> 
+           ( (uid, uinfo), 
+             map (\(token, desc) -> (uid, token, desc)) 
+                 (Map.toList (userTokens uinfo))
+           )
+        ) (Users.enumerateAllUsers users)
+  
+  let usersToInsert = map fst usersAndTokens
+  let tokensToInsert = concatMap snd usersAndTokens
   withTransaction $ do
-    forM_ (Users.enumerateAllUsers users) $ \(uid, uinfo) -> do
-      let (status, authInfo) = 
-            case userStatus uinfo of
-              AccountEnabled a -> (Enabled, Just a)
-              AccountDisabled ma -> (Disabled, ma)
-              AccountDeleted -> (Deleted, Nothing)
-
-      Database.runInsert $
-        insert
-          (_tblUsers Database.hackageDb)
-          (insertValues [UsersRow {
-            _uId = uid,
-            _uUsername = userName uinfo,
-            _uStatus = status,
-            _uAuthInfo = authInfo,
-            _uAdmin = Group.member uid admins
-          }])
-
-      forM_ (Map.toList (userTokens uinfo)) $ \(token, desc) -> do
-        Database.runInsert $
-          insert
-            (_tblUserTokens Database.hackageDb)
-            (insertExpressions [UserTokensRow {
-              _utId = default_,
-              _utUserId = val_ uid,
-              _utToken = val_ token,
-              _utDescription = val_ desc
-            }])
+    Database.runInsert $
+      insert
+        (_tblUsers Database.hackageDb)
+        (insertValues (map (\(uid, uinfo) -> 
+          let (status, authInfo) = 
+                case userStatus uinfo of
+                  AccountEnabled a  -> (Enabled, Just a)
+                  AccountDisabled ma -> (Disabled, ma)
+                  AccountDeleted    -> (Deleted, Nothing)
+          in
+            UsersRow {
+              _uId       = uid,
+              _uUsername = userName uinfo,
+              _uStatus   = status,
+              _uAuthInfo = authInfo,
+              _uAdmin    = Group.member uid admins
+            }
+        ) usersToInsert))
+
+    Database.runInsert $
+      insert
+        (_tblUserTokens Database.hackageDb)
+        (insertExpressions (map (\(uid, token, desc) ->
+          UserTokensRow {
+            _utId          = default_,
+            _utUserId      = val_ uid,
+            _utToken       = val_ token,
+            _utDescription = val_ desc
+          }
+        ) tokensToInsert))
    
 
 usersStateComponent :: FilePath -> IO (StateComponent AcidState Users.Users)