diff --git a/Distribution/Server/Features/Html.hs b/Distribution/Server/Features/Html.hs
index b47c5c9ed..5abc5020e 100644
--- a/Distribution/Server/Features/Html.hs
+++ b/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
-------------------------------------------------------------------------------}
diff --git a/Distribution/Server/Features/PackageCandidates.hs b/Distribution/Server/Features/PackageCandidates.hs
index 7f32186fa..a402d409c 100644
--- a/Distribution/Server/Features/PackageCandidates.hs
+++ b/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)]
}
diff --git a/Distribution/Server/Pages/Package.hs b/Distribution/Server/Pages/Package.hs
index 45becc72f..61db9203e 100644
--- a/Distribution/Server/Pages/Package.hs
+++ b/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)
diff --git a/datafiles/templates/Html/maintain-candidate.html.st b/datafiles/templates/Html/maintain-candidate.html.st
new file mode 100644
index 000000000..628e3b0ae
--- /dev/null
+++ b/datafiles/templates/Html/maintain-candidate.html.st
@@ -0,0 +1,39 @@
+
+
+
+$hackageCssTheme()$
+Hackage: Maintainers' page for $pkgname$-$pkgversion$ candidate
+
+
+
+$hackagePageHeader()$
+
+
+
Maintainers' page for $pkgname$-$pkgversion$ candidate
+
+
Here, you can delete a candidate, publish it, upload a new one, and
+edit the maintainer group.
+
+
+- Delete candidate
+ - Discard this candidate (does not affect published packages).
+
+
+- Publish candidate
+ - Publish this candidate to make it visible in the main package database.
+
+
+- Upload a new candidate
+ - If you upload a new candidate with the same version as an
+ existing candidate, the older will be overwritten.
+
+
+- Maintainer group
+ - Only these users are allowed to upload new versions of the package.
+ Existing members can add other users into the maintainer group.
+
+
+
+
+
+