Skip to content

Enhance Tagging feature #613

New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Merged
merged 1 commit into from
Aug 28, 2017
Merged

Enhance Tagging feature #613

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
1 commit
Select commit
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
1 change: 1 addition & 0 deletions Distribution/Server/Features.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -241,6 +241,7 @@ initHackageFeatures env@ServerEnv{serverVerbosity = verbosity} = do
tagsFeature <- mkTagsFeature
coreFeature
uploadFeature
usersFeature

versionsFeature <- mkVersionsFeature
coreFeature
Expand Down
105 changes: 89 additions & 16 deletions Distribution/Server/Features/Html.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -127,6 +127,7 @@ initHtmlFeature env@ServerEnv{serverTemplatesDir, serverTemplatesMode,
, "revisions.html"
, "package-page.html"
, "table-interface.html"
, "tag-edit.html"
]


Expand Down Expand Up @@ -277,7 +278,7 @@ htmlFeature env@ServerEnv{..}
docsCandidates tarIndexCache
candidates templates
htmlPreferred = mkHtmlPreferred utilities core versions
htmlTags = mkHtmlTags utilities core list tags templates
htmlTags = mkHtmlTags utilities core upload user list tags templates
htmlSearch = mkHtmlSearch utilities core list names templates

htmlResources = concat [
Expand Down Expand Up @@ -1467,16 +1468,20 @@ data HtmlTags = HtmlTags {

mkHtmlTags :: HtmlUtilities
-> CoreFeature
-> UploadFeature
-> UserFeature
-> ListFeature
-> TagsFeature
-> Templates
-> HtmlTags
mkHtmlTags HtmlUtilities{..}
CoreFeature{ coreResource = CoreResource{
packageInPath
, lookupPackageName
, guardValidPackageName
}
}
UploadFeature{ maintainersGroup, trusteesGroup }
UserFeature{ guardAuthorised', guardAuthorised_ }
ListFeature{makeItemList}
TagsFeature{..}
templates
Expand All @@ -1496,7 +1501,13 @@ mkHtmlTags HtmlUtilities{..}
resourceGet = [("html", serveTagListing)]
}
, (extendResource $ packageTagsListing tags) {
resourcePut = [("html", putPackageTags)], resourceGet = []
resourcePut = [("html", putPackageTags)], resourceGet = [("html", showPackageTags)]
}
, (extendResource $ tagAliasEdit tags) {
resourcePut = [("html", putAliasEdit)]
}
, (extendResource $ tagAliasEditForm tags) {
resourceGet = [("html", serveAliasForm)]
}
, tagEdit -- (extendResource $ packageTagsEdit tags) { resourceGet = [("html", serveTagsForm)] }
]
Expand All @@ -1519,8 +1530,37 @@ mkHtmlTags HtmlUtilities{..}
]
tagItem tg = anchor ! [href $ tagUri tags "" tg] << display tg

putAliasEdit :: DynamicPath -> ServerPartE Response
putAliasEdit dpath = do
tagname <- tagInPath dpath
targetTag <- optional $ look "tags"
mergeTags targetTag (Tag tagname)
return $ toResponse $ Resource.XHtml $ hackagePage "Merged Tag"
[ h2 << "Merged tag"
, toHtml "Return to "
, anchor ! [href "/packages/tags"] << "tag listings"
]

serveAliasForm :: DynamicPath -> ServerPartE Response
serveAliasForm dpath = do
tagname <- tagInPath dpath
guardAuthorised_ [InGroup trusteesGroup]

let aliasForm = [ thediv ! [theclass "box"] <<
[h2 << ("Merge Tag " ++ tagname)
, form ! [XHtml.method "post", action ("/packages/tag/" ++ tagname ++ "/alias")] <<
[ hidden "_method" "PUT"
, input ! [value "", name "tags", identifier "tags"]
, toHtml " (Tag to merge with) ", br
, input ! [thetype "submit", value "Merge"]
]
]
]
return $ toResponse $ Resource.XHtml $ hackagePage ("Merge Tag " ++ tagname) aliasForm

serveTagListing :: DynamicPath -> ServerPartE Response
serveTagListing dpath =
serveTagListing dpath = do
tagname <- tagInPath dpath
withTagPath dpath $ \tg pkgnames -> do
let tagd = "Packages tagged " ++ display tg
pkgs = Set.toList pkgnames
Expand All @@ -1536,6 +1576,8 @@ mkHtmlTags HtmlUtilities{..}
[] -> toHtml "No packages have this tag."
_ -> toHtml
[ paragraph << [if count==1 then "1 package has" else show count ++ " packages have", " this tag."]
, anchor ! [href $ tagname ++ "/alias/edit"] << "[Merge tag]"
, toHtml " (trustees only)"
, paragraph ! [theclass "toc"] << [toHtml "Related tags: ", toHtml $ showHistogram histogram]
]
, "tabledata" $= rowList
Expand All @@ -1553,24 +1595,55 @@ mkHtmlTags HtmlUtilities{..}
putPackageTags :: DynamicPath -> ServerPartE Response
putPackageTags dpath = do
pkgname <- packageInPath dpath
_ <- lookupPackageName pkgname -- TODO: necessary?
putTags pkgname
return $ toResponse $ Resource.XHtml $ hackagePage "Set tags"
[toHtml "Put tags for ", packageNameLink pkgname]
guardValidPackageName pkgname
addns <- optional $ look "addns"
delns <- optional $ look "delns"
raddns <- optional $ look "raddns"
rdelns <- optional $ look "rdelns"

putTags addns delns raddns rdelns pkgname
currTags <- queryTagsForPackage pkgname
revTags <- queryReviewTagsForPackage pkgname
let disp = renderReviewTags currTags revTags pkgname
return $ toResponse $ Resource.XHtml $ hackagePage "Package Tags" disp

showPackageTags :: DynamicPath -> ServerPartE Response
showPackageTags dpath = do
pkgname <- packageInPath dpath
currTags <- queryTagsForPackage pkgname
revTags <- queryReviewTagsForPackage pkgname
let disp = renderReviewTags currTags revTags pkgname
return $ toResponse $ Resource.XHtml $ hackagePage "Package Tags" disp

-- serve form for editing, to be received by putTags
serveTagsForm :: DynamicPath -> ServerPartE Response
serveTagsForm dpath = do
pkgname <- packageInPath dpath
currTags <- queryTagsForPackage pkgname
let tagsStr = concat . intersperse ", " . map display . Set.toList $ currTags
return $ toResponse $ Resource.XHtml $ hackagePage "Edit package tags"
[paragraph << [toHtml "Set tags for ", packageNameLink pkgname],
form ! [theclass "box", XHtml.method "post", action $ packageTagsUri tags "" pkgname] <<
[ hidden "_method" "PUT"
, dlist . ddef . toHtml $ makeInput [thetype "text", value tagsStr] "tags" "Set tags to "
, paragraph << input ! [thetype "submit", value "Set tags"]
]]
revTags <- queryReviewTagsForPackage pkgname
template <- getTemplate templates "tag-edit.html"
let toStr = intercalate ", " . map display . Set.toList
tagsStr = toStr currTags
addns = toStr $ fst revTags
delns = toStr $ snd revTags
trustainer <- guardAuthorised' [InGroup (maintainersGroup pkgname), InGroup trusteesGroup]
user <- guardAuthorised' [AnyKnownUser]
if trustainer || user
then return $ toResponse . template $
[ "pkgname" $= display pkgname
, "addns" $= addns
, "tags" $= tagsStr
, "delns" $= delns
, "istrustee" $= trustainer
, "isuser" $= not trustainer
]
else return $ toResponse $ Resource.XHtml $ hackagePage "Error" [h2 << "Authorization Error"
, paragraph << "You need to be logged in to propose tags"]

-- | Find a TagName inside a path.
tagInPath :: forall m a. (MonadPlus m, FromReqURI a) => DynamicPath -> m a
tagInPath dpath = maybe mzero return (lookup "tag" dpath >>= fromReqURI)


{-------------------------------------------------------------------------------
Search
Expand Down
24 changes: 22 additions & 2 deletions Distribution/Server/Features/Html/HtmlUtilities.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
@@ -1,4 +1,4 @@
{-# LANGUAGE RecursiveDo, FlexibleContexts, RankNTypes, NamedFieldPuns, RecordWildCards #-}
{-# LANGUAGE FlexibleContexts, RankNTypes, NamedFieldPuns, RecordWildCards #-}
module Distribution.Server.Features.Html.HtmlUtilities (
HtmlUtilities(..),
htmlUtilities
Expand All @@ -9,7 +9,7 @@ import qualified Data.Set as Set
import Distribution.Server.Features.Tags
import Distribution.Server.Features.Core
import Distribution.Text (display)
import Data.List (intersperse)
import Data.List (intersperse, intercalate)
import Data.Set (Set)
import Distribution.Server.Features.PackageList
import Distribution.Server.Pages.Util (packageType)
Expand All @@ -22,6 +22,7 @@ data HtmlUtilities = HtmlUtilities {
, renderItem :: PackageItem -> Html
, makeRow :: PackageItem -> Html
, renderTags :: Set Tag -> [Html]
, renderReviewTags :: Set Tag -> (Set Tag, Set Tag) -> PackageName -> [Html]
}

htmlUtilities :: CoreFeature -> TagsFeature -> UserFeature -> HtmlUtilities
Expand Down Expand Up @@ -68,4 +69,23 @@ htmlUtilities CoreFeature{coreResource}
(map (\tg -> anchor ! [href $ tagUri tagsResource "" tg] << display tg)
$ Set.toList tags)

-- The page displayed at /package/:package/tags
renderReviewTags :: Set Tag -> (Set Tag, Set Tag) -> PackageName -> [Html]
renderReviewTags currTags revTags pkgname=
let toStr = intercalate ", " . map display . Set.toList
tagsStr = toStr currTags
addns = toStr $ fst revTags
delns = toStr $ snd revTags
disp = thediv ! [theclass "box"] << [ paragraph << [bold $ toHtml "Current Tags: ", toHtml tagsStr, br]
, paragraph << [bold $ toHtml "Additions to be reviewed: ", toHtml $ if (addns /= "") then addns else "None", br]
, paragraph << [bold $ toHtml "Deletions to be reviewed: ", toHtml $ if (delns /= "") then delns else "None", br]
]
in
[ big $ bold $ toHtml $ display pkgname
, disp
, anchor ![href "tags/edit" ] << "Propose a tag?", toHtml " or "
, toHtml "return to ", packageNameLink pkgname, br
]


cores = coreResource
Loading