UI: Group: Buttons for adding and removing members

src/Vervis/Form/Tracker.hs

@@ -27,6 +27,8 @@ module Vervis.Form.Tracker
     , ProjectInvite (..)
     , projectInviteForm
     , projectInviteCompForm
+    , GroupInvite (..)
+    , groupInviteForm
     --, NewProjectCollab (..)
     --, newProjectCollabForm
     --, editProjectForm
@@ -179,6 +181,38 @@ projectInviteForm projectID = renderDivs $ ProjectInvite
 projectInviteCompForm :: Form FedURI
 projectInviteCompForm = renderDivs $ areq fedUriField "Component URI*" Nothing
 
+data GroupInvite = GroupInvite
+    { giPerson :: PersonId
+    , giRole   :: AP.Role
+    }
+
+groupInviteForm :: GroupId -> Form GroupInvite
+groupInviteForm groupID = renderDivs $ GroupInvite
+    <$> areq selectPerson "Person*" Nothing
+    <*> areq selectRole   "Role*"   Nothing
+    where
+    selectPerson = selectField $ do
+        l <- runDB $ E.select $
+            E.from $ \ (person `E.InnerJoin` actor `E.LeftOuterJoin` (recip `E.InnerJoin` topic)) -> do
+                E.on $ recip E.^. CollabRecipLocalCollab E.==. topic E.^. CollabTopicGroupCollab E.&&.
+                       topic E.^. CollabTopicGroupGroup E.==. E.val groupID
+                E.on $ person E.^. PersonId E.==. recip E.^. CollabRecipLocalPerson
+                E.on $ person E.^. PersonActor E.==. actor E.^. ActorId
+                E.where_ $ E.isNothing $ E.just $ recip E.^. CollabRecipLocalId
+                return (person, actor)
+        optionsPairs $
+            map (\ (Entity pid p, Entity _ a) ->
+                    ( T.concat
+                        [ actorName a
+                        , " ~"
+                        , username2text $ personUsername p
+                        ]
+                    , pid
+                    )
+                )
+            l
+    selectRole = selectField optionsEnum
+
 {-
 editProjectAForm :: SharerId -> Entity Project -> AForm Handler Project
 editProjectAForm sid (Entity jid project) = Project

src/Vervis/Foundation.hs

@@ -883,7 +883,9 @@ instance YesodBreadcrumbs App where
 
         GroupStampR g k -> ("Stamp #" <> keyHashidText k, Just $ GroupR g)
 
-        GroupMembersR g -> ("Members", Just $ GroupR g)
+        GroupMembersR g  -> ("Members", Just $ GroupR g)
+        GroupInviteR g   -> ("Invite", Just $ GroupR g)
+        GroupRemoveR _ _ -> ("", Nothing)
 
         RepoR r             -> ("Repo ^" <> keyHashidText r, Just HomeR)
         RepoInboxR r        -> ("Inbox", Just $ RepoR r)

src/Vervis/Handler/Group.hs

@@ -28,6 +28,9 @@ module Vervis.Handler.Group
     , getGroupStampR
 
     , getGroupMembersR
+    , getGroupInviteR
+    , postGroupInviteR
+    , postGroupRemoveR
 
 
 
@@ -290,6 +293,95 @@ getGroupMembersR groupHash = do
                 LocalActorPerson personID -> return personID
                 _ -> error "Surprise, local inviter actor isn't a Person"
 
+getGroupInviteR :: KeyHashid Group -> Handler Html
+getGroupInviteR groupHash = do
+    groupID <- decodeKeyHashid404 groupHash
+    ((_result, widget), enctype) <- runFormPost $ groupInviteForm groupID
+    defaultLayout $(widgetFile "group/member/new")
+
+postGroupInviteR :: KeyHashid Group -> Handler Html
+postGroupInviteR groupHash = do
+    groupID <- decodeKeyHashid404 groupHash
+    GroupInvite recipPersonID role <-
+        runFormPostRedirect (GroupInviteR groupHash) $ groupInviteForm groupID
+
+    personEntity@(Entity personID person) <- requireAuth
+    personHash <- encodeKeyHashid personID
+    recipPersonHash <- encodeKeyHashid recipPersonID
+    encodeRouteHome <- getEncodeRouteHome
+
+    result <- runExceptT $ do
+        (maybeSummary, audience, invite) <- do
+            let uRecipient = encodeRouteHome $ PersonR recipPersonHash
+                uResourceCollabs = encodeRouteHome $ GroupMembersR groupHash
+            C.invite personID uRecipient uResourceCollabs role
+        grantID <- do
+            maybeItem <- lift $ runDB $ getGrant CollabTopicGroupCollab CollabTopicGroupGroup groupID personID
+            fromMaybeE maybeItem "You need to be a collaborator in the Group to invite people"
+        grantHash <- encodeKeyHashid grantID
+        let uCap = encodeRouteHome $ GroupOutboxItemR groupHash grantHash
+        (localRecips, remoteRecips, fwdHosts, action) <-
+            C.makeServerInput (Just uCap) maybeSummary audience $ AP.InviteActivity invite
+        let cap =
+                Left (LocalActorGroup groupID, LocalActorGroup groupHash, grantID)
+        handleViaActor
+            personID (Just cap) localRecips remoteRecips fwdHosts action
+
+    case result of
+        Left e -> do
+            setMessage $ toHtml e
+            redirect $ GroupInviteR groupHash
+        Right inviteID -> do
+            setMessage "Invite sent"
+            redirect $ GroupMembersR groupHash
+
+postGroupRemoveR :: KeyHashid Group -> CollabTopicGroupId -> Handler Html
+postGroupRemoveR groupHash ctID = do
+    groupID <- decodeKeyHashid404 groupHash
+
+    personEntity@(Entity personID person) <- requireAuth
+    personHash <- encodeKeyHashid personID
+    encodeRouteHome <- getEncodeRouteHome
+
+    result <- runExceptT $ do
+        mpidOrU <- lift $ runDB $ runMaybeT $ do
+            CollabTopicGroup collabID groupID' <- MaybeT $ get ctID
+            guard $ groupID' == groupID
+            _ <- MaybeT $ getBy $ UniqueCollabEnable collabID
+            member <-
+                Left <$> MaybeT (getValBy $ UniqueCollabRecipLocal collabID) <|>
+                Right <$> MaybeT (getValBy $ UniqueCollabRecipRemote collabID)
+            lift $
+                bitraverse
+                    (pure . collabRecipLocalPerson)
+                    (getRemoteActorURI <=< getJust . collabRecipRemoteActor)
+                    member
+        pidOrU <- maybe notFound pure mpidOrU
+        (maybeSummary, audience, remove) <- do
+            uRecipient <-
+                case pidOrU of
+                    Left pid -> encodeRouteHome . PersonR <$> encodeKeyHashid pid
+                    Right u -> pure u
+            let uResourceCollabs = encodeRouteHome $ GroupMembersR groupHash
+            C.remove personID uRecipient uResourceCollabs
+        grantID <- do
+            maybeItem <- lift $ runDB $ getGrant CollabTopicGroupCollab CollabTopicGroupGroup groupID personID
+            fromMaybeE maybeItem "You need to be a collaborator in the Group to remove people"
+        grantHash <- encodeKeyHashid grantID
+        let uCap = encodeRouteHome $ GroupOutboxItemR groupHash grantHash
+        (localRecips, remoteRecips, fwdHosts, action) <-
+            C.makeServerInput (Just uCap) maybeSummary audience $ AP.RemoveActivity remove
+        let cap =
+                Left (LocalActorGroup groupID, LocalActorGroup groupHash, grantID)
+        handleViaActor
+            personID (Just cap) localRecips remoteRecips fwdHosts action
+
+    case result of
+        Left e -> do
+            setMessage $ toHtml e
+        Right removeID ->
+            setMessage "Remove sent"
+    redirect $ GroupMembersR groupHash
 
 
 

templates/group/member/new.hamlet

@@ -1,6 +1,6 @@
 $# This file is part of Vervis.
 $#
-$# Written in 2016 by fr33domlover <fr33domlover@riseup.net>.
+$# Written in 2016, 2023 by fr33domlover <fr33domlover@riseup.net>.
 $#
 $# ♡ Copying is an act of love. Please copy, reuse and share.
 $#
@@ -12,7 +12,7 @@ $# You should have received a copy of the CC0 Public Domain Dedication along
 $# with this software. If not, see
 $# <http://creativecommons.org/publicdomain/zero/1.0/>.
 
-<form method=POST action=@{GroupMembersR shar} enctype=#{enctype}>
+<form method=POST action=@{GroupInviteR groupHash} enctype=#{enctype}>
   ^{widget}
   <div class="submit">
     <input type="submit">

templates/group/members.hamlet

@@ -26,7 +26,7 @@ $# <http://creativecommons.org/publicdomain/zero/1.0/>.
       <td>#{show role}
       <td>^{personLinkFedW person}
       <td>#{showDate since}
-      $#<td>^{buttonW POST "Remove" (GroupRemoveR groupHash ctID)}
+      <td>^{buttonW POST "Remove" (GroupRemoveR groupHash ctID)}
 
 <h2>Invites
 
@@ -43,7 +43,7 @@ $# <http://creativecommons.org/publicdomain/zero/1.0/>.
       <td>#{show role}
       <td>#{showDate time}
 
-$#<a href=@{ProjectInviteR projectHash}>Invite…
+<a href=@{GroupInviteR groupHash}>Invite…
 
 <h2>Joins
 

th/routes

@@ -169,6 +169,8 @@
 /groups/#GroupKeyHashid/stamps/#SigKeyKeyHashid         GroupStampR      GET
 
 /groups/#GroupKeyHashid/members                         GroupMembersR    GET
+/groups/#GroupKeyHashid/invite                          GroupInviteR     GET POST
+/groups/#GroupKeyHashid/remove/#CollabTopicGroupId      GroupRemoveR     POST
 
 ---- Repo --------------------------------------------------------------------