Client, UI: Team: Creation, invite/join display, list in personal overview

src/Vervis/Actor/Person/Client.hs

@@ -211,7 +211,7 @@ clientAdd now personMeID (ClientMsg maybeCap localRecips remoteRecips fwdHosts a
                 manager <- asksEnv envHttpManager
                 coll <- ExceptT $ liftIO $ first T.pack <$> AP.fetchAPID manager AP.collectionId h luComps
                 lu <- fromMaybeE (AP.collectionContext (coll :: AP.Collection FedURI URIMode)) "Remote topic collabs has no 'context'"
-                AP.ResourceWithCollections _ _ mluComps <- ExceptT $ liftIO $ first (T.pack . show) <$> AP.fetchRWC manager h lu
+                AP.ResourceWithCollections _ _ mluComps _ <- ExceptT $ liftIO $ first (T.pack . show) <$> AP.fetchRWC manager h lu
                 unless (mluComps == Just luComps) $
                     throwE "Add target isn't a components list"
 
@@ -845,8 +845,8 @@ clientInvite now personMeID (ClientMsg maybeCap localRecips remoteRecips fwdHost
                 manager <- asksEnv envHttpManager
                 coll <- ExceptT $ liftIO $ first T.pack <$> AP.fetchAPID manager AP.collectionId h luColl
                 lu <- fromMaybeE (AP.collectionContext (coll :: AP.Collection FedURI URIMode)) "Remote topic collabs has no 'context'"
-                AP.ResourceWithCollections _ mluCollabs mluComps <- ExceptT $ liftIO $ first (T.pack . show) <$> AP.fetchRWC manager h lu
+                AP.ResourceWithCollections _ mluCollabs mluComps mluMembers <- ExceptT $ liftIO $ first (T.pack . show) <$> AP.fetchRWC manager h lu
-                unless (mluCollabs == Just luColl || mluComps == Just luColl) $
+                unless (mluCollabs == Just luColl || mluComps == Just luColl || mluMembers == Just luColl) $
                     throwE "Invite target isn't a collabs/components list"
 
                 instanceID <-
@@ -1079,8 +1079,8 @@ clientRemove now personMeID (ClientMsg maybeCap localRecips remoteRecips fwdHost
                 manager <- asksEnv envHttpManager
                 coll <- ExceptT $ liftIO $ first T.pack <$> AP.fetchAPID manager AP.collectionId h luColl
                 lu <- fromMaybeE (AP.collectionContext (coll :: AP.Collection FedURI URIMode)) "Remote topic collabs has no 'context'"
-                AP.ResourceWithCollections _ mluCollabs _ <- ExceptT $ liftIO $ first (T.pack . show) <$> AP.fetchRWC manager h lu
+                AP.ResourceWithCollections _ mluCollabs _ mluMembers <- ExceptT $ liftIO $ first (T.pack . show) <$> AP.fetchRWC manager h lu
-                unless (mluCollabs == Just luColl) $
+                unless (mluCollabs == Just luColl || mluMembers == Just luColl) $
                     throwE "Remove origin isn't a collabs list"
                 return $ ObjURI h lu
             )

src/Vervis/Client.hs

@@ -38,6 +38,7 @@ module Vervis.Client
     , createLoom
     , createRepo
     , createProject
+    , createGroup
     , invite
     , remove
     , inviteComponent
@@ -1050,6 +1051,27 @@ createProject senderHash name desc = do
 
     return (Nothing, audience, detail)
 
+createGroup
+    :: (MonadHandler m, HandlerSite m ~ App, MonadSite m, SiteEnv m ~ App)
+    => KeyHashid Person
+    -> Text
+    -> Text
+    -> m (Maybe HTML, [Aud URIMode], AP.ActorDetail)
+createGroup senderHash name desc = do
+    let audAuthor =
+            AudLocal [] [LocalStagePersonFollowers senderHash]
+
+        audience = [audAuthor]
+
+        detail = AP.ActorDetail
+            { AP.actorType     = AP.ActorTypeTeam
+            , AP.actorUsername = Nothing
+            , AP.actorName     = Just name
+            , AP.actorSummary  = Just desc
+            }
+
+    return (Nothing, audience, detail)
+
 invite
     :: PersonId
     -> FedURI
@@ -1090,8 +1112,8 @@ invite personID uRecipient uResourceCollabs role = do
                 manager <- asksSite appHttpManager
                 coll <- ExceptT $ liftIO $ first T.pack <$> AP.fetchAPID manager AP.collectionId h luColl
                 lu <- fromMaybeE (AP.collectionContext (coll :: AP.Collection FedURI URIMode)) "Remote topic collabs has no 'context'"
-                AP.ResourceWithCollections _ mluCollabs _ <- ExceptT $ liftIO $ first (T.pack . show) <$> AP.fetchRWC manager h lu
+                AP.ResourceWithCollections _ mluCollabs _ mluMembers <- ExceptT $ liftIO $ first (T.pack . show) <$> AP.fetchRWC manager h lu
-                unless (mluCollabs == Just luColl) $
+                unless (mluCollabs == Just luColl || mluMembers == Just luColl) $
                     throwE "Invite target isn't a collabs list"
                 return $ ObjURI h lu
             )
@@ -1204,8 +1226,8 @@ remove personID uRecipient uResourceCollabs = do
                 manager <- asksSite appHttpManager
                 coll <- ExceptT $ liftIO $ first T.pack <$> AP.fetchAPID manager AP.collectionId h luColl
                 lu <- fromMaybeE (AP.collectionContext (coll :: AP.Collection FedURI URIMode)) "Remote topic collabs has no 'context'"
-                AP.ResourceWithCollections _ mluCollabs _ <- ExceptT $ liftIO $ first (T.pack . show) <$> AP.fetchRWC manager h lu
+                AP.ResourceWithCollections _ mluCollabs _ mluMembers <- ExceptT $ liftIO $ first (T.pack . show) <$> AP.fetchRWC manager h lu
-                unless (mluCollabs == Just luColl) $
+                unless (mluCollabs == Just luColl || mluMembers == Just luColl) $
                     throwE "Remove origin isn't a collabs list"
                 return $ ObjURI h lu
             )

src/Vervis/Data/Collab.hs

@@ -100,12 +100,14 @@ parseGrantResource (RepoR r) = Just $ GrantResourceRepo r
 parseGrantResource (DeckR d) = Just $ GrantResourceDeck d
 parseGrantResource (LoomR l) = Just $ GrantResourceLoom l
 parseGrantResource (ProjectR l) = Just $ GrantResourceProject l
+parseGrantResource (GroupR l) = Just $ GrantResourceGroup l
 parseGrantResource _         = Nothing
 
 parseGrantResourceCollabs (RepoCollabsR r) = Just $ GrantResourceRepo r
 parseGrantResourceCollabs (DeckCollabsR d) = Just $ GrantResourceDeck d
 parseGrantResourceCollabs (LoomCollabsR l) = Just $ GrantResourceLoom l
 parseGrantResourceCollabs (ProjectCollabsR l) = Just $ GrantResourceProject l
+parseGrantResourceCollabs (GroupMembersR l) = Just $ GrantResourceGroup l
 parseGrantResourceCollabs _         = Nothing
 
 data GrantRecipBy f = GrantRecipPerson (f Person)

src/Vervis/Form/Tracker.hs

@@ -18,6 +18,8 @@ module Vervis.Form.Tracker
     , newDeckForm
     , NewProject (..)
     , newProjectForm
+    , NewGroup (..)
+    , newGroupForm
     , NewLoom (..)
     , newLoomForm
     , DeckInvite (..)
@@ -73,6 +75,16 @@ newProjectForm = renderDivs $ NewProject
     <$> areq textField "Name*"       Nothing
     <*> areq textField "Description" Nothing
 
+data NewGroup = NewGroup
+    { ngName  :: Text
+    , ngDesc  :: Text
+    }
+
+newGroupForm :: Form NewGroup
+newGroupForm = renderDivs $ NewGroup
+    <$> areq textField "Name*"       Nothing
+    <*> areq textField "Description" Nothing
+
 data NewLoom = NewLoom
     { nlName  :: Text
     , nlDesc  :: Text

src/Vervis/Foundation.hs

@@ -872,6 +872,7 @@ instance YesodBreadcrumbs App where
 
         PersonStampR p k -> ("Stamp #" <> keyHashidText k, Just $ PersonR p)
 
+        GroupNewR            -> ("New Team", Just HomeR)
         GroupR g             -> ("Team &" <> keyHashidText g, Just HomeR)
         GroupInboxR g        -> ("Inbox", Just $ GroupR g)
         GroupOutboxR g       -> ("Outbox", Just $ GroupR g)

src/Vervis/Handler/Client.hs

@@ -130,7 +130,7 @@ getHomeR = do
     where
     personalOverview :: Entity Person -> Handler Html
     personalOverview (Entity pid _person) = do
-        (repos, decks, looms, projects) <- runDB $ (,,,)
+        (repos, decks, looms, projects, groups) <- runDB $ (,,,,)
             <$> (E.select $ E.from $ \ (recip `E.InnerJoin` collab `E.InnerJoin` topic `E.InnerJoin` enable `E.InnerJoin` repo `E.InnerJoin` actor) -> do
                     E.on $ repo E.^. RepoActor E.==. actor E.^. ActorId
                     E.on $ topic E.^. CollabTopicRepoRepo E.==. repo E.^. RepoId
@@ -171,10 +171,21 @@ getHomeR = do
                     E.orderBy [E.asc $ project E.^. ProjectId]
                     return (project, actor, collab)
                 )
+            <*> (E.select $ E.from $ \ (recip `E.InnerJoin` collab `E.InnerJoin` topic `E.InnerJoin` enable `E.InnerJoin` group `E.InnerJoin` actor) -> do
+                    E.on $ group E.^. GroupActor E.==. actor E.^. ActorId
+                    E.on $ topic E.^. CollabTopicGroupGroup E.==. group E.^. GroupId
+                    E.on $ topic E.^. CollabTopicGroupCollab E.==. enable E.^. CollabEnableCollab
+                    E.on $ recip E.^. CollabRecipLocalCollab E.==. topic E.^. CollabTopicGroupCollab
+                    E.on $ recip E.^. CollabRecipLocalCollab E.==. collab E.^. CollabId
+                    E.where_ $ recip E.^. CollabRecipLocalPerson E.==. E.val pid
+                    E.orderBy [E.asc $ group E.^. GroupId]
+                    return (group, actor, collab)
+                )
         hashRepo <- getEncodeKeyHashid
         hashDeck <- getEncodeKeyHashid
         hashLoom <- getEncodeKeyHashid
         hashProject <- getEncodeKeyHashid
+        hashGroup <- getEncodeKeyHashid
         defaultLayout $(widgetFile "personal-overview")
 
 getBrowseR :: Handler Html

src/Vervis/Handler/Group.hs

@@ -14,7 +14,10 @@
  -}
 
 module Vervis.Handler.Group
-    ( getGroupR
+    ( getGroupNewR
+    , postGroupNewR
+
+    , getGroupR
     , getGroupInboxR
     , postGroupInboxR
     , getGroupOutboxR
@@ -33,8 +36,6 @@ module Vervis.Handler.Group
 
     {-
     , getGroupsR
-    , postGroupsR
-    , getGroupNewR
     , postGroupMembersR
     , getGroupMemberNewR
     , getGroupMemberR
@@ -118,6 +119,37 @@ import Vervis.Widget.Tracker
 
 import qualified Vervis.Client as C
 
+getGroupNewR :: Handler Html
+getGroupNewR = do
+    ((_result, widget), enctype) <- runFormPost newGroupForm
+    defaultLayout $(widgetFile "group/new")
+
+postGroupNewR :: Handler Html
+postGroupNewR = do
+    NewGroup name desc <- runFormPostRedirect GroupNewR newGroupForm
+
+    personEntity@(Entity personID person) <- requireAuth
+    personHash <- encodeKeyHashid personID
+    (maybeSummary, audience, detail) <- C.createGroup personHash name desc
+    (localRecips, remoteRecips, fwdHosts, action) <-
+        C.makeServerInput Nothing maybeSummary audience $ AP.CreateActivity $ AP.Create (AP.CreateTeam detail Nothing) Nothing
+    result <-
+        runExceptT $
+        handleViaActor personID Nothing localRecips remoteRecips fwdHosts action
+
+    case result of
+        Left e -> do
+            setMessage $ toHtml e
+            redirect GroupNewR
+        Right createID -> do
+            maybeGroupID <- runDB $ getKeyBy $ UniqueGroupCreate createID
+            case maybeGroupID of
+                Nothing -> error "Can't find the newly created group"
+                Just groupID -> do
+                    groupHash <- encodeKeyHashid groupID
+                    setMessage "New group created"
+                    redirect $ GroupR groupHash
+
 getGroupR :: KeyHashid Group -> Handler TypedContent
 getGroupR groupHash = do
     groupID <- decodeKeyHashid404 groupHash
@@ -194,8 +226,7 @@ getGroupMembersR groupHash = do
     members <- runDB $ do
         _group <- get404 groupID
         grants <-
-            --getTopicGrants CollabTopicGroupCollab CollabTopicGroupGroup groupID
+            getTopicGrants CollabTopicGroupCollab CollabTopicGroupGroup groupID
-            pure ([] :: [(AP.Role, Either PersonId RemoteActorId, (), UTCTime)])
         for grants $ \ (role, actor, _ct, time) ->
             (role,time,) <$> bitraverse pure (getRemoteActorURI <=< getJust) actor
     h <- asksSite siteInstanceHost
@@ -230,16 +261,14 @@ getGroupMembersR groupHash = do
     provideHtmlAndAP membersAP $ getHtml groupID
     where
     getHtml groupID = do
-        (group, actor, members{-, invites, joins-}) <- handlerToWidget $ runDB $ do
+        (group, actor, members, invites, joins) <- handlerToWidget $ runDB $ do
             group <- get404 groupID
             actor <- getJust $ groupActor group
             members <- do
                 grants <-
-                    --getTopicGrants CollabTopicGroupCollab CollabTopicGroupGroup groupID
+                    getTopicGrants CollabTopicGroupCollab CollabTopicGroupGroup groupID
-                    pure ([] :: [(AP.Role, Either PersonId RemoteActorId, (), UTCTime)])
                 for grants $ \ (role, actor, ct, time) ->
                     (,role,ct,time) <$> getPersonWidgetInfo actor
-            {-
             invites <- do
                 invites' <-
                     getTopicInvites CollabTopicGroupCollab CollabTopicGroupGroup groupID
@@ -253,8 +282,7 @@ getGroupMembersR groupHash = do
                     getTopicJoins CollabTopicGroupCollab CollabTopicGroupGroup groupID
                 for joins' $ \ (recip, time, role) ->
                     (,time,role) <$> getPersonWidgetInfo recip
-            -}
+            return (group, actor, members, invites, joins)
-            return (group, actor, members{-, invites, joins-})
         $(widgetFile "group/members")
         where
         grabPerson actorID = do
@@ -290,44 +318,6 @@ getGroupsR = do
         return sharer
     defaultLayout $(widgetFile "group/list")
 
-postGroupsR :: Handler Html
-postGroupsR = do
-    ((result, widget), enctype) <- runFormPost newGroupForm
-    case result of
-        FormSuccess ng -> do
-            now <- liftIO getCurrentTime
-            pid <- requireAuthId
-            runDB $ do
-                let sharer = Sharer
-                        { sharerIdent   = ngIdent ng
-                        , sharerName    = ngName ng
-                        , sharerCreated = now
-                        }
-                sid <- insert sharer
-                let group = Group
-                        { groupIdent = sid
-                        }
-                gid <- insert group
-                let member = GroupMember
-                        { groupMemberPerson = pid
-                        , groupMemberGroup  = gid
-                        , groupMemberRole   = GRAdmin
-                        , groupMemberJoined = now
-                        }
-                insert_ member
-            redirect $ SharerR $ ngIdent ng
-        FormMissing -> do
-            setMessage "Field(s) missing"
-            defaultLayout $(widgetFile "group/new")
-        FormFailure _l -> do
-            setMessage "Group creation failed, see errors below"
-            defaultLayout $(widgetFile "group/new")
-
-getGroupNewR :: Handler Html
-getGroupNewR = do
-    ((_result, widget), enctype) <- runFormPost newGroupForm
-    defaultLayout $(widgetFile "group/new")
-
 getgid :: ShrIdent -> AppDB GroupId
 getgid shar = do
     Entity s _ <- getBy404 $ UniqueSharer shar

src/Vervis/Migration.hs

@@ -3047,6 +3047,8 @@ changes hLocal ctx =
         "OutboxItem"
       -- 550
     , addUnique' "Group" "Create" ["create"]
+      -- 551
+    , addEntities model_551_group_collab
     ]
 
 migrateDB

src/Web/ActivityPub.hs

@@ -860,6 +860,7 @@ data ResourceWithCollections u = ResourceWithCollections
     { rwcResource   :: Resource u
     , rwcCollabs    :: Maybe LocalURI
     , rwcComponents :: Maybe LocalURI
+    , rwcMembers    :: Maybe LocalURI
     }
 
 instance ActivityPub ResourceWithCollections where
@@ -869,10 +870,12 @@ instance ActivityPub ResourceWithCollections where
         fmap (h,) $ ResourceWithCollections r
             <$> withAuthorityMaybeO h (o .:? "collaborators")
             <*> withAuthorityMaybeO h (o .:? "components")
-    toSeries h (ResourceWithCollections r collabs comps)
+            <*> withAuthorityMaybeO h (o .:? "members")
+    toSeries h (ResourceWithCollections r collabs comps members)
         =  toSeries h r
         <> "collaborators" .=? (ObjURI h <$> collabs)
         <> "components"    .=? (ObjURI h <$> comps)
+        <> "members"       .=? (ObjURI h <$> members)
 
 data Project u = Project
     { projectActor      :: Actor u

templates/group/members.hamlet

@@ -27,3 +27,33 @@ $# <http://creativecommons.org/publicdomain/zero/1.0/>.
       <td>^{personLinkFedW person}
       <td>#{showDate since}
       $#<td>^{buttonW POST "Remove" (GroupRemoveR groupHash ctID)}
+
+<h2>Invites
+
+<table>
+  <tr>
+    <th>Inviter
+    <th>Invitee
+    <th>Role
+    <th>Time
+  $forall (inviter, invitee, time, role) <- invites
+    <tr>
+      <td>^{personLinkFedW inviter}
+      <td>^{personLinkFedW invitee}
+      <td>#{show role}
+      <td>#{showDate time}
+
+$#<a href=@{ProjectInviteR projectHash}>Invite…
+
+<h2>Joins
+
+<table>
+  <tr>
+    <th>Joiner
+    <th>Role
+    <th>Time
+  $forall (joiner, time, role) <- joins
+    <tr>
+      <td>^{personLinkFedW joiner}
+      <td>#{show role}
+      <td>#{showDate time}

templates/group/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=@{GroupsR} enctype=#{enctype}>
+<form method=POST action=@{GroupNewR} enctype=#{enctype}>
   ^{widget}
   <div class="submit">
-    <input type="submit">
+      <input type="submit">

templates/personal-overview.hamlet

@@ -25,17 +25,26 @@ $# <http://creativecommons.org/publicdomain/zero/1.0/>.
     <a href=@{KeysR}>
       SSH key settings
   <li>
-    <a href=@{RepoNewR}>
+    Create a new…
-      Create a new repository
+    <ul>
-  <li>
+      <li>
-    <a href=@{DeckNewR}>
+        <a href=@{ProjectNewR}>
-      Create a new ticket tracker
+          project
-  <li>
+      <li>
-    <a href=@{LoomNewR}>
+        <a href=@{GroupNewR}>
-      Create a new patch tracker
+          team
-  <li>
+      <li>
-    <a href=@{ProjectNewR}>
+        component:
-      Create a new project
+        <ul>
+          <li>
+            <a href=@{RepoNewR}>
+              repository
+          <li>
+            <a href=@{DeckNewR}>
+              ticket tracker
+          <li>
+            <a href=@{LoomNewR}>
+              patch tracker
   <li>
     <a href=@{PublishOfferMergeR}>
       Open a merge request
@@ -57,7 +66,14 @@ $#       Comment on a ticket or merge request
 
 <h2>Your teams
 
-<p>You aren't a member of any teams at the moment.
+<ul>
+  $forall (Entity groupID _, Entity _ actor, Entity _ (Collab role)) <- groups
+    <li>
+      [
+      #{show role}
+      ]
+      <a href=@{GroupR $ hashGroup groupID}>
+        &#{keyHashidText $ hashGroup groupID} #{actorName actor}
 
 <h2>Your repos
 

th/routes

@@ -156,6 +156,8 @@
 
 ---- Group ------------------------------------------------------------------
 
+/new-group                                              GroupNewR        GET POST
+
 /groups/#GroupKeyHashid                                 GroupR           GET
 /groups/#GroupKeyHashid/inbox                           GroupInboxR      GET POST
 /groups/#GroupKeyHashid/outbox                          GroupOutboxR     GET