From 6dceaa1cffd6c1bc68d60b251f0cc948c085f3fa Mon Sep 17 00:00:00 2001 From: Pere Lev Date: Thu, 7 Dec 2023 17:03:26 +0200 Subject: [PATCH 01/14] S2S: Person: Revoke: Delete Permit records --- src/Vervis/Actor/Person.hs | 150 +++++++++++++++++++++++++++++++++++-- 1 file changed, 143 insertions(+), 7 deletions(-) diff --git a/src/Vervis/Actor/Person.hs b/src/Vervis/Actor/Person.hs index db8c47e..5f4f1b5 100644 --- a/src/Vervis/Actor/Person.hs +++ b/src/Vervis/Actor/Person.hs @@ -28,6 +28,7 @@ import Control.Monad.Trans.Except import Control.Monad.Trans.Maybe import Control.Monad.Trans.Reader import Data.Barbie +import Data.Bifoldable import Data.Bifunctor import Data.Bitraversable import Data.ByteString (ByteString) @@ -1105,27 +1106,162 @@ personGrant now recipPersonID (Verse authorIdMsig body) grant = do return (action, recipientSet, remoteActors, fwdHosts) -- Meaning: An actor has revoked some previously published Grants --- Behavior: Insert to my inbox +-- Behavior: +-- * Insert to my inbox +-- * For each revoked activity: +-- * If it's a direct-Grant given to me: +-- * Verify the sender is the Permit topic +-- * Delete the Permit record +-- * If it's an extension-Grant given to me: +-- * Verify the sender is the Permit topic +-- * Delete the PermitTopicExtend* record personRevoke :: UTCTime -> PersonId -> Verse -> AP.Revoke URIMode -> ActE (Text, Act (), Next) -personRevoke now recipPersonID (Verse authorIdMsig body) (AP.Revoke _lus) = do +personRevoke now recipPersonID (Verse authorIdMsig body) (AP.Revoke lus) = do - maybeRevoke <- lift $ withDB $ do + -- Check input + grants <- nameExceptT "Revoke.object" $ do + ObjURI h _ <- lift $ getActorURI authorIdMsig + hl <- hostIsLocal h + if hl + then + for lus $ \ lu -> + (\ (actor, _, item) -> Left (actor, item)) <$> + parseLocalActivityURI' lu + else + pure $ Right . ObjURI h <$> lus + + maybeNew <- withDBExcept $ do -- Grab me from DB - (_personRecip, actorRecip) <- do + (personRecip, actorRecip) <- lift $ do p <- getJust recipPersonID (p,) <$> getJust (personActor p) - insertToInbox now authorIdMsig body (actorInbox actorRecip) True + -- Look for the revoked Grants in my Permit records + grantsDB <- for grants $ \ grant -> runMaybeT $ do + grantDB <- MaybeT $ getActivity grant + found <- + Left <$> tryDirect grantDB <|> + Right <$> tryExtension grantDB + bitraverse + (\ (gestureID, topicAndEnable) -> do - case maybeRevoke of + -- Verify the Permit is mine + PermitPersonGesture permitID _ <- lift . lift $ getJust gestureID + Permit p _ <- lift . lift $ getJust permitID + guard $ p == recipPersonID + + -- Verify the Revoke sender is the Permit topic + lift $ do + topic <- lift $ getPermitTopic permitID + case (bimap snd snd topic, bimap (view _1) (view _1) authorIdMsig) of + (Left la, Left la') | la == la' -> pure () + (Right raID, Right ra) | raID == remoteAuthorId ra -> pure () + _ -> throwE "Revoke sender isn't the Permit topic" + + -- Return data for Permit deletion + return (permitID, gestureID, topicAndEnable) + ) + (\ extend -> do + + -- Verify the Permit is mine + sendID <- + lift . lift $ case extend of + Left k -> permitTopicExtendLocalPermit <$> getJust k + Right k -> permitTopicExtendRemotePermit <$> getJust k + PermitPersonSendDelegator gestureID _ <- lift . lift $ getJust sendID + PermitPersonGesture permitID _ <- lift . lift $ getJust gestureID + Permit p _ <- lift . lift $ getJust permitID + guard $ p == recipPersonID + + -- Verify the Revoke sender is the Permit topic + lift $ do + topic <- lift $ getPermitTopic permitID + case (bimap snd snd topic, bimap (view _1) (view _1) authorIdMsig) of + (Left la, Left la') | la == la' -> pure () + (Right raID, Right ra) | raID == remoteAuthorId ra -> pure () + _ -> throwE "Revoke sender isn't the Permit topic" + + -- Return data for PermitTopicExtend* deletion + return extend + ) + found + + mractid <- lift $ insertToInbox now authorIdMsig body (actorInbox actorRecip) True + lift $ for mractid $ \ _revokeDB -> + -- Delete revoked records from DB + for grantsDB $ traverse_ $ + bitraverse_ + (\ (permitID, gestureID, topicAndEnable) -> do + case topicAndEnable of + Left (_, enableID) -> + deleteWhere [PermitTopicExtendLocalTopic ==. enableID] + Right (_, enableID) -> + deleteWhere [PermitTopicExtendRemoteTopic ==. enableID] + deleteBy $ UniquePermitPersonSendDelegator gestureID + case topicAndEnable of + Left (topicID, enableID) -> do + delete enableID + deleteBy $ UniquePermitTopicAcceptLocalTopic topicID + Right (topicID, enableID) -> do + delete enableID + deleteBy $ UniquePermitTopicAcceptRemoteTopic topicID + maybeInvite <- getKeyBy $ UniquePermitFulfillsInvite permitID + for_ maybeInvite $ \ inviteID -> do + deleteBy $ UniquePermitTopicGestureLocal inviteID + deleteBy $ UniquePermitTopicGestureRemote inviteID + delete gestureID + deleteBy $ UniquePermitFulfillsTopicCreation permitID + deleteBy $ UniquePermitFulfillsInvite permitID + deleteBy $ UniquePermitFulfillsJoin permitID + case topicAndEnable of + Left (topicID, _) -> do + deleteBy $ UniquePermitTopicRepo topicID + deleteBy $ UniquePermitTopicDeck topicID + deleteBy $ UniquePermitTopicLoom topicID + deleteBy $ UniquePermitTopicProject topicID + deleteBy $ UniquePermitTopicGroup topicID + delete topicID + Right (topicID, _) -> delete topicID + delete permitID + ) + (\case + Left k -> delete k + Right k -> delete k + ) + + case maybeNew of Nothing -> done "I already have this activity in my inbox" - Just _revokeDB -> done "Inserted to my inbox" + Just _ -> done "Deleted any relevant Permit/Extend records" + + where + + tryDirect objectDB = + case objectDB of + Left (_actorByKey, _actorEntity, itemID) -> do + Entity enableID (PermitTopicEnableLocal gestureID topicID _) <- + MaybeT $ lift $ getBy $ UniquePermitTopicEnableLocalGrant itemID + return (gestureID, Left (topicID, enableID)) + Right remoteActivityID -> do + Entity enableID (PermitTopicEnableRemote gestureID topicID _) <- + MaybeT $ lift $ getBy $ UniquePermitTopicEnableRemoteGrant remoteActivityID + return (gestureID, Right (topicID, enableID)) + + tryExtension objectDB = + case objectDB of + Left (_actorByKey, _actorEntity, itemID) -> do + Entity extendID (PermitTopicExtendLocal _ _ _) <- + MaybeT $ lift $ getBy $ UniquePermitTopicExtendLocalGrant itemID + return $ Left extendID + Right remoteActivityID -> do + Entity extendID (PermitTopicExtendRemote _ _ _) <- + MaybeT $ lift $ getBy $ UniquePermitTopicExtendRemoteGrant remoteActivityID + return $ Right extendID ------------------------------------------------------------------------------ -- Main behavior function From cfc8add212027a9794908c272dbe13bc40847207 Mon Sep 17 00:00:00 2001 From: Pere Lev Date: Thu, 7 Dec 2023 18:21:35 +0200 Subject: [PATCH 02/14] S2S: Common: Remove: When deleting Collab record, delete CollabDeleg*s too --- src/Vervis/Actor/Common.hs | 2 ++ 1 file changed, 2 insertions(+) diff --git a/src/Vervis/Actor/Common.hs b/src/Vervis/Actor/Common.hs index 145727a..5468e6d 100644 --- a/src/Vervis/Actor/Common.hs +++ b/src/Vervis/Actor/Common.hs @@ -1379,6 +1379,8 @@ topicRemove grabActor topicResource topicField topicCollabField now topicKey (Ve lift $ for maybeRemoveDB $ \ _removeDB -> do -- Delete the whole Collab record + deleteBy $ UniqueCollabDelegLocal enableID + deleteBy $ UniqueCollabDelegRemote enableID delete enableID case recipID of Left (E.Value l) -> do From e2462627a521b29f9f8481e22d6acb4655845f94 Mon Sep 17 00:00:00 2001 From: Pere Lev Date: Thu, 7 Dec 2023 18:22:51 +0200 Subject: [PATCH 03/14] Remove old empty Vervis.Federation.Collab module --- src/Vervis/Federation/Collab.hs | 150 -------------------------------- src/Vervis/Handler/Deck.hs | 1 - src/Vervis/Handler/Group.hs | 1 - src/Vervis/Handler/Loom.hs | 1 - src/Vervis/Handler/Person.hs | 1 - src/Vervis/Handler/Project.hs | 1 - src/Vervis/Handler/Repo.hs | 1 - vervis.cabal | 1 - 8 files changed, 157 deletions(-) delete mode 100644 src/Vervis/Federation/Collab.hs diff --git a/src/Vervis/Federation/Collab.hs b/src/Vervis/Federation/Collab.hs deleted file mode 100644 index a8c2544..0000000 --- a/src/Vervis/Federation/Collab.hs +++ /dev/null @@ -1,150 +0,0 @@ -{- This file is part of Vervis. - - - - Written in 2022, 2023 by fr33domlover . - - - - ♡ Copying is an act of love. Please copy, reuse and share. - - - - The author(s) have dedicated all copyright and related and neighboring - - rights to this software to the public domain worldwide. This software is - - distributed without any warranty. - - - - You should have received a copy of the CC0 Public Domain Dedication along - - with this software. If not, see - - . - -} - -{-# LANGUAGE RankNTypes #-} - -module Vervis.Federation.Collab - ( --personInviteF - --topicInviteF - - -- repoJoinF - --, deckJoinF - --, loomJoinF - - --, repoAcceptF - --, deckAcceptF - --, loomAcceptF - - --, personGrantF - ) -where - -import Control.Applicative -import Control.Exception hiding (Handler) -import Control.Monad -import Control.Monad.IO.Class -import Control.Monad.Trans.Class -import Control.Monad.Trans.Except -import Control.Monad.Trans.Maybe -import Control.Monad.Trans.Reader -import Data.Barbie -import Data.Bifunctor -import Data.Bitraversable -import Data.ByteString (ByteString) -import Data.Either -import Data.Foldable -import Data.Functor.Identity -import Data.List.NonEmpty (NonEmpty) -import Data.Maybe -import Data.Text (Text) -import Data.Time.Clock -import Data.Traversable -import Database.Persist -import Database.Persist.Sql -import Yesod.Persist.Core - -import qualified Data.ByteString.Lazy as BL -import qualified Data.Text as T - -import Database.Persist.JSON -import Development.PatchMediaType -import Network.FedURI -import Yesod.ActivityPub -import Yesod.FedURI -import Yesod.Hashids -import Yesod.MonadSite - -import qualified Web.ActivityPub as AP - -import Control.Monad.Trans.Except.Local -import Data.Either.Local -import Data.Tuple.Local -import Database.Persist.Local -import Yesod.Persist.Local - -import Vervis.Access -import Vervis.ActivityPub -import Vervis.Actor (RemoteAuthor (..), ActivityBody (..)) -import Vervis.Data.Actor -import Vervis.Data.Collab -import Vervis.Web.Delivery -import Vervis.FedURI -import Vervis.Federation.Auth -import Vervis.Federation.Util -import Vervis.Foundation -import Vervis.Model -import Vervis.Persist.Actor -import Vervis.Persist.Collab -import Vervis.Recipient -import Vervis.RemoteActorStore - -{- -repoJoinF - :: UTCTime - -> KeyHashid Repo - -> RemoteAuthor - -> ActivityBody - -> Maybe (RecipientRoutes, ByteString) - -> LocalURI - -> AP.Join URIMode - -> ExceptT Text Handler (Text, Maybe (ExceptT Text Worker Text)) -repoJoinF = topicJoinF repoActor GrantResourceRepo - -deckJoinF - :: UTCTime - -> KeyHashid Deck - -> RemoteAuthor - -> ActivityBody - -> Maybe (RecipientRoutes, ByteString) - -> LocalURI - -> AP.Join URIMode - -> ExceptT Text Handler (Text, Maybe (ExceptT Text Worker Text)) -deckJoinF = topicJoinF deckActor GrantResourceDeck - -loomJoinF - :: UTCTime - -> KeyHashid Loom - -> RemoteAuthor - -> ActivityBody - -> Maybe (RecipientRoutes, ByteString) - -> LocalURI - -> AP.Join URIMode - -> ExceptT Text Handler (Text, Maybe (ExceptT Text Worker Text)) -loomJoinF = topicJoinF loomActor GrantResourceLoom --} - -{- -repoAcceptF - :: UTCTime - -> KeyHashid Repo - -> RemoteAuthor - -> ActivityBody - -> Maybe (RecipientRoutes, ByteString) - -> LocalURI - -> AP.Accept URIMode - -> ExceptT Text Handler (Text, Maybe (ExceptT Text Worker Text)) -repoAcceptF = topicAcceptF repoActor GrantResourceRepo - -loomAcceptF - :: UTCTime - -> KeyHashid Loom - -> RemoteAuthor - -> ActivityBody - -> Maybe (RecipientRoutes, ByteString) - -> LocalURI - -> AP.Accept URIMode - -> ExceptT Text Handler (Text, Maybe (ExceptT Text Worker Text)) -loomAcceptF = topicAcceptF loomActor GrantResourceLoom --} diff --git a/src/Vervis/Handler/Deck.hs b/src/Vervis/Handler/Deck.hs index fa8bd14..0be9469 100644 --- a/src/Vervis/Handler/Deck.hs +++ b/src/Vervis/Handler/Deck.hs @@ -109,7 +109,6 @@ import Yesod.Persist.Local import Vervis.Access import Vervis.API import Vervis.Federation.Auth -import Vervis.Federation.Collab import Vervis.Federation.Discussion import Vervis.Federation.Offer import Vervis.Federation.Ticket diff --git a/src/Vervis/Handler/Group.hs b/src/Vervis/Handler/Group.hs index 691f18b..6950bdb 100644 --- a/src/Vervis/Handler/Group.hs +++ b/src/Vervis/Handler/Group.hs @@ -94,7 +94,6 @@ import Vervis.Access import Vervis.API import Vervis.Data.Collab import Vervis.Federation.Auth -import Vervis.Federation.Collab import Vervis.Federation.Discussion import Vervis.Federation.Offer import Vervis.Federation.Ticket diff --git a/src/Vervis/Handler/Loom.hs b/src/Vervis/Handler/Loom.hs index 65b7e9e..bbf075c 100644 --- a/src/Vervis/Handler/Loom.hs +++ b/src/Vervis/Handler/Loom.hs @@ -78,7 +78,6 @@ import Yesod.Persist.Local import Vervis.Access import Vervis.API import Vervis.Federation.Auth -import Vervis.Federation.Collab import Vervis.Federation.Discussion import Vervis.Federation.Offer import Vervis.Federation.Ticket diff --git a/src/Vervis/Handler/Person.hs b/src/Vervis/Handler/Person.hs index b89f652..e80a72c 100644 --- a/src/Vervis/Handler/Person.hs +++ b/src/Vervis/Handler/Person.hs @@ -73,7 +73,6 @@ import Vervis.ActivityPub import Vervis.API import Vervis.Data.Actor import Vervis.Federation.Auth -import Vervis.Federation.Collab import Vervis.Federation.Discussion import Vervis.Federation.Offer import Vervis.FedURI diff --git a/src/Vervis/Handler/Project.hs b/src/Vervis/Handler/Project.hs index 3a43242..9473a1d 100644 --- a/src/Vervis/Handler/Project.hs +++ b/src/Vervis/Handler/Project.hs @@ -90,7 +90,6 @@ import Vervis.Access import Vervis.API import Vervis.Data.Collab import Vervis.Federation.Auth -import Vervis.Federation.Collab import Vervis.Federation.Discussion import Vervis.Federation.Offer import Vervis.Federation.Ticket diff --git a/src/Vervis/Handler/Repo.hs b/src/Vervis/Handler/Repo.hs index 9bb50b4..762bcae 100644 --- a/src/Vervis/Handler/Repo.hs +++ b/src/Vervis/Handler/Repo.hs @@ -165,7 +165,6 @@ import Vervis.Access import Vervis.ActivityPub import Vervis.API import Vervis.Federation.Auth -import Vervis.Federation.Collab import Vervis.Federation.Offer import Vervis.FedURI import Vervis.Form.Repo diff --git a/vervis.cabal b/vervis.cabal index 0286bde..f9280f3 100644 --- a/vervis.cabal +++ b/vervis.cabal @@ -171,7 +171,6 @@ library --Vervis.Federation Vervis.Federation.Auth - Vervis.Federation.Collab Vervis.Federation.Discussion Vervis.Federation.Offer --Vervis.Federation.Push From 12e228438953bfbfaea4da1e1ffec91b6305d024 Mon Sep 17 00:00:00 2001 From: Pere Lev Date: Thu, 7 Dec 2023 18:50:44 +0200 Subject: [PATCH 04/14] C2S: When creating a resource, insert a Permit record --- src/Vervis/Actor/Person/Client.hs | 25 +++++++++++++++++++++++++ 1 file changed, 25 insertions(+) diff --git a/src/Vervis/Actor/Person/Client.hs b/src/Vervis/Actor/Person/Client.hs index a0adfc4..8db73f2 100644 --- a/src/Vervis/Actor/Person/Client.hs +++ b/src/Vervis/Actor/Person/Client.hs @@ -360,6 +360,7 @@ clientAdd now personMeID (ClientMsg maybeCap localRecips remoteRecips fwdHosts a -- Meaning: The human wants to create a ticket tracker -- Behavior: -- * Create a deck on DB +-- * Create a Permit record in DB -- * Launch a deck actor -- * Record a FollowRequest in DB -- * Create and send Create and Follow to it @@ -389,6 +390,14 @@ clientCreateDeck now personMeID (ClientMsg maybeCap localRecips remoteRecips fwd (deckID, deckFollowerSetID) <- lift $ insertDeck now name msummary createID wid actorMeID + -- Insert a Permit record + lift $ do + permitID <- insert $ Permit personMeID AP.RoleAdmin + topicID <- insert $ PermitTopicLocal permitID + insert_ $ PermitTopicDeck topicID deckID + insert_ $ PermitFulfillsTopicCreation permitID + insert_ $ PermitPersonGesture permitID createID + -- Insert the Create activity to my outbox deckHash <- encodeKeyHashid deckID actionCreate <- prepareCreate name msummary deckHash @@ -525,6 +534,7 @@ clientCreateDeck now personMeID (ClientMsg maybeCap localRecips remoteRecips fwd -- Meaning: The human wants to create a project -- Behavior: -- * Create a project on DB +-- * Create a Permit record in DB -- * Launch a project actor -- * Record a FollowRequest in DB -- * Create and send Create and Follow to it @@ -553,6 +563,13 @@ clientCreateProject now personMeID (ClientMsg maybeCap localRecips remoteRecips (projectID, projectFollowerSetID) <- insertProject now name msummary createID actorMeID + -- Insert a Permit record + permitID <- insert $ Permit personMeID AP.RoleAdmin + topicID <- insert $ PermitTopicLocal permitID + insert_ $ PermitTopicProject topicID projectID + insert_ $ PermitFulfillsTopicCreation permitID + insert_ $ PermitPersonGesture permitID createID + -- Insert the Create activity to my outbox projectHash <- lift $ encodeKeyHashid projectID actionCreate <- lift $ prepareCreate name msummary projectHash @@ -682,6 +699,7 @@ clientCreateProject now personMeID (ClientMsg maybeCap localRecips remoteRecips -- Meaning: The human wants to create a team -- Behavior: -- * Create a team on DB +-- * Create a Permit record in DB -- * Launch a team actor -- * Record a FollowRequest in DB -- * Create and send Create and Follow to it @@ -710,6 +728,13 @@ clientCreateTeam now personMeID (ClientMsg maybeCap localRecips remoteRecips fwd (groupID, projectFollowerSetID) <- insertTeam now name msummary createID actorMeID + -- Insert a Permit record + permitID <- insert $ Permit personMeID AP.RoleAdmin + topicID <- insert $ PermitTopicLocal permitID + insert_ $ PermitTopicGroup topicID groupID + insert_ $ PermitFulfillsTopicCreation permitID + insert_ $ PermitPersonGesture permitID createID + -- Insert the Create activity to my outbox groupHash <- lift $ encodeKeyHashid groupID actionCreate <- lift $ prepareCreate name msummary groupHash From b2b4d8778df4e9d87107cdee94422201044a990d Mon Sep 17 00:00:00 2001 From: Pere Lev Date: Sat, 9 Dec 2023 01:04:21 +0200 Subject: [PATCH 05/14] DB: For each CollabRecipLocal record, produce a matching Permit record --- migrations/565_2023-12-09_collab_permit.model | 300 ++++++++++++++++++ src/Vervis/Migration.hs | 75 +++++ src/Vervis/Migration/Model.hs | 3 + th/models | 4 - 4 files changed, 378 insertions(+), 4 deletions(-) create mode 100644 migrations/565_2023-12-09_collab_permit.model diff --git a/migrations/565_2023-12-09_collab_permit.model b/migrations/565_2023-12-09_collab_permit.model new file mode 100644 index 0000000..c8a2f97 --- /dev/null +++ b/migrations/565_2023-12-09_collab_permit.model @@ -0,0 +1,300 @@ +Repo +Deck +Loom +Project +Group +RemoteActor +RemoteActivity +Inbox +FollowerSet + +Outbox + +OutboxItem + outbox OutboxId + activity PersistJSONObject + published UTCTime + +Actor + name Text + desc Text + createdAt UTCTime + inbox InboxId + outbox OutboxId + followers FollowerSetId + justCreatedBy ActorId Maybe + + UniqueActorInbox inbox + UniqueActorOutbox outbox + UniqueActorFollowers followers + +Person + username Username + login Text + passphraseHash ByteString + email EmailAddress + verified Bool + verifiedKey Text + verifiedKeyCreated UTCTime + resetPassKey Text + resetPassKeyCreated UTCTime + actor ActorId +-- reviewFollow Bool + + UniquePersonUsername username + UniquePersonLogin login + UniquePersonEmail email + UniquePersonActor actor + +Collab + role Role + +CollabFulfillsLocalTopicCreation + collab CollabId + + UniqueCollabFulfillsLocalTopicCreation collab + +CollabFulfillsInvite + collab CollabId + accept OutboxItemId + + UniqueCollabFulfillsInvite collab + UniqueCollabFulfillsInviteAccept accept + +CollabInviterLocal + collab CollabFulfillsInviteId + invite OutboxItemId + + UniqueCollabInviterLocal collab + UniqueCollabInviterLocalInvite invite + +CollabInviterRemote + collab CollabFulfillsInviteId + actor RemoteActorId + invite RemoteActivityId + + UniqueCollabInviterRemote collab + UniqueCollabInviterRemoteInvite invite + +CollabFulfillsJoin + collab CollabId + + UniqueCollabFulfillsJoin collab + +CollabApproverLocal + collab CollabFulfillsJoinId + accept OutboxItemId + + UniqueCollabApproverLocal collab + UniqueCollabApproverLocalAccept accept + +CollabApproverRemote + collab CollabFulfillsJoinId + actor RemoteActorId + accept RemoteActivityId + + UniqueCollabApproverRemote collab + UniqueCollabApproverRemoteAccept accept + +CollabRecipLocalJoin + collab CollabRecipLocalId + fulfills CollabFulfillsJoinId + join OutboxItemId + + UniqueCollabRecipLocalJoinCollab collab + UniqueCollabRecipLocalJoinFulfills fulfills + UniqueCollabRecipLocalJoinJoin join + +CollabTopicRepo + collab CollabId + repo RepoId + + UniqueCollabTopicRepo collab + +CollabTopicDeck + collab CollabId + deck DeckId + + UniqueCollabTopicDeck collab + +CollabTopicLoom + collab CollabId + loom LoomId + + UniqueCollabTopicLoom collab + +CollabTopicProject + collab CollabId + project ProjectId + + UniqueCollabTopicProject collab + +CollabTopicGroup + collab CollabId + group GroupId + + UniqueCollabTopicGroup collab + +CollabRecipLocal + collab CollabId + person PersonId + + UniqueCollabRecipLocal collab + +CollabRecipLocalAccept + collab CollabRecipLocalId + invite CollabFulfillsInviteId + accept OutboxItemId + + UniqueCollabRecipLocalAcceptCollab collab + UniqueCollabRecipLocalAcceptInvite invite + UniqueCollabRecipLocalAcceptAccept accept + +CollabEnable + collab CollabId + grant OutboxItemId + + UniqueCollabEnable collab + UniqueCollabEnableGrant grant + +CollabDelegLocal + enable CollabEnableId + recip CollabRecipLocalId + grant OutboxItemId + + UniqueCollabDelegLocal enable + UniqueCollabDelegLocalRecip recip + UniqueCollabDelegLocalGrant grant + +Permit + person PersonId + role Role + +PermitTopicLocal + permit PermitId + + UniquePermitTopicLocal permit + +PermitTopicRepo + permit PermitTopicLocalId + repo RepoId + + UniquePermitTopicRepo permit + +PermitTopicDeck + permit PermitTopicLocalId + deck DeckId + + UniquePermitTopicDeck permit + +PermitTopicLoom + permit PermitTopicLocalId + loom LoomId + + UniquePermitTopicLoom permit + +PermitTopicProject + permit PermitTopicLocalId + project ProjectId + + UniquePermitTopicProject permit + +PermitTopicGroup + permit PermitTopicLocalId + group GroupId + + UniquePermitTopicGroup permit + +PermitTopicRemote + permit PermitId + actor RemoteActorId + + UniquePermitTopicRemote permit + +PermitFulfillsTopicCreation + permit PermitId + + UniquePermitFulfillsTopicCreation permit + +PermitFulfillsInvite + permit PermitId + + UniquePermitFulfillsInvite permit + +PermitFulfillsJoin + permit PermitId + + UniquePermitFulfillsJoin permit + +PermitPersonGesture + permit PermitId + activity OutboxItemId + + UniquePermitPersonGesture permit + UniquePermitPersonGestureActivity activity + +PermitTopicGestureLocal + fulfills PermitFulfillsInviteId + invite OutboxItemId + + UniquePermitTopicGestureLocal fulfills + UniquePermitTopicGestureLocalInvite invite + +PermitTopicGestureRemote + fulfills PermitFulfillsInviteId + actor RemoteActorId + invite RemoteActivityId + + UniquePermitTopicGestureRemote fulfills + UniquePermitTopicGestureRemoteInvite invite + +PermitTopicAcceptLocal + fulfills PermitFulfillsInviteId + topic PermitTopicLocalId + accept OutboxItemId + + UniquePermitTopicAcceptLocal fulfills + UniquePermitTopicAcceptLocalTopic topic + UniquePermitTopicAcceptLocalAccept accept + +PermitTopicEnableLocal + permit PermitPersonGestureId + topic PermitTopicLocalId + grant OutboxItemId + + UniquePermitTopicEnableLocal permit + UniquePermitTopicEnableLocalTopic topic + UniquePermitTopicEnableLocalGrant grant + +PermitPersonSendDelegator + permit PermitPersonGestureId + grant OutboxItemId + + UniquePermitPersonSendDelegator permit + UniquePermitPersonSendDelegatorGrant grant + +PermitTopicExtendLocal + permit PermitPersonSendDelegatorId + topic PermitTopicEnableLocalId + grant OutboxItemId + + UniquePermitTopicExtendLocalGrant grant + +Component + project ProjectId + role Role + +ComponentEnable + component ComponentId + grant OutboxItemId + + UniqueComponentEnable component + UniqueComponentEnableGrant grant + +ComponentFurtherLocal + component ComponentEnableId + collab CollabDelegLocalId + grant OutboxItemId + + UniqueComponentFurtherLocal component collab + UniqueComponentFurtherLocalGrant grant diff --git a/src/Vervis/Migration.hs b/src/Vervis/Migration.hs index 97dd4ce..ed10521 100644 --- a/src/Vervis/Migration.hs +++ b/src/Vervis/Migration.hs @@ -3121,6 +3121,81 @@ changes hLocal ctx = , addUnique' "ComponentFurtherRemote" "" ["component", "collab"] -- 564 , addEntities model_564_permit + -- 565 + , removeUnique' "PermitTopicExtendLocal" "" + -- 566 + , removeUnique' "PermitTopicExtendLocal" "Topic" + -- 567 + , removeUnique' "PermitTopicExtendRemote" "" + -- 568 + , removeUnique' "PermitTopicExtendRemote" "Topic" + -- 569 + , unchecked $ lift $ do + recips <- selectList [] [] + for_ recips $ \ (Entity recipID (CollabRecipLocal565 collabID personID)) -> do + Collab565 role <- getJust collabID + permitID <- insert $ Permit565 personID role + topicID <- insert $ PermitTopicLocal565 permitID + + mr <- getValBy $ UniqueCollabTopicRepo565 collabID + for_ mr $ \ (CollabTopicRepo565 _ repoID) -> + insert_ $ PermitTopicRepo565 topicID repoID + md <- getValBy $ UniqueCollabTopicDeck565 collabID + for_ md $ \ (CollabTopicDeck565 _ deckID) -> + insert_ $ PermitTopicDeck565 topicID deckID + ml <- getValBy $ UniqueCollabTopicLoom565 collabID + for_ ml $ \ (CollabTopicLoom565 _ loomID) -> + insert_ $ PermitTopicLoom565 topicID loomID + mj <- getValBy $ UniqueCollabTopicProject565 collabID + for_ mj $ \ (CollabTopicProject565 _ projectID) -> + insert_ $ PermitTopicProject565 topicID projectID + mg <- getValBy $ UniqueCollabTopicGroup565 collabID + for_ mg $ \ (CollabTopicGroup565 _ groupID) -> + insert_ $ PermitTopicGroup565 topicID groupID + + fc <- getKeyBy $ UniqueCollabFulfillsLocalTopicCreation565 collabID + g1 <- for fc $ \ fulfillsID -> do + insert_ $ PermitFulfillsTopicCreation565 permitID + actorID <- person565Actor <$> getJust personID + outboxID <- actor565Outbox <$> getJust actorID + let doc = persistJSONObjectFromDoc $ Doc hLocal emptyActivity + createID <- insert $ OutboxItem565 outboxID doc defaultTime + insert $ PermitPersonGesture565 permitID createID + + fi <- getBy $ UniqueCollabFulfillsInvite565 collabID + g2 <- for fi $ \ (Entity fulfillsID (CollabFulfillsInvite565 _ acceptID)) -> do + pfi <- insert $ PermitFulfillsInvite565 permitID + l <- getValBy $ UniqueCollabInviterLocal565 fulfillsID + for_ l $ \ (CollabInviterLocal565 _ inviteID) -> + insert_ $ PermitTopicGestureLocal565 pfi inviteID + r <- getValBy $ UniqueCollabInviterRemote565 fulfillsID + for_ r $ \ (CollabInviterRemote565 _ actorID inviteID) -> + insert_ $ PermitTopicGestureRemote565 pfi actorID inviteID + insert_ $ PermitTopicAcceptLocal565 pfi topicID acceptID + a <- getValBy $ UniqueCollabRecipLocalAcceptCollab565 recipID + for a $ \ (CollabRecipLocalAccept565 _ _ acceptID) -> + insert $ PermitPersonGesture565 permitID acceptID + + fj <- getKeyBy $ UniqueCollabFulfillsJoin565 collabID + g3 <- for fj $ \ fulfillsID -> do + CollabRecipLocalJoin565 _ _ joinID <- getValByJust $ UniqueCollabRecipLocalJoinCollab565 recipID + insert $ PermitPersonGesture565 permitID joinID + + me <- getValBy $ UniqueCollabEnable565 collabID + for_ (liftA2 (,) me (g1 <|> join g2 <|> g3)) $ \ (CollabEnable565 _ grantID, gestureID) -> do + enableID <- insert $ PermitTopicEnableLocal565 gestureID topicID grantID + d <- getBy $ UniqueCollabDelegLocalRecip565 recipID + for_ d $ \ (Entity cdl (CollabDelegLocal565 _ _ delegID)) -> do + sendID <- insert $ PermitPersonSendDelegator565 gestureID delegID + for_ mj $ \ (CollabTopicProject565 _ projectID) -> do + gs <- E.select $ E.from $ \ (enable `E.InnerJoin` comp `E.InnerJoin` further) -> do + E.on $ enable E.^. ComponentEnable565Id E.==. further E.^. ComponentFurtherLocal565Component + E.on $ enable E.^. ComponentEnable565Component E.==. comp E.^. Component565Id + E.where_ $ + comp E.^. Component565Project E.==. E.val projectID E.&&. + further E.^. ComponentFurtherLocal565Collab E.==. E.val cdl + return $ further E.^. ComponentFurtherLocal565Grant + insertMany_ $ map (PermitTopicExtendLocal565 sendID enableID . E.unValue) gs ] migrateDB diff --git a/src/Vervis/Migration/Model.hs b/src/Vervis/Migration/Model.hs index e713717..bda0e4f 100644 --- a/src/Vervis/Migration/Model.hs +++ b/src/Vervis/Migration/Model.hs @@ -537,3 +537,6 @@ makeEntitiesMigration "553" makeEntitiesMigration "554" $(modelFile "migrations/554_2023-11-21_further_local_deleg.model") + +makeEntitiesMigration "565" + $(modelFile "migrations/565_2023-12-09_collab_permit.model") diff --git a/th/models b/th/models index 4da41c9..d99f88c 100644 --- a/th/models +++ b/th/models @@ -920,8 +920,6 @@ PermitTopicExtendLocal topic PermitTopicEnableLocalId grant OutboxItemId - UniquePermitTopicExtendLocal permit - UniquePermitTopicExtendLocalTopic topic UniquePermitTopicExtendLocalGrant grant PermitTopicExtendRemote @@ -929,8 +927,6 @@ PermitTopicExtendRemote topic PermitTopicEnableRemoteId grant RemoteActivityId - UniquePermitTopicExtendRemote permit - UniquePermitTopicExtendRemoteTopic topic UniquePermitTopicExtendRemoteGrant grant ------------------------------------------------------------------------------ From 702ad39b961b3a9a45a91f881b171dac83ddcb17 Mon Sep 17 00:00:00 2001 From: Pere Lev Date: Sat, 9 Dec 2023 02:46:11 +0200 Subject: [PATCH 06/14] S2S: Group: Adapt collab-mode code from Project --- src/Vervis/Actor/Common.hs | 3 +- src/Vervis/Actor/Group.hs | 712 ++++++++++++++++++++++++++++++++++++ src/Vervis/Actor/Person.hs | 4 +- src/Vervis/Actor/Project.hs | 4 +- src/Vervis/Data/Collab.hs | 50 +-- 5 files changed, 720 insertions(+), 53 deletions(-) diff --git a/src/Vervis/Actor/Common.hs b/src/Vervis/Actor/Common.hs index 5468e6d..364758c 100644 --- a/src/Vervis/Actor/Common.hs +++ b/src/Vervis/Actor/Common.hs @@ -1855,8 +1855,7 @@ componentGrant grabActor topicComponent now recipKey (Verse authorIdMsig body) g (Right u, Right (ra, _, _)) | remoteAuthorURI ra == u -> pure () _ -> throwE "Author and resource aren't the same project actor" case recipient of - Left (GrantRecipComponent' c) - | topicComponent recipKey == c -> pure () + Left la | topicResource recipKey == la -> pure () _ -> throwE "Grant recipient isn't me" for_ mstart $ \ start -> unless (start < now) $ throwE "Start time is in the future" diff --git a/src/Vervis/Actor/Group.hs b/src/Vervis/Actor/Group.hs index 931d35e..22ab360 100644 --- a/src/Vervis/Actor/Group.hs +++ b/src/Vervis/Actor/Group.hs @@ -78,6 +78,292 @@ import Vervis.Persist.Collab import Vervis.Persist.Discussion import Vervis.Ticket +-- Meaning: An actor accepted something +-- Behavior: +-- * Check if I know the activity that's being Accepted: +-- * Is it an Invite to be a collaborator in me? +-- * Verify the Accept is by the Invite target +-- * Is it a Join to be a collaborator in me? +-- * Verify the Accept is authorized +-- * If it's none of these, respond with error +-- +-- * Verify the Collab isn't enabled yet +-- +-- * Insert the Accept to my inbox +-- +-- * Record the Accept and enable the Collab in DB +-- +-- * Forward the Accept to my followers +-- +-- * Possibly send a Grant: +-- * For Invite-collab mode: +-- * Regular collaborator-Grant +-- * To: Accepter (i.e. Invite target) +-- * CC: Invite sender, Accepter's followers, my followers +-- * For Join-as-collab mode: +-- * Regular collaborator-Grant +-- * To: Join sender +-- * CC: Accept sender, Join sender's followers, my followers +groupAccept + :: UTCTime + -> GroupId + -> Verse + -> AP.Accept URIMode + -> ActE (Text, Act (), Next) +groupAccept now groupID (Verse authorIdMsig body) accept = do + + -- Check input + acceptee <- parseAccept accept + + -- Verify that the capability URI, if specified, is one of: + -- * Outbox item URI of a local actor, i.e. a local activity + -- * A remote URI + maybeCap <- + traverse + (nameExceptT "Accept capability" . parseActivityURI') + (AP.activityCapability $ actbActivity body) + + maybeNew <- withDBExcept $ do + + -- Grab me from DB + (recipActorID, recipActor) <- lift $ do + recip <- getJust groupID + let actorID = groupActor recip + (actorID,) <$> getJust actorID + + -- Find the accepted activity in our DB + accepteeDB <- do + a <- getActivity acceptee + fromMaybeE a "Can't find acceptee in DB" + + -- See if the accepted activity is an Invite or Join where my collabs + -- URI is the resource, grabbing the Collab record from our DB, + (collabID, fulfills, inviterOrJoiner) <- do + let adapt = maybe (Right Nothing) (either Left (Right . Just)) + maybeCollab <- + ExceptT $ fmap adapt $ runMaybeT $ + runExceptT (tryInviteCollab accepteeDB) <|> + runExceptT (tryJoinCollab accepteeDB) + fromMaybeE + maybeCollab + "Accepted activity isn't an Invite/Join I'm aware of" + + collab <- bitraverse + + -- If accepting an Invite, find the Collab recipient and verify + -- it's the sender of the Accept + (\ fulfillsID -> do + recip <- + lift $ + requireEitherAlt + (getBy $ UniqueCollabRecipLocal collabID) + (getBy $ UniqueCollabRecipRemote collabID) + "Found Collab with no recip" + "Found Collab with multiple recips" + case (recip, authorIdMsig) of + (Left (Entity crlid crl), Left (LocalActorPerson personID, _, _)) + | collabRecipLocalPerson crl == personID -> + return (fulfillsID, Left crlid) + (Right (Entity crrid crr), Right (author, _, _)) + | collabRecipRemoteActor crr == remoteAuthorId author -> + return (fulfillsID, Right crrid) + _ -> throwE "Accepting an Invite whose recipient is someone else" + ) + + -- If accepting a Join, verify accepter has permission + (\ fulfillsID -> do + capID <- fromMaybeE maybeCap "No capability provided" + capability <- + case capID of + Left (capActor, _, capItem) -> return (capActor, capItem) + Right _ -> throwE "Capability is a remote URI, i.e. not authored by the local resource" + verifyCapability' + capability + authorIdMsig + (LocalActorGroup groupID) + AP.RoleAdmin + return fulfillsID + ) + + fulfills + + -- In collab mode, verify the Collab isn't already validated + maybeEnabled <- lift $ getBy $ UniqueCollabEnable collabID + verifyNothingE maybeEnabled "I already sent a Grant for this Invite/Join" + + maybeAcceptDB <- lift $ insertToInbox now authorIdMsig body (actorInbox recipActor) False + for maybeAcceptDB $ \ acceptDB -> do + + (grantID, enableID) <- do + + -- In collab mode, record the Accept and enable the Collab + case (collab, acceptDB) of + (Left (fulfillsID, Left recipID), Left (_, _, acceptID)) -> do + maybeAccept <- lift $ insertUnique $ CollabRecipLocalAccept recipID fulfillsID acceptID + unless (isNothing maybeAccept) $ + throwE "This Invite already has an Accept by recip" + (Left (fulfillsID, Right recipID), Right (_, _, acceptID)) -> do + maybeAccept <- lift $ insertUnique $ CollabRecipRemoteAccept recipID fulfillsID acceptID + unless (isJust maybeAccept) $ + throwE "This Invite already has an Accept by recip" + (Right fulfillsID, Left (_, _, acceptID)) -> do + maybeAccept <- lift $ insertUnique $ CollabApproverLocal fulfillsID acceptID + unless (isJust maybeAccept) $ + throwE "This Join already has an Accept" + (Right fulfillsID, Right (author, _, acceptID)) -> do + maybeAccept <- lift $ insertUnique $ CollabApproverRemote fulfillsID (remoteAuthorId author) acceptID + unless (isJust maybeAccept) $ + throwE "This Join already has an Accept" + _ -> error "groupAccept impossible" + grantID <- lift $ insertEmptyOutboxItem' (actorOutbox recipActor) now + enableID <- lift $ insert $ CollabEnable collabID grantID + return (grantID, enableID) + + -- Prepare forwarding of Accept to my followers + let recipByID = LocalActorGroup groupID + recipByHash <- hashLocalActor recipByID + let sieve = makeRecipientSet [] [localActorFollowers recipByHash] + + maybeGrant <- lift $ do + + -- In collab mode, prepare a regular Grant + let isInvite = isLeft collab + grant@(actionGrant, _, _, _) <- do + Collab role <- getJust collabID + prepareCollabGrant isInvite inviterOrJoiner role + let recipByKey = LocalActorGroup groupID + _luGrant <- updateOutboxItem' recipByKey grantID actionGrant + return $ Just (grantID, grant) + + return (recipActorID, sieve, maybeGrant) + + case maybeNew of + Nothing -> done "I already have this activity in my inbox" + Just (recipActorID, sieve, maybeGrant) -> do + let recipByID = LocalActorGroup groupID + forwardActivity authorIdMsig body recipByID recipActorID sieve + lift $ for_ maybeGrant $ \ (grantID, (actionGrant, localRecipsGrant, remoteRecipsGrant, fwdHostsGrant)) -> + sendActivity + recipByID recipActorID localRecipsGrant + remoteRecipsGrant fwdHostsGrant grantID actionGrant + done "Forwarded the Accept and maybe published a Grant" + + where + + verifyCollabTopic collabID = do + topic <- lift $ getCollabTopic collabID + unless (LocalActorGroup groupID == topic) $ + throwE "Accept object is an Invite/Join for some other resource" + + verifyInviteCollabTopic fulfillsID = do + collabID <- lift $ collabFulfillsInviteCollab <$> getJust fulfillsID + verifyCollabTopic collabID + return collabID + + verifyJoinCollabTopic fulfillsID = do + collabID <- lift $ collabFulfillsJoinCollab <$> getJust fulfillsID + verifyCollabTopic collabID + return collabID + + tryInviteCollab (Left (actorByKey, _actorEntity, itemID)) = do + fulfillsID <- + lift $ collabInviterLocalCollab <$> + MaybeT (getValBy $ UniqueCollabInviterLocalInvite itemID) + collabID <- + ExceptT $ lift $ runExceptT $ verifyInviteCollabTopic fulfillsID + return (collabID, Left fulfillsID, Left actorByKey) + tryInviteCollab (Right remoteActivityID) = do + CollabInviterRemote fulfillsID actorID _ <- + lift $ MaybeT $ getValBy $ + UniqueCollabInviterRemoteInvite remoteActivityID + collabID <- + ExceptT $ lift $ runExceptT $ verifyInviteCollabTopic fulfillsID + sender <- lift $ lift $ do + actor <- getJust actorID + (,remoteActorFollowers actor) <$> getRemoteActorURI actor + return (collabID, Left fulfillsID, Right sender) + + tryJoinCollab (Left (actorByKey, _actorEntity, itemID)) = do + fulfillsID <- + lift $ collabRecipLocalJoinFulfills <$> + MaybeT (getValBy $ UniqueCollabRecipLocalJoinJoin itemID) + collabID <- + ExceptT $ lift $ runExceptT $ verifyJoinCollabTopic fulfillsID + return (collabID, Right fulfillsID, Left actorByKey) + tryJoinCollab (Right remoteActivityID) = do + CollabRecipRemoteJoin recipID fulfillsID _ <- + lift $ MaybeT $ getValBy $ + UniqueCollabRecipRemoteJoinJoin remoteActivityID + collabID <- + ExceptT $ lift $ runExceptT $ verifyJoinCollabTopic fulfillsID + joiner <- lift $ lift $ do + remoteActorID <- collabRecipRemoteActor <$> getJust recipID + actor <- getJust remoteActorID + (,remoteActorFollowers actor) <$> getRemoteActorURI actor + return (collabID, Right fulfillsID, Right joiner) + + prepareCollabGrant isInvite sender role = do + encodeRouteHome <- getEncodeRouteHome + encodeRouteLocal <- getEncodeRouteLocal + + audAccepter <- makeAudSenderWithFollowers authorIdMsig + audApprover <- lift $ makeAudSenderOnly authorIdMsig + recipHash <- encodeKeyHashid groupID + let topicByHash = LocalActorGroup recipHash + + senderHash <- bitraverse hashLocalActor pure sender + + uAccepter <- lift $ getActorURI authorIdMsig + + let audience = + if isInvite + then + let audInviter = + case senderHash of + Left actor -> AudLocal [actor] [] + Right (ObjURI h lu, _followers) -> + AudRemote h [lu] [] + audTopic = AudLocal [] [localActorFollowers topicByHash] + in [audInviter, audAccepter, audTopic] + else + let audJoiner = + case senderHash of + Left actor -> AudLocal [actor] [localActorFollowers actor] + Right (ObjURI h lu, followers) -> + AudRemote h [lu] (maybeToList followers) + audTopic = AudLocal [] [localActorFollowers topicByHash] + in [audJoiner, audApprover, audTopic] + + (recipientSet, remoteActors, fwdHosts, audLocal, audRemote) = + collectAudience audience + + recips = map encodeRouteHome audLocal ++ audRemote + action = AP.Action + { AP.actionCapability = Nothing + , AP.actionSummary = Nothing + , AP.actionAudience = AP.Audience recips [] [] [] [] [] + , AP.actionFulfills = [AP.acceptObject accept] + , AP.actionSpecific = AP.GrantActivity AP.Grant + { AP.grantObject = AP.RXRole role + , AP.grantContext = + encodeRouteHome $ renderLocalActor topicByHash + , AP.grantTarget = + if isInvite + then uAccepter + else case senderHash of + Left actor -> + encodeRouteHome $ renderLocalActor actor + Right (ObjURI h lu, _) -> ObjURI h lu + , AP.grantResult = Nothing + , AP.grantStart = Just now + , AP.grantEnd = Nothing + , AP.grantAllows = AP.Invoke + , AP.grantDelegates = Nothing + } + } + + return (action, recipientSet, remoteActors, fwdHosts) + -- Meaning: Someone has created a group with my ID URI -- Behavior: -- * Verify I'm in a just-been-created state @@ -143,6 +429,426 @@ groupFollow now recipGroupID verse follow = do (\ _ -> pure []) now recipGroupID verse follow +-- Meaning: An actor is granting access-to-some-resource to another actor +-- Behavior: +-- * Option 1 - Collaborator sending me a delegator-Grant - Verify that: +-- * The sender is a collaborator of mine, A +-- * The Grant's context is A +-- * The Grant's target is me +-- * The Grant's usage is invoke & role is delegate +-- * The Grant doesn't specify 'delegates' +-- * The activity is authorized via a valid direct-Grant I had sent +-- to A +-- * Verify I don't yet have a delegator-Grant from A +-- * Insert the Grant to my inbox +-- * Record the delegator-Grant in the Collab record in DB +-- * Forward the Grant to my followers +-- +-- * If not 1, raise an error +groupGrant + :: UTCTime + -> GroupId + -> Verse + -> AP.Grant URIMode + -> ActE (Text, Act (), Next) +groupGrant now groupID (Verse authorIdMsig body) grant = do + + -- Check capability + capability <- do + + -- Verify that a capability is provided + uCap <- do + let muCap = AP.activityCapability $ actbActivity body + fromMaybeE muCap "No capability provided" + + -- Verify the capability URI is one of: + -- * Outbox item URI of a local actor, i.e. a local activity + -- * A remote URI + cap <- nameExceptT "Invite capability" $ parseActivityURI' uCap + + -- Verify the capability is local + case cap of + Left (actorByKey, _, outboxItemID) -> + return (actorByKey, outboxItemID) + _ -> throwE "Capability is remote i.e. definitely not by me" + + -- Check grant + collab <- checkDelegator grant + + handleCollab capability collab + + where + + checkDelegator g = do + (role, resource, recipient, _mresult, mstart, mend, usage, mdeleg) <- + parseGrant' g + case role of + AP.RXRole _ -> throwE "Role isn't delegator" + AP.RXDelegator -> pure () + collab <- + bitraverse + (\case + LocalActorPerson p -> pure p + _ -> throwE "Local resource isn't a Person, therefore not a collaborator of mine" + ) + pure + resource + case (collab, authorIdMsig) of + (Left c, Left (a, _, _)) | LocalActorPerson c == a -> pure () + (Right u, Right (ra, _, _)) | remoteAuthorURI ra == u -> pure () + _ -> throwE "Author and context aren't the same actor" + case recipient of + Left (LocalActorGroup g) | g == groupID -> pure () + _ -> throwE "Target isn't me" + for_ mstart $ \ start -> + unless (start < now) $ throwE "Start time is in the future" + for_ mend $ \ _ -> + throwE "End time is specified" + unless (usage == AP.Invoke) $ + throwE "Usage isn't Invoke" + for_ mdeleg $ \ _ -> + throwE "'delegates' is specified" + return collab + + handleCollab capability collab = do + + maybeNew <- withDBExcept $ do + + -- Grab me from DB + (recipActorID, recipActor) <- lift $ do + recip <- getJust groupID + let actorID = groupActor recip + (actorID,) <$> getJust actorID + + -- Find the Collab record from the capability + Entity enableID (CollabEnable collabID _) <- do + unless (fst capability == LocalActorGroup groupID) $ + throwE "Capability isn't mine" + m <- lift $ getBy $ UniqueCollabEnableGrant $ snd capability + fromMaybeE m "I don't have a Collab with this capability" + Collab role <- lift $ getJust collabID + topic <- lift $ getCollabTopic collabID + unless (topic == LocalActorGroup groupID) $ + throwE "Found a Collab for this direct-Grant but it's not mine" + recip <- lift $ getCollabRecip collabID + recipForCheck <- + lift $ + bitraverse + (pure . collabRecipLocalPerson . entityVal) + (getRemoteActorURI <=< getJust . collabRecipRemoteActor . entityVal) + recip + unless (recipForCheck == collab) $ + throwE "Capability's collaborator and Grant author aren't the same actor" + + -- Verify I don't yet have a delegator-Grant from the collaborator + maybeDeleg <- + lift $ case bimap entityKey entityKey recip of + Left localID -> (() <$) <$> getBy (UniqueCollabDelegLocalRecip localID) + Right remoteID -> (() <$) <$> getBy (UniqueCollabDelegRemoteRecip remoteID) + verifyNothingE maybeDeleg "I already have a delegator-Grant from this collaborator" + + maybeGrantDB <- lift $ insertToInbox now authorIdMsig body (actorInbox recipActor) False + for maybeGrantDB $ \ grantDB -> do + + -- Record the delegator-Grant in the Collab record + lift $ case (grantDB, bimap entityKey entityKey recip) of + (Left (grantActor, _, grantID), Left localID) -> + insert_ $ CollabDelegLocal enableID localID grantID + (Right (_, _, grantID), Right remoteID) -> + insert_ $ CollabDelegRemote enableID remoteID grantID + _ -> error "groupGrant impossible 2" + + -- Prepare forwarding of Accept to my followers + groupHash <- encodeKeyHashid groupID + let sieve = makeRecipientSet [] [LocalStageGroupFollowers groupHash] + + -- For each parent group of mine, prepare a + -- delegation-extension Grant + extensions <- lift $ pure [] + + return (recipActorID, sieve, extensions) + + case maybeNew of + Nothing -> done "I already have this activity in my inbox" + Just (recipActorID, sieve, extensions) -> do + let recipByID = LocalActorGroup groupID + forwardActivity authorIdMsig body recipByID recipActorID sieve + lift $ for_ extensions $ + \ (extID, (actionExt, localRecipsExt, remoteRecipsExt, fwdHostsExt)) -> + sendActivity + recipByID recipActorID localRecipsExt + remoteRecipsExt fwdHostsExt extID actionExt + done "Forwarded the delegator-Grant, updated DB" + +-- Meaning: An actor A invited actor B to a resource +-- Behavior: +-- * Verify the resource is my collabs list +-- * If resource is collabs and B is local, verify it's a Person +-- * Verify A isn't inviting themselves +-- * Verify A is authorized by me to invite collabs to me +-- +-- * Verify B doesn't already have an invite/join/grant for me +-- +-- * Insert the Invite to my inbox +-- +-- * Insert a Collab record to DB +-- +-- * Forward the Invite to my followers +-- * Send Accept to A, B, my-followers +groupInvite + :: UTCTime + -> GroupId + -> Verse + -> AP.Invite URIMode + -> ActE (Text, Act (), Next) +groupInvite now groupID (Verse authorIdMsig body) invite = do + + -- Check capability + capability <- do + + -- Verify that a capability is provided + uCap <- do + let muCap = AP.activityCapability $ actbActivity body + fromMaybeE muCap "No capability provided" + + -- Verify the capability URI is one of: + -- * Outbox item URI of a local actor, i.e. a local activity + -- * A remote URI + cap <- nameExceptT "Invite capability" $ parseActivityURI' uCap + + -- Verify the capability is local + case cap of + Left (actorByKey, _, outboxItemID) -> + return (actorByKey, outboxItemID) + _ -> throwE "Capability is remote i.e. definitely not by me" + + -- Check invite + (role, invited) <- do + let author = bimap (view _1) (remoteAuthorURI . view _1) authorIdMsig + (role, resourceOrComps, recipientOrComp) <- parseInvite author invite + mode <- + case resourceOrComps of + Left (Left (LocalActorGroup j)) | j == groupID -> + bitraverse + (\case + Left r -> pure r + Right _ -> throwE "Not accepting local component actors as collabs" + ) + pure + recipientOrComp + _ -> throwE "Invite topic isn't my collabs URI" + return (role, mode) + + -- If target is local, find it in our DB + -- If target is remote, HTTP GET it, verify it's an actor, and store in + -- our DB (if it's already there, no need for HTTP) + -- + -- NOTE: This is a blocking HTTP GET done right here in the Invite handler, + -- which is NOT a good idea. Ideally, it would be done async, and the + -- handler result (approve/disapprove the Invite) would be sent later in a + -- separate (e.g. Accept) activity. But for the PoC level, the current + -- situation will hopefully do. + invitedDB <- + bitraverse + (withDBExcept . flip getGrantRecip "Invitee not found in DB") + getRemoteActorFromURI + invited + + maybeNew <- withDBExcept $ do + + -- Grab me from DB + (topicActorID, topicActor) <- lift $ do + recip <- getJust groupID + let actorID = groupActor recip + (actorID,) <$> getJust actorID + + -- Verify the specified capability gives relevant access + verifyCapability' + capability authorIdMsig (LocalActorGroup groupID) AP.RoleAdmin + + -- Verify that target doesn't already have a Collab for me + existingCollabIDs <- lift $ getExistingCollabs invitedDB + case existingCollabIDs of + [] -> pure () + [_] -> throwE "I already have a Collab for the target" + _ -> error "Multiple collabs found for target" + + maybeInviteDB <- lift $ insertToInbox now authorIdMsig body (actorInbox topicActor) False + lift $ for maybeInviteDB $ \ inviteDB -> do + + -- Insert Collab or Component record to DB + acceptID <- insertEmptyOutboxItem' (actorOutbox topicActor) now + insertCollab role invitedDB inviteDB acceptID + + -- Prepare forwarding Invite to my followers + sieve <- do + groupHash <- encodeKeyHashid groupID + return $ makeRecipientSet [] [LocalStageGroupFollowers groupHash] + + -- Prepare an Accept activity and insert to my outbox + accept@(actionAccept, _, _, _) <- prepareAccept invitedDB + _luAccept <- updateOutboxItem' (LocalActorGroup groupID) acceptID actionAccept + + return (topicActorID, sieve, acceptID, accept) + + case maybeNew of + Nothing -> done "I already have this activity in my inbox" + Just (groupActorID, sieve, acceptID, (actionAccept, localRecipsAccept, remoteRecipsAccept, fwdHostsAccept)) -> do + forwardActivity + authorIdMsig body (LocalActorGroup groupID) groupActorID sieve + lift $ sendActivity + (LocalActorGroup groupID) groupActorID localRecipsAccept + remoteRecipsAccept fwdHostsAccept acceptID actionAccept + done "Recorded and forwarded the Invite, sent an Accept" + + where + + getRemoteActorFromURI (ObjURI h lu) = do + instanceID <- + lift $ withDB $ either entityKey id <$> insertBy' (Instance h) + result <- + ExceptT $ first (T.pack . displayException) <$> + fetchRemoteActor' instanceID h lu + case result of + Left Nothing -> throwE "Target @id mismatch" + Left (Just err) -> throwE $ T.pack $ displayException err + Right Nothing -> throwE "Target isn't an actor" + Right (Just actor) -> return $ entityKey actor + + getExistingCollabs (Left (GrantRecipPerson (Entity personID _))) = + E.select $ E.from $ \ (topic `E.InnerJoin` recipl) -> do + E.on $ + topic E.^. CollabTopicGroupCollab E.==. + recipl E.^. CollabRecipLocalCollab + E.where_ $ + topic E.^. CollabTopicGroupGroup E.==. E.val groupID E.&&. + recipl E.^. CollabRecipLocalPerson E.==. E.val personID + return $ recipl E.^. CollabRecipLocalCollab + getExistingCollabs (Right remoteActorID) = + E.select $ E.from $ \ (topic `E.InnerJoin` recipr) -> do + E.on $ + topic E.^. CollabTopicGroupCollab E.==. + recipr E.^. CollabRecipRemoteCollab + E.where_ $ + topic E.^. CollabTopicGroupGroup E.==. E.val groupID E.&&. + recipr E.^. CollabRecipRemoteActor E.==. E.val remoteActorID + return $ recipr E.^. CollabRecipRemoteCollab + + insertCollab role recipient inviteDB acceptID = do + collabID <- insert $ Collab role + fulfillsID <- insert $ CollabFulfillsInvite collabID acceptID + insert_ $ CollabTopicGroup collabID groupID + case inviteDB of + Left (_, _, inviteID) -> + insert_ $ CollabInviterLocal fulfillsID inviteID + Right (author, _, inviteID) -> do + let authorID = remoteAuthorId author + insert_ $ CollabInviterRemote fulfillsID authorID inviteID + case recipient of + Left (GrantRecipPerson (Entity personID _)) -> + insert_ $ CollabRecipLocal collabID personID + Right remoteActorID -> + insert_ $ CollabRecipRemote collabID remoteActorID + + prepareAccept invitedDB = do + encodeRouteHome <- getEncodeRouteHome + + audInviter <- lift $ makeAudSenderOnly authorIdMsig + audInvited <- + case invitedDB of + Left (GrantRecipPerson (Entity p _)) -> do + ph <- encodeKeyHashid p + return $ AudLocal [LocalActorPerson ph] [] + Right remoteActorID -> do + ra <- getJust remoteActorID + ObjURI h lu <- getRemoteActorURI ra + return $ AudRemote h [lu] [] + audTopic <- + AudLocal [] . pure . LocalStageGroupFollowers <$> + encodeKeyHashid groupID + uInvite <- lift $ getActivityURI authorIdMsig + + let (recipientSet, remoteActors, fwdHosts, audLocal, audRemote) = + collectAudience [audInviter, audInvited, audTopic] + + recips = map encodeRouteHome audLocal ++ audRemote + action = AP.Action + { AP.actionCapability = Nothing + , AP.actionSummary = Nothing + , AP.actionAudience = AP.Audience recips [] [] [] [] [] + , AP.actionFulfills = [uInvite] + , AP.actionSpecific = AP.AcceptActivity AP.Accept + { AP.acceptObject = uInvite + , AP.acceptResult = Nothing + } + } + + return (action, recipientSet, remoteActors, fwdHosts) + +-- Meaning: An actor A asked to join a resource +-- Behavior: +-- * Verify the resource is me +-- * Verify A doesn't already have an invite/join/grant for me +-- * Remember the join in DB +-- * Forward the Join to my followers +groupJoin + :: UTCTime + -> GroupId + -> Verse + -> AP.Join URIMode + -> ActE (Text, Act (), Next) +groupJoin = + topicJoin + groupActor LocalActorGroup + CollabTopicGroupGroup CollabTopicGroupCollab CollabTopicGroup + +-- Meaning: An actor rejected something +-- Behavior: +-- * If it's on an Invite where I'm the resource: +-- * Verify the Reject is by the Invite target +-- * Remove the relevant Collab record from DB +-- * Forward the Reject to my followers +-- * Send a Reject on the Invite: +-- * To: Rejecter (i.e. Invite target) +-- * CC: Invite sender, Rejecter's followers, my followers +-- * If it's on a Join where I'm the resource: +-- * Verify the Reject is authorized +-- * Remove the relevant Collab record from DB +-- * Forward the Reject to my followers +-- * Send a Reject: +-- * To: Join sender +-- * CC: Reject sender, Join sender's followers, my followers +-- * Otherwise respond with error +groupReject + :: UTCTime + -> GroupId + -> Verse + -> AP.Reject URIMode + -> ActE (Text, Act (), Next) +groupReject = topicReject groupActor LocalActorGroup + +-- Meaning: An actor A is removing actor B from a resource +-- Behavior: +-- * Verify the resource is me +-- * Verify A isn't removing themselves +-- * Verify A is authorized by me to remove actors from me +-- * Verify B already has a Grant for me +-- * Remove the whole Collab record from DB +-- * Forward the Remove to my followers +-- * Send a Revoke: +-- * To: Actor B +-- * CC: Actor A, B's followers, my followers +groupRemove + :: UTCTime + -> GroupId + -> Verse + -> AP.Remove URIMode + -> ActE (Text, Act (), Next) +groupRemove = + topicRemove + groupActor LocalActorGroup + CollabTopicGroupGroup CollabTopicGroupCollab + -- Meaning: An actor is undoing some previous action -- Behavior: -- * If they're undoing their Following of me: @@ -269,8 +975,14 @@ groupUndo now recipGroupID (Verse authorIdMsig body) (AP.Undo uObject) = do groupBehavior :: UTCTime -> GroupId -> VerseExt -> ActE (Text, Act (), Next) groupBehavior now groupID (Left verse@(Verse _authorIdMsig body)) = case AP.activitySpecific $ actbActivity body of + AP.AcceptActivity accept -> groupAccept now groupID verse accept AP.CreateActivity create -> groupCreate now groupID verse create AP.FollowActivity follow -> groupFollow now groupID verse follow + AP.GrantActivity grant -> groupGrant now groupID verse grant + AP.InviteActivity invite -> groupInvite now groupID verse invite + AP.JoinActivity join -> groupJoin now groupID verse join + AP.RejectActivity reject -> groupReject now groupID verse reject + AP.RemoveActivity remove -> groupRemove now groupID verse remove AP.UndoActivity undo -> groupUndo now groupID verse undo _ -> throwE "Unsupported activity type for Group" groupBehavior _ _ (Right _) = throwE "ClientMsgs aren't supported for Group" diff --git a/src/Vervis/Actor/Person.hs b/src/Vervis/Actor/Person.hs index 5f4f1b5..a8ec28a 100644 --- a/src/Vervis/Actor/Person.hs +++ b/src/Vervis/Actor/Person.hs @@ -844,7 +844,7 @@ personGrant now recipPersonID (Verse authorIdMsig body) grant = do (role, resource, recip, _mresult, mstart, mend, usage, mdeleg) <- parseGrant' grant case (recip, authorIdMsig) of - (Left (GrantRecipPerson' p), Left (LocalActorPerson p', _, _)) + (Left (LocalActorPerson p), Left (LocalActorPerson p', _, _)) | p == p' -> throwE "Grant sender and target are the same local Person" (Right uRecip, Right (author, _, _)) @@ -864,7 +864,7 @@ personGrant now recipPersonID (Verse authorIdMsig body) grant = do -- For an extension-Grant, use 'capability' for that runMaybeT $ do guard $ usage == AP.Invoke - guard $ recip == Left (GrantRecipPerson' recipPersonID) + guard $ recip == Left (LocalActorPerson recipPersonID) lift $ do for_ mstart $ \ start -> unless (start <= now) $ diff --git a/src/Vervis/Actor/Project.hs b/src/Vervis/Actor/Project.hs index 8248c3f..a80bdd8 100644 --- a/src/Vervis/Actor/Project.hs +++ b/src/Vervis/Actor/Project.hs @@ -978,7 +978,7 @@ projectGrant now projectID (Verse authorIdMsig body) grant = do (Right u, Right (ra, _, _)) | remoteAuthorURI ra == u -> pure () _ -> throwE "Author and context aren't the same actor" case recipient of - Left (GrantRecipProject' j) | j == projectID -> pure () + Left (LocalActorProject j) | j == projectID -> pure () _ -> throwE "Target isn't me" for_ mstart $ \ start -> unless (start < now) $ throwE "Start time is in the future" @@ -1009,7 +1009,7 @@ projectGrant now projectID (Verse authorIdMsig body) grant = do (Right u, Right (ra, _, _)) | remoteAuthorURI ra == u -> pure () _ -> throwE "Author and context aren't the same actor" case recipient of - Left (GrantRecipProject' j) | j == projectID -> pure () + Left (LocalActorProject j) | j == projectID -> pure () _ -> throwE "Target isn't me" for_ mstart $ \ start -> unless (start < now) $ throwE "Start time is in the future" diff --git a/src/Vervis/Data/Collab.hs b/src/Vervis/Data/Collab.hs index ed315b6..4d094d9 100644 --- a/src/Vervis/Data/Collab.hs +++ b/src/Vervis/Data/Collab.hs @@ -39,9 +39,6 @@ module Vervis.Data.Collab , unhashComponentE , componentActor , actorToComponent - - , GrantRecipBy' (..) - , hashGrantRecip' ) where @@ -301,7 +298,7 @@ parseGrant' -> ActE ( AP.RoleExt , Either (LocalActorBy Key) FedURI - , Either (GrantRecipBy' Key) FedURI + , Either (LocalActorBy Key) FedURI , Maybe (LocalURI, Maybe Int) , Maybe UTCTime , Maybe UTCTime @@ -333,7 +330,7 @@ parseGrant' (AP.Grant object context target mresult mstart mend allows deleg) = "Grant context isn't a valid route" parseLocalActorE' route else pure $ Right u - parseTarget u@(ObjURI h lu) = do + parseTarget u@(ObjURI h lu) = nameExceptT "Grant target" $ do hl <- hostIsLocal h if hl then Left <$> do @@ -341,13 +338,7 @@ parseGrant' (AP.Grant object context target mresult mstart mend allows deleg) = fromMaybeE (decodeRouteLocal lu) "Grant target isn't a valid route" - recipHash <- - fromMaybeE - (parseGrantRecip' route) - "Grant target isn't a grant recipient route" - unhashGrantRecipE' - recipHash - "Grant target contains invalid hashid" + parseLocalActorE' route else pure $ Right u parseAccept (AP.Accept object mresult) = do @@ -471,38 +462,3 @@ actorToComponent = \case LocalActorLoom k -> Just $ ComponentLoom k LocalActorProject _ -> Nothing LocalActorGroup _ -> Nothing - -data GrantRecipBy' f - = GrantRecipPerson' (f Person) - | GrantRecipProject' (f Project) - | GrantRecipComponent' (ComponentBy f) - deriving (Generic, FunctorB, TraversableB, ConstraintsB) - -deriving instance AllBF Eq f GrantRecipBy' => Eq (GrantRecipBy' f) - -parseGrantRecip' (PersonR p) = Just $ GrantRecipPerson' p -parseGrantRecip' (ProjectR j) = Just $ GrantRecipProject' j -parseGrantRecip' r = GrantRecipComponent' <$> parseComponent r - -hashGrantRecip' (GrantRecipPerson' k) = - GrantRecipPerson' <$> WAP.encodeKeyHashid k -hashGrantRecip' (GrantRecipProject' k) = - GrantRecipProject' <$> WAP.encodeKeyHashid k -hashGrantRecip' (GrantRecipComponent' byk) = - GrantRecipComponent' <$> hashComponent byk - -unhashGrantRecipPure' ctx = f - where - f (GrantRecipPerson' p) = - GrantRecipPerson' <$> decodeKeyHashidPure ctx p - f (GrantRecipProject' p) = - GrantRecipProject' <$> decodeKeyHashidPure ctx p - f (GrantRecipComponent' c) = - GrantRecipComponent' <$> unhashComponentPure ctx c - -unhashGrantRecip' resource = do - ctx <- asksEnv WAP.stageHashidsContext - return $ unhashGrantRecipPure' ctx resource - -unhashGrantRecipE' resource e = - ExceptT $ maybe (Left e) Right <$> unhashGrantRecip' resource From 5af2fdd58bfb4c0ef0ea08862b9777ad63da180a Mon Sep 17 00:00:00 2001 From: Pere Lev Date: Sat, 9 Dec 2023 03:03:06 +0200 Subject: [PATCH 07/14] UI: Group: Buttons for adding and removing members --- src/Vervis/Form/Tracker.hs | 34 ++++++++++++ src/Vervis/Foundation.hs | 4 +- src/Vervis/Handler/Group.hs | 92 +++++++++++++++++++++++++++++++ templates/group/member/new.hamlet | 4 +- templates/group/members.hamlet | 4 +- th/routes | 2 + 6 files changed, 135 insertions(+), 5 deletions(-) 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 -------------------------------------------------------------------- From 119779b9b30650f24756fa9d7c7a29b69da05f3d Mon Sep 17 00:00:00 2001 From: Pere Lev Date: Sat, 9 Dec 2023 07:13:34 +0200 Subject: [PATCH 08/14] UI: Display personal resources using Permit records --- src/Vervis/Actor.hs | 11 +++ src/Vervis/Handler/Client.hs | 139 +++++++++++++++++------------ src/Vervis/Persist/Collab.hs | 44 +++++---- src/Vervis/Widget/Person.hs | 15 +++- src/Vervis/Widget/Tracker.hs | 70 +++++++++++++++ templates/personal-overview.hamlet | 47 ++++------ 6 files changed, 219 insertions(+), 107 deletions(-) diff --git a/src/Vervis/Actor.hs b/src/Vervis/Actor.hs index 04c4921..22b1f72 100644 --- a/src/Vervis/Actor.hs +++ b/src/Vervis/Actor.hs @@ -80,6 +80,8 @@ module Vervis.Actor , sendToLocalActors , actorIsAddressed + + , localActorType ) where @@ -714,3 +716,12 @@ actorIsAddressed recips = isJust . verify verify (LocalActorProject j) = do routes <- lookup j $ recipProjects recips guard $ routeProject routes + +localActorType :: LocalActorBy f -> AP.ActorType +localActorType = \case + LocalActorPerson _ -> AP.ActorTypePerson + LocalActorRepo _ -> AP.ActorTypeRepo + LocalActorDeck _ -> AP.ActorTypeTicketTracker + LocalActorLoom _ -> AP.ActorTypePatchTracker + LocalActorProject _ -> AP.ActorTypeProject + LocalActorGroup _ -> AP.ActorTypeTeam diff --git a/src/Vervis/Handler/Client.hs b/src/Vervis/Handler/Client.hs index 4bf69bd..c017650 100644 --- a/src/Vervis/Handler/Client.hs +++ b/src/Vervis/Handler/Client.hs @@ -53,12 +53,14 @@ import Control.Monad import Control.Monad.Trans.Except import Data.Bifunctor import Data.Bitraversable +import Data.Function import Data.List import Data.Text (Text) import Data.Time.Clock import Data.Traversable import Database.Persist import Text.Blaze.Html (preEscapedToHtml) +import Optics.Core import Yesod.Auth import Yesod.Auth.Account import Yesod.Auth.Account.Message @@ -89,6 +91,7 @@ import Data.EventTime.Local import Database.Persist.Local import Yesod.Form.Local +import Vervis.Actor import Vervis.API import Vervis.Client import Vervis.Data.Actor @@ -98,6 +101,7 @@ import Vervis.Form.Ticket import Vervis.Foundation import Vervis.Model import Vervis.Model.Ident +import Vervis.Persist.Actor import Vervis.Persist.Collab import Vervis.Recipient import Vervis.Settings @@ -130,64 +134,87 @@ getHomeR = do where personalOverview :: Entity Person -> Handler Html personalOverview (Entity pid _person) = do - (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 - E.on $ topic E.^. CollabTopicRepoCollab E.==. enable E.^. CollabEnableCollab - E.on $ recip E.^. CollabRecipLocalCollab E.==. topic E.^. CollabTopicRepoCollab - E.on $ recip E.^. CollabRecipLocalCollab E.==. collab E.^. CollabId - E.where_ $ recip E.^. CollabRecipLocalPerson E.==. E.val pid - E.orderBy [E.asc $ repo E.^. RepoId] - return (repo, actor, collab) - ) - <*> (E.select $ E.from $ \ (recip `E.InnerJoin` collab `E.InnerJoin` topic `E.InnerJoin` enable `E.InnerJoin` deck `E.InnerJoin` actor) -> do - E.on $ deck E.^. DeckActor E.==. actor E.^. ActorId - E.on $ topic E.^. CollabTopicDeckDeck E.==. deck E.^. DeckId - E.on $ topic E.^. CollabTopicDeckCollab E.==. enable E.^. CollabEnableCollab - E.on $ recip E.^. CollabRecipLocalCollab E.==. topic E.^. CollabTopicDeckCollab - E.on $ recip E.^. CollabRecipLocalCollab E.==. collab E.^. CollabId - E.where_ $ recip E.^. CollabRecipLocalPerson E.==. E.val pid - E.orderBy [E.asc $ deck E.^. DeckId] - return (deck, actor, collab) - ) - <*> (E.select $ E.from $ \ (recip `E.InnerJoin` collab `E.InnerJoin` topic `E.InnerJoin` enable `E.InnerJoin` loom `E.InnerJoin` actor) -> do - E.on $ loom E.^. LoomActor E.==. actor E.^. ActorId - E.on $ topic E.^. CollabTopicLoomLoom E.==. loom E.^. LoomId - E.on $ topic E.^. CollabTopicLoomCollab E.==. enable E.^. CollabEnableCollab - E.on $ recip E.^. CollabRecipLocalCollab E.==. topic E.^. CollabTopicLoomCollab - E.on $ recip E.^. CollabRecipLocalCollab E.==. collab E.^. CollabId - E.where_ $ recip E.^. CollabRecipLocalPerson E.==. E.val pid - E.orderBy [E.asc $ loom E.^. LoomId] - return (loom, actor, collab) - ) - <*> (E.select $ E.from $ \ (recip `E.InnerJoin` collab `E.InnerJoin` topic `E.InnerJoin` enable `E.InnerJoin` project `E.InnerJoin` actor) -> do - E.on $ project E.^. ProjectActor E.==. actor E.^. ActorId - E.on $ topic E.^. CollabTopicProjectProject E.==. project E.^. ProjectId - E.on $ topic E.^. CollabTopicProjectCollab E.==. enable E.^. CollabEnableCollab - E.on $ recip E.^. CollabRecipLocalCollab E.==. topic E.^. CollabTopicProjectCollab - E.on $ recip E.^. CollabRecipLocalCollab E.==. collab E.^. CollabId - E.where_ $ recip E.^. CollabRecipLocalPerson E.==. E.val pid - 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 + permits <- runDB $ do + locals <- do + ls <- E.select $ E.from $ \ (permit `E.InnerJoin` topic `E.InnerJoin` enable) -> do + E.on $ topic E.^. PermitTopicLocalId E.==. enable E.^. PermitTopicEnableLocalTopic + E.on $ permit E.^. PermitId E.==. topic E.^. PermitTopicLocalPermit + E.where_ $ permit E.^. PermitPerson E.==. E.val pid + E.orderBy [E.asc $ enable E.^. PermitTopicEnableLocalId] + return + ( permit E.^. PermitId + , permit E.^. PermitRole + , topic E.^. PermitTopicLocalId + ) + for ls $ \ (E.Value permitID, E.Value role, E.Value topicID) -> do + topic <- getPermitTopicLocal topicID + actorID <- do + ma <- getLocalActorEntity topic + case ma of + Nothing -> error "Impossible, we should have found the local actor in DB" + Just a -> pure $ localActorID a + actor <- getJust actorID + return + ( permitID + , role + , localActorType topic + , Left (topic, actor) + ) + remotes <- do + rs <- E.select $ E.from $ \ (permit `E.InnerJoin` topic `E.InnerJoin` enable) -> do + E.on $ topic E.^. PermitTopicRemoteId E.==. enable E.^. PermitTopicEnableRemoteTopic + E.on $ permit E.^. PermitId E.==. topic E.^. PermitTopicRemotePermit + E.where_ $ permit E.^. PermitPerson E.==. E.val pid + E.orderBy [E.asc $ enable E.^. PermitTopicEnableRemoteId] + return + ( permit E.^. PermitId + , permit E.^. PermitRole + , topic E.^. PermitTopicRemoteActor + ) + for rs $ \ (E.Value permitID, E.Value role, E.Value remoteActorID) -> do + remoteActor <- getJust remoteActorID + remoteObject <- getJust $ remoteActorIdent remoteActor + inztance <- getJust $ remoteObjectInstance remoteObject + return + ( permitID + , role + , remoteActorType remoteActor + , Right (inztance, remoteObject, remoteActor) + ) + return $ locals ++ remotes + let (people, repos, decks, looms, projects, groups, others) = + partitionByActorType (view _3) (view _1) permits + if null people + then pure () + else error "Bug: Person as a PermitTopic" defaultLayout $(widgetFile "personal-overview") + where + + partitionByActorType + :: Eq b + => (a -> AP.ActorType) + -> (a -> b) + -> [a] + -> ([a], [a], [a], [a], [a], [a], [a]) + partitionByActorType typ key xs = + let p = filter ((== AP.ActorTypePerson) . typ) xs + r = filter ((== AP.ActorTypeRepo) . typ) xs + d = filter ((== AP.ActorTypeTicketTracker) . typ) xs + l = filter ((== AP.ActorTypePatchTracker) . typ) xs + j = filter ((== AP.ActorTypeProject) . typ) xs + g = filter ((== AP.ActorTypeTeam) . typ) xs + x = deleteFirstsBy ((==) `on` key) xs (p ++ r ++ d ++ l ++ j ++ g) + in (p, r, d, l, j, g, x) + + item (_permitID, role, _typ, actor) = + [whamlet| + [ + #{show role} + ] + ^{actorLinkFedW actor} + |] + getBrowseR :: Handler Html getBrowseR = do (people, groups, repos, decks, looms, projects) <- runDB $ diff --git a/src/Vervis/Persist/Collab.hs b/src/Vervis/Persist/Collab.hs index 4caaef5..aeb816b 100644 --- a/src/Vervis/Persist/Collab.hs +++ b/src/Vervis/Persist/Collab.hs @@ -17,6 +17,7 @@ module Vervis.Persist.Collab ( getCollabTopic , getCollabTopic' , getCollabRecip + , getPermitTopicLocal , getPermitTopic , getStemIdent , getStemProject @@ -112,6 +113,29 @@ getCollabRecip collabID = "Collab without recip" "Collab with both local and remote recip" +getPermitTopicLocal + :: MonadIO m + => PermitTopicLocalId + -> ReaderT SqlBackend m (LocalActorBy Key) +getPermitTopicLocal localID = do + options <- + sequence + [ fmap (LocalActorRepo . permitTopicRepoRepo) <$> + getValBy (UniquePermitTopicRepo localID) + , fmap (LocalActorDeck . permitTopicDeckDeck) <$> + getValBy (UniquePermitTopicDeck localID) + , fmap (LocalActorLoom . permitTopicLoomLoom) <$> + getValBy (UniquePermitTopicLoom localID) + , fmap (LocalActorProject . permitTopicProjectProject) <$> + getValBy (UniquePermitTopicProject localID) + , fmap (LocalActorGroup . permitTopicGroupGroup) <$> + getValBy (UniquePermitTopicGroup localID) + ] + exactlyOneJust + options + "Found Permit without topic" + "Found Permit with multiple topics" + getPermitTopic :: MonadIO m => PermitId @@ -128,25 +152,7 @@ getPermitTopic permitID = do "Permit without topic" "Permit with both local and remote topic" bitraverse - (\ localID -> (localID,) <$> do - options <- - sequence - [ fmap (LocalActorRepo . permitTopicRepoRepo) <$> - getValBy (UniquePermitTopicRepo localID) - , fmap (LocalActorDeck . permitTopicDeckDeck) <$> - getValBy (UniquePermitTopicDeck localID) - , fmap (LocalActorLoom . permitTopicLoomLoom) <$> - getValBy (UniquePermitTopicLoom localID) - , fmap (LocalActorProject . permitTopicProjectProject) <$> - getValBy (UniquePermitTopicProject localID) - , fmap (LocalActorGroup . permitTopicGroupGroup) <$> - getValBy (UniquePermitTopicGroup localID) - ] - exactlyOneJust - options - "Found Permit without topic" - "Found Permit with multiple topics" - ) + (\ localID -> (localID,) <$> getPermitTopicLocal localID) (\ (Entity topicID (PermitTopicRemote _ actorID)) -> return (topicID, actorID) ) diff --git a/src/Vervis/Widget/Person.hs b/src/Vervis/Widget/Person.hs index 862fc76..9231148 100644 --- a/src/Vervis/Widget/Person.hs +++ b/src/Vervis/Widget/Person.hs @@ -1,6 +1,6 @@ {- This file is part of Vervis. - - - Written in 2016, 2019, 2022 by fr33domlover . + - Written in 2016, 2019, 2022, 2023 by fr33domlover . - - ♡ Copying is an act of love. Please copy, reuse and share. - @@ -31,6 +31,8 @@ import Network.FedURI import Yesod.Auth.Unverified import Yesod.Hashids +import qualified Web.ActivityPub as AP + import Database.Persist.Local import Vervis.Foundation @@ -54,13 +56,22 @@ personLinkFedW (Left (ep, a)) = personLinkW ep a personLinkFedW (Right (inztance, object, actor)) = [whamlet| + #{marker $ remoteActorType actor} # $maybe name <- remoteActorName actor - #{name} + #{name} @ #{renderAuthority $ instanceHost inztance} $nothing #{renderAuthority $ instanceHost inztance}#{localUriPath $ remoteObjectIdent object} |] where uActor = ObjURI (instanceHost inztance) (remoteObjectIdent object) + marker = \case + AP.ActorTypePerson -> '~' + AP.ActorTypeRepo -> '^' + AP.ActorTypeTicketTracker -> '=' + AP.ActorTypePatchTracker -> '+' + AP.ActorTypeProject -> '$' + AP.ActorTypeTeam -> '&' + AP.ActorTypeOther _ -> '?' followW :: Route App -> Route App -> FollowerSetId -> Widget followW followRoute unfollowRoute fsid = do diff --git a/src/Vervis/Widget/Tracker.hs b/src/Vervis/Widget/Tracker.hs index 17edc8e..2ae7e59 100644 --- a/src/Vervis/Widget/Tracker.hs +++ b/src/Vervis/Widget/Tracker.hs @@ -19,19 +19,26 @@ module Vervis.Widget.Tracker , projectNavW , componentLinkFedW , projectLinkFedW + , actorLinkFedW , groupNavW ) where +import Database.Persist import Database.Persist.Types import Yesod.Core.Widget +import Yesod.Persist.Core import Network.FedURI import Yesod.Hashids +import qualified Web.ActivityPub as AP + +import Vervis.Actor import Vervis.Data.Collab import Vervis.Foundation import Vervis.Model +import Vervis.Model.Ident import Vervis.Settings deckNavW :: Entity Deck -> Actor -> Widget @@ -110,3 +117,66 @@ projectLinkFedW (Right (inztance, object, actor)) = |] where uActor = ObjURI (instanceHost inztance) (remoteObjectIdent object) + +actorLinkW :: LocalActorBy Key -> Actor -> Widget +actorLinkW (LocalActorPerson k) actor = do + p <- handlerToWidget $ runDB $ getJust k + h <- encodeKeyHashid k + [whamlet| + + ~#{username2text $ personUsername p} #{actorName actor} + |] +actorLinkW (LocalActorRepo k) actor = do + h <- encodeKeyHashid k + [whamlet| + + ^#{keyHashidText h} #{actorName actor} + |] +actorLinkW (LocalActorDeck k) actor = do + h <- encodeKeyHashid k + [whamlet| + + =#{keyHashidText h} #{actorName actor} + |] +actorLinkW (LocalActorLoom k) actor = do + h <- encodeKeyHashid k + [whamlet| + + +#{keyHashidText h} #{actorName actor} + |] +actorLinkW (LocalActorProject k) actor = do + h <- encodeKeyHashid k + [whamlet| + + \$#{keyHashidText h} #{actorName actor} + |] +actorLinkW (LocalActorGroup k) actor = do + h <- encodeKeyHashid k + [whamlet| + + &#{keyHashidText h} #{actorName actor} + |] + +actorLinkFedW + :: Either (LocalActorBy Key, Actor) (Instance, RemoteObject, RemoteActor) + -> Widget +actorLinkFedW (Left (c, a)) = actorLinkW c a +actorLinkFedW (Right (inztance, object, actor)) = + [whamlet| + + #{marker $ remoteActorType actor} # + $maybe name <- remoteActorName actor + #{name} @ #{renderAuthority $ instanceHost inztance} + $nothing + #{renderAuthority $ instanceHost inztance}#{localUriPath $ remoteObjectIdent object} + |] + where + uActor = ObjURI (instanceHost inztance) (remoteObjectIdent object) + marker = \case + AP.ActorTypePerson -> '~' + AP.ActorTypeRepo -> '^' + AP.ActorTypeTicketTracker -> '=' + AP.ActorTypePatchTracker -> '+' + AP.ActorTypeProject -> '$' + AP.ActorTypeTeam -> '&' + AP.ActorTypeOther _ -> '?' diff --git a/templates/personal-overview.hamlet b/templates/personal-overview.hamlet index dd4b9dd..7cbc5fb 100644 --- a/templates/personal-overview.hamlet +++ b/templates/personal-overview.hamlet @@ -67,54 +67,41 @@ $# Comment on a ticket or merge request

Your teams