diff --git a/src/Vervis/Form/Tracker.hs b/src/Vervis/Form/Tracker.hs index 98c2c68..6d206d6 100644 --- a/src/Vervis/Form/Tracker.hs +++ b/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 diff --git a/src/Vervis/Foundation.hs b/src/Vervis/Foundation.hs index ebb12e3..0468b93 100644 --- a/src/Vervis/Foundation.hs +++ b/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) diff --git a/src/Vervis/Handler/Group.hs b/src/Vervis/Handler/Group.hs index 6950bdb..d38d0aa 100644 --- a/src/Vervis/Handler/Group.hs +++ b/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 diff --git a/templates/group/member/new.hamlet b/templates/group/member/new.hamlet index e4843fa..698efb2 100644 --- a/templates/group/member/new.hamlet +++ b/templates/group/member/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/group/members.hamlet b/templates/group/members.hamlet index a6ac257..6c22d53 100644 --- a/templates/group/members.hamlet +++ b/templates/group/members.hamlet @@ -26,7 +26,7 @@ $# . #{show role} ^{personLinkFedW person} #{showDate since} - $#^{buttonW POST "Remove" (GroupRemoveR groupHash ctID)} + ^{buttonW POST "Remove" (GroupRemoveR groupHash ctID)}

Invites @@ -43,7 +43,7 @@ $# . #{show role} #{showDate time} -$#Invite… +Invite…

Joins diff --git a/th/routes b/th/routes index c2f1e89..2f1cebe 100644 --- a/th/routes +++ b/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 --------------------------------------------------------------------