UI: Group: Display parent and child invites & approve-remove buttons

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) ->
+        (map (\ (E.Value role, E.Value time, E.Value child, Entity _ actor, E.Value destID) ->
-                (role, time, Left (child, actor))
+                (role, time, Left (child, actor), destID)
              )
             <$> getLocals groupID
         )
-        (map (\ (E.Value role, E.Value time, Entity _ i, Entity _ ro, Entity _ ra) ->
+        (map (\ (E.Value role, E.Value time, Entity _ i, Entity _ ro, Entity _ ra, E.Value destID) ->
-                (role, time, Right (i, ro, ra))
+                (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) ->
+        (map (\ (E.Value role, E.Value time, E.Value parent, Entity _ actor, E.Value sourceID) ->
-                (role, time, Left (parent, actor))
+                (role, time, Left (parent, actor), sourceID)
              )
             <$> getLocals groupID
         )
-        (map (\ (E.Value role, E.Value time, Entity _ i, Entity _ ro, Entity _ ra) ->
+        (map (\ (E.Value role, E.Value time, Entity _ i, Entity _ ro, Entity _ ra, E.Value sourceID) ->
-                (role, time, Right (i, ro, ra))
+                (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 ()

templates/group/children.hamlet

@@ -1,6 +1,7 @@
 $# This file is part of Vervis.
 $#
-$# Written in 2016, 2019, 2022, 2023 by fr33domlover <fr33domlover@riseup.net>.
+$# Written in 2016, 2019, 2022, 2023, 2024
+$# by fr33domlover <fr33domlover@riseup.net>.
 $#
 $# ♡ Copying is an act of love. Please copy, reuse and share.
 $#
@@ -21,8 +22,49 @@ $# <http://creativecommons.org/publicdomain/zero/1.0/>.
     <th>Role
     <th>Since
     <th>Child
-  $forall (role, since, child) <- children
+    $if haveAdmin
+      <th>Remove
+  $forall (role, since, child, destID) <- children
     <tr>
       <td>#{show role}
       <td>#{showDate since}
       <td>^{groupLinkFedW child}
+      $if haveAdmin
+        <td>^{buttonW POST "Remove" (GroupRemoveChildR groupHash destID)}
+
+$if haveAdmin
+  <p>Add a child:
+  <form method=POST action=@{GroupAddChildR groupHash} enctype=#{enctypeAP}>
+    ^{widgetAP}
+    <input type=submit>
+
+<h2>Invites
+
+<table>
+  <tr>
+    <th>Inviter
+    <th>Via
+    <th>Invited child
+    <th>I accepted?
+    <th>Role
+    <th>Time
+    $if haveAdmin
+      <th>Approve
+  $forall (inviter, us, child, accept, time, role, destID) <- invites
+    <tr>
+      <td>^{actorLinkFedW inviter}
+      <td>
+        $if us
+          Us
+        $else
+          Them
+      <td>^{groupLinkFedW child}
+      <td>
+        $if accept
+          [x]
+        $else
+          [_]
+      <td>#{show role}
+      <td>#{showDate time}
+      $if haveAdmin && (not accept && not us)
+        <td>^{buttonW POST "Approve" (GroupApproveChildR groupHash destID)}

templates/group/parents.hamlet

@@ -1,6 +1,7 @@
 $# This file is part of Vervis.
 $#
-$# Written in 2016, 2019, 2022, 2023 by fr33domlover <fr33domlover@riseup.net>.
+$# Written in 2016, 2019, 2022, 2023, 2024
+$# by fr33domlover <fr33domlover@riseup.net>.
 $#
 $# ♡ Copying is an act of love. Please copy, reuse and share.
 $#
@@ -20,9 +21,50 @@ $# <http://creativecommons.org/publicdomain/zero/1.0/>.
   <tr>
     <th>Role
     <th>Since
-    <th>Child
+    <th>Parent
-  $forall (role, since, parent) <- parents
+    $if haveAdmin
+      <th>Remove
+  $forall (role, since, parent, sourceID) <- parents
     <tr>
       <td>#{show role}
       <td>#{showDate since}
       <td>^{groupLinkFedW parent}
+      $if haveAdmin
+        <td>^{buttonW POST "Remove" (GroupRemoveParentR groupHash sourceID)}
+
+$if haveAdmin
+  <p>Add a parent:
+  <form method=POST action=@{GroupAddParentR groupHash} enctype=#{enctypeAC}>
+    ^{widgetAC}
+    <input type=submit>
+
+<h2>Invites
+
+<table>
+  <tr>
+    <th>Inviter
+    <th>Via
+    <th>Invited parent
+    <th>Parent accepted?
+    <th>Role
+    <th>Time
+    $if haveAdmin
+      <th>Approve
+  $forall (inviter, us, parent, accept, time, role, sourceID) <- invites
+    <tr>
+      <td>^{actorLinkFedW inviter}
+      <td>
+        $if us
+          Us
+        $else
+          Them
+      <td>^{groupLinkFedW parent}
+      <td>
+        $if accept
+          [x]
+        $else
+          [_]
+      <td>#{show role}
+      <td>#{showDate time}
+      $if haveAdmin && (accept && not us)
+        <td>^{buttonW POST "Approve" (GroupApproveParentR groupHash sourceID)}