Skip to content

Commit d1fd17a

Browse files
author
Soorya Narayan
committed
Tag Aliasing
When a trustee aliases Tag abcd -> Tag abc, all packages that were earlier tagged abcd get tagged to abc and any new packages tagged abcd get retagged abc on upload
1 parent d89a44c commit d1fd17a

File tree

5 files changed

+151
-14
lines changed

5 files changed

+151
-14
lines changed

‎Distribution/Server/Features/Core.hs

Lines changed: 4 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -230,7 +230,8 @@ data CoreResource = CoreResource {
230230

231231
-- | Find a PackageId or PackageName inside a path.
232232
packageInPath :: forall m a. (MonadPlus m, FromReqURI a) => DynamicPath -> m a,
233-
233+
-- | Find a TagName inside a path.
234+
tagInPath :: forall m a. (MonadPlus m, FromReqURI a) => DynamicPath -> m a,
234235
-- | Find a tarball's PackageId from inside a path, doing some checking
235236
-- for consistency between the package and tarball.
236237
--
@@ -448,6 +449,8 @@ coreFeature ServerEnv{serverBlobStore = store} UserFeature{..}
448449

449450
packageInPath dpath = maybe mzero return (lookup "package" dpath >>= fromReqURI)
450451

452+
tagInPath dpath = maybe mzero return (lookup "tag" dpath >>= fromReqURI)
453+
451454
packageTarballInPath dpath = do
452455
PackageIdentifier name version <- packageInPath dpath
453456
case lookup "tarball" dpath >>= fromReqURI of

‎Distribution/Server/Features/Html.hs

Lines changed: 35 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -63,7 +63,7 @@ import qualified Data.Map as Map
6363
import Data.Set (Set)
6464
import qualified Data.Set as Set
6565
import qualified Data.Vector as Vec
66-
import Data.Maybe (fromMaybe, isJust, fromJust)
66+
import Data.Maybe (fromMaybe, isJust)
6767
import Data.Monoid ((<>))
6868
import qualified Data.Text as T
6969
import Data.Traversable (traverse)
@@ -1467,10 +1467,11 @@ mkHtmlTags :: HtmlUtilities
14671467
mkHtmlTags HtmlUtilities{..}
14681468
CoreFeature{ coreResource = CoreResource{
14691469
packageInPath
1470+
, tagInPath
14701471
, lookupPackageName
14711472
}
14721473
}
1473-
UploadFeature{guardAuthorisedAsUploaderOrMaintainerOrTrustee}
1474+
UploadFeature{guardAuthorisedAsUploaderOrMaintainerOrTrustee,guardAuthorisedAsTrustee}
14741475
ListFeature{makeItemList}
14751476
TagsFeature{..}
14761477
templates
@@ -1492,6 +1493,12 @@ mkHtmlTags HtmlUtilities{..}
14921493
, (extendResource $ packageTagsListing tags) {
14931494
resourcePut = [("html", putPackageTags)], resourceGet = [("html", showPackageTags)]
14941495
}
1496+
, (extendResource $ tagAliasEdit tags) {
1497+
resourcePut = [("html", putAliasEdit)]
1498+
}
1499+
, (extendResource $ tagAliasEditForm tags) {
1500+
resourceGet = [("html", serveAliasForm)]
1501+
}
14951502
, tagEdit -- (extendResource $ packageTagsEdit tags) { resourceGet = [("html", serveTagsForm)] }
14961503
]
14971504

@@ -1513,8 +1520,32 @@ mkHtmlTags HtmlUtilities{..}
15131520
]
15141521
tagItem tg = anchor ! [href $ tagUri tags "" tg] << display tg
15151522

1523+
putAliasEdit :: DynamicPath -> ServerPartE Response
1524+
putAliasEdit dpath = do
1525+
let tagname = snd (dpath !! 0)
1526+
mergeTags (Tag tagname)
1527+
return $ toResponse $ Resource.XHtml $ hackagePage ("Merged Tag " ++ tagname) $
1528+
[ paragraph << ["Return to"]
1529+
, anchor ! [href "/packages/tags"] << tagname
1530+
]
1531+
1532+
serveAliasForm :: DynamicPath -> ServerPartE Response
1533+
serveAliasForm dpath = do
1534+
tagname <- tagInPath dpath
1535+
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"]
1542+
]
1543+
]
1544+
return $ toResponse $ Resource.XHtml $ hackagePage ("Merge Tag " ++ tagname) $ aliasForm
1545+
15161546
serveTagListing :: DynamicPath -> ServerPartE Response
1517-
serveTagListing dpath =
1547+
serveTagListing dpath = do
1548+
tagname <- tagInPath dpath
15181549
withTagPath dpath $ \tg pkgnames -> do
15191550
let tagd = "Packages tagged " ++ display tg
15201551
pkgs = Set.toList pkgnames
@@ -1528,6 +1559,7 @@ mkHtmlTags HtmlUtilities{..}
15281559
[] -> toHtml "No packages have this tag."
15291560
_ -> toHtml
15301561
[ paragraph << [if count==1 then "1 package has" else show count ++ " packages have", " this tag."]
1562+
, anchor ! [href $ tagname ++ "/alias/edit"] << "[Merge tag]"
15311563
, paragraph ! [theclass "toc"] << [toHtml "Related tags: ", toHtml $ showHistogram histogram]
15321564
, ulist ! [theclass "packages"] << map renderItem items ]
15331565
]

‎Distribution/Server/Features/Tags.hs

Lines changed: 65 additions & 8 deletions
Original file line numberDiff line numberDiff line change
@@ -32,7 +32,7 @@ import Distribution.PackageDescription
3232
import Distribution.PackageDescription.Configuration
3333
import Distribution.License
3434

35-
import Data.Maybe(fromMaybe)
35+
import Data.Maybe(fromMaybe, fromJust)
3636
import Data.Set (Set)
3737
import qualified Data.Set as Set
3838
import Data.Map (Map)
@@ -50,6 +50,7 @@ data TagsFeature = TagsFeature {
5050
queryGetTagList :: forall m. MonadIO m => m [(Tag, Set PackageName)],
5151
queryTagsForPackage :: forall m. MonadIO m => PackageName -> m (Set Tag),
5252
queryReviewTagsForPackage :: forall m. MonadIO m => PackageName -> m (Maybe (Set Tag,Set Tag)),
53+
queryAliasForTag :: MonadIO m => Tag -> m (Maybe Tag),
5354

5455
-- All package names that were modified, and all tags that were modified
5556
-- In almost all cases, one of these will be a singleton. Happstack
@@ -68,7 +69,8 @@ data TagsFeature = TagsFeature {
6869
withTagPath :: forall a. DynamicPath -> (Tag -> Set PackageName -> ServerPartE a) -> ServerPartE a,
6970
collectTags :: forall m. MonadIO m => Set PackageName -> m (Map PackageName (Set Tag)),
7071

71-
putTags :: PackageName -> ServerPartE ()
72+
putTags :: PackageName -> ServerPartE (),
73+
mergeTags :: Tag -> ServerPartE ()
7274

7375
}
7476

@@ -80,6 +82,8 @@ data TagsResource = TagsResource {
8082
tagListing :: Resource,
8183
packageTagsListing :: Resource,
8284
packageTagsEdit :: Resource,
85+
tagAliasEdit :: Resource,
86+
tagAliasEditForm :: Resource,
8387

8488
tagUri :: String -> Tag -> String,
8589
tagsUri :: String -> String,
@@ -93,20 +97,23 @@ initTagsFeature :: ServerEnv
9397
initTagsFeature ServerEnv{serverStateDir} = do
9498
tagsState <- tagsStateComponent serverStateDir
9599
tagsReview <- tagsReviewComponent serverStateDir
100+
tagAlias <- tagsAliasComponent serverStateDir
96101
specials <- newMemStateWHNF emptyPackageTags
97102
updateTag <- newHook
98103

99104
return $ \core@CoreFeature{..} upload -> do
100-
let feature = tagsFeature core upload tagsState tagsReview specials updateTag
105+
let feature = tagsFeature core upload tagsState tagsReview tagAlias specials updateTag
101106

102107
registerHookJust packageChangeHook isPackageChangeAny $ \(pkgid, mpkginfo) ->
103108
case mpkginfo of
104109
Nothing -> return ()
105110
Just pkginfo -> do
106111
let pkgname = packageName pkgid
107-
tags = Set.fromList . constructImmutableTags . pkgDesc $ pkginfo
108-
updateState tagsState . SetPackageTags pkgname $ tags
109-
runHook_ updateTag (Set.singleton pkgname, tags)
112+
tags = constructImmutableTags . pkgDesc $ pkginfo
113+
aliases <- sequence $ map (\tag -> queryState tagAlias $ GetTagAlias tag) tags
114+
let newtags = Set.fromList $ map fromJust aliases
115+
updateState tagsState . SetPackageTags pkgname $ newtags
116+
runHook_ updateTag (Set.singleton pkgname, newtags)
110117

111118
return feature
112119

@@ -123,6 +130,20 @@ tagsStateComponent stateDir = do
123130
, resetState = tagsStateComponent
124131
}
125132

133+
tagsAliasComponent :: FilePath -> IO (StateComponent AcidState TagAlias)
134+
tagsAliasComponent stateDir = do
135+
st <- openLocalStateFrom (stateDir </> "db" </> "Tags" </> "Alias") emptyTagAlias
136+
return StateComponent {
137+
stateDesc = "Tags Alias"
138+
, stateHandle = st
139+
, getState = query st GetTagAliasesState
140+
, putState = update st . AddTagAliasesState
141+
-- , backupState = \_ pkgTags -> [csvToBackup ["tags.csv"] $ tagsToCSV pkgTags]
142+
-- , restoreState = tagsBackup
143+
-- , resetState = tagsStateComponent
144+
}
145+
146+
126147
tagsReviewComponent :: FilePath -> IO (StateComponent AcidState ReviewTags)
127148
tagsReviewComponent stateDir = do
128149
st <- openLocalStateFrom (stateDir </> "db" </> "Tags" </> "Review") emptyReviewTags
@@ -142,6 +163,7 @@ tagsFeature :: CoreFeature
142163
-> UploadFeature
143164
-> StateComponent AcidState PackageTags
144165
-> StateComponent AcidState ReviewTags
166+
-> StateComponent AcidState TagAlias
145167
-> MemState PackageTags
146168
-> Hook (Set PackageName, Set Tag) ()
147169
-> TagsFeature
@@ -152,13 +174,16 @@ tagsFeature CoreFeature{ queryGetPackageIndex
152174
UploadFeature{ guardAuthorisedAsUploaderOrMaintainerOrTrustee }
153175
tagsState
154176
tagsReview
177+
tagsAlias
155178
calculatedTags
156179
tagsUpdated
157180
= TagsFeature{..}
158181
where
159182
tagsResource = fix $ \r -> TagsResource
160183
{ tagsListing = resourceAt "/packages/tags/.:format"
161184
, tagListing = resourceAt "/packages/tag/:tag.:format"
185+
, tagAliasEdit = resourceAt "/packages/tag/:tag/alias"
186+
, tagAliasEditForm = resourceAt "/packages/tag/:tag/alias/edit"
162187
, packageTagsListing = resourceAt "/package/:package/tags.:format"
163188
, packageTagsEdit = resourceAt "/package/:package/tags/edit"
164189
, tagUri = \format tag -> renderResource (tagListing r) [display tag, format]
@@ -200,6 +225,9 @@ tagsFeature CoreFeature{ queryGetPackageIndex
200225
queryTagsForPackage :: MonadIO m => PackageName -> m (Set Tag)
201226
queryTagsForPackage pkgname = queryState tagsState (TagsForPackage pkgname)
202227

228+
queryAliasForTag :: MonadIO m => Tag -> m (Maybe Tag)
229+
queryAliasForTag tag = queryState tagsAlias (GetTagAlias tag)
230+
203231
queryReviewTagsForPackage :: MonadIO m => PackageName -> m (Maybe (Set Tag,Set Tag))
204232
queryReviewTagsForPackage pkgname = queryState tagsReview (LookupReviewTags pkgname)
205233

@@ -221,6 +249,29 @@ tagsFeature CoreFeature{ queryGetPackageIndex
221249
pkgMap <- liftM packageTags $ queryState tagsState GetPackageTags
222250
return $ Map.fromDistinctAscList . map (\pkg -> (pkg, Map.findWithDefault Set.empty pkg pkgMap)) $ Set.toList pkgs
223251

252+
253+
mergeTags :: Tag -> ServerPartE ()
254+
mergeTags deprTag = do
255+
tags <- optional $ look "tags"
256+
index <- queryGetPackageIndex
257+
case simpleParse =<< tags of
258+
Just (Tag orig) -> do
259+
void $ updateState tagsAlias $ AddTagAlias (Tag orig) deprTag
260+
void $ constructMergedTagIndex (Tag orig) deprTag index
261+
_ -> errBadRequest "Tag not recognised" [MText "Couldn't parse tag. It should be a single tag."]
262+
263+
-- tags on merging
264+
constructMergedTagIndex :: forall m. MonadIO m => Tag -> Tag -> PackageIndex PkgInfo -> m (PackageTags)
265+
constructMergedTagIndex orig depr = foldM addToTags emptyPackageTags . PackageIndex.allPackagesByName
266+
where addToTags calcTags pkgList = do
267+
let info = pkgDesc $ last pkgList
268+
!pn = packageName info
269+
pkgTags <- queryTagsForPackage pn
270+
let newTags = if (depr `elem` pkgTags) then (Set.delete depr (Set.insert orig pkgTags)) else pkgTags
271+
void $ updateState tagsState $ SetPackageTags pn newTags
272+
runHook_ tagsUpdated (Set.singleton pn, newTags)
273+
return (setTags pn newTags calcTags)
274+
224275
putTags :: PackageName -> ServerPartE ()
225276
putTags pkgname = do
226277
guardValidPackageName pkgname
@@ -235,16 +286,20 @@ tagsFeature CoreFeature{ queryGetPackageIndex
235286
user <- guardAuthorisedAsUploaderOrMaintainerOrTrustee pkgname
236287
case user of
237288
"Uploaders" -> do
289+
aliases <- sequence $ map (\tag -> queryState tagsAlias $ GetTagAlias tag) add
238290
calcTags <- queryTagsForPackage pkgname
239-
let addTags = Set.fromList add `Set.difference` calcTags
291+
let add_ = map fromJust aliases
292+
addTags = Set.fromList add_ `Set.difference` calcTags
240293
delTags = Set.fromList del `Set.intersection` calcTags
241294
void $ updateState tagsReview $ InsertReviewTags pkgname addTags delTags
242295
return ()
243296
_ -> do
244297
calcTags <- queryTagsForPackage pkgname
298+
aliases <- sequence $ map (\tag -> queryState tagsAlias $ GetTagAlias tag) add
245299
revTags <- queryReviewTagsForPackage pkgname
246300
let tagSet = (addTags `Set.union` calcTags) `Set.difference` delTags
247-
addTags = Set.fromList add
301+
add_ = map fromJust aliases
302+
addTags = Set.fromList add_
248303
delTags = Set.fromList del
249304
rdel = case simpleParse =<< rdelns of
250305
Just (TagList rdel) -> rdel
@@ -282,6 +337,8 @@ constructImmutableTagIndex = foldl' addToTags emptyPackageTags . PackageIndex.al
282337
!tags = constructImmutableTags info
283338
in setTags pn (Set.fromList tags) calcTags
284339

340+
341+
285342
-- These are constructed when a package is uploaded/on startup
286343
constructCategoryTags :: PackageDescription -> [Tag]
287344
constructCategoryTags = map (tagify . map toLower) . fillMe . categorySplit . category

‎Distribution/Server/Features/Tags/State.hs

Lines changed: 42 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -70,12 +70,39 @@ data PackageTags = PackageTags {
7070
-- Packagename (Proposed Additions, Proposed Deletions)
7171
data ReviewTags = ReviewTags (Map PackageName (Set Tag, Set Tag)) deriving (Eq, Show)
7272

73+
data TagAlias = TagAlias (Map Tag (Set Tag))
74+
75+
addTagAlias :: Tag -> Tag -> Update TagAlias ()
76+
addTagAlias tag alias= do
77+
TagAlias m <- get
78+
put (TagAlias (Map.insertWith (Set.union) tag (Set.singleton alias) m))
79+
80+
lookupTagAlias :: Tag -> Query TagAlias (Maybe (Set Tag))
81+
lookupTagAlias tag
82+
= do TagAlias m <- ask
83+
return (Map.lookup tag m)
84+
85+
getTagAlias :: Tag -> Query TagAlias (Maybe Tag)
86+
getTagAlias tag
87+
= do TagAlias m <- ask
88+
return (canonical tag m) where
89+
canonical tag m
90+
| tag `elem` (Map.keys m) = Just tag
91+
| tag `elem` (foldr Set.union Set.empty $ Map.elems m) = Just (lookupKey tag m)
92+
| otherwise = Just tag
93+
where
94+
lookupKey key m = (Map.keys $ Map.filter (tag `elem` ) m) !! 0
95+
7396
emptyPackageTags :: PackageTags
7497
emptyPackageTags = PackageTags Map.empty Map.empty
7598

7699
emptyReviewTags :: ReviewTags
77100
emptyReviewTags = ReviewTags Map.empty
78101

102+
emptyTagAlias :: TagAlias
103+
emptyTagAlias = TagAlias Map.empty
104+
105+
79106
tagToPackages :: Tag -> PackageTags -> Set PackageName
80107
tagToPackages tag = Map.findWithDefault Set.empty tag . tagPackages
81108

@@ -95,7 +122,6 @@ alterTags name mtagList (PackageTags tags packages) =
95122
setTags :: PackageName -> Set Tag -> PackageTags -> PackageTags
96123
setTags pkgname tagList = alterTags pkgname (keepSet tagList)
97124

98-
99125
deletePackageTags :: PackageName -> PackageTags -> PackageTags
100126
deletePackageTags name = alterTags name Nothing
101127

@@ -150,7 +176,7 @@ renameTag tag tag' pkgTags@(PackageTags _ packages) =
150176
$(deriveSafeCopy 0 'base ''Tag)
151177
$(deriveSafeCopy 0 'base ''PackageTags)
152178
$(deriveSafeCopy 0 'base ''ReviewTags)
153-
179+
$(deriveSafeCopy 0 'base ''TagAlias)
154180

155181
instance NFData PackageTags where
156182
rnf (PackageTags a b) = rnf a `seq` rnf b
@@ -182,6 +208,13 @@ getReviewTags = ask
182208
replaceReviewTags :: ReviewTags -> Update ReviewTags ()
183209
replaceReviewTags = put
184210

211+
getTagAliasesState :: Query TagAlias TagAlias
212+
getTagAliasesState = ask
213+
214+
addTagAliasesState :: TagAlias -> Update TagAlias ()
215+
addTagAliasesState = put
216+
217+
185218
setPackageTags :: PackageName -> Set Tag -> Update PackageTags ()
186219
setPackageTags name tagList = modify $ setTags name tagList
187220

@@ -247,6 +280,12 @@ $(makeAcidic ''ReviewTags ['insertReviewTags
247280
,'replaceReviewTags
248281
])
249282

283+
$(makeAcidic ''TagAlias ['addTagAlias
284+
,'getTagAlias
285+
,'lookupTagAlias
286+
,'addTagAliasesState
287+
,'getTagAliasesState
288+
])
250289

251290
$(makeAcidic ''PackageTags ['tagsForPackage
252291
,'packagesForTag
@@ -259,3 +298,4 @@ $(makeAcidic ''PackageTags ['tagsForPackage
259298
,'removePackageTag
260299
])
261300

301+

‎Distribution/Server/Features/Upload.hs

Lines changed: 5 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -59,6 +59,7 @@ data UploadFeature = UploadFeature {
5959
-- | Requiring being logged in as the maintainer of a package.
6060
guardAuthorisedAsUploaderOrMaintainerOrTrustee :: PackageName -> ServerPartE String,
6161
guardAuthorisedAsMaintainer :: PackageName -> ServerPartE (),
62+
guardAuthorisedAsTrustee :: ServerPartE (),
6263
-- | Requiring being logged in as the maintainer of a package or a trustee.
6364
guardAuthorisedAsMaintainerOrTrustee :: PackageName -> ServerPartE (),
6465

@@ -297,6 +298,10 @@ uploadFeature ServerEnv{serverBlobStore = store}
297298
guardAuthorisedAsMaintainer pkgname =
298299
guardAuthorised_ [InGroup (maintainersGroup pkgname)]
299300

301+
guardAuthorisedAsTrustee :: ServerPartE ()
302+
guardAuthorisedAsTrustee =
303+
guardAuthorised_ [InGroup trusteesGroup]
304+
300305
guardAuthorisedAsUploaderOrMaintainerOrTrustee :: PackageName -> ServerPartE String
301306
guardAuthorisedAsUploaderOrMaintainerOrTrustee pkgname= do
302307
mt <- guardAuthorised' [InGroup (maintainersGroup pkgname), InGroup trusteesGroup]

0 commit comments

Comments
 (0)