From 1464e982b759e7d1d67f1a3c1a234abf811362d1 Mon Sep 17 00:00:00 2001 From: Janus Troelsen Date: Sun, 18 Oct 2026 11:19:13 -0600 Subject: [PATCH 1/2] Narrow package index queries in the core feature Call sites that only need part of the package index now ask the core feature for exactly that, rather than fetching the whole index: - single-package lookups use queryLookupPackageName - new queryAllPackageNames, queryAllPackageIds and queryCountPackages serve callers that need names, IDs or the package count - new queryLatestUploadsBetween serves the notification job's recent uploads and revisions The acid store implements the new Store fields over the in-memory index, so behaviour is unchanged. --- src/Distribution/Server/Features.hs | 4 +-- src/Distribution/Server/Features/Core.hs | 30 +++++++++++++++++-- src/Distribution/Server/Features/Core/Acid.hs | 25 ++++++++++------ .../Server/Features/Core/Store.hs | 8 +++++ src/Distribution/Server/Features/Html.hs | 10 ++----- .../Server/Features/PackageCandidates.hs | 7 +++-- .../Server/Features/PreferredVersions.hs | 12 ++++---- src/Distribution/Server/Features/Upload.hs | 2 +- .../Server/Features/UserNotify.hs | 17 ++++------- 9 files changed, 71 insertions(+), 44 deletions(-) diff --git a/src/Distribution/Server/Features.hs b/src/Distribution/Server/Features.hs index c8aa49a16..b9d6d20ad 100644 --- a/src/Distribution/Server/Features.hs +++ b/src/Distribution/Server/Features.hs @@ -15,7 +15,7 @@ import Distribution.Server.Framework.Logging import Distribution.Server.Features.StaticFiles (initStaticFilesFeature) import Distribution.Server.Features.Users (initUserFeature, UserFeature) -import Distribution.Server.Features.Core (initCoreFeature, coreResource, queryGetPackageIndex) +import Distribution.Server.Features.Core (initCoreFeature, coreResource, queryAllPackageIds) import Distribution.Server.Features.Security (initSecurityFeature) import Distribution.Server.Features.Upload (initUploadFeature) import Distribution.Server.Features.Mirror (initMirrorFeature) @@ -243,7 +243,7 @@ initHackageFeatures env@ServerEnv{serverVerbosity = verbosity} = do documentationCoreFeature <- mkDocumentationCoreFeature (coreResource coreFeature) - (map packageId . allPackages <$> queryGetPackageIndex coreFeature) + (queryAllPackageIds coreFeature) uploadFeature tarIndexCacheFeature reportsCoreFeature diff --git a/src/Distribution/Server/Features/Core.hs b/src/Distribution/Server/Features/Core.hs index f30dc86dd..fdc4a0426 100644 --- a/src/Distribution/Server/Features/Core.hs +++ b/src/Distribution/Server/Features/Core.hs @@ -83,6 +83,19 @@ data CoreFeature = CoreFeature { -- | Retrieves the latest version of every package. queryLatestPackages :: forall m. MonadIO m => m [PkgInfo], + -- | Retrieves the name of every package, in ascending order. + queryAllPackageNames :: forall m. MonadIO m => m [PackageName], + + -- | Retrieves the ID of every version of every package. + queryAllPackageIds :: forall m. MonadIO m => m [PackageId], + + -- | Counts the packages, i.e. the number of distinct package names. + queryCountPackages :: forall m. MonadIO m => m Int, + + -- | Retrieves the package versions whose latest upload or revision + -- happened after the first time and no later than the second. + queryLatestUploadsBetween :: forall m. MonadIO m => UTCTime -> UTCTime -> m [PkgInfo], + -- | Retrieve the raw tarball info queryGetIndexTarballInfo :: forall m. MonadIO m => m IndexTarballInfo, @@ -508,6 +521,18 @@ coreFeature ServerEnv{serverBlobStore = store} UserFeature{..} queryLatestPackages :: MonadIO m => m [PkgInfo] queryLatestPackages = Store.latestPackages packagesStore + queryAllPackageNames :: MonadIO m => m [PackageName] + queryAllPackageNames = Store.allPackageNames packagesStore + + queryAllPackageIds :: MonadIO m => m [PackageId] + queryAllPackageIds = Store.allPackageIds packagesStore + + queryCountPackages :: MonadIO m => m Int + queryCountPackages = Store.countPackages packagesStore + + queryLatestUploadsBetween :: MonadIO m => UTCTime -> UTCTime -> m [PkgInfo] + queryLatestUploadsBetween = Store.latestUploadsBetween packagesStore + queryGetIndexTarballInfo :: MonadIO m => m IndexTarballInfo queryGetIndexTarballInfo = readAsyncCache cacheIndexTarball @@ -683,9 +708,8 @@ coreFeature ServerEnv{serverBlobStore = store} UserFeature{..} -- as we don't keep the parsed cabal files in memory) servePackageList :: DynamicPath -> ServerPartE Response servePackageList _ = do - pkgIndex <- queryGetPackageIndex - let pkgNames = PackageIndex.allPackageNames pkgIndex - list = map display pkgNames + pkgNames <- queryAllPackageNames + let list = map display pkgNames -- We construct the JSON manually so that we control what it looks like; -- in particular, we use objects for the packages so that we can add -- additional fields later without (hopefully) breaking clients diff --git a/src/Distribution/Server/Features/Core/Acid.hs b/src/Distribution/Server/Features/Core/Acid.hs index 9cbf31095..2d7767f87 100644 --- a/src/Distribution/Server/Features/Core/Acid.hs +++ b/src/Distribution/Server/Features/Core/Acid.hs @@ -9,24 +9,31 @@ import qualified Distribution.Server.Features.Core.State as Acid import Distribution.Server.Features.Security.Migration import Distribution.Server.Framework import qualified Distribution.Server.Packages.PackageIndex as PackageIndex +import Distribution.Server.Packages.Types (PkgInfo, pkgLatestUploadTime) + +import Distribution.Package (packageId) import qualified Data.List.NonEmpty as NE acidStore :: ServerEnv -> Verbosity -> Bool -> FilePath -> IO Backend acidStore env verbosity freshDB stateDir = do packagesState <- packagesStateComponent verbosity freshDB stateDir + let withIndex :: MonadIO m => (PackageIndex.PackageIndex PkgInfo -> a) -> m a + withIndex f = f . Acid.packageIndex <$> queryState packagesState Acid.GetPackagesState pure Backend { backendStore = Store { getPackagesState = queryState packagesState Acid.GetPackagesState - , lookupPackageName = \pkgname -> do - packages <- queryState packagesState Acid.GetPackagesState - pure (PackageIndex.lookupPackageName (Acid.packageIndex packages) pkgname) - , lookupPackageId = \pkgid -> do - packages <- queryState packagesState Acid.GetPackagesState - pure (PackageIndex.lookupPackageId (Acid.packageIndex packages) pkgid) - , latestPackages = do - packages <- queryState packagesState Acid.GetPackagesState - pure (NE.last <$> PackageIndex.allPackagesByNameNE (Acid.packageIndex packages)) + , lookupPackageName = \pkgname -> withIndex (`PackageIndex.lookupPackageName` pkgname) + , lookupPackageId = \pkgid -> withIndex (`PackageIndex.lookupPackageId` pkgid) + , latestPackages = withIndex (map NE.last . PackageIndex.allPackagesByNameNE) + , allPackageNames = withIndex PackageIndex.allPackageNames + , allPackageIds = withIndex (map packageId . PackageIndex.allPackages) + , countPackages = withIndex PackageIndex.indexSize + , latestUploadsBetween = \earlier later -> + let isBetween pkginfo = + let t = pkgLatestUploadTime pkginfo + in t > earlier && t <= later + in withIndex (filter isBetween . PackageIndex.allPackages) , addPackage = \pkginfo uploadinfo username entries -> updateState packagesState (Acid.AddPackage3 pkginfo uploadinfo username entries) , deletePackage = \pkgid -> diff --git a/src/Distribution/Server/Features/Core/Store.hs b/src/Distribution/Server/Features/Core/Store.hs index 23856468a..56c23787a 100644 --- a/src/Distribution/Server/Features/Core/Store.hs +++ b/src/Distribution/Server/Features/Core/Store.hs @@ -27,6 +27,14 @@ data Store = Store { , lookupPackageName :: forall m. MonadIO m => PackageName -> m [PkgInfo] , lookupPackageId :: forall m. MonadIO m => PackageId -> m (Maybe PkgInfo) , latestPackages :: forall m. MonadIO m => m [PkgInfo] + -- | Every package name, in ascending order. + , allPackageNames :: forall m. MonadIO m => m [PackageName] + , allPackageIds :: forall m. MonadIO m => m [PackageId] + -- | The number of distinct package names, not package versions. + , countPackages :: forall m. MonadIO m => m Int + -- | Package versions whose latest upload or revision is after the first + -- time and no later than the second. + , latestUploadsBetween :: forall m. MonadIO m => UTCTime -> UTCTime -> m [PkgInfo] , addPackage :: forall m. MonadIO m => PkgInfo -> UploadInfo -> UserName -> [TarIndexEntry] -> m Bool , deletePackage :: forall m. MonadIO m => PackageId -> m (Maybe PkgInfo) , addPackageRevision :: forall m. MonadIO m => PackageId -> CabalFileText -> UploadInfo -> UserName -> m (Maybe PkgInfo, PkgInfo) diff --git a/src/Distribution/Server/Features/Html.hs b/src/Distribution/Server/Features/Html.hs index 9fffd0f39..a85ceef34 100644 --- a/src/Distribution/Server/Features/Html.hs +++ b/src/Distribution/Server/Features/Html.hs @@ -44,7 +44,6 @@ import qualified Distribution.Server.Users.Group as Group import Distribution.Server.Packages.Types import Distribution.Server.Packages.Render import qualified Distribution.Server.Users.Users as Users -import qualified Distribution.Server.Packages.PackageIndex as PackageIndex import Distribution.Server.Users.Group (UserGroup(..)) import qualified Distribution.Server.Pages.Package as Pages @@ -1325,9 +1324,7 @@ mkHtmlCandidates ServerEnv{..} utilities@HtmlUtilities{..} candRender <- liftIO $ candidateRender cand let PackageIdentifier pkgname version = packageId cand render = candPackageRender candRender - otherVersions <- map packageVersion - . flip PackageIndex.lookupPackageName pkgname - <$> queryGetPackageIndex + otherVersions = indexedVersions candRender prefInfo <- queryGetPreferredInfo pkgname let maintainHtml = anchor ! [href $ renderResource maintain [display $ packageId cand]] << "maintain" -- bottom sections, currently documentation and readme @@ -1350,7 +1347,6 @@ mkHtmlCandidates ServerEnv{..} utilities@HtmlUtilities{..} let docURL = packageDocsContentUri docs (packageId cand) - -- also utilize hasIndexedPackage :: Bool let warningBox = case renderWarnings candRender of [] -> [] warn -> [thediv ! [theclass "candidate-warn"] << [paragraph << strong (toHtml "Warnings:"), unordList warn]] @@ -2119,7 +2115,7 @@ mkHtmlReverse HtmlUtilities{..} , corePackageIdUri , corePackageNameUri }, - queryGetPackageIndex + queryCountPackages } VersionsFeature{withPackageVersion} ListFeature{} @@ -2188,6 +2184,6 @@ mkHtmlReverse HtmlUtilities{..} serveReverseList :: DynamicPath -> ServerPartE Response serveReverseList _ = do namesWithCounts <- revCountForAllPackages - hackCount <- PackageIndex.indexSize <$> queryGetPackageIndex + hackCount <- queryCountPackages return $ toResponse $ Resource.XHtml $ hackagePage "Reverse dependencies" $ reversePackagesRender (corePackageNameUri "") hackCount namesWithCounts diff --git a/src/Distribution/Server/Features/PackageCandidates.hs b/src/Distribution/Server/Features/PackageCandidates.hs index 28ec3ec2a..dfc9a9849 100644 --- a/src/Distribution/Server/Features/PackageCandidates.hs +++ b/src/Distribution/Server/Features/PackageCandidates.hs @@ -126,7 +126,7 @@ data PackageCandidatesResource = PackageCandidatesResource { data CandidateRender = CandidateRender { candPackageRender :: PackageRender, renderWarnings :: [String], - hasIndexedPackage :: Bool + indexedVersions :: [Version] } @@ -168,6 +168,7 @@ candidatesFeature ServerEnv{serverBlobStore = store} UserFeature{..} CoreFeature{ coreResource=core@CoreResource{packageInPath, packageTarballInPath} , queryGetPackageIndex + , queryLookupPackageName , updateAddPackage } UploadFeature{..} @@ -516,7 +517,7 @@ candidatesFeature ServerEnv{serverBlobStore = store} candidateRender :: CandPkgInfo -> IO CandidateRender candidateRender cand = do users <- queryGetUserDb - index <- queryGetPackageIndex + indexedPkgs <- queryLookupPackageName (packageName cand) let pkg = candPkgInfo cand changeLog <- findToplevelFile pkg isChangeLogFile >>= either (\_ -> return Nothing) (return . Just) @@ -528,7 +529,7 @@ candidatesFeature ServerEnv{serverBlobStore = store} , rendChangeLog = changeLog , rendReadme = readme}, renderWarnings = candWarnings cand, - hasIndexedPackage = not . null $ PackageIndex.lookupPackageName index (packageName cand) + indexedVersions = map packageVersion indexedPkgs } ------------------------------------------------------------------------------ diff --git a/src/Distribution/Server/Features/PreferredVersions.hs b/src/Distribution/Server/Features/PreferredVersions.hs index a654aa175..e86b54d18 100644 --- a/src/Distribution/Server/Features/PreferredVersions.hs +++ b/src/Distribution/Server/Features/PreferredVersions.hs @@ -30,7 +30,6 @@ import Distribution.Server.Features.Upload import Distribution.Server.Features.Users import Distribution.Server.Features.Tags -import qualified Distribution.Server.Packages.PackageIndex as PackageIndex import Distribution.Server.Packages.Types import Distribution.Package @@ -271,9 +270,9 @@ versionsFeature ServerEnv{ serverVerbosity = verbosity } withPackageVersion :: PackageId -> (PkgInfo -> ServerPartE a) -> ServerPartE a withPackageVersion pkgid func = do - pkgIndex <- queryGetPackageIndex guard (packageVersion pkgid /= nullVersion) - case PackageIndex.lookupPackageName pkgIndex (packageName pkgid) of + pkgs <- queryLookupPackageName (packageName pkgid) + case pkgs of [] -> packageError [MText $ "No such package in package index. ", MLink "Search for related terms instead?"$ "/packages/search?terms=" ++ (display $ pkgName pkgid)] pkg -> case find ((== packageVersion pkgid) . packageVersion) pkg of Nothing -> packageError [MText $ "No such package version for " ++ display (packageName pkgid)] @@ -286,8 +285,8 @@ versionsFeature ServerEnv{ serverVerbosity = verbosity } -- which is outside of the scope of this feature. withPackagePreferred :: PackageId -> (PkgInfo -> [PkgInfo] -> ServerPartE a) -> ServerPartE a withPackagePreferred pkgid func = do - pkgIndex <- queryGetPackageIndex - case PackageIndex.lookupPackageName pkgIndex (packageName pkgid) of + allPkgs <- queryLookupPackageName (packageName pkgid) + case allPkgs of [] -> packageError [MText "No such package in package index. ", MLink "Search for related terms instead?" $ "/packages/search?terms=" ++ (display $ pkgName pkgid)] pkgs | pkgVersion pkgid == nullVersion -> Store.getPreferredInfo preferredStore (packageName pkgid) >>= \info -> do let rangeToCheck = sumRange info @@ -346,13 +345,12 @@ versionsFeature ServerEnv{ serverVerbosity = verbosity } putDeprecated pkgname = do guardValidPackageName pkgname guardAuthorisedAsMaintainerOrTrustee pkgname - index <- queryGetPackageIndex isDepr <- optional $ look "deprecated" case isDepr of Just {} -> do depr <- optional $ fmap words $ look "by" case mapM simpleParse =<< depr of - Just deprs -> case filter (null . PackageIndex.lookupPackageName index) deprs of + Just deprs -> filterM (fmap null . queryLookupPackageName) deprs >>= \case [] -> case pkgname `elem` deprs of True -> deprecatedError "You can not deprecate a package in favor of itself!" _ -> do diff --git a/src/Distribution/Server/Features/Upload.hs b/src/Distribution/Server/Features/Upload.hs index 03cca15ba..28c2533e7 100644 --- a/src/Distribution/Server/Features/Upload.hs +++ b/src/Distribution/Server/Features/Upload.hs @@ -132,7 +132,7 @@ initUploadFeature env@ServerEnv{serverStateDir} = do (uploadersGroup, uploadersGroupResource) <- groupResourceAt "/packages/uploaders" uploadersGroupDescription - pkgNames <- PackageIndex.packageNames <$> queryGetPackageIndex + pkgNames <- queryAllPackageNames (maintainersGroup, maintainersGroupResource) <- groupResourcesAt "/package/:package/maintainers" maintainersGroupDescription diff --git a/src/Distribution/Server/Features/UserNotify.hs b/src/Distribution/Server/Features/UserNotify.hs index 7370513fd..24d8775fc 100644 --- a/src/Distribution/Server/Features/UserNotify.hs +++ b/src/Distribution/Server/Features/UserNotify.hs @@ -483,7 +483,7 @@ userNotifyFeature UserFeature{..} else lastNotifyTime -- for testing you can increase this users <- queryGetUserDb - revisionsAndUploads <- collectRevisionsAndUploads trimLastTime now + revisionsAndUploads <- queryLatestUploadsBetween trimLastTime now revisionUploadNotifications <- concatMapM (genRevUploadList notifyPrefs trimLastTime now) revisionsAndUploads groupActions <- collectAdminActions trimLastTime now @@ -515,13 +515,6 @@ userNotifyFeature UserFeature{..} Store.setNotifyTime notifyStore now - collectRevisionsAndUploads earlier now = do - pkgIndex <- queryGetPackageIndex - let isRecent pkgInfo = - let rt = pkgLatestUploadTime pkgInfo - in rt > earlier && rt <= now - return $ filter isRecent $ (PackageIndex.allPackages pkgIndex) - collectAdminActions earlier now = do aLog <- queryGetAdminLog let isRecent (t,_,_,_) = t > earlier && t <= now @@ -546,13 +539,13 @@ userNotifyFeature UserFeature{..} pure $ Map.toList logs genRevUploadList notifyPrefs earlier now pkg = do - pkgIndex <- queryGetPackageIndex + let pkgName = packageName . pkgInfoId $ pkg + allVersions <- queryLookupPackageName pkgName let actor = pkgLatestUploadUser pkg isRevision = pkgNumRevisions pkg > 1 - pkgName = packageName . pkgInfoId $ pkg - mbLatest = listToMaybe . take 1 . reverse $ PackageIndex.lookupPackageName pkgIndex pkgName + mbLatest = listToMaybe (reverse allVersions) isLatestVersion = maybe False (\x -> pkgInfoId pkg == pkgInfoId x) mbLatest - maintainers <- queryUserGroup $ maintainersGroup (packageName . pkgInfoId $ pkg) + maintainers <- queryUserGroup $ maintainersGroup pkgName pure . flip mapMaybe (toList maintainers) $ \uid -> fmap (uid,) $ do let Acid.NotifyPref{..} = fromMaybe Acid.defaultNotifyPrefs (Map.lookup uid notifyPrefs) From 80ad9dcf542df4fd37c7889a8c47af9c7ef7d51f Mon Sep 17 00:00:00 2001 From: Janus Troelsen Date: Sun, 18 Oct 2026 11:27:02 -0600 Subject: [PATCH 2/2] Narrow user database queries for auth and lookups Authentication no longer needs the whole user database: it takes a UserLookup with name and API token lookups, and the privilege checks drop the user database argument they never used. The users store gains lookups by id, name and token, listings of all and active users, and a user name search. Callers that looked up a single user, listed users, or searched by name use these instead of fetching the whole user database. --- .../Server/Features/AdminFrontend.hs | 15 +-- src/Distribution/Server/Features/Core.hs | 12 +- src/Distribution/Server/Features/Html.hs | 2 +- src/Distribution/Server/Features/Mirror.hs | 5 +- src/Distribution/Server/Features/Users.hs | 113 +++++++++------- .../Server/Features/Users/Acid.hs | 18 +++ .../Server/Features/Users/Store.hs | 10 +- src/Distribution/Server/Framework/Auth.hs | 127 ++++++++++-------- src/Distribution/Server/Users/Users.hs | 14 +- 9 files changed, 185 insertions(+), 131 deletions(-) diff --git a/src/Distribution/Server/Features/AdminFrontend.hs b/src/Distribution/Server/Features/AdminFrontend.hs index a9a81c73a..47c7f4a1f 100644 --- a/src/Distribution/Server/Features/AdminFrontend.hs +++ b/src/Distribution/Server/Features/AdminFrontend.hs @@ -17,9 +17,7 @@ import Distribution.Server.Features.UserSignup import Distribution.Server.Users.Types import qualified Distribution.Server.Users.Users as Users import Distribution.Text -import Distribution.Simple.Utils (lowercase) -import Data.List import qualified Data.Text as T import Control.Applicative (optional) import Data.Maybe (isJust) @@ -104,9 +102,7 @@ adminFrontendFeature _env templates findAccount <- optional (look "find-account") accounts <- case findAccount of Nothing -> return [] - Just searchTerms -> do - users <- queryGetUserDb - return (accountSearch users searchTerms) + Just searchTerms -> querySearchUserNames (words searchTerms) findSignup <- optional (lookText' "find-signup") signups <- case findSignup of @@ -123,13 +119,6 @@ adminFrontendFeature _env templates , "signups" $= map signupRequestToTemplate signups ] where - accountSearch users searchTerms = - [ (uid, uinfo) - | let terms = map lowercase (words searchTerms) - , (uid, uinfo@UserInfo{ userName = UserName uname }) - <- Users.enumerateAllUsers users - , any (`isInfixOf` lowercase uname) terms ] - signupSearch allSignupInfo searchTerms = [ signupInfo | let terms = map T.toCaseFold (T.words searchTerms) @@ -157,7 +146,7 @@ adminFrontendFeature _env templates guardAuthorised_ [InGroup adminGroup] cacheControlWithoutETag [Private] template <- getTemplate templates "accounts.html" - accounts <- Users.enumerateAllUsers <$> queryGetUserDb + accounts <- queryAllUsers ok $ toResponse $ template [ "accounts" $= [ accountBasicInfoToTemplate uid uinfo | (uid, uinfo) <- accounts ] diff --git a/src/Distribution/Server/Features/Core.hs b/src/Distribution/Server/Features/Core.hs index fdc4a0426..b7fb3f9c3 100644 --- a/src/Distribution/Server/Features/Core.hs +++ b/src/Distribution/Server/Features/Core.hs @@ -50,8 +50,7 @@ import qualified Distribution.Server.Packages.PackageIndex as PackageIn import Distribution.Server.Packages.Types import Distribution.Server.Users.Types (UserId, userName) -import Distribution.Server.Users.Users (lookupUserId, - userIdToName) +import Distribution.Server.Users.Users (userIdToName) -- Cabal import Distribution.Package @@ -86,7 +85,6 @@ data CoreFeature = CoreFeature { -- | Retrieves the name of every package, in ascending order. queryAllPackageNames :: forall m. MonadIO m => m [PackageName], - -- | Retrieves the ID of every version of every package. queryAllPackageIds :: forall m. MonadIO m => m [PackageId], -- | Counts the packages, i.e. the number of distinct package names. @@ -546,8 +544,8 @@ coreFeature ServerEnv{serverBlobStore = store} UserFeature{..} -> CabalFileText -> UploadInfo -> Maybe PkgTarball -> m Bool updateAddPackage pkgid cabalFile uploadinfo@(_, uid) mtarball = logTiming maxBound ("updateAddPackage " ++ display pkgid) $ do - usersdb <- queryGetUserDb - let Just userInfo = lookupUserId uid usersdb + muserInfo <- queryLookupUserId uid + let Just userInfo = muserInfo let pkginfo = Acid.mkPackageInfo pkgid cabalFile uploadinfo mtarball additionalEntries <- concat `liftM` runHook preIndexUpdateHook (PackageChangeAdd pkginfo) @@ -575,8 +573,8 @@ coreFeature ServerEnv{serverBlobStore = store} UserFeature{..} updateAddPackageRevision :: MonadIO m => PackageId -> CabalFileText -> UploadInfo -> m () updateAddPackageRevision pkgid cabalfile uploadinfo@(_, uid) = logTiming maxBound ("updateAddPackageRevision " ++ display pkgid) $ do - usersdb <- queryGetUserDb - let Just userInfo = lookupUserId uid usersdb + muserInfo <- queryLookupUserId uid + let Just userInfo = muserInfo (moldpkginfo, newpkginfo) <- Store.addPackageRevision packagesStore pkgid cabalfile diff --git a/src/Distribution/Server/Features/Html.hs b/src/Distribution/Server/Features/Html.hs index a85ceef34..47f6b83db 100644 --- a/src/Distribution/Server/Features/Html.hs +++ b/src/Distribution/Server/Features/Html.hs @@ -901,7 +901,7 @@ mkHtmlUsers UserFeature{..} UserDetailsFeature{..} = HtmlUsers{..} serveUserList :: DynamicPath -> ServerPartE Response serveUserList _ = do - userlist <- Users.enumerateActiveUsers <$> queryGetUserDb + userlist <- queryActiveUsers let hlist = unordList [ anchor ! [href $ userPageUri users "" uname] << display uname | (_, uinfo) <- userlist, let uname = userName uinfo ] diff --git a/src/Distribution/Server/Features/Mirror.hs b/src/Distribution/Server/Features/Mirror.hs index 253c6a63e..560a571b8 100644 --- a/src/Distribution/Server/Features/Mirror.hs +++ b/src/Distribution/Server/Features/Mirror.hs @@ -186,8 +186,9 @@ mirrorFeature ServerEnv{serverBlobStore = store} uploaderGet dpath = do pkg <- packageInPath dpath >>= lookupPackageId - userdb <- queryGetUserDb - return $ toResponse $ display (userIdToName userdb (pkgLatestUploadUser pkg)) + let uid = pkgLatestUploadUser pkg + muser <- queryLookupUserId uid + return $ toResponse $ display (userNameOrPlaceholder uid muser) uploaderPut :: DynamicPath -> ServerPartE Response uploaderPut dpath = do diff --git a/src/Distribution/Server/Features/Users.hs b/src/Distribution/Server/Features/Users.hs index 227098bf3..04482cb7a 100644 --- a/src/Distribution/Server/Features/Users.hs +++ b/src/Distribution/Server/Features/Users.hs @@ -73,6 +73,15 @@ data UserFeature = UserFeature { authFailHook :: Hook Auth.AuthError (Maybe ErrorResponse), -- | Retrieves the entire user base. queryGetUserDb :: forall m. MonadIO m => m Acid.Users, + queryLookupUserId :: forall m. MonadIO m => UserId -> m (Maybe UserInfo), + queryLookupUserName :: forall m. MonadIO m => UserName -> m (Maybe (UserId, UserInfo)), + -- | Retrieves every user account, including disabled and deleted ones. + queryAllUsers :: forall m. MonadIO m => m [(UserId, UserInfo)], + -- | Retrieves every user account except deleted ones. + queryActiveUsers :: forall m. MonadIO m => m [(UserId, UserInfo)], + -- | Retrieves the user accounts whose name contains any of the given + -- terms, ignoring case. + querySearchUserNames :: forall m. MonadIO m => [String] -> m [(UserId, UserInfo)], -- | Creates a Hackage 2 user credential. newUserAuth :: UserName -> PasswdPlain -> UserAuth, @@ -366,6 +375,21 @@ userFeature templates UserStore.Backend{backendStore = userStore, backendState = queryGetUserDb :: MonadIO m => m Acid.Users queryGetUserDb = UserStore.getUsers userStore + queryLookupUserId :: MonadIO m => UserId -> m (Maybe UserInfo) + queryLookupUserId = UserStore.lookupUserId userStore + + queryLookupUserName :: MonadIO m => UserName -> m (Maybe (UserId, UserInfo)) + queryLookupUserName = UserStore.lookupUserName userStore + + queryAllUsers :: MonadIO m => m [(UserId, UserInfo)] + queryAllUsers = UserStore.enumerateAllUsers userStore + + queryActiveUsers :: MonadIO m => m [(UserId, UserInfo)] + queryActiveUsers = UserStore.enumerateActiveUsers userStore + + querySearchUserNames :: MonadIO m => [String] -> m [(UserId, UserInfo)] + querySearchUserNames = UserStore.searchUserNames userStore + updateAddUser :: MonadIO m => UserName -> UserAuth -> m (Either Acid.ErrUserNameClash UserId) updateAddUser = UserStore.addUser userStore @@ -385,9 +409,8 @@ userFeature templates UserStore.Backend{backendStore = userStore, backendState = guardAuthorisedWhenInAnyGroup [] = fail "Group list is empty, this is not meant to happen" guardAuthorisedWhenInAnyGroup groups = do - users <- queryGetUserDb - uid <- guardAuthenticatedWithErrHook users - Auth.guardInAnyGroup users uid groups + uid <- guardAuthenticated + Auth.guardInAnyGroup uid groups return uid -- High level, all in one check that the client is authenticated as a @@ -399,25 +422,48 @@ userFeature templates UserStore.Backend{backendStore = userStore, backendState = -- As above but also return the identity of the client guardAuthorised :: [PrivilegeCondition] -> ServerPartE UserId guardAuthorised privconds = do - users <- queryGetUserDb - uid <- guardAuthenticatedWithErrHook users - Auth.guardPriviledged users uid privconds + uid <- guardAuthenticated + Auth.guardPriviledged uid privconds return uid guardAuthorised' :: [PrivilegeCondition] -> ServerPartE Bool guardAuthorised' privconds = do - users <- queryGetUserDb - uid <- guardAuthenticatedWithErrHook users - valid <- Auth.checkPriviledged users uid privconds + uid <- guardAuthenticated + valid <- Auth.checkPriviledged uid privconds return valid -- Simply check if the user is authenticated as some user, without any -- check that they have any particular privileges. Only useful as a -- building block. + -- See note about "authn" cookie below guardAuthenticated :: ServerPartE UserId guardAuthenticated = do - users <- queryGetUserDb - guardAuthenticatedWithErrHook users + uid <- Auth.checkAuthenticated realm userLookup userFeatureServerEnv + >>= either handleAuthError return + addCookie Session (mkCookie "authn" "1") + -- Set-Cookie:authn="1";Path=/;Version="1" + return uid + where + realm = Auth.hackageRealm --TODO: should be configurable + + handleAuthError :: Auth.AuthError -> ServerPartE a + handleAuthError Auth.BadHost { actualHost, oughtToBeHost } = + errForbidden "Bad Host" [MText $ "Authenticated resources can only be accessed using the regular server host name " <> oughtToBeHost <> ", but was provided host " <> show actualHost] + handleAuthError err = do + defaultResponse <- Auth.authErrorResponse realm err + overrideResponse <- msum <$> runHook authFailHook err + let resp' = fromMaybe defaultResponse overrideResponse + -- reset authn to "0" on auth failures + resp'' = case resp' of + r@ErrorResponse{} -> r { errorHeaders = ("Set-Cookie","authn=\"0\";Path=/;Version=\"1\""):errorHeaders r } + GenericErrorResponse -> GenericErrorResponse + throwError resp'' + + userLookup :: Auth.UserLookup + userLookup = Auth.UserLookup { + Auth.lookupUserByName = UserStore.lookupUserName userStore, + Auth.lookupUserByAuthToken = UserStore.lookupAuthToken userStore + } -- [Note about authentication & `authn` hint cookie] -- @@ -450,42 +496,14 @@ userFeature templates UserStore.Backend{backendStore = userStore, backendState = -- will be re-synced on the next authentication -- attempt. - -- As above but using the given userdb snapshot - -- See note about "authn" cookie above - guardAuthenticatedWithErrHook :: Acid.Users -> ServerPartE UserId - guardAuthenticatedWithErrHook users = do - uid <- Auth.checkAuthenticated realm users userFeatureServerEnv - >>= either handleAuthError return - addCookie Session (mkCookie "authn" "1") - -- Set-Cookie:authn="1";Path=/;Version="1" - return uid - where - realm = Auth.hackageRealm --TODO: should be configurable - - handleAuthError :: Auth.AuthError -> ServerPartE a - handleAuthError Auth.BadHost { actualHost, oughtToBeHost } = - errForbidden "Bad Host" [MText $ "Authenticated resources can only be accessed using the regular server host name " <> oughtToBeHost <> ", but was provided host " <> show actualHost] - handleAuthError err = do - defaultResponse <- Auth.authErrorResponse realm err - overrideResponse <- msum <$> runHook authFailHook err - let resp' = fromMaybe defaultResponse overrideResponse - -- reset authn to "0" on auth failures - resp'' = case resp' of - r@ErrorResponse{} -> r { errorHeaders = ("Set-Cookie","authn=\"0\";Path=/;Version=\"1\""):errorHeaders r } - GenericErrorResponse -> GenericErrorResponse - throwError resp'' - -- Check if there is an authenticated userid, and return info, if so. -- See note about "authn" cookie above checkAuthenticated :: ServerPartE (Maybe UserId) checkAuthenticated = do authn <- optional (lookCookieValue "authn") case authn of - Just "1" -> void guardAuthenticated - _ -> pure () - - users <- queryGetUserDb - either (const Nothing) Just `fmap` Auth.checkAuthenticated Auth.hackageRealm users userFeatureServerEnv + Just "1" -> Just <$> guardAuthenticated + _ -> either (const Nothing) Just `fmap` Auth.checkAuthenticated Auth.hackageRealm userLookup userFeatureServerEnv -- | Resources representing the collection of known users. -- @@ -499,7 +517,7 @@ userFeature templates UserStore.Backend{backendStore = userStore, backendState = serveUsersGet :: DynamicPath -> ServerPartE Response serveUsersGet _ = do - userlist <- Acid.enumerateActiveUsers <$> queryGetUserDb + userlist <- queryActiveUsers let users = [ UserNameIdResource { ui_username = userName uinfo, ui_userid = uid @@ -645,8 +663,8 @@ userFeature templates UserStore.Backend{backendStore = userStore, backendState = lookupUserNameFull :: UserName -> ServerPartE (UserId, UserInfo) lookupUserNameFull uname = do - users <- UserStore.getUsers userStore - case Acid.lookupUserName uname users of + muser <- queryLookupUserName uname + case muser of Just u -> return u Nothing -> userLost "Could not find user: not presently registered" where userLost = errNotFound "User not found" . return . MText @@ -656,8 +674,8 @@ userFeature templates UserStore.Backend{backendStore = userStore, backendState = lookupUserInfo :: UserId -> ServerPartE UserInfo lookupUserInfo uid = do - users <- UserStore.getUsers userStore - case Acid.lookupUserId uid users of + muser <- queryLookupUserId uid + case muser of Just uinfo -> return uinfo Nothing -> errInternalError [MText "user id does not exist"] @@ -732,12 +750,11 @@ userFeature templates UserStore.Backend{backendStore = userStore, backendState = groupAddUser :: UserGroup -> DynamicPath -> ServerPartE () groupAddUser group _ = do actorUid <- guardAuthorised (map InGroup (groupsAllowedToAdd group)) - users <- UserStore.getUsers userStore muser <- optional $ look "user" reason <- optional $ look "reason" case muser of Nothing -> addError "Bad request (could not find 'user' argument)" - Just ustr -> case simpleParse ustr >>= \uname -> Acid.lookupUserName uname users of + Just ustr -> join <$> traverse queryLookupUserName (simpleParse ustr) >>= \case Nothing -> addError $ "No user with name " ++ show ustr ++ " found" Just (uid,_) -> do liftIO $ addUserToGroup group uid diff --git a/src/Distribution/Server/Features/Users/Acid.hs b/src/Distribution/Server/Features/Users/Acid.hs index 1f424c1b8..28bb94715 100644 --- a/src/Distribution/Server/Features/Users/Acid.hs +++ b/src/Distribution/Server/Features/Users/Acid.hs @@ -10,14 +10,32 @@ import Distribution.Server.Framework.BackupDump import Distribution.Server.Users.Backup import qualified Distribution.Server.Users.State as Acid import qualified Distribution.Server.Users.Users as Acid +import Distribution.Server.Users.Types (UserInfo(userName), UserName(UserName)) + +import Distribution.Simple.Utils (lowercase) + +import Data.List (isInfixOf) acidStore :: FilePath -> IO Store.Backend acidStore stateDir = do usersState <- usersStateComponent stateDir adminsState <- adminsStateComponent stateDir + let withUsers :: MonadIO m => (Acid.Users -> a) -> m a + withUsers f = f <$> queryState usersState Acid.GetUserDb pure Store.Backend { Store.backendStore = Store.Store { Store.getUsers = queryState usersState Acid.GetUserDb + , Store.lookupUserId = \uid -> withUsers (Acid.lookupUserId uid) + , Store.lookupUserName = \uname -> withUsers (Acid.lookupUserName uname) + , Store.lookupAuthToken = \token -> withUsers (Acid.lookupAuthToken token) + , Store.enumerateAllUsers = withUsers Acid.enumerateAllUsers + , Store.enumerateActiveUsers = withUsers Acid.enumerateActiveUsers + , Store.searchUserNames = \terms -> + let lowerTerms = map lowercase terms + matches (_, uinfo) = + let UserName uname = userName uinfo + in any (`isInfixOf` lowercase uname) lowerTerms + in withUsers (filter matches . Acid.enumerateAllUsers) , Store.addUser = \uname auth -> updateState usersState (Acid.AddUserEnabled uname auth) , Store.addDisabledUser = \uname -> updateState usersState (Acid.AddUserDisabled uname) , Store.setUserEnabledStatus = \uid enabled -> updateState usersState (Acid.SetUserEnabledStatus uid enabled) diff --git a/src/Distribution/Server/Features/Users/Store.hs b/src/Distribution/Server/Features/Users/Store.hs index a68989f89..6ece557d6 100644 --- a/src/Distribution/Server/Features/Users/Store.hs +++ b/src/Distribution/Server/Features/Users/Store.hs @@ -7,7 +7,7 @@ module Distribution.Server.Features.Users.Store import Distribution.Server.Framework (AbstractStateComponent) import Distribution.Server.Users.Group (UserIdSet) -import Distribution.Server.Users.Types (AuthToken, UserAuth, UserId, UserName) +import Distribution.Server.Users.Types (AuthToken, UserAuth, UserId, UserInfo, UserName) import Distribution.Server.Users.Users ( Users , ErrUserNameClash @@ -26,6 +26,14 @@ data Backend = Backend { data Store = Store { getUsers :: forall m. MonadIO m => m Users + , lookupUserId :: forall m. MonadIO m => UserId -> m (Maybe UserInfo) + , lookupUserName :: forall m. MonadIO m => UserName -> m (Maybe (UserId, UserInfo)) + , lookupAuthToken :: forall m. MonadIO m => AuthToken -> m (Maybe (UserId, UserInfo)) + , enumerateAllUsers :: forall m. MonadIO m => m [(UserId, UserInfo)] + -- | Every user account except deleted ones. + , enumerateActiveUsers :: forall m. MonadIO m => m [(UserId, UserInfo)] + -- | Users whose name contains any of the given terms, ignoring case. + , searchUserNames :: forall m. MonadIO m => [String] -> m [(UserId, UserInfo)] , addUser :: forall m. MonadIO m => UserName -> UserAuth -> m (Either ErrUserNameClash UserId) , addDisabledUser :: forall m. MonadIO m => UserName -> m (Either ErrUserNameClash UserId) , setUserEnabledStatus :: forall m. MonadIO m => UserId -> Bool -> m (Maybe (Either ErrNoSuchUserId ErrDeletedUser)) diff --git a/src/Distribution/Server/Framework/Auth.hs b/src/Distribution/Server/Framework/Auth.hs index c979c53ff..229cb1d27 100644 --- a/src/Distribution/Server/Framework/Auth.hs +++ b/src/Distribution/Server/Framework/Auth.hs @@ -25,6 +25,9 @@ module Distribution.Server.Framework.Auth ( guardInAnyGroup, PrivilegeCondition(..), + -- ** Looking up users + UserLookup(..), + -- ** Errors AuthError(..), authErrorResponse, @@ -35,9 +38,8 @@ module Distribution.Server.Framework.Auth ( ) where import qualified Data.Text as T -import Distribution.Server.Users.Types (UserId, UserName(..), UserAuth(..), UserInfo) +import Distribution.Server.Users.Types (UserId, UserName(..), UserAuth(..), UserInfo, AuthToken) import qualified Distribution.Server.Users.Types as Users -import qualified Distribution.Server.Users.Users as Users import qualified Distribution.Server.Users.Group as Group import qualified Distribution.Server.Users.UserIdSet as UserIdSet import Distribution.Server.Framework.AuthCrypt @@ -71,6 +73,12 @@ hackageRealm, adminRealm :: RealmName hackageRealm = RealmName "Hackage" adminRealm = RealmName "Hackage admin" +-- | How to find the user account that a client claims to be. +data UserLookup = UserLookup { + lookupUserByName :: UserName -> IO (Maybe (UserId, UserInfo)), + lookupUserByAuthToken :: AuthToken -> IO (Maybe (UserId, UserInfo)) + } + -- | Check that the client is authenticated and is authorised to perform some -- privileged action. @@ -82,12 +90,12 @@ adminRealm = RealmName "Hackage admin" -- * is a member of a given group of users who are permitted to perform -- certain privileged actions. -- -guardAuthorised :: RealmName -> Users.Users -> [PrivilegeCondition] +guardAuthorised :: RealmName -> UserLookup -> [PrivilegeCondition] -> ServerEnv -> ServerPartE UserId guardAuthorised realm users privconds env = do uid <- guardAuthenticated realm users env - guardPriviledged users uid privconds + guardPriviledged uid privconds return uid @@ -100,14 +108,14 @@ guardAuthorised realm users privconds env = do -- It only checks the user is known, it does not imply that the user is -- authorised to do anything in particular, see 'guardAuthorised'. -- -guardAuthenticated :: RealmName -> Users.Users -> ServerEnv -> ServerPartE UserId +guardAuthenticated :: RealmName -> UserLookup -> ServerEnv -> ServerPartE UserId guardAuthenticated realm users env = do authres <- checkAuthenticated realm users env case authres of Left autherr -> throwError =<< authErrorResponse realm autherr Right info -> return info -checkAuthenticated :: ServerMonad m => RealmName -> Users.Users -> ServerEnv -> m (Either AuthError UserId) +checkAuthenticated :: (ServerMonad m, MonadIO m) => RealmName -> UserLookup -> ServerEnv -> m (Either AuthError UserId) checkAuthenticated realm users ServerEnv { serverRequiredBaseHostHeader } = do mbHost <- getHost case mbHost of @@ -122,12 +130,12 @@ checkAuthenticated realm users ServerEnv { serverRequiredBaseHostHeader } = do where goCheck = do req <- askRq - return $ case getHeaderAuth req of + liftIO $ case getHeaderAuth req of Just (DigestAuth, ahdr) -> checkDigestAuth users ahdr req - Just _ | plainHttp req -> Left InsecureAuthError + Just _ | plainHttp req -> return (Left InsecureAuthError) Just (BasicAuth, ahdr) -> checkBasicAuth users realm ahdr Just (AuthToken, ahdr) -> checkTokenAuth users ahdr - Nothing -> Left NoAuthError + Nothing -> return (Left NoAuthError) -- | Authentication methods supported by hackage-server. data AuthMethod @@ -159,11 +167,11 @@ data PrivilegeCondition = InGroup Group.UserGroup | IsUserId UserId | AnyKnownUser -guardInAnyGroup :: Users.Users -> UserId -> [Group.UserGroup] -> ServerPartE () -guardInAnyGroup _ _ [] = +guardInAnyGroup :: UserId -> [Group.UserGroup] -> ServerPartE () +guardInAnyGroup _ [] = fail "Group list is empty, this is not meant to happen" -guardInAnyGroup users uid groups = do - allok <- checkPriviledged users uid (map InGroup groups) +guardInAnyGroup uid groups = do + allok <- checkPriviledged uid (map InGroup groups) let groupTitles = map (Group.groupTitle . Group.groupDesc) groups errMsg = "Access denied, you must be member of either of the following groups: " <> show groupTitles @@ -179,27 +187,27 @@ guardInAnyGroup users uid groups = do -- It only checks if the user is in the privileged user group, it does not -- imply that the current client has been authenticated, see 'guardAuthorised'. -- -guardPriviledged :: Users.Users -> UserId -> [PrivilegeCondition] -> ServerPartE () -guardPriviledged users uid privconds = do - allok <- checkPriviledged users uid privconds +guardPriviledged :: UserId -> [PrivilegeCondition] -> ServerPartE () +guardPriviledged uid privconds = do + allok <- checkPriviledged uid privconds when (not allok) $ errForbidden "Forbidden" [MText "No access for this resource."] -checkPriviledged :: MonadIO m => Users.Users -> UserId -> [PrivilegeCondition] -> m Bool -checkPriviledged _users _uid [] = return False +checkPriviledged :: MonadIO m => UserId -> [PrivilegeCondition] -> m Bool +checkPriviledged _uid [] = return False -checkPriviledged users uid (InGroup ugroup:others) = do +checkPriviledged uid (InGroup ugroup:others) = do uset <- liftIO $ Group.queryUserGroup ugroup if UserIdSet.member uid uset then return True - else checkPriviledged users uid others + else checkPriviledged uid others -checkPriviledged users uid (IsUserId uid':others) = +checkPriviledged uid (IsUserId uid':others) = if uid == uid' then return True - else checkPriviledged users uid others + else checkPriviledged uid others -checkPriviledged _ _ (AnyKnownUser:_) = return True +checkPriviledged _ (AnyKnownUser:_) = return True ------------------------------------------------------------------------ @@ -266,16 +274,17 @@ plainHttp req -- -- | Handle a auth request using an access token -checkTokenAuth :: Users.Users -> BS.ByteString - -> Either AuthError UserId -checkTokenAuth users ahdr = do - parsedToken <- - case Users.parseOriginalToken (T.decodeUtf8 ahdr) of - Left _ -> Left BadApiKeyError - Right tok -> Right (Users.convertToken tok) - (uid, uinfo) <- Users.lookupAuthToken parsedToken users ?! BadApiKeyError - _ <- getUserAuth uinfo ?! UserStatusError uid uinfo - return uid +checkTokenAuth :: UserLookup -> BS.ByteString + -> IO (Either AuthError UserId) +checkTokenAuth users ahdr = + case Users.parseOriginalToken (T.decodeUtf8 ahdr) of + Left _ -> return (Left BadApiKeyError) + Right tok -> do + muser <- lookupUserByAuthToken users (Users.convertToken tok) + return $ do + (uid, uinfo) <- muser ?! BadApiKeyError + _ <- getUserAuth uinfo ?! UserStatusError uid uinfo + return uid ------------------------------------------------------------------------ -- Basic auth method @@ -283,16 +292,20 @@ checkTokenAuth users ahdr = do -- | Use HTTP Basic auth to authenticate the client as an active enabled user. -- -checkBasicAuth :: Users.Users -> RealmName -> BS.ByteString - -> Either AuthError UserId -checkBasicAuth users realm ahdr = do - authInfo <- getBasicAuthInfo realm ahdr ?! UnrecognizedAuthError - let uname = basicUsername authInfo - (uid, uinfo) <- Users.lookupUserName uname users ?! NoSuchUserError uname - uauth <- getUserAuth uinfo ?! UserStatusError uid uinfo - let passwdhash = getPasswdHash uauth - guard (checkBasicAuthInfo passwdhash authInfo) ?! PasswordMismatchError uid uinfo - return uid +checkBasicAuth :: UserLookup -> RealmName -> BS.ByteString + -> IO (Either AuthError UserId) +checkBasicAuth users realm ahdr = + case getBasicAuthInfo realm ahdr of + Nothing -> return (Left UnrecognizedAuthError) + Just authInfo -> do + let uname = basicUsername authInfo + muser <- lookupUserByName users uname + return $ do + (uid, uinfo) <- muser ?! NoSuchUserError uname + uauth <- getUserAuth uinfo ?! UserStatusError uid uinfo + let passwdhash = getPasswdHash uauth + guard (checkBasicAuthInfo passwdhash authInfo) ?! PasswordMismatchError uid uinfo + return uid getBasicAuthInfo :: RealmName -> BS.ByteString -> Maybe BasicAuthInfo getBasicAuthInfo realm authHeader @@ -342,18 +355,22 @@ headerBasicAuthChallenge (RealmName realmName) = -- | Use HTTP Digest auth to authenticate the client as an active enabled user. -- -checkDigestAuth :: Users.Users -> BS.ByteString -> Request - -> Either AuthError UserId -checkDigestAuth users ahdr req = do - authInfo <- getDigestAuthInfo ahdr req ?! UnrecognizedAuthError - let uname = digestUsername authInfo - (uid, uinfo) <- Users.lookupUserName uname users ?! NoSuchUserError uname - uauth <- getUserAuth uinfo ?! UserStatusError uid uinfo - let passwdhash = getPasswdHash uauth - guard (checkDigestAuthInfo passwdhash authInfo) ?! PasswordMismatchError uid uinfo - -- TODO: if we want to prevent replay attacks, then we must check the - -- nonce and nonce count and issue stale=true replies. - return uid +checkDigestAuth :: UserLookup -> BS.ByteString -> Request + -> IO (Either AuthError UserId) +checkDigestAuth users ahdr req = + case getDigestAuthInfo ahdr req of + Nothing -> return (Left UnrecognizedAuthError) + Just authInfo -> do + let uname = digestUsername authInfo + muser <- lookupUserByName users uname + return $ do + (uid, uinfo) <- muser ?! NoSuchUserError uname + uauth <- getUserAuth uinfo ?! UserStatusError uid uinfo + let passwdhash = getPasswdHash uauth + guard (checkDigestAuthInfo passwdhash authInfo) ?! PasswordMismatchError uid uinfo + -- TODO: if we want to prevent replay attacks, then we must check the + -- nonce and nonce count and issue stale=true replies. + return uid -- | retrieve the Digest auth info from the headers -- diff --git a/src/Distribution/Server/Users/Users.hs b/src/Distribution/Server/Users/Users.hs index 619c8f6d2..94a42aa74 100644 --- a/src/Distribution/Server/Users/Users.hs +++ b/src/Distribution/Server/Users/Users.hs @@ -26,6 +26,7 @@ module Distribution.Server.Users.Users ( -- ** Lookup utils userIdToName, + userNameOrPlaceholder, -- * Enumeration enumerateAllUsers, @@ -171,10 +172,15 @@ lookupAuthToken authTok users = -- an ugly placeholder is used instead. -- userIdToName :: Users -> UserId -> UserName -userIdToName users userId@(UserId idNum) = - case lookupUserId userId users of - Just user -> userName user - Nothing -> UserName $ "~id#" ++ show idNum +userIdToName users userId = + userNameOrPlaceholder userId (lookupUserId userId users) + +-- | The name of a looked-up user. If there is no such user, an ugly +-- placeholder is used instead. +-- +userNameOrPlaceholder :: UserId -> Maybe UserInfo -> UserName +userNameOrPlaceholder _ (Just user) = userName user +userNameOrPlaceholder (UserId idNum) Nothing = UserName $ "~id#" ++ show idNum -- | Add a new user account, in the enabled state.