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

2023-11-21 18:28:05 +02:00 · 2023-11-21 18:28:05 +02:00 · 7517db9619
commit 7517db9619
parent 8584c6387c
13 changed files with 166 additions and 75 deletions
--- a/src/Vervis/Actor/Person/Client.hs
+++ b/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
-                unless (mluCollabs == Just luColl || mluComps == Just luColl) $
+                AP.ResourceWithCollections _ mluCollabs mluComps mluMembers <- ExceptT $ liftIO $ first (T.pack . show) <$> AP.fetchRWC manager h lu
+                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
-                unless (mluCollabs == Just luColl) $
+                AP.ResourceWithCollections _ mluCollabs _ mluMembers <- ExceptT $ liftIO $ first (T.pack . show) <$> AP.fetchRWC manager h lu
+                unless (mluCollabs == Just luColl || mluMembers == Just luColl) $
                    throwE "Remove origin isn't a collabs list"
                return $ ObjURI h lu
            )
--- a/src/Vervis/Client.hs
+++ b/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
-                unless (mluCollabs == Just luColl) $
+                AP.ResourceWithCollections _ mluCollabs _ mluMembers <- ExceptT $ liftIO $ first (T.pack . show) <$> AP.fetchRWC manager h lu
+                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
-                unless (mluCollabs == Just luColl) $
+                AP.ResourceWithCollections _ mluCollabs _ mluMembers <- ExceptT $ liftIO $ first (T.pack . show) <$> AP.fetchRWC manager h lu
+                unless (mluCollabs == Just luColl || mluMembers == Just luColl) $
                    throwE "Remove origin isn't a collabs list"
                return $ ObjURI h lu
            )
--- a/src/Vervis/Data/Collab.hs
+++ b/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)
--- a/src/Vervis/Form/Tracker.hs
+++ b/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
--- a/src/Vervis/Foundation.hs
+++ b/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)
--- a/src/Vervis/Handler/Client.hs
+++ b/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
--- a/src/Vervis/Handler/Group.hs
+++ b/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
-            pure ([] :: [(AP.Role, Either PersonId RemoteActorId, (), UTCTime)])
+            getTopicGrants CollabTopicGroupCollab CollabTopicGroupGroup groupID
        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
-                    pure ([] :: [(AP.Role, Either PersonId RemoteActorId, (), UTCTime)])
+                    getTopicGrants CollabTopicGroupCollab CollabTopicGroupGroup groupID
                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
--- a/src/Vervis/Migration.hs
+++ b/src/Vervis/Migration.hs
@ -3047,6 +3047,8 @@ changes hLocal ctx =
        "OutboxItem"
      -- 550
    , addUnique' "Group" "Create" ["create"]
+      -- 551
+    , addEntities model_551_group_collab
    ]

 migrateDB
--- a/src/Web/ActivityPub.hs
+++ b/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
--- a/templates/group/members.hamlet
+++ b/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}
--- a/templates/group/new.hamlet
+++ b/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">
--- a/templates/personal-overview.hamlet
+++ b/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 repository
-  <li>
-    <a href=@{DeckNewR}>
-      Create a new ticket tracker
-  <li>
-    <a href=@{LoomNewR}>
-      Create a new patch tracker
+    Create a new…
+    <ul>
      <li>
        <a href=@{ProjectNewR}>
-      Create a new project
+          project
+      <li>
+        <a href=@{GroupNewR}>
+          team
+      <li>
+        component:
+        <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

--- a/th/routes
+++ b/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