From 74af2ea2232e101d70656cc11392ec1f6c06253d Mon Sep 17 00:00:00 2001 From: Pere Lev Date: Sun, 12 May 2024 20:15:53 +0300 Subject: [PATCH] UI: Group: Display parent and child invites & approve-remove buttons --- src/Vervis/Handler/Group.hs | 167 +++++++++++++++++++++++++++++--- templates/group/children.hamlet | 46 ++++++++- templates/group/parents.hamlet | 48 ++++++++- 3 files changed, 244 insertions(+), 17 deletions(-) diff --git a/src/Vervis/Handler/Group.hs b/src/Vervis/Handler/Group.hs index 9a3d155..759d5fc 100644 --- a/src/Vervis/Handler/Group.hs +++ b/src/Vervis/Handler/Group.hs @@ -62,6 +62,7 @@ module Vervis.Handler.Group where import Control.Applicative +import Control.Arrow ((&&&)) import Control.Monad import Control.Monad.Trans.Except import Control.Monad.Trans.Maybe @@ -72,7 +73,7 @@ import Data.ByteString (ByteString) import Data.Default.Class import Data.Foldable import Data.List -import Data.Maybe (fromMaybe) +import Data.Maybe import Data.Text (Text) import Data.Time.Clock import Data.Traversable @@ -416,15 +417,15 @@ getGroupChildrenR groupHash = do actor <- getJust $ groupActor group children <- getChildren groupID return (actor, group, children) - encodeRouteLocal <- getEncodeRouteLocal encodeRouteHome <- getEncodeRouteHome + encodeRouteLocal <- getEncodeRouteLocal hashGroup <- getEncodeKeyHashid h <- asksSite siteInstanceHost let makeId (Left (childID, _)) = encodeRouteHome $ GroupR $ hashGroup childID 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 $ GroupR groupHash @@ -451,13 +452,13 @@ getGroupChildrenR groupHash = do where getChildren groupID = fmap (sortOn $ view _2) $ liftA2 (++) - (map (\ (E.Value role, E.Value time, E.Value child, Entity _ actor) -> - (role, time, Left (child, actor)) + (map (\ (E.Value role, E.Value time, E.Value child, Entity _ actor, E.Value destID) -> + (role, time, Left (child, actor), destID) ) <$> getLocals groupID ) - (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 groupID ) @@ -478,6 +479,7 @@ getGroupChildrenR groupHash = do , grant E.^. OutboxItemPublished , topic E.^. DestTopicGroupChild , actor + , dest E.^. DestId ) getRemotes groupID = @@ -498,10 +500,80 @@ getGroupChildrenR groupHash = do , i , ro , ra + , dest E.^. DestId ) getHtml groupID group actor children = do + mp <- maybeAuthId + haveAdmin <- fmap isJust $ handlerToWidget $ runDB $ runMaybeT $ do + personID <- MaybeT $ pure mp + MaybeT $ getCapability personID (Left $ groupResource group) AP.RoleAdmin + ((_, widgetAP), enctypeAP) <- runFormPost addChildForm + 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 + E.on $ accept E.?. DestUsAcceptId E.==. delegl E.?. DestThemSendDelegatorLocalDest + E.on $ E.just (dest E.^. DestId) E.==. accept E.?. DestUsAcceptDest + E.on $ dest E.^. DestId E.==. holder E.^. DestHolderGroupDest + E.where_ $ + holder E.^. DestHolderGroupGroup E.==. E.val groupID E.&&. + E.isNothing (delegl E.?. DestThemSendDelegatorLocalId) E.&&. + E.isNothing (delegr E.?. DestThemSendDelegatorRemoteId) + E.orderBy [E.asc $ dest E.^. DestId] + return dest + for dests $ \ (Entity destID (Dest role)) -> do + child <- do + topic <- getDestTopic destID + bitraverse + (\ (_, e) -> do + jID <- + case e of + Right j -> pure j + Left _ -> error "I'm a Group but my child is a Project" + j <- getJust jID + actor <- getJust $ groupActor j + return (jID, actor) + ) + (\ (_, actorID) -> getRemoteActorData actorID) + topic + accept <- isJust <$> getBy (UniqueDestUsAccept destID) + ((inviter, time), us) <- do + usOrThem <- + requireEitherAlt + (getKeyBy $ UniqueDestOriginUs destID) + (getKeyBy $ UniqueDestOriginThem destID) + "Neither us nor them" + "Both us and them" + (addOrActor, us) <- + case usOrThem of + Left _usID -> (,True) <$> + requireEitherAlt + (fmap destUsGestureLocalActivity <$> getValBy (UniqueDestUsGestureLocal destID)) + (fmap (destUsGestureRemoteActor &&& destUsGestureRemoteActivity) <$> getValBy (UniqueDestUsGestureRemote destID)) + "Neither local not remote" + "Both local and remote" + Right themID -> (,False) <$> + requireEitherAlt + (fmap destThemGestureLocalAdd <$> getValBy (UniqueDestThemGestureLocal themID)) + (fmap (destThemGestureRemoteActor &&& destThemGestureRemoteAdd) <$> getValBy (UniqueDestThemGestureRemote themID)) + "Neither local not remote" + "Both local and remote" + (,us) <$> case addOrActor of + Left addID -> do + OutboxItem outboxID _ time <- getJust addID + Entity actorID actor <- getByJust $ UniqueActorOutbox outboxID + (,time) . Left . (,actor) <$> getLocalActor actorID + Right (actorID, addID) -> do + RemoteActivity _ _ time <- getJust addID + (,time) . Right <$> getRemoteActorData actorID + return (inviter, us, child, accept, time, role, destID) $(widgetFile "group/children") + where + getRemoteActorData actorID = do + actor <- getJust actorID + object <- getJust $ remoteActorIdent actor + inztance <- getJust $ remoteObjectInstance object + return (inztance, object, actor) getGroupChildLiveR :: KeyHashid Group -> KeyHashid DestUsStart -> Handler () getGroupChildLiveR groupHash startHash = do @@ -531,7 +603,7 @@ getGroupParentsR groupHash = do encodeRouteHome $ GroupR $ hashGroup 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 $ GroupR groupHash @@ -558,13 +630,13 @@ getGroupParentsR groupHash = do where getParents groupID = 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 sourceID) -> + (role, time, Left (parent, actor), sourceID) ) <$> getLocals groupID ) - (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 sourceID) -> + (role, time, Right (i, ro, ra), sourceID) ) <$> getRemotes groupID ) @@ -584,6 +656,7 @@ getGroupParentsR groupHash = do , grant E.^. OutboxItemPublished , topic E.^. SourceTopicGroupParent , actor + , source E.^. SourceId ) getRemotes groupID = @@ -603,10 +676,80 @@ getGroupParentsR groupHash = do , i , ro , ra + , source E.^. SourceId ) getHtml groupID group actor parents = do + mp <- maybeAuthId + haveAdmin <- fmap isJust $ handlerToWidget $ runDB $ runMaybeT $ do + personID <- MaybeT $ pure mp + MaybeT $ getCapability personID (Left $ groupResource group) AP.RoleAdmin + ((_, widgetAC), enctypeAC) <- runFormPost addParentForm + invites <- handlerToWidget $ runDB $ do + sources <- E.select $ E.from $ \ (source `E.InnerJoin` holder `E.LeftOuterJoin` deleg) -> do + E.on $ E.just (source E.^. SourceId) E.==. deleg E.?. SourceUsSendDelegatorSource + E.on $ source E.^. SourceId E.==. holder E.^. SourceHolderGroupSource + E.where_ $ + holder E.^. SourceHolderGroupGroup E.==. E.val groupID E.&&. + E.isNothing (deleg E.?. SourceUsSendDelegatorId) + E.orderBy [E.asc $ source E.^. SourceId] + return source + for sources $ \ (Entity sourceID (Source role)) -> do + (parent, accept) <- do + topic <- getSourceTopic sourceID + accept <- + case bimap fst fst topic of + Left localID -> isJust <$> getBy (UniqueSourceThemAcceptLocal localID) + Right remoteID -> isJust <$> getBy (UniqueSourceThemAcceptRemote remoteID) + (,accept) <$> bitraverse + (\ (_, e) -> do + jID <- + case e of + Right j -> pure j + Left _ -> error "I'm a Group but my parent is a Project" + j <- getJust jID + actor <- getJust $ groupActor j + return (jID, actor) + ) + (\ (_, actorID) -> getRemoteActorData actorID) + topic + ((inviter, time), us) <- do + usOrThem <- + requireEitherAlt + (getKeyBy $ UniqueSourceOriginUs sourceID) + (getKeyBy $ UniqueSourceOriginThem sourceID) + "Neither us nor them" + "Both us and them" + (addOrActor, us) <- + case usOrThem of + Left usID -> (,True) <$> + requireEitherAlt + (fmap sourceUsGestureLocalAdd <$> getValBy (UniqueSourceUsGestureLocal usID)) + (fmap (sourceUsGestureRemoteActor &&& sourceUsGestureRemoteAdd) <$> getValBy (UniqueSourceUsGestureRemote usID)) + "Neither local not remote" + "Both local and remote" + Right themID -> (,False) <$> + requireEitherAlt + (fmap sourceThemGestureLocalAdd <$> getValBy (UniqueSourceThemGestureLocal themID)) + (fmap (sourceThemGestureRemoteActor &&& sourceThemGestureRemoteAdd) <$> getValBy (UniqueSourceThemGestureRemote themID)) + "Neither local not remote" + "Both local and remote" + (,us) <$> case addOrActor of + Left addID -> do + OutboxItem outboxID _ time <- getJust addID + Entity actorID actor <- getByJust $ UniqueActorOutbox outboxID + (,time) . Left . (,actor) <$> getLocalActor actorID + Right (actorID, addID) -> do + RemoteActivity _ _ time <- getJust addID + (,time) . Right <$> getRemoteActorData actorID + return (inviter, us, parent, accept, time, role, sourceID) $(widgetFile "group/parents") + where + getRemoteActorData actorID = do + actor <- getJust actorID + object <- getJust $ remoteActorIdent actor + inztance <- getJust $ remoteObjectInstance object + return (inztance, object, actor) getGroupMemberLiveR :: KeyHashid Group -> KeyHashid CollabEnable -> Handler () diff --git a/templates/group/children.hamlet b/templates/group/children.hamlet index e726a8d..b819211 100644 --- a/templates/group/children.hamlet +++ b/templates/group/children.hamlet @@ -1,6 +1,7 @@ $# This file is part of Vervis. $# -$# Written in 2016, 2019, 2022, 2023 by fr33domlover . +$# Written in 2016, 2019, 2022, 2023, 2024 +$# by fr33domlover . $# $# ♡ Copying is an act of love. Please copy, reuse and share. $# @@ -21,8 +22,49 @@ $# . Role Since Child - $forall (role, since, child) <- children + $if haveAdmin + Remove + $forall (role, since, child, destID) <- children #{show role} #{showDate since} ^{groupLinkFedW child} + $if haveAdmin + ^{buttonW POST "Remove" (GroupRemoveChildR groupHash destID)} + +$if haveAdmin +

Add a child: +

+ ^{widgetAP} + + +

Invites + + + + +
Inviter + Via + Invited child + I accepted? + Role + Time + $if haveAdmin + Approve + $forall (inviter, us, child, accept, time, role, destID) <- invites +
^{actorLinkFedW inviter} + + $if us + Us + $else + Them + ^{groupLinkFedW child} + + $if accept + [x] + $else + [_] + #{show role} + #{showDate time} + $if haveAdmin && (not accept && not us) + ^{buttonW POST "Approve" (GroupApproveChildR groupHash destID)} diff --git a/templates/group/parents.hamlet b/templates/group/parents.hamlet index 5258021..41318af 100644 --- a/templates/group/parents.hamlet +++ b/templates/group/parents.hamlet @@ -1,6 +1,7 @@ $# This file is part of Vervis. $# -$# Written in 2016, 2019, 2022, 2023 by fr33domlover . +$# Written in 2016, 2019, 2022, 2023, 2024 +$# by fr33domlover . $# $# ♡ Copying is an act of love. Please copy, reuse and share. $# @@ -20,9 +21,50 @@ $# .
Role Since - Child - $forall (role, since, parent) <- parents + Parent + $if haveAdmin + Remove + $forall (role, since, parent, sourceID) <- parents
#{show role} #{showDate since} ^{groupLinkFedW parent} + $if haveAdmin + ^{buttonW POST "Remove" (GroupRemoveParentR groupHash sourceID)} + +$if haveAdmin +

Add a parent: + + ^{widgetAC} + + +

Invites + + + + +
Inviter + Via + Invited parent + Parent accepted? + Role + Time + $if haveAdmin + Approve + $forall (inviter, us, parent, accept, time, role, sourceID) <- invites +
^{actorLinkFedW inviter} + + $if us + Us + $else + Them + ^{groupLinkFedW parent} + + $if accept + [x] + $else + [_] + #{show role} + #{showDate time} + $if haveAdmin && (accept && not us) + ^{buttonW POST "Approve" (GroupApproveParentR groupHash sourceID)}