forge/Vervis
1
0
Fork 0
Code Pull requests Activity

UI: Project: Buttons for removing parents

Browse source
This commit is contained in:
Pere Lev 2024-04-27 11:31:09 +03:00
parent c62c1674ee
commit bb1685f695
No known key found for this signature in database
GPG key ID: 5252C5C863E5E57D
4 changed files with 79 additions and 8 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

1
src/Vervis/Foundation.hs
View file

@ -1039,3 +1039,4 @@ instance YesodBreadcrumbs App where
ProjectParentLiveR j d -> (keyHashidText d, Just $ ProjectParentsR j)
ProjectRemoveChildR _ _ -> ("", Nothing)
ProjectRemoveParentR _ _ -> ("", Nothing)

77
src/Vervis/Handler/Project.hs
View file

@ -45,6 +45,7 @@ module Vervis.Handler.Project
, getProjectParentLiveR
, postProjectRemoveChildR
, postProjectRemoveParentR
)
where
@ -764,7 +765,7 @@ getProjectParentsR projectHash = do
encodeRouteHome $ ProjectR $ hashProject parentID
makeId (Right (i, ro, _)) =
ObjURI (instanceHost i) (remoteObjectIdent ro)
makeItem (role, time, i) = AP.Relationship
makeItem (role, time, i, _) = AP.Relationship
{ AP.relationshipId = Nothing
, AP.relationshipExtraTypes = []
, AP.relationshipSubject = encodeRouteHome $ ProjectR projectHash
@ -791,13 +792,13 @@ getProjectParentsR projectHash = do
where
getParents projectID = fmap (sortOn $ view _2) $ liftA2 (++)
(map (\ (E.Value role, E.Value time, E.Value parent, Entity _ actor) ->
(role, time, Left (parent, actor))
(map (\ (E.Value role, E.Value time, E.Value parent, Entity _ actor, E.Value destID) ->
(role, time, Left (parent, actor), destID)
)
<$> getLocals projectID
)
(map (\ (E.Value role, E.Value time, Entity _ i, Entity _ ro, Entity _ ra) ->
(role, time, Right (i, ro, ra))
(map (\ (E.Value role, E.Value time, Entity _ i, Entity _ ro, Entity _ ra, E.Value destID) ->
(role, time, Right (i, ro, ra), destID)
)
<$> getRemotes projectID
)
@ -818,6 +819,7 @@ getProjectParentsR projectHash = do
, grant E.^. OutboxItemPublished
, topic E.^. DestTopicProjectParent
, actor
, dest E.^. DestId
)
getRemotes projectID =
@ -838,9 +840,14 @@ getProjectParentsR projectHash = do
, i
, ro
, ra
, dest E.^. DestId
)
getHtml projectID project actor parents = do
mp <- maybeAuthId
haveAdmin <- fmap isJust $ handlerToWidget $ runDB $ runMaybeT $ do
personID <- MaybeT $ pure mp
MaybeT $ getCapability personID (Left $ projectResource project) AP.RoleAdmin
invites <- handlerToWidget $ runDB $ do
dests <- E.select $ E.from $ \ (dest `E.InnerJoin` holder `E.LeftOuterJoin` accept `E.LeftOuterJoin` delegl `E.LeftOuterJoin` delegr) -> do
E.on $ accept E.?. DestUsAcceptId E.==. delegr E.?. DestThemSendDelegatorRemoteDest
@ -961,7 +968,7 @@ postProjectRemoveChildR projectHash sourceID = do
C.remove personID uChild uCollection
cap <- do
maybeItem <- lift $ runDB $ getCapability personID (Left resourceID) AP.RoleAdmin
fromMaybeE maybeItem "You need to be have Admin access to the Project to remove people"
fromMaybeE maybeItem "You need to be have Admin access to the Project to remove children"
uCap <- lift $ renderActivityURI cap
(localRecips, remoteRecips, fwdHosts, action) <-
C.makeServerInput (Just uCap) maybeSummary audience $ AP.RemoveActivity remove
@ -975,3 +982,61 @@ postProjectRemoveChildR projectHash sourceID = do
Right removeID ->
setMessage "Remove sent"
redirect $ ProjectChildrenR projectHash
postProjectRemoveParentR :: KeyHashid Project -> DestId -> Handler Html
postProjectRemoveParentR projectHash destID = do
projectID <- decodeKeyHashid404 projectHash
personEntity@(Entity personID person) <- requireAuth
personHash <- encodeKeyHashid personID
encodeRouteHome <- getEncodeRouteHome
result <- runExceptT $ do
mpidOrU <- lift $ runDB $ runMaybeT $ do
project <- MaybeT $ get projectID
_ <- MaybeT $ get destID
DestHolderProject _ j <-
MaybeT $ getValBy $ UniqueDestHolderProject destID
guard $ projectID == j
acceptID <- MaybeT $ getKeyBy $ UniqueDestUsAccept destID
_ <- MaybeT $ getBy $ UniqueDestUsStart acceptID
topic <- lift $ do
t <- bimap snd snd <$> getDestTopic destID
bitraverse
(\case
Left j' -> pure j'
Right _g -> error "I'm a project, I have a Dest with topic being Group"
)
pure
t
lift $
(projectResource project,) <$>
bitraverse
pure
(getRemoteActorURI <=< getJust)
topic
(resourceID, pidOrU) <- maybe notFound pure mpidOrU
(maybeSummary, audience, remove) <- do
uParent <-
case pidOrU of
Left j -> encodeRouteHome . ProjectR <$> encodeKeyHashid j
Right u -> pure u
let uCollection = encodeRouteHome $ ProjectParentsR projectHash
C.remove personID uParent uCollection
cap <- do
maybeItem <- lift $ runDB $ getCapability personID (Left resourceID) AP.RoleAdmin
fromMaybeE maybeItem "You need to be have Admin access to the Project to remove parents"
uCap <- lift $ renderActivityURI cap
(localRecips, remoteRecips, fwdHosts, action) <-
C.makeServerInput (Just uCap) maybeSummary audience $ AP.RemoveActivity remove
let cap' = first (\ (la, i) -> (la, error "lah", i)) cap
handleViaActor
personID (Just cap') localRecips remoteRecips fwdHosts action
case result of
Left e -> do
setMessage $ toHtml e
Right removeID ->
setMessage "Remove sent"
redirect $ ProjectParentsR projectHash

6
templates/project/parents.hamlet
View file

@ -22,11 +22,15 @@ $# <http://creativecommons.org/publicdomain/zero/1.0/>.
<th>Role
<th>Since
<th>Parent
$forall (role, since, parent) <- parents
$if haveAdmin
<th>Remove
$forall (role, since, parent, destID) <- parents
<tr>
<td>#{show role}
<td>#{showDate since}
<td>^{projectLinkFedW parent}
$if haveAdmin
<td>^{buttonW POST "Remove" (ProjectRemoveParentR projectHash destID)}
<h2>Invites

3
th/routes
View file

@ -354,4 +354,5 @@
/projects/#ProjectKeyHashid/parents ProjectParentsR GET
/projects/#ProjectKeyHashid/parents/#DestUsStartKeyHashid/live ProjectParentLiveR GET
/projects/#ProjectKeyHashid/children/remove/#SourceId ProjectRemoveChildR POST
/projects/#ProjectKeyHashid/child/remove/#SourceId ProjectRemoveChildR POST
/projects/#ProjectKeyHashid/parent/remove/#DestId ProjectRemoveParentR POST