Skip to content

Commit 6fd4b51

Browse files
author
Soorya Narayan
committed
Cleaning up earlier code
Added backup functions for tag alias Fixed tag aliasing bug on startup
1 parent 4273b18 commit 6fd4b51

File tree

13 files changed

+225
-242
lines changed

13 files changed

+225
-242
lines changed

‎Distribution/Server/Features/Html.hs

+44-81
Original file line numberDiff line numberDiff line change
@@ -440,8 +440,7 @@ htmlFeature env@ServerEnv{..}
440440

441441
{-------------------------------------------------------------------------------
442442
Core
443-
-----------------------------------------------------------------------------
444-
-}
443+
-------------------------------------------------------------------------------}
445444

446445
data HtmlCore = HtmlCore {
447446
htmlCoreResources :: [Resource]
@@ -519,10 +518,10 @@ mkHtmlCore ServerEnv{serverBaseURI}
519518
, (resourceAt "/packages/names" ) {
520519
resourceGet = [("html", const $ readAsyncCache cacheNamesPage)]
521520
}
522-
, (resourceAt "/packages/names/experiment" ) {
521+
, (resourceAt "/packages/names/tags" ) {
523522
resourceDesc = [(GET, "Show detailed package dependency information")]
524523
, resourceGet = [("html",
525-
serveMaintainPage')]
524+
serveTagIndex)]
526525
}
527526
, (extendResource $ corePackagesPage cores) {
528527
resourceDesc = [(GET, "Show package index")]
@@ -619,13 +618,13 @@ mkHtmlCore ServerEnv{serverBaseURI}
619618
, "versions" $= map packageId pkgs
620619
]
621620

622-
serveMaintainPage' :: DynamicPath -> ServerPartE Response
623-
serveMaintainPage' _ = do
621+
serveTagIndex :: DynamicPath -> ServerPartE Response
622+
serveTagIndex _ = do
624623
pkgIndex <- queryGetPackageIndex
625624
let packageNames = Pages.toPackageNames pkgIndex
626625
pkgDetails <- liftIO $ makeItemList packageNames
627626
let rowList = map (makeRow) pkgDetails
628-
tabledata = "" +++ rowList +++""
627+
tabledata = "" +++ rowList +++ ""
629628
template <- getTemplate templates "tag-interface.html"
630629
return $ toResponse $ template
631630
[ "tabledata" $= tabledata ]
@@ -679,8 +678,7 @@ mkHtmlCore ServerEnv{serverBaseURI}
679678

680679
{-------------------------------------------------------------------------------
681680
Users
682-
-----------------------------------------------------------------------------
683-
-}
681+
-------------------------------------------------------------------------------}
684682

685683
data HtmlUsers = HtmlUsers {
686684
htmlUsersResources :: [Resource]
@@ -791,8 +789,7 @@ mkHtmlUsers UserFeature{..} UserDetailsFeature{..} = HtmlUsers{..}
791789

792790
{-------------------------------------------------------------------------------
793791
Uploads
794-
-----------------------------------------------------------------------------
795-
-}
792+
-------------------------------------------------------------------------------}
796793

797794
data HtmlUploads = HtmlUploads {
798795
htmlUploadsResources :: [Resource]
@@ -840,8 +837,7 @@ mkHtmlUploads HtmlUtilities{..} UploadFeature{..} = HtmlUploads{..}
840837

841838
{-------------------------------------------------------------------------------
842839
Documentation uploads
843-
-----------------------------------------------------------------------------
844-
-}
840+
-------------------------------------------------------------------------------}
845841

846842
data HtmlDocUploads = HtmlDocUploads {
847843
htmlDocUploadsResources :: [Resource]
@@ -888,8 +884,7 @@ mkHtmlDocUploads HtmlUtilities{..} CoreFeature{coreResource} DocumentationFeatur
888884

889885
{-------------------------------------------------------------------------------
890886
Build reports
891-
-----------------------------------------------------------------------------
892-
-}
887+
-------------------------------------------------------------------------------}
893888

894889
data HtmlReports = HtmlReports {
895890
htmlReportsResources :: [Resource]
@@ -933,8 +928,7 @@ mkHtmlReports HtmlUtilities{..} CoreFeature{..} ReportsFeature{..} templates = H
933928

934929
{-------------------------------------------------------------------------------
935930
Candidates
936-
-----------------------------------------------------------------------------
937-
-}
931+
-------------------------------------------------------------------------------}
938932

939933
data HtmlCandidates = HtmlCandidates {
940934
htmlCandidatesResources :: [Resource]
@@ -1191,8 +1185,7 @@ dependenciesPage isCandidate render =
11911185

11921186
{-------------------------------------------------------------------------------
11931187
Preferred versions
1194-
-----------------------------------------------------------------------------
1195-
-}
1188+
-------------------------------------------------------------------------------}
11961189

11971190
data HtmlPreferred = HtmlPreferred {
11981191
htmlPreferredResources :: [Resource]
@@ -1410,8 +1403,7 @@ mkHtmlPreferred HtmlUtilities{..}
14101403

14111404
{-------------------------------------------------------------------------------
14121405
Downloads
1413-
-----------------------------------------------------------------------------
1414-
-}
1406+
-------------------------------------------------------------------------------}
14151407

14161408
data HtmlDownloads = HtmlDownloads {
14171409
htmlDownloadsResources :: [Resource]
@@ -1449,8 +1441,7 @@ mkHtmlDownloads HtmlUtilities{..} DownloadFeature{..} = HtmlDownloads{..}
14491441

14501442
{-------------------------------------------------------------------------------
14511443
Tags
1452-
-----------------------------------------------------------------------------
1453-
-}
1444+
-------------------------------------------------------------------------------}
14541445

14551446
data HtmlTags = HtmlTags {
14561447
htmlTagsResources :: [Resource]
@@ -1471,7 +1462,7 @@ mkHtmlTags HtmlUtilities{..}
14711462
, lookupPackageName
14721463
}
14731464
}
1474-
UploadFeature{guardAuthorisedAsUploaderOrMaintainerOrTrustee,guardAuthorisedAsTrustee}
1465+
UploadFeature{authorisedAsAnyUser, authorisedAsMaintainerOrTrustee, guardAuthorisedAsTrustee}
14751466
ListFeature{makeItemList}
14761467
TagsFeature{..}
14771468
templates
@@ -1524,21 +1515,24 @@ mkHtmlTags HtmlUtilities{..}
15241515
putAliasEdit dpath = do
15251516
let tagname = snd (dpath !! 0)
15261517
mergeTags (Tag tagname)
1527-
return $ toResponse $ Resource.XHtml $ hackagePage ("Merged Tag " ++ tagname) $
1528-
[ paragraph << ["Return to"]
1529-
, anchor ! [href "/packages/tags"] << tagname
1518+
return $ toResponse $ Resource.XHtml $ hackagePage "Merged Tag" $
1519+
[ h2 << "Merged tag"
1520+
, toHtml "Return to "
1521+
, anchor ! [href $ "/packages/tags"] << "tag listings"
15301522
]
15311523

15321524
serveAliasForm :: DynamicPath -> ServerPartE Response
15331525
serveAliasForm dpath = do
15341526
tagname <- tagInPath dpath
15351527
guardAuthorisedAsTrustee
1536-
let aliasForm = [ h2 << ("Merge Tag " ++ tagname)
1537-
, form ! [theclass "box", XHtml.method "post", action ("/packages/tag/" ++ tagname ++ "/alias")] <<
1538-
[ hidden "_method" "PUT"
1539-
, input ! [value " ", name "tags", identifier "tags"]
1540-
, toHtml "Tag(s) to merge with"
1541-
, input ! [thetype "submit", value "Merge"]
1528+
let aliasForm = [ thediv ! [theclass "box"] <<
1529+
[h2 << ("Merge Tag " ++ tagname)
1530+
, form ! [XHtml.method "post", action ("/packages/tag/" ++ tagname ++ "/alias")] <<
1531+
[ hidden "_method" "PUT"
1532+
, input ! [value "", name "tags", identifier "tags"]
1533+
, toHtml " (Tag to merge with) ", br
1534+
, input ! [thetype "submit", value "Merge"]
1535+
]
15421536
]
15431537
]
15441538
return $ toResponse $ Resource.XHtml $ hackagePage ("Merge Tag " ++ tagname) $ aliasForm
@@ -1579,40 +1573,16 @@ mkHtmlTags HtmlUtilities{..}
15791573
putTags pkgname
15801574
currTags <- queryTagsForPackage pkgname
15811575
revTags <- queryReviewTagsForPackage pkgname
1582-
let toStr = concat . intersperse ", " . map display . Set.toList
1583-
tagsStr = toStr currTags
1584-
addns = toStr $ fst $ fromMaybe (Set.empty, Set.empty) revTags
1585-
delns = toStr $ snd $ fromMaybe (Set.empty, Set.empty) revTags
1586-
disp = thediv ! [theclass "box"] << [ paragraph << [bold $ toHtml "Current Tags: ", toHtml tagsStr, br],
1587-
paragraph << [bold $ toHtml "Additions to be reviewed: ", toHtml addns, br],
1588-
paragraph << [bold $ toHtml "Deletions to be reviewed: ", toHtml delns, br]
1589-
]
1590-
1591-
return $ toResponse $ Resource.XHtml $ hackagePage "Package Tags" [ big $ bold $ toHtml $ display pkgname
1592-
, disp
1593-
, anchor ![href $ "tags/edit" ] << "Propose a tag?", toHtml " or "
1594-
, toHtml "return to ", packageNameLink pkgname, br
1595-
]
1576+
let disp = renderReviewTags currTags revTags pkgname
1577+
return $ toResponse $ Resource.XHtml $ hackagePage "Package Tags" disp
15961578

15971579
showPackageTags :: DynamicPath -> ServerPartE Response
15981580
showPackageTags dpath = do
15991581
pkgname <- packageInPath dpath
16001582
currTags <- queryTagsForPackage pkgname
16011583
revTags <- queryReviewTagsForPackage pkgname
1602-
let toStr = concat . intersperse ", " . map display . Set.toList
1603-
tagsStr = toStr currTags
1604-
addns = toStr $ fst $ fromMaybe (Set.empty, Set.empty) revTags
1605-
delns = toStr $ snd $ fromMaybe (Set.empty, Set.empty) revTags
1606-
disp = thediv ! [theclass "box"] << [ paragraph << [bold $ toHtml "Current Tags: ", toHtml tagsStr, br],
1607-
paragraph << [bold $ toHtml "Additions to be reviewed: ", toHtml addns, br],
1608-
paragraph << [bold $ toHtml "Deletions to be reviewed: ", toHtml delns, br]
1609-
]
1610-
1611-
return $ toResponse $ Resource.XHtml $ hackagePage "Package Tags" [ big $ bold $ toHtml $ display pkgname
1612-
, disp
1613-
, anchor ![href $ "tags/edit" ] << "Propose a tag?", toHtml " or "
1614-
, toHtml "return to ", packageNameLink pkgname, br
1615-
]
1584+
let disp = renderReviewTags currTags revTags pkgname
1585+
return $ toResponse $ Resource.XHtml $ hackagePage "Package Tags" disp
16161586

16171587
-- serve form for editing, to be received by putTags
16181588
serveTagsForm :: DynamicPath -> ServerPartE Response
@@ -1623,33 +1593,27 @@ mkHtmlTags HtmlUtilities{..}
16231593
template <- getTemplate templates "tag-edit.html"
16241594
let toStr = concat . intersperse ", " . map display . Set.toList
16251595
tagsStr = toStr currTags
1626-
addns = toStr $ fst $ fromMaybe (Set.empty,Set.empty) revTags
1627-
delns = toStr $ snd $ fromMaybe (Set.empty, Set.empty) revTags
1628-
1629-
1630-
user <- guardAuthorisedAsUploaderOrMaintainerOrTrustee pkgname
1631-
case user of
1632-
"Uploaders" -> return $ toResponse . template $
1633-
[ "pkgname" $= display pkgname
1634-
, "addns" $= addns
1635-
, "tags" $= (tagsStr)
1636-
, "delns" $= delns
1637-
, "isuser" $= "true"
1638-
]
1639-
_ -> return $toResponse . template $
1596+
addns = toStr $ fst revTags
1597+
delns = toStr $ snd revTags
1598+
trustainer <- authorisedAsMaintainerOrTrustee pkgname
1599+
user <- authorisedAsAnyUser
1600+
if trustainer || user
1601+
then return $ toResponse . template $
16401602
[ "pkgname" $= display pkgname
16411603
, "addns" $= addns
1642-
, "tags" $= (tagsStr)
1604+
, "tags" $= tagsStr
16431605
, "delns" $= delns
1644-
, "istrustee" $= "false"
1606+
, "istrustee" $= trustainer
1607+
, "isuser" $= if trustainer then False else True
16451608
]
1609+
else return $ toResponse $ Resource.XHtml $ hackagePage "Error" $ [h2 << "Authorization Error"
1610+
, paragraph << "You need to be logged in to propose tags"]
16461611

16471612

16481613

16491614
{-------------------------------------------------------------------------------
16501615
Search
1651-
-----------------------------------------------------------------------------
1652-
-}
1616+
-------------------------------------------------------------------------------}
16531617

16541618
data HtmlSearch = HtmlSearch {
16551619
htmlSearchResources :: [Resource]
@@ -1908,8 +1872,7 @@ mkHtmlSearch HtmlUtilities{..}
19081872

19091873
{-------------------------------------------------------------------------------
19101874
Groups
1911-
-----------------------------------------------------------------------------
1912-
-}
1875+
-------------------------------------------------------------------------------}
19131876

19141877
htmlGroupResource :: UserFeature -> GroupResource -> [Resource]
19151878
htmlGroupResource UserFeature{..} r@(GroupResource groupR userR getGroup) =

‎Distribution/Server/Features/Html/HtmlUtilities.hs

+20
Original file line numberDiff line numberDiff line change
@@ -11,6 +11,7 @@ import Distribution.Server.Features.Core
1111
import Distribution.Text (display)
1212
import Data.List (intersperse)
1313
import Data.Set (Set)
14+
import Data.Maybe (fromMaybe)
1415
import Distribution.Server.Features.PackageList
1516
import Distribution.Server.Pages.Util (packageType)
1617
import Distribution.Package
@@ -21,6 +22,7 @@ data HtmlUtilities = HtmlUtilities {
2122
, renderItem :: PackageItem -> Html
2223
, makeRow :: PackageItem -> Html
2324
, renderTags :: Set Tag -> [Html]
25+
, renderReviewTags :: Set Tag -> (Set Tag, Set Tag) -> PackageName -> [Html]
2426
}
2527

2628
htmlUtilities :: CoreFeature -> TagsFeature -> HtmlUtilities
@@ -61,4 +63,22 @@ htmlUtilities CoreFeature{coreResource}
6163
(map (\tg -> anchor ! [href $ tagUri tagsResource "" tg] << display tg)
6264
$ Set.toList tags)
6365

66+
-- The page displayed at /package/:package/tags
67+
renderReviewTags :: Set Tag -> (Set Tag, Set Tag) -> PackageName -> [Html]
68+
renderReviewTags currTags revTags pkgname=
69+
let toStr = concat . intersperse ", " . map display . Set.toList
70+
tagsStr = toStr currTags
71+
addns = toStr $ fst revTags
72+
delns = toStr $ snd revTags
73+
disp = thediv ! [theclass "box"] << [ paragraph << [bold $ toHtml "Current Tags: ", toHtml tagsStr, br]
74+
, paragraph << [bold $ toHtml "Additions to be reviewed: ", toHtml $ if (addns /= "") then addns else "None", br]
75+
, paragraph << [bold $ toHtml "Deletions to be reviewed: ", toHtml $ if (delns /= "") then delns else "None", br]
76+
]
77+
in
78+
[ big $ bold $ toHtml $ display pkgname
79+
, disp
80+
, anchor ![href $ "tags/edit" ] << "Propose a tag?", toHtml " or "
81+
, toHtml "return to ", packageNameLink pkgname, br
82+
]
83+
6484
cores = coreResource

‎Distribution/Server/Features/PackageList.hs

+3-4
Original file line numberDiff line numberDiff line change
@@ -60,11 +60,11 @@ data PackageItem = PackageItem {
6060
itemMaintainer :: !String,
6161
-- Whether the item is in the Haskell Platform
6262
--itemPlatform :: Bool,
63-
-- Author of the package (Probably won't be used in display)
64-
itemVotes :: Int,
63+
-- Number of votes for the package
64+
itemVotes :: !Int,
6565
-- The total number of downloads. (For sorting, not displaying.)
6666
-- Updated periodically.
67-
itemDownloads :: Int,
67+
itemDownloads :: !Int,
6868
-- The number of direct revdeps. (Likewise.)
6969
-- also: distinguish direct/flat?
7070
-- [reverse index disabled] itemRevDepsCount :: !Int,
@@ -251,7 +251,6 @@ updateDescriptionItem genDesc item =
251251
-- This checks if the library is buildable. However, since
252252
-- desc is flattened, we might miss some flags. Perhaps use the
253253
-- CondTree instead.
254-
-- itemAuthor = author desc,
255254
itemMaintainer = maintainer desc,
256255
itemHasLibrary = hasLibs desc,
257256
itemNumExecutables = length . filter (buildable . buildInfo) $ executables desc,

0 commit comments

Comments
 (0)