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 87c7ba31d..dd458ddd6 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 @@ -465,14 +465,14 @@ mkHtmlCore :: ServerEnv -> HtmlCore mkHtmlCore ServerEnv{serverBaseURI, serverBlobStore} utilities@HtmlUtilities{..} - UserFeature{queryGetUserDb, checkAuthenticated} + UserFeature{queryGetUserDb, checkAuthenticated, guardAuthorised_, adminGroup} CoreFeature{coreResource} VersionsFeature{ versionsResource , queryGetDeprecatedFor , queryGetPreferredInfo , withPackagePreferred } - UploadFeature{guardAuthorisedAsMaintainerOrTrustee} + UploadFeature{..} TagsFeature{queryTagsForPackage} documentationFeature@DocumentationFeature{documentationResource, queryDocumentation} TarIndexCacheFeature{cachedTarIndex} @@ -684,7 +684,7 @@ mkHtmlCore ServerEnv{serverBaseURI, serverBlobStore} 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 @@ -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{..} DocumentationFeature{documentationResource, queryDocumentation,..} TarIndexCacheFeature{cachedTarIndex} PackageCandidatesFeature{..} + UserFeature{ guardAuthorised, guardAuthorised_ } templates = HtmlCandidates{..} where candidates = candidatesResource @@ -1175,6 +1177,9 @@ mkHtmlCandidates utilities@HtmlUtilities{..} ] ] + guardAuthorisedAsMaintainerOrTrustee pkgname = + guardAuthorised_ [InGroup (maintainersGroup pkgname), InGroup trusteesGroup] + serveCandidateMaintain :: DynamicPath -> ServerPartE Response serveCandidateMaintain dpath = do pkgid <- packageInPath dpath @@ -1241,6 +1246,8 @@ mkHtmlCandidates utilities@HtmlUtilities{..} let render = candPackageRender candRender return $ toResponse $ dependenciesPage True render "docs" + guardAuthorisedAsMaintainer pkgName = guardAuthorised [InGroup . maintainersGroup $ 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..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 @@ -442,7 +445,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/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 1e7b786cd..2067c3575 100644 --- a/src/Distribution/Server/Features/Upload.hs +++ b/src/Distribution/Server/Features/Upload.hs @@ -59,11 +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 (), - -- | 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. @@ -295,15 +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." } - guardAuthorisedAsMaintainer :: PackageName -> ServerPartE Users.UserId - guardAuthorisedAsMaintainer pkgname = - guardAuthorised [InGroup (maintainersGroup pkgname)] - - guardAuthorisedAsMaintainerOrTrustee :: PackageName -> ServerPartE () - guardAuthorisedAsMaintainerOrTrustee pkgname = - guardAuthorised_ [InGroup (maintainersGroup pkgname), InGroup trusteesGroup] - - ---------------------------------------------------- -- This is the upload function. It returns a generic result for multiple formats.