Implement candidate maintenance (fixes #72)

Distribution/Server/Features/Html.hs

@@ -109,7 +109,7 @@ initHtmlFeature ServerEnv{serverTemplatesDir, serverTemplatesMode,
     -- Page templates
     templates <- loadTemplates serverTemplatesMode
                    [serverTemplatesDir, serverTemplatesDir </> "Html"]
-                   [ "maintain.html" ]
+                   [ "maintain.html", "maintain-candidate.html" ]
 
     -- do rec, tie the knot
     rec let (feature, packageIndex, packagesPage) =
@@ -218,7 +218,7 @@ htmlFeature user
     htmlUsers      = mkHtmlUsers      user usersdetails
     htmlUploads    = mkHtmlUploads    utilities upload
     htmlDownloads  = mkHtmlDownloads  utilities download
-    htmlCandidates = mkHtmlCandidates utilities core versions upload docsCandidates candidates
+    htmlCandidates = mkHtmlCandidates utilities core versions upload docsCandidates candidates templates
     htmlPreferred  = mkHtmlPreferred  utilities core versions
     htmlTags       = mkHtmlTags       utilities core list tags
     htmlSearch     = mkHtmlSearch     utilities      list names
@@ -493,7 +493,7 @@ mkHtmlCore HtmlUtilities{..}
               Nothing -> noHtml
         -- and put it all together
         return $ toResponse $ Resource.XHtml $
-            Pages.packagePage render [tagLinks] [deprHtml] (beforeHtml ++ middleHtml ++ afterHtml) [] docURL
+            Pages.packagePage render [tagLinks] [deprHtml] (beforeHtml ++ middleHtml ++ afterHtml) [] docURL False
       where
         showDist (dname, info) = toHtml (display dname ++ ":") +++
             anchor ! [href $ distroUrl info] << toHtml (display $ distroVersion info)
@@ -729,6 +729,7 @@ mkHtmlCandidates :: HtmlUtilities
                  -> UploadFeature
                  -> DocumentationFeature
                  -> PackageCandidatesFeature
+                 -> Templates
                  -> HtmlCandidates
 mkHtmlCandidates HtmlUtilities{..}
                  CoreFeature{ coreResource = CoreResource{packageInPath}
@@ -737,7 +738,8 @@ mkHtmlCandidates HtmlUtilities{..}
                  VersionsFeature{ queryGetPreferredInfo }
                  UploadFeature{ guardAuthorisedAsMaintainer }
                  DocumentationFeature{documentationResource, queryHasDocumentation}
-                 PackageCandidatesFeature{..} = HtmlCandidates{..}
+                 PackageCandidatesFeature{..}
+                 templates = HtmlCandidates{..}
   where
     candidates     = candidatesResource
     candidatesCore = candidatesCoreResource
@@ -795,6 +797,13 @@ mkHtmlCandidates HtmlUtilities{..}
          , resourceGet  = [ ("html", servePublishForm) ]
          , resourcePost = [ ("html", servePostPublish) ]
          }
+      , (extendResource $ deletePage candidates) {
+           resourceDesc = [ (GET, "Show candidate deletion form")
+                          , (POST, "Delete a package candidate")
+                          ]
+         , resourceGet  = [ ("html", serveDeleteForm) ]
+         , resourcePost = [ ("html", doDeleteCandidate) ]
+         }
       ]
 
     serveCandidateUploadForm :: DynamicPath -> ServerPartE Response
@@ -821,11 +830,13 @@ mkHtmlCandidates HtmlUtilities{..}
     serveCandidateMaintain dpath = do
       candidate <- packageInPath dpath >>= lookupCandidateId
       guardAuthorisedAsMaintainer (packageName candidate)
-      return $ toResponse $ Resource.XHtml $ hackagePage "Maintain candidate"
-          [toHtml "Here, you can delete a candidate, publish it, upload a new one, and edit the maintainer group."]
+      template <- getTemplate templates "maintain-candidate.html"
+      return $ toResponse $ template
+        [ "pkgname"  $= display (packageName candidate)
+        , "pkgversion" $= display (packageVersion candidate)
+        ]
     {-some useful URIs here: candidateUri check "" pkgid, packageCandidatesUri check "" pkgid, publishUri check "" pkgid-}
 
-
     serveCandidatePage :: Resource -> DynamicPath -> ServerPartE Response
     serveCandidatePage maintain dpath = do
       cand <- packageInPath dpath >>= lookupCandidateId
@@ -848,7 +859,7 @@ mkHtmlCandidates HtmlUtilities{..}
               [] -> []
               warn -> [thediv ! [theclass "notification"] << [toHtml "Warnings:", unordList warn]]
       return $ toResponse $ Resource.XHtml $
-          Pages.packagePage render [maintainHtml] warningBox sectionHtml [] docURL
+          Pages.packagePage render [maintainHtml] warningBox sectionHtml [] docURL True
 
     servePublishForm :: DynamicPath -> ServerPartE Response
     servePublishForm dpath = do
@@ -914,6 +925,16 @@ mkHtmlCandidates HtmlUtilities{..}
             [] -> []
             warns -> [paragraph << "There were some warnings:", unordList warns]
 
+    serveDeleteForm :: DynamicPath -> ServerPartE Response
+    serveDeleteForm dpath = do
+      candidate <- packageInPath dpath >>= lookupCandidateId
+      guardAuthorisedAsMaintainer (packageName candidate)
+      let pkgid = packageId candidate
+      return $ toResponse $ Resource.XHtml $ hackagePage "Deleting candidates"
+                  [form ! [theclass "box", XHtml.method "post", action $ deleteUri candidatesResource "" pkgid]
+                      << input ! [thetype "submit", value "Delete package candidate"]]
+
+
 {-------------------------------------------------------------------------------
   Preferred versions
 -------------------------------------------------------------------------------}

Distribution/Server/Features/PackageCandidates.hs

@@ -92,8 +92,10 @@ instance IsHackageFeature PackageCandidatesFeature where
 data PackageCandidatesResource = PackageCandidatesResource {
     packageCandidatesPage :: Resource,
     publishPage           :: Resource,
+    deletePage            :: Resource,
     packageCandidatesUri  :: String -> PackageName -> String,
     publishUri            :: String -> PackageId -> String,
+    deleteUri             :: String -> PackageId -> String,
 
     -- TODO: Why don't the following entries have a corresponding entry
     -- in CoreResource?
@@ -207,6 +209,7 @@ candidatesFeature ServerEnv{serverBlobStore = store}
     candidatesResource = fix $ \r -> PackageCandidatesResource {
         packageCandidatesPage = resourceAt "/package/:package/candidates/.:format"
       , publishPage = resourceAt "/package/:package/candidate/publish.:format"
+      , deletePage = resourceAt "/package/:package/candidate/delete.:format"
       , candidateContents = (resourceAt "/package/:package/candidate/src/..") {
             resourceGet = [("", serveContents)]
           }
@@ -217,6 +220,8 @@ candidatesFeature ServerEnv{serverBlobStore = store}
           renderResource (packageCandidatesPage r) [display pkgname, format]
       , publishUri = \format pkgid ->
           renderResource (publishPage r) [display pkgid, format]
+      , deleteUri = \format pkgid ->
+          renderResource (deletePage r) [display pkgid, format]
       , candidateChangeLogUri = \pkgid ->
           renderResource (candidateChangeLog candidatesResource) [display pkgid, display (packageName pkgid)]
       }

Distribution/Server/Pages/Package.hs

@@ -31,8 +31,8 @@ import System.FilePath.Posix    ((</>), (<.>))
 import System.Locale            (defaultTimeLocale)
 import Data.Time.Format         (formatTime)
 
-packagePage :: PackageRender -> [Html] -> [Html] -> [(String, Html)] -> [(String, Html)] -> Maybe URL -> Html
-packagePage render headLinks top sections bottom docURL =
+packagePage :: PackageRender -> [Html] -> [Html] -> [(String, Html)] -> [(String, Html)] -> Maybe URL -> Bool -> Html
+packagePage render headLinks top sections bottom docURL isCandidate =
     hackagePageWith [] docTitle docSubtitle docBody [docFooter]
   where
     pkgid = rendPkgId render
@@ -52,7 +52,7 @@ packagePage render headLinks top sections bottom docURL =
              pkgBody render sections,
              moduleSection render docURL,
              downloadSection render,
-             maintainerSection pkgid,
+             maintainerSection pkgid isCandidate,
              map pair bottom
            ]
     bodyTitle = "The " ++ display (pkgName pkgid) ++ " package"
@@ -125,15 +125,16 @@ downloadSection PackageRender{..} =
     srcURL        = rendPkgUri </> "src/"
     tarGzFileName = display rendPkgId ++ ".tar.gz"
 
-maintainerSection :: PackageId -> [Html]
-maintainerSection pkgid =
+maintainerSection :: PackageId -> Bool -> [Html]
+maintainerSection pkgid isCandidate =
     [ h4 << "Maintainers' corner"
     , paragraph << "For package maintainers and hackage trustees"
     , ulist << li << anchor ! [href maintainURL]
                   << "edit package information"
     ]
   where
-    maintainURL = display (packageName pkgid) </> "maintain"
+    maintainURL | isCandidate = "candidate/maintain"
+                | otherwise   = display (packageName pkgid) </> "maintain"
 
 moduleSection :: PackageRender -> Maybe URL -> [Html]
 moduleSection render docURL = maybeToList $ fmap msect (rendModules render)

datafiles/templates/Html/maintain-candidate.html.st

@@ -0,0 +1,39 @@
+<!DOCTYPE html>
+<html>
+<head>
+$hackageCssTheme()$
+<title>Hackage: Maintainers' page for $pkgname$-$pkgversion$ candidate</title>
+</head>
+
+<body>
+$hackagePageHeader()$
+
+<div id="content">
+<h2>Maintainers' page for $pkgname$-$pkgversion$ candidate</h2>
+
+<p>Here, you can delete a candidate, publish it, upload a new one, and
+edit the maintainer group.
+
+<dl>
+<dt><a href="delete">Delete candidate</a></dt>
+  <dd>Discard this candidate (does not affect published packages).
+  </dd>
+
+<dt><a href="publish">Publish candidate</a></dt>
+  <dd>Publish this candidate to make it visible in the main package database.
+  </dd>
+
+<dt><a href="upload">Upload a new candidate</a></dt>
+  <dd>If you upload a new candidate with the same version as an
+  existing candidate, the older will be overwritten.
+  </dd>
+
+<dt><a href="/package/$pkgname$/maintainers">Maintainer group</a></dt>
+  <dd>Only these users are allowed to upload new versions of the package.
+      Existing members can add other users into the maintainer group.
+  </dd>
+
+</dl>
+
+</div>
+</body></html>