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/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 f30dc86dd..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 @@ -83,6 +82,18 @@ 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], + + 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 +519,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 @@ -521,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) @@ -550,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 @@ -683,9 +706,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..47f6b83db 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 @@ -902,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 ] @@ -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/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/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) 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.