From fdac2b60af042db30a3d276e17913ffd91f93e58 Mon Sep 17 00:00:00 2001 From: Janus Troelsen Date: Fri, 1 Apr 2022 00:33:35 -0500 Subject: [PATCH 1/3] Remove guardAuthorisedAsMaintainer from UploadFeature --- src/Distribution/Server/Features/Html.hs | 8 ++++++-- src/Distribution/Server/Features/PackageCandidates.hs | 2 +- src/Distribution/Server/Features/Upload.hs | 6 ------ 3 files changed, 7 insertions(+), 9 deletions(-) diff --git a/src/Distribution/Server/Features/Html.hs b/src/Distribution/Server/Features/Html.hs index 87c7ba31d..fbb2d465f 100644 --- a/src/Distribution/Server/Features/Html.hs +++ b/src/Distribution/Server/Features/Html.hs @@ -278,7 +278,7 @@ htmlFeature env@ServerEnv{..} htmlReports = mkHtmlReports utilities core reportsCore templates htmlCandidates = mkHtmlCandidates utilities core versions upload docsCandidates tarIndexCache - candidates templates + candidates user templates htmlPreferred = mkHtmlPreferred utilities core versions htmlTags = mkHtmlTags utilities core upload user list tags templates @@ -1057,6 +1057,7 @@ mkHtmlCandidates :: HtmlUtilities -> DocumentationFeature -> TarIndexCacheFeature -> PackageCandidatesFeature + -> UserFeature -> Templates -> HtmlCandidates mkHtmlCandidates utilities@HtmlUtilities{..} @@ -1064,10 +1065,11 @@ mkHtmlCandidates utilities@HtmlUtilities{..} , queryGetPackageIndex } VersionsFeature{ queryGetPreferredInfo } - UploadFeature{ guardAuthorisedAsMaintainer, guardAuthorisedAsMaintainerOrTrustee } + uploadFeature@UploadFeature{ guardAuthorisedAsMaintainerOrTrustee } DocumentationFeature{documentationResource, queryDocumentation,..} TarIndexCacheFeature{cachedTarIndex} PackageCandidatesFeature{..} + UserFeature{ guardAuthorised } templates = HtmlCandidates{..} where candidates = candidatesResource @@ -1241,6 +1243,8 @@ mkHtmlCandidates utilities@HtmlUtilities{..} let render = candPackageRender candRender return $ toResponse $ dependenciesPage True render "docs" + guardAuthorisedAsMaintainer pkgName = guardAuthorised [InGroup . maintainersGroup uploadFeature $ pkgName] + servePublishForm :: DynamicPath -> ServerPartE Response servePublishForm dpath = do candidate <- packageInPath dpath >>= lookupCandidateId diff --git a/src/Distribution/Server/Features/PackageCandidates.hs b/src/Distribution/Server/Features/PackageCandidates.hs index cb56d54a1..bd62c7885 100644 --- a/src/Distribution/Server/Features/PackageCandidates.hs +++ b/src/Distribution/Server/Features/PackageCandidates.hs @@ -442,7 +442,7 @@ candidatesFeature ServerEnv{serverBlobStore = store} packages <- queryGetPackageIndex candidate <- packageInPath dpath >>= lookupCandidateId -- check authorization to upload - must already be a maintainer - uid <- guardAuthorisedAsMaintainer (packageName candidate) + uid <- guardAuthorised [InGroup . maintainersGroup $ packageName candidate] -- check if package or later already exists checkPublish uid packages candidate >>= \case Just failed -> throwError failed diff --git a/src/Distribution/Server/Features/Upload.hs b/src/Distribution/Server/Features/Upload.hs index 1e7b786cd..78bb8db87 100644 --- a/src/Distribution/Server/Features/Upload.hs +++ b/src/Distribution/Server/Features/Upload.hs @@ -59,8 +59,6 @@ data UploadFeature = UploadFeature { -- | The group of maintainers for a given package. maintainersGroup :: PackageName -> UserGroup, - -- | Requiring being logged in as the maintainer of a package. - guardAuthorisedAsMaintainer :: PackageName -> ServerPartE Users.UserId, -- | Requiring being logged in as the maintainer of a package or a trustee. guardAuthorisedAsMaintainerOrTrustee :: PackageName -> ServerPartE (), @@ -295,10 +293,6 @@ uploadFeature ServerEnv{serverBlobStore = store} uploaderDescription :: GroupDescription uploaderDescription = nullDescription { groupTitle = "Package uploaders", groupPrologue = "Package uploaders are allowed to upload packages. Note that if a package already exists then you also need to be in the maintainer group for that package." } - guardAuthorisedAsMaintainer :: PackageName -> ServerPartE Users.UserId - guardAuthorisedAsMaintainer pkgname = - guardAuthorised [InGroup (maintainersGroup pkgname)] - guardAuthorisedAsMaintainerOrTrustee :: PackageName -> ServerPartE () guardAuthorisedAsMaintainerOrTrustee pkgname = guardAuthorised_ [InGroup (maintainersGroup pkgname), InGroup trusteesGroup] From 595177f0db4058b3243641b7c73c264043515c0c Mon Sep 17 00:00:00 2001 From: Janus Troelsen Date: Fri, 1 Apr 2022 01:02:33 -0500 Subject: [PATCH 2/3] Remove guardAuthorisedAsMaintainerOrTrustee from UploadFeature --- src/Distribution/Server/Features.hs | 3 +++ src/Distribution/Server/Features/BuildReports.hs | 3 +++ .../Server/Features/Documentation.hs | 11 +++++++++-- src/Distribution/Server/Features/Html.hs | 16 +++++++++++----- .../Server/Features/PackageCandidates.hs | 3 +++ .../Server/Features/PreferredVersions.hs | 11 +++++++++-- src/Distribution/Server/Features/Upload.hs | 8 -------- 7 files changed, 38 insertions(+), 17 deletions(-) diff --git a/src/Distribution/Server/Features.hs b/src/Distribution/Server/Features.hs index 71c23c4f6..741497ab4 100644 --- a/src/Distribution/Server/Features.hs +++ b/src/Distribution/Server/Features.hs @@ -232,6 +232,7 @@ initHackageFeatures env@ServerEnv{serverVerbosity = verbosity} = do uploadFeature tarIndexCacheFeature reportsCoreFeature + usersFeature documentationCandidatesFeature <- mkDocumentationCandidatesFeature (candidatesCoreResource candidatesFeature) @@ -239,6 +240,7 @@ initHackageFeatures env@ServerEnv{serverVerbosity = verbosity} = do uploadFeature tarIndexCacheFeature reportsCandidatesFeature + usersFeature downloadFeature <- mkDownloadFeature coreFeature @@ -257,6 +259,7 @@ initHackageFeatures env@ServerEnv{serverVerbosity = verbosity} = do coreFeature uploadFeature tagsFeature + usersFeature {- [reverse index disabled] reverseFeature <- mkReverseFeature diff --git a/src/Distribution/Server/Features/BuildReports.hs b/src/Distribution/Server/Features/BuildReports.hs index 75dad21a3..73985286c 100644 --- a/src/Distribution/Server/Features/BuildReports.hs +++ b/src/Distribution/Server/Features/BuildReports.hs @@ -305,6 +305,9 @@ buildReportsFeature name void $ updateState reportsState $ SetBuildLog pkgid reportId Nothing noContent (toResponse ()) + guardAuthorisedAsMaintainerOrTrustee pkgname = + guardAuthorised_ [InGroup (maintainersGroup pkgname), InGroup trusteesGroup] + resetBuildFails :: DynamicPath -> ServerPartE Response resetBuildFails dpath = do pkgid <- packageInPath dpath diff --git a/src/Distribution/Server/Features/Documentation.hs b/src/Distribution/Server/Features/Documentation.hs index 4a87e868e..1eaa05318 100644 --- a/src/Distribution/Server/Features/Documentation.hs +++ b/src/Distribution/Server/Features/Documentation.hs @@ -10,6 +10,7 @@ import Distribution.Server.Framework import Distribution.Server.Features.Documentation.State import Distribution.Server.Features.Upload +import Distribution.Server.Features.Users import Distribution.Server.Features.Core import Distribution.Server.Features.TarIndexCache import Distribution.Server.Features.BuildReports @@ -81,6 +82,7 @@ initDocumentationFeature :: String -> UploadFeature -> TarIndexCacheFeature -> ReportsFeature + -> UserFeature -> IO DocumentationFeature) initDocumentationFeature name env@ServerEnv{serverStateDir} = do @@ -90,9 +92,9 @@ initDocumentationFeature name -- Hooks documentationChangeHook <- newHook - return $ \core getPackages upload tarIndexCache reportsCore -> do + return $ \core getPackages upload tarIndexCache reportsCore user -> do let feature = documentationFeature name env - core getPackages upload tarIndexCache reportsCore + core getPackages upload tarIndexCache reportsCore user documentationState documentationChangeHook return feature @@ -137,6 +139,7 @@ documentationFeature :: String -> UploadFeature -> TarIndexCacheFeature -> ReportsFeature + -> UserFeature -> StateComponent AcidState Documentation -> Hook PackageId () -> DocumentationFeature @@ -153,6 +156,7 @@ documentationFeature name UploadFeature{..} TarIndexCacheFeature{cachedTarIndex} ReportsFeature{..} + UserFeature{ guardAuthorised_ } documentationState documentationChangeHook = DocumentationFeature{..} @@ -293,6 +297,9 @@ documentationFeature name | t > 3600*24*4 = maxAgeDays 1 | otherwise = maxAgeSeconds $ 60*10 + ceiling (exp (3.28697e-5 * fromInteger (ceiling t) :: Double)) + guardAuthorisedAsMaintainerOrTrustee pkgname = + guardAuthorised_ [InGroup (maintainersGroup pkgname), InGroup trusteesGroup] + uploadDocumentation :: DynamicPath -> ServerPartE Response uploadDocumentation dpath = do pkgid <- packageInPath dpath diff --git a/src/Distribution/Server/Features/Html.hs b/src/Distribution/Server/Features/Html.hs index fbb2d465f..62c70d16f 100644 --- a/src/Distribution/Server/Features/Html.hs +++ b/src/Distribution/Server/Features/Html.hs @@ -465,14 +465,14 @@ mkHtmlCore :: ServerEnv -> HtmlCore mkHtmlCore ServerEnv{serverBaseURI, serverBlobStore} utilities@HtmlUtilities{..} - UserFeature{queryGetUserDb, checkAuthenticated} + UserFeature{queryGetUserDb, checkAuthenticated, guardAuthorised_} CoreFeature{coreResource} VersionsFeature{ versionsResource , queryGetDeprecatedFor , queryGetPreferredInfo , withPackagePreferred } - UploadFeature{guardAuthorisedAsMaintainerOrTrustee} + UploadFeature{..} TagsFeature{queryTagsForPackage} documentationFeature@DocumentationFeature{documentationResource, queryDocumentation} TarIndexCacheFeature{cachedTarIndex} @@ -680,6 +680,9 @@ mkHtmlCore ServerEnv{serverBaseURI, serverBlobStore} render <- liftIO $ packageRender pkg return $ toResponse $ dependenciesPage False render "docs" + guardAuthorisedAsMaintainerOrTrustee pkgname = + guardAuthorised_ [InGroup (maintainersGroup pkgname), InGroup trusteesGroup] + serveMaintainPage :: DynamicPath -> ServerPartE Response serveMaintainPage dpath = do pkgname <- packageInPath dpath @@ -1065,11 +1068,11 @@ mkHtmlCandidates utilities@HtmlUtilities{..} , queryGetPackageIndex } VersionsFeature{ queryGetPreferredInfo } - uploadFeature@UploadFeature{ guardAuthorisedAsMaintainerOrTrustee } + UploadFeature{..} DocumentationFeature{documentationResource, queryDocumentation,..} TarIndexCacheFeature{cachedTarIndex} PackageCandidatesFeature{..} - UserFeature{ guardAuthorised } + UserFeature{ guardAuthorised, guardAuthorised_ } templates = HtmlCandidates{..} where candidates = candidatesResource @@ -1177,6 +1180,9 @@ mkHtmlCandidates utilities@HtmlUtilities{..} ] ] + guardAuthorisedAsMaintainerOrTrustee pkgname = + guardAuthorised_ [InGroup (maintainersGroup pkgname), InGroup trusteesGroup] + serveCandidateMaintain :: DynamicPath -> ServerPartE Response serveCandidateMaintain dpath = do pkgid <- packageInPath dpath @@ -1243,7 +1249,7 @@ mkHtmlCandidates utilities@HtmlUtilities{..} let render = candPackageRender candRender return $ toResponse $ dependenciesPage True render "docs" - guardAuthorisedAsMaintainer pkgName = guardAuthorised [InGroup . maintainersGroup uploadFeature $ pkgName] + guardAuthorisedAsMaintainer pkgName = guardAuthorised [InGroup . maintainersGroup $ pkgName] servePublishForm :: DynamicPath -> ServerPartE Response servePublishForm dpath = do diff --git a/src/Distribution/Server/Features/PackageCandidates.hs b/src/Distribution/Server/Features/PackageCandidates.hs index bd62c7885..70500489d 100644 --- a/src/Distribution/Server/Features/PackageCandidates.hs +++ b/src/Distribution/Server/Features/PackageCandidates.hs @@ -343,6 +343,9 @@ candidatesFeature ServerEnv{serverBlobStore = store} pkgInfo <- uploadCandidate (==pkgid) seeOther (corePackageIdUri candidatesCoreResource "" $ packageId pkgInfo) (toResponse ()) + guardAuthorisedAsMaintainerOrTrustee pkgname = + guardAuthorised_ [InGroup (maintainersGroup pkgname), InGroup trusteesGroup] + -- FIXME: DELETE should not redirect, but rather return ServerPartE () doDeleteCandidate :: DynamicPath -> ServerPartE Response doDeleteCandidate dpath = do diff --git a/src/Distribution/Server/Features/PreferredVersions.hs b/src/Distribution/Server/Features/PreferredVersions.hs index 99af9dfca..99ad53e9a 100644 --- a/src/Distribution/Server/Features/PreferredVersions.hs +++ b/src/Distribution/Server/Features/PreferredVersions.hs @@ -19,6 +19,7 @@ import Distribution.Server.Features.PreferredVersions.Backup import Distribution.Server.Features.Core import Distribution.Server.Features.Upload +import Distribution.Server.Features.Users import Distribution.Server.Features.Tags import qualified Distribution.Server.Packages.PackageIndex as PackageIndex @@ -91,15 +92,16 @@ initVersionsFeature :: ServerEnv -> IO (CoreFeature -> UploadFeature -> TagsFeature + -> UserFeature -> IO VersionsFeature) initVersionsFeature env@ServerEnv{serverStateDir} = do preferredState <- preferredStateComponent False serverStateDir deprecatedHook <- newHook - return $ \core upload tags -> do + return $ \core upload tags user -> do let feature = versionsFeature env - core upload tags + core upload tags user preferredState deprecatedHook return feature @@ -121,6 +123,7 @@ versionsFeature :: ServerEnv -> CoreFeature -> UploadFeature -> TagsFeature + -> UserFeature -> StateComponent AcidState PreferredVersions -> Hook (PackageName, Maybe [PackageName]) () -> VersionsFeature @@ -128,6 +131,7 @@ versionsFeature ServerEnv{ serverVerbosity = verbosity } CoreFeature{..} UploadFeature{..} TagsFeature{..} + UserFeature{ guardAuthorised_ } preferredState deprecatedHook = VersionsFeature{..} @@ -225,6 +229,9 @@ versionsFeature ServerEnv{ serverVerbosity = verbosity } | pkg <- fromMaybe [] mdep ]) ] + guardAuthorisedAsMaintainerOrTrustee pkgname = + guardAuthorised_ [InGroup (maintainersGroup pkgname), InGroup trusteesGroup] + handlePackageDeprecatedPut :: DynamicPath -> ServerPartE Response handlePackageDeprecatedPut dpath = do pkgname <- packageInPath dpath diff --git a/src/Distribution/Server/Features/Upload.hs b/src/Distribution/Server/Features/Upload.hs index 78bb8db87..2067c3575 100644 --- a/src/Distribution/Server/Features/Upload.hs +++ b/src/Distribution/Server/Features/Upload.hs @@ -59,9 +59,6 @@ data UploadFeature = UploadFeature { -- | The group of maintainers for a given package. maintainersGroup :: PackageName -> UserGroup, - -- | Requiring being logged in as the maintainer of a package or a trustee. - guardAuthorisedAsMaintainerOrTrustee :: PackageName -> ServerPartE (), - -- | Takes an upload request and, depending on the result of the -- passed-in function, either commits the uploaded tarball to the blob -- storage or throws it away and yields an error. @@ -293,11 +290,6 @@ uploadFeature ServerEnv{serverBlobStore = store} uploaderDescription :: GroupDescription uploaderDescription = nullDescription { groupTitle = "Package uploaders", groupPrologue = "Package uploaders are allowed to upload packages. Note that if a package already exists then you also need to be in the maintainer group for that package." } - guardAuthorisedAsMaintainerOrTrustee :: PackageName -> ServerPartE () - guardAuthorisedAsMaintainerOrTrustee pkgname = - guardAuthorised_ [InGroup (maintainersGroup pkgname), InGroup trusteesGroup] - - ---------------------------------------------------- -- This is the upload function. It returns a generic result for multiple formats. From 84e61174dcf6fe100e80a39fd6b959e02c5174ed Mon Sep 17 00:00:00 2001 From: Janus Troelsen Date: Fri, 1 Apr 2022 01:10:13 -0500 Subject: [PATCH 3/3] Admins can view /maintain page --- src/Distribution/Server/Features/Html.hs | 7 ++----- 1 file changed, 2 insertions(+), 5 deletions(-) diff --git a/src/Distribution/Server/Features/Html.hs b/src/Distribution/Server/Features/Html.hs index 62c70d16f..dd458ddd6 100644 --- a/src/Distribution/Server/Features/Html.hs +++ b/src/Distribution/Server/Features/Html.hs @@ -465,7 +465,7 @@ mkHtmlCore :: ServerEnv -> HtmlCore mkHtmlCore ServerEnv{serverBaseURI, serverBlobStore} utilities@HtmlUtilities{..} - UserFeature{queryGetUserDb, checkAuthenticated, guardAuthorised_} + UserFeature{queryGetUserDb, checkAuthenticated, guardAuthorised_, adminGroup} CoreFeature{coreResource} VersionsFeature{ versionsResource , queryGetDeprecatedFor @@ -680,14 +680,11 @@ mkHtmlCore ServerEnv{serverBaseURI, serverBlobStore} render <- liftIO $ packageRender pkg return $ toResponse $ dependenciesPage False render "docs" - guardAuthorisedAsMaintainerOrTrustee pkgname = - guardAuthorised_ [InGroup (maintainersGroup pkgname), InGroup trusteesGroup] - serveMaintainPage :: DynamicPath -> ServerPartE Response serveMaintainPage dpath = do pkgname <- packageInPath dpath pkgs <- lookupPackageName pkgname - guardAuthorisedAsMaintainerOrTrustee (pkgname :: PackageName) + guardAuthorised_ [InGroup (maintainersGroup pkgname), InGroup trusteesGroup, InGroup adminGroup] cacheControl [Public, NoCache] (etagFromHash (length pkgs)) template <- getTemplate templates "maintain.html" return $ toResponse $ template