From 8d543c001618ae507af485b1d5e3a8c854bcc612 Mon Sep 17 00:00:00 2001 From: Pere Lev Date: Tue, 21 Nov 2023 16:52:16 +0200 Subject: [PATCH] S2S: Group: Implement Create handler, sending back an admin-Grant --- migrations/551_2023-11-21_group_collab.model | 5 ++ src/Vervis/API.hs | 3 + src/Vervis/Actor/Group.hs | 70 +++++++++++++++++++- src/Vervis/Actor/Person/Client.hs | 5 ++ src/Vervis/Client.hs | 4 ++ src/Vervis/Data/Collab.hs | 16 ++++- src/Vervis/Migration/Entities.hs | 4 ++ src/Vervis/Persist/Collab.hs | 33 +++------ th/models | 6 ++ 9 files changed, 120 insertions(+), 26 deletions(-) create mode 100644 migrations/551_2023-11-21_group_collab.model diff --git a/migrations/551_2023-11-21_group_collab.model b/migrations/551_2023-11-21_group_collab.model new file mode 100644 index 0000000..b0c77d0 --- /dev/null +++ b/migrations/551_2023-11-21_group_collab.model @@ -0,0 +1,5 @@ +CollabTopicGroup + collab CollabId + group GroupId + + UniqueCollabTopicGroup collab diff --git a/src/Vervis/API.hs b/src/Vervis/API.hs index b28e90f..f30193f 100644 --- a/src/Vervis/API.hs +++ b/src/Vervis/API.hs @@ -175,6 +175,9 @@ verifyResourceAddressed localRecips resource = do verify (GrantResourceProject r) = do routes <- lookup r $ recipProjects localRecips guard $ routeProject routes + verify (GrantResourceGroup r) = do + routes <- lookup r $ recipGroups localRecips + guard $ routeGroup routes verifyRemoteAddressed :: Monad m => [(Host, NonEmpty LocalURI)] -> FedURI -> ExceptT Text m () diff --git a/src/Vervis/Actor/Group.hs b/src/Vervis/Actor/Group.hs index 61e40f2..e94f54b 100644 --- a/src/Vervis/Actor/Group.hs +++ b/src/Vervis/Actor/Group.hs @@ -18,43 +18,109 @@ module Vervis.Actor.Group ) where +import Control.Applicative +import Control.Exception.Base import Control.Monad import Control.Monad.IO.Class import Control.Monad.Logger.CallStack 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.Bifoldable +import Data.Bifunctor +import Data.Bitraversable import Data.ByteString (ByteString) +import Data.Either import Data.Foldable +import Data.Maybe import Data.Text (Text) import Data.Time.Clock +import Data.Traversable import Database.Persist +import Database.Persist.Sql +import Optics.Core import Yesod.Persist.Core import qualified Data.Text as T +import qualified Database.Esqueleto as E import Control.Concurrent.Actor import Network.FedURI +import Web.Actor +import Web.Actor.Persist import Yesod.MonadSite import qualified Web.ActivityPub as AP import Control.Monad.Trans.Except.Local +import Data.Either.Local import Database.Persist.Local +import Vervis.Access +import Vervis.ActivityPub import Vervis.Actor +import Vervis.Actor.Common +import Vervis.Actor2 import Vervis.Cloth +import Vervis.Data.Actor +import Vervis.Data.Collab import Vervis.Data.Discussion import Vervis.FedURI import Vervis.Federation.Util import Vervis.Foundation -import Vervis.Model +import Vervis.Model hiding (groupCreate) +import Vervis.Recipient (makeRecipientSet, LocalStageBy (..), Aud (..), collectAudience, localActorFollowers, renderLocalActor) +import Vervis.RemoteActorStore +import Vervis.Persist.Actor +import Vervis.Persist.Collab import Vervis.Persist.Discussion import Vervis.Ticket +-- Meaning: Someone has created a group with my ID URI +-- Behavior: +-- * Verify I'm in a just-been-created state +-- * Verify my creator and the Create sender are the same actor +-- * Create an admin Collab record in DB +-- * Send an admin Grant to the creator +-- * Get out of the just-been-created state +groupCreateMe + :: UTCTime + -> GroupId + -> Verse + -> ActE (Text, Act (), Next) +groupCreateMe = + topicCreateMe + groupActor GrantResourceGroup + CollabTopicGroupGroup CollabTopicGroup + +groupCreate + :: UTCTime + -> GroupId + -> Verse + -> AP.Create URIMode + -> ActE (Text, Act (), Next) +groupCreate now groupID verse (AP.Create obj _muTarget) = + case obj of + + AP.CreateTeam _ mlocal -> do + (h, local) <- fromMaybeE mlocal "No group id provided" + let luGroup = AP.actorId local + uMe <- do + groupHash <- encodeKeyHashid groupID + encodeRouteHome <- getEncodeRouteHome + return $ encodeRouteHome $ GroupR groupHash + unless (uMe == ObjURI h luGroup) $ + throwE "The created group id isn't me" + groupCreateMe now groupID verse + + _ -> throwE "Unsupported Create object for Group" + groupBehavior :: UTCTime -> GroupId -> VerseExt -> ActE (Text, Act (), Next) -groupBehavior now groupID (Left _verse@(Verse _authorIdMsig body)) = +groupBehavior now groupID (Left verse@(Verse _authorIdMsig body)) = case AP.activitySpecific $ actbActivity body of + AP.CreateActivity create -> groupCreate now groupID verse create _ -> throwE "Unsupported activity type for Group" groupBehavior _ _ (Right _) = throwE "ClientMsgs aren't supported for Group" diff --git a/src/Vervis/Actor/Person/Client.hs b/src/Vervis/Actor/Person/Client.hs index d65b957..1f53280 100644 --- a/src/Vervis/Actor/Person/Client.hs +++ b/src/Vervis/Actor/Person/Client.hs @@ -98,6 +98,9 @@ verifyResourceAddressed localRecips resource = do verify (GrantResourceProject r) = do routes <- lookup r $ recipProjects localRecips guard $ routeProject routes + verify (GrantResourceGroup r) = do + routes <- lookup r $ recipGroups localRecips + guard $ routeGroup routes verifyProjectAddressed localRecips projectID = do projectHash <- encodeKeyHashid projectID @@ -1131,6 +1134,7 @@ clientRemove now personMeID (ClientMsg maybeCap localRecips remoteRecips fwdHost Left (GrantResourceDeck d) -> Just $ LocalActorDeck d Left (GrantResourceLoom l) -> Just $ LocalActorLoom l Left (GrantResourceProject l) -> Just $ LocalActorProject l + Left (GrantResourceGroup l) -> Just $ LocalActorGroup l Right _ -> Nothing , case recipientHash of Left (GrantRecipPerson p) -> Just $ LocalActorPerson p @@ -1143,6 +1147,7 @@ clientRemove now personMeID (ClientMsg maybeCap localRecips remoteRecips fwdHost Left (GrantResourceDeck d) -> Just $ LocalStageDeckFollowers d Left (GrantResourceLoom l) -> Just $ LocalStageLoomFollowers l Left (GrantResourceProject l) -> Just $ LocalStageProjectFollowers l + Left (GrantResourceGroup l) -> Just $ LocalStageGroupFollowers l Right _ -> Nothing , case recipientHash of Left (GrantRecipPerson p) -> Just $ LocalStagePersonFollowers p diff --git a/src/Vervis/Client.hs b/src/Vervis/Client.hs index d8a4130..e63fd11 100644 --- a/src/Vervis/Client.hs +++ b/src/Vervis/Client.hs @@ -1144,6 +1144,8 @@ invite personID uRecipient uResourceCollabs role = do AudLocal [LocalActorLoom l] [LocalStageLoomFollowers l] Left (GrantResourceProject l) -> AudLocal [LocalActorProject l] [LocalStageProjectFollowers l] + Left (GrantResourceGroup l) -> + AudLocal [LocalActorGroup l] [LocalStageGroupFollowers l] Right (remoteActor, ObjURI h lu) -> AudRemote h [lu] @@ -1259,6 +1261,8 @@ remove personID uRecipient uResourceCollabs = do AudLocal [LocalActorLoom l] [LocalStageLoomFollowers l] Left (GrantResourceProject l) -> AudLocal [LocalActorProject l] [LocalStageProjectFollowers l] + Left (GrantResourceGroup l) -> + AudLocal [LocalActorGroup l] [LocalStageGroupFollowers l] Right (remoteActor, ObjURI h lu) -> AudRemote h [lu] diff --git a/src/Vervis/Data/Collab.hs b/src/Vervis/Data/Collab.hs index 995a65f..c895b44 100644 --- a/src/Vervis/Data/Collab.hs +++ b/src/Vervis/Data/Collab.hs @@ -455,13 +455,15 @@ grantResourceActorID :: GrantResourceBy Identity -> ActorId grantResourceActorID (GrantResourceRepo (Identity r)) = repoActor r grantResourceActorID (GrantResourceDeck (Identity d)) = deckActor d grantResourceActorID (GrantResourceLoom (Identity l)) = loomActor l -grantResourceActorID (GrantResourceProject (Identity l)) = projectActor l +grantResourceActorID (GrantResourceProject (Identity j)) = projectActor j +grantResourceActorID (GrantResourceGroup (Identity g)) = groupActor g data GrantResourceBy f = GrantResourceRepo (f Repo) | GrantResourceDeck (f Deck) | GrantResourceLoom (f Loom) | GrantResourceProject (f Project) + | GrantResourceGroup (f Group) deriving (Generic, FunctorB, TraversableB, ConstraintsB) deriving instance AllBF Eq f GrantResourceBy => Eq (GrantResourceBy f) @@ -476,6 +478,8 @@ unhashGrantResourcePure ctx = f GrantResourceLoom <$> decodeKeyHashidPure ctx l f (GrantResourceProject l) = GrantResourceProject <$> decodeKeyHashidPure ctx l + f (GrantResourceGroup l) = + GrantResourceGroup <$> decodeKeyHashidPure ctx l unhashGrantResource resource = do ctx <- asksSite siteHashidsContext @@ -501,6 +505,8 @@ hashGrantResource (GrantResourceLoom k) = GrantResourceLoom <$> encodeKeyHashid k hashGrantResource (GrantResourceProject k) = GrantResourceProject <$> encodeKeyHashid k +hashGrantResource (GrantResourceGroup k) = + GrantResourceGroup <$> encodeKeyHashid k hashGrantResource' (GrantResourceRepo k) = GrantResourceRepo <$> WAP.encodeKeyHashid k @@ -510,6 +516,8 @@ hashGrantResource' (GrantResourceLoom k) = GrantResourceLoom <$> WAP.encodeKeyHashid k hashGrantResource' (GrantResourceProject k) = GrantResourceProject <$> WAP.encodeKeyHashid k +hashGrantResource' (GrantResourceGroup k) = + GrantResourceGroup <$> WAP.encodeKeyHashid k getGrantResource (GrantResourceRepo k) e = GrantResourceRepo <$> getEntityE k e @@ -519,6 +527,8 @@ getGrantResource (GrantResourceLoom k) e = GrantResourceLoom <$> getEntityE k e getGrantResource (GrantResourceProject k) e = GrantResourceProject <$> getEntityE k e +getGrantResource (GrantResourceGroup k) e = + GrantResourceGroup <$> getEntityE k e getGrantResource404 = maybe notFound return <=< getGrantResourceEntity where @@ -530,12 +540,15 @@ getGrantResource404 = maybe notFound return <=< getGrantResourceEntity fmap GrantResourceLoom <$> getEntity k getGrantResourceEntity (GrantResourceProject k) = fmap GrantResourceProject <$> getEntity k + getGrantResourceEntity (GrantResourceGroup k) = + fmap GrantResourceGroup <$> getEntity k grantResourceLocalActor :: GrantResourceBy f -> LocalActorBy f grantResourceLocalActor (GrantResourceRepo r) = LocalActorRepo r grantResourceLocalActor (GrantResourceDeck d) = LocalActorDeck d grantResourceLocalActor (GrantResourceLoom l) = LocalActorLoom l grantResourceLocalActor (GrantResourceProject l) = LocalActorProject l +grantResourceLocalActor (GrantResourceGroup l) = LocalActorGroup l data ComponentBy f = ComponentRepo (f Repo) @@ -578,6 +591,7 @@ resourceToComponent = \case GrantResourceDeck k -> Just $ ComponentDeck k GrantResourceLoom k -> Just $ ComponentLoom k GrantResourceProject _ -> Nothing + GrantResourceGroup _ -> Nothing data GrantRecipBy' f = GrantRecipPerson' (f Person) diff --git a/src/Vervis/Migration/Entities.hs b/src/Vervis/Migration/Entities.hs index 1a5dcac..c4e7247 100644 --- a/src/Vervis/Migration/Entities.hs +++ b/src/Vervis/Migration/Entities.hs @@ -64,6 +64,7 @@ module Vervis.Migration.Entities , model_531_follow_request , model_541_project , model_542_component + , model_551_group_collab ) where @@ -248,3 +249,6 @@ model_541_project = $(schema "541_2023-06-26_project") model_542_component :: [Entity SqlBackend] model_542_component = $(schema "542_2023-06-26_component") + +model_551_group_collab :: [Entity SqlBackend] +model_551_group_collab = $(schema "551_2023-11-21_group_collab") diff --git a/src/Vervis/Persist/Collab.hs b/src/Vervis/Persist/Collab.hs index 5506727..84147ff 100644 --- a/src/Vervis/Persist/Collab.hs +++ b/src/Vervis/Persist/Collab.hs @@ -71,23 +71,7 @@ import Vervis.Persist.Actor getCollabTopic :: MonadIO m => CollabId -> ReaderT SqlBackend m (GrantResourceBy Key) -getCollabTopic collabID = do - maybeRepo <- getValBy $ UniqueCollabTopicRepo collabID - maybeDeck <- getValBy $ UniqueCollabTopicDeck collabID - maybeLoom <- getValBy $ UniqueCollabTopicLoom collabID - maybeProject <- getValBy $ UniqueCollabTopicProject collabID - return $ - case (maybeRepo, maybeDeck, maybeLoom, maybeProject) of - (Nothing, Nothing, Nothing, Nothing) -> error "Found Collab without topic" - (Just r, Nothing, Nothing, Nothing) -> - GrantResourceRepo $ collabTopicRepoRepo r - (Nothing, Just d, Nothing, Nothing) -> - GrantResourceDeck $ collabTopicDeckDeck d - (Nothing, Nothing, Just l, Nothing) -> - GrantResourceLoom $ collabTopicLoomLoom l - (Nothing, Nothing, Nothing, Just l) -> - GrantResourceProject $ collabTopicProjectProject l - _ -> error "Found Collab with multiple topics" +getCollabTopic = fmap snd . getCollabTopic' getCollabTopic' :: MonadIO m => CollabId -> ReaderT SqlBackend m (ReaderT SqlBackend m (), GrantResourceBy Key) @@ -96,17 +80,20 @@ getCollabTopic' collabID = do maybeDeck <- getBy $ UniqueCollabTopicDeck collabID maybeLoom <- getBy $ UniqueCollabTopicLoom collabID maybeProject <- getBy $ UniqueCollabTopicProject collabID + maybeGroup <- getBy $ UniqueCollabTopicGroup collabID return $ - case (maybeRepo, maybeDeck, maybeLoom, maybeProject) of - (Nothing, Nothing, Nothing, Nothing) -> error "Found Collab without topic" - (Just (Entity k r), Nothing, Nothing, Nothing) -> + case (maybeRepo, maybeDeck, maybeLoom, maybeProject, maybeGroup) of + (Nothing, Nothing, Nothing, Nothing, Nothing) -> error "Found Collab without topic" + (Just (Entity k r), Nothing, Nothing, Nothing, Nothing) -> (delete k, GrantResourceRepo $ collabTopicRepoRepo r) - (Nothing, Just (Entity k d), Nothing, Nothing) -> + (Nothing, Just (Entity k d), Nothing, Nothing, Nothing) -> (delete k, GrantResourceDeck $ collabTopicDeckDeck d) - (Nothing, Nothing, Just (Entity k l), Nothing) -> + (Nothing, Nothing, Just (Entity k l), Nothing, Nothing) -> (delete k, GrantResourceLoom $ collabTopicLoomLoom l) - (Nothing, Nothing, Nothing, Just (Entity k l)) -> + (Nothing, Nothing, Nothing, Just (Entity k l), Nothing) -> (delete k, GrantResourceProject $ collabTopicProjectProject l) + (Nothing, Nothing, Nothing, Nothing, Just (Entity k l)) -> + (delete k, GrantResourceGroup $ collabTopicGroupGroup l) _ -> error "Found Collab with multiple topics" getStemIdent :: MonadIO m => StemId -> ReaderT SqlBackend m (ComponentBy Key) diff --git a/th/models b/th/models index d4ba2d6..af3205c 100644 --- a/th/models +++ b/th/models @@ -676,6 +676,12 @@ CollabTopicProject UniqueCollabTopicProject collab +CollabTopicGroup + collab CollabId + group GroupId + + UniqueCollabTopicGroup collab + CollabEnable collab CollabId grant OutboxItemId