From bb1685f695f051aeefb8176d53bb3c7b42e7018c Mon Sep 17 00:00:00 2001 From: Pere Lev Date: Sat, 27 Apr 2024 11:31:09 +0300 Subject: [PATCH] UI: Project: Buttons for removing parents --- src/Vervis/Foundation.hs | 1 + src/Vervis/Handler/Project.hs | 77 +++++++++++++++++++++++++++++--- templates/project/parents.hamlet | 6 ++- th/routes | 3 +- 4 files changed, 79 insertions(+), 8 deletions(-) diff --git a/src/Vervis/Foundation.hs b/src/Vervis/Foundation.hs index 437483a..86dc9c9 100644 --- a/src/Vervis/Foundation.hs +++ b/src/Vervis/Foundation.hs @@ -1039,3 +1039,4 @@ instance YesodBreadcrumbs App where ProjectParentLiveR j d -> (keyHashidText d, Just $ ProjectParentsR j) ProjectRemoveChildR _ _ -> ("", Nothing) + ProjectRemoveParentR _ _ -> ("", Nothing) diff --git a/src/Vervis/Handler/Project.hs b/src/Vervis/Handler/Project.hs index 9c779b0..c3902a6 100644 --- a/src/Vervis/Handler/Project.hs +++ b/src/Vervis/Handler/Project.hs @@ -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 diff --git a/templates/project/parents.hamlet b/templates/project/parents.hamlet index acc5152..0cd049a 100644 --- a/templates/project/parents.hamlet +++ b/templates/project/parents.hamlet @@ -22,11 +22,15 @@ $# . Role Since Parent - $forall (role, since, parent) <- parents + $if haveAdmin + Remove + $forall (role, since, parent, destID) <- parents #{show role} #{showDate since} ^{projectLinkFedW parent} + $if haveAdmin + ^{buttonW POST "Remove" (ProjectRemoveParentR projectHash destID)}

Invites diff --git a/th/routes b/th/routes index a9b1a9c..f009ad4 100644 --- a/th/routes +++ b/th/routes @@ -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