Admins can view /maintain page (#1045)

* Remove guardAuthorisedAsMaintainer from UploadFeature

* Remove guardAuthorisedAsMaintainerOrTrustee from UploadFeature

* Admins can view /maintain page

Author: ysangkok

src/Distribution/Server/Features.hs

@@ -232,13 +232,15 @@ initHackageFeatures env@ServerEnv{serverVerbosity = verbosity} = do
                          uploadFeature
                          tarIndexCacheFeature
                          reportsCoreFeature
+                         usersFeature
 
     documentationCandidatesFeature <- mkDocumentationCandidatesFeature
                          (candidatesCoreResource candidatesFeature)
                          (map packageId . allPackages <$> queryGetCandidateIndex candidatesFeature)
                          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

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

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

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,17 +1057,19 @@ mkHtmlCandidates :: HtmlUtilities
                  -> DocumentationFeature
                  -> TarIndexCacheFeature
                  -> PackageCandidatesFeature
+                 -> UserFeature
                  -> Templates
                  -> HtmlCandidates
 mkHtmlCandidates utilities@HtmlUtilities{..}
                  CoreFeature{ coreResource = CoreResource{packageInPath}
                             , 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

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

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,13 +123,15 @@ versionsFeature :: ServerEnv
                 -> CoreFeature
                 -> UploadFeature
                 -> TagsFeature
+                -> UserFeature
                 -> StateComponent AcidState PreferredVersions
                 -> Hook (PackageName, Maybe [PackageName]) ()
                 -> VersionsFeature
 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

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.