From 7517db9619c584d400774cf531777f34aea9b0ba Mon Sep 17 00:00:00 2001 From: Pere Lev Date: Tue, 21 Nov 2023 18:28:05 +0200 Subject: [PATCH] Client, UI: Team: Creation, invite/join display, list in personal overview --- src/Vervis/Actor/Person/Client.hs | 10 ++-- src/Vervis/Client.hs | 30 ++++++++-- src/Vervis/Data/Collab.hs | 2 + src/Vervis/Form/Tracker.hs | 12 ++++ src/Vervis/Foundation.hs | 1 + src/Vervis/Handler/Client.hs | 13 ++++- src/Vervis/Handler/Group.hs | 88 +++++++++++++----------------- src/Vervis/Migration.hs | 2 + src/Web/ActivityPub.hs | 5 +- templates/group/members.hamlet | 30 ++++++++++ templates/group/new.hamlet | 6 +- templates/personal-overview.hamlet | 40 ++++++++++---- th/routes | 2 + 13 files changed, 166 insertions(+), 75 deletions(-) diff --git a/src/Vervis/Actor/Person/Client.hs b/src/Vervis/Actor/Person/Client.hs index 1f53280..a4c2dda 100644 --- 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 ) diff --git a/src/Vervis/Client.hs b/src/Vervis/Client.hs index e63fd11..c4ae8a1 100644 --- 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 ) diff --git a/src/Vervis/Data/Collab.hs b/src/Vervis/Data/Collab.hs index c895b44..89d076b 100644 --- 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) diff --git a/src/Vervis/Form/Tracker.hs b/src/Vervis/Form/Tracker.hs index 66c5cf4..98c2c68 100644 --- 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 diff --git a/src/Vervis/Foundation.hs b/src/Vervis/Foundation.hs index dcc07cb..ebb12e3 100644 --- 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) diff --git a/src/Vervis/Handler/Client.hs b/src/Vervis/Handler/Client.hs index 492da48..4bf69bd 100644 --- 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 diff --git a/src/Vervis/Handler/Group.hs b/src/Vervis/Handler/Group.hs index c14b38c..691f18b 100644 --- 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 diff --git a/src/Vervis/Migration.hs b/src/Vervis/Migration.hs index 245ee8d..9fe65e2 100644 --- 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 diff --git a/src/Web/ActivityPub.hs b/src/Web/ActivityPub.hs index 939fc2a..db3e34c 100644 --- 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 diff --git a/templates/group/members.hamlet b/templates/group/members.hamlet index c5ac3f7..a6ac257 100644 --- a/templates/group/members.hamlet +++ b/templates/group/members.hamlet @@ -27,3 +27,33 @@ $# . ^{personLinkFedW person} #{showDate since} $#^{buttonW POST "Remove" (GroupRemoveR groupHash ctID)} + +

Invites + + + + +
Inviter + Invitee + Role + Time + $forall (inviter, invitee, time, role) <- invites +
^{personLinkFedW inviter} + ^{personLinkFedW invitee} + #{show role} + #{showDate time} + +$#Invite… + +

Joins + + + + +
Joiner + Role + Time + $forall (joiner, time, role) <- joins +
^{personLinkFedW joiner} + #{show role} + #{showDate time} diff --git a/templates/group/new.hamlet b/templates/group/new.hamlet index 50c5661..8e81382 100644 --- 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 . +$# Written in 2016, 2023 by fr33domlover . $# $# ♡ 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 $# . -
+ ^{widget}
- + diff --git a/templates/personal-overview.hamlet b/templates/personal-overview.hamlet index d0581de..dd4b9dd 100644 --- a/templates/personal-overview.hamlet +++ b/templates/personal-overview.hamlet @@ -25,17 +25,26 @@ $# . SSH key settings
  • - - Create a new repository -
  • - - Create a new ticket tracker -
  • - - Create a new patch tracker -
  • - - Create a new project + Create a new… +