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. +
+ +
+ +
+