From 4a2f97d9dd3231b305e1e3aaf6d6c2efb5d7e8ca Mon Sep 17 00:00:00 2001 From: Pere Lev Date: Wed, 28 Jun 2023 21:34:19 +0300 Subject: [PATCH] S2S: Upgrade the Project Invite handler to handle components --- src/Vervis/Actor/Common.hs | 3 +- src/Vervis/Actor/Project.hs | 374 ++++++++++++++++++++++-------------- src/Vervis/Data/Collab.hs | 5 + 3 files changed, 235 insertions(+), 147 deletions(-) diff --git a/src/Vervis/Actor/Common.hs b/src/Vervis/Actor/Common.hs index aadcb1a..2c2c082 100644 --- a/src/Vervis/Actor/Common.hs +++ b/src/Vervis/Actor/Common.hs @@ -842,7 +842,8 @@ topicInvite grabActor topicResource topicField topicCollabField collabTopicCtor return $ AudLocal [LocalActorPerson ph] [] Right (ObjURI h lu) -> return $ AudRemote h [lu] [] audTopic <- - flip AudLocal [] . pure . grantResourceLocalActor . topicResource <$> + AudLocal [] . pure . localActorFollowers . + grantResourceLocalActor . topicResource <$> encodeKeyHashid topicKey uInvite <- getActivityURI authorIdMsig diff --git a/src/Vervis/Actor/Project.hs b/src/Vervis/Actor/Project.hs index 25af626..94b764d 100644 --- a/src/Vervis/Actor/Project.hs +++ b/src/Vervis/Actor/Project.hs @@ -27,6 +27,7 @@ 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) @@ -67,7 +68,7 @@ import Vervis.FedURI import Vervis.Federation.Util import Vervis.Foundation import Vervis.Model hiding (projectCreate) -import Vervis.Recipient (makeRecipientSet, LocalStageBy (..), Aud (..), collectAudience) +import Vervis.Recipient (makeRecipientSet, LocalStageBy (..), Aud (..), collectAudience, localActorFollowers) import Vervis.RemoteActorStore import Vervis.Persist.Actor import Vervis.Persist.Collab @@ -97,6 +98,93 @@ projectAccept -> ActE (Text, Act (), Next) projectAccept = topicAccept projectActor GrantResourceProject +checkExistingComponents + :: ProjectId -> Either (ComponentBy Entity) RemoteActorId -> ActDBE () +checkExistingComponents projectID componentDB = do + + -- Find existing Component records I have for this component + componentIDs <- lift $ getExistingComponents componentDB + + -- Grab all the enabled ones, make sure none are enabled, and even if + -- any are enabled, make sure there's at most one (otherwise it's a + -- bug) + byEnabled <- + lift $ for componentIDs $ \ (componentID, _) -> + isJust <$> runMaybeT (tryComponentEnabled componentID) + case length $ filter id byEnabled of + 0 -> return () + 1 -> throwE "I already have a ComponentEnable for this component" + _ -> error "Multiple ComponentEnable for a component" + + -- Verify none of the Component records are already in + -- Add-waiting-for-project or Invite-waiting-for-component state + anyStarted <- + lift $ runMaybeT $ asum $ + map (\ (componentID, identID) -> + tryComponentAddAccept componentID identID <|> + tryComponentInviteAccept componentID + ) + componentIDs + unless (isNothing anyStarted) $ + throwE + "One of the Component records is already in Add-Accept or \ + \Invite-Accept state" + + where + + getExistingComponents (Left (ComponentRepo (Entity repoID _))) = + fmap (map $ bimap E.unValue (Left . E.unValue)) $ + E.select $ E.from $ \ (ident `E.InnerJoin` local `E.InnerJoin` comp) -> do + E.on $ local E.^. ComponentLocalComponent E.==. comp E.^. ComponentId + E.on $ ident E.^. ComponentLocalRepoComponent E.==. local E.^. ComponentLocalId + E.where_ $ + ident E.^. ComponentLocalRepoRepo E.==. E.val repoID E.&&. + comp E.^. ComponentProject E.==. E.val projectID + return (comp E.^. ComponentId, local E.^. ComponentLocalId) + getExistingComponents (Left (ComponentDeck (Entity deckID _))) = + fmap (map $ bimap E.unValue (Left . E.unValue)) $ + E.select $ E.from $ \ (ident `E.InnerJoin` local `E.InnerJoin` comp) -> do + E.on $ local E.^. ComponentLocalComponent E.==. comp E.^. ComponentId + E.on $ ident E.^. ComponentLocalDeckComponent E.==. local E.^. ComponentLocalId + E.where_ $ + ident E.^. ComponentLocalDeckDeck E.==. E.val deckID E.&&. + comp E.^. ComponentProject E.==. E.val projectID + return (comp E.^. ComponentId, local E.^. ComponentLocalId) + getExistingComponents (Left (ComponentLoom (Entity loomID _))) = + fmap (map $ bimap E.unValue (Left . E.unValue)) $ + E.select $ E.from $ \ (ident `E.InnerJoin` local `E.InnerJoin` comp) -> do + E.on $ local E.^. ComponentLocalComponent E.==. comp E.^. ComponentId + E.on $ ident E.^. ComponentLocalLoomComponent E.==. local E.^. ComponentLocalId + E.where_ $ + ident E.^. ComponentLocalLoomLoom E.==. E.val loomID E.&&. + comp E.^. ComponentProject E.==. E.val projectID + return (comp E.^. ComponentId, local E.^. ComponentLocalId) + getExistingComponents (Right remoteActorID) = + fmap (map $ bimap E.unValue (Right . E.unValue)) $ + E.select $ E.from $ \ (ident `E.InnerJoin` comp) -> do + E.on $ ident E.^. ComponentRemoteComponent E.==. comp E.^. ComponentId + E.where_ $ + ident E.^. ComponentRemoteActor E.==. E.val remoteActorID E.&&. + comp E.^. ComponentProject E.==. E.val projectID + return (comp E.^. ComponentId, ident E.^. ComponentRemoteId) + + tryComponentEnabled componentID = + const () <$> MaybeT (getBy $ UniqueComponentEnable componentID) + + tryComponentAddAccept componentID identID = do + _ <- MaybeT $ getBy $ UniqueComponentOriginAdd componentID + case identID of + Left localID -> + const () <$> + MaybeT (getBy $ UniqueComponentAcceptLocal localID) + Right remoteID -> + const () <$> + MaybeT (getBy $ UniqueComponentAcceptRemote remoteID) + + tryComponentInviteAccept componentID = do + originID <- MaybeT $ getKeyBy $ UniqueComponentOriginInvite componentID + const () <$> MaybeT (getBy $ UniqueComponentProjectAccept originID) + -- Meaning: An actor is adding some object to some target -- Behavior: -- * Verify my components list is the target @@ -166,32 +254,9 @@ projectAdd now projectID (Verse authorIdMsig body) add = do (p,) <$> getJust (projectActor p) -- Find existing Component records I have for this component - componentIDs <- lift $ getExistingComponents componentDB - - -- Grab all the enabled ones, make sure none are enabled, and even if - -- any are enabled, make sure there's at most one (otherwise it's a - -- bug) - byEnabled <- - lift $ for componentIDs $ \ (componentID, _) -> - isJust <$> runMaybeT (tryComponentEnabled componentID) - case length $ filter id byEnabled of - 0 -> return () - 1 -> throwE "I already have a ComponentEnable for this component" - _ -> error "Multiple ComponentEnable for a component" - - -- Verify none of the Component records are already in - -- Add-waiting-for-project or Invite-waiting-for-component state - anyStarted <- - lift $ runMaybeT $ asum $ - map (\ (componentID, identID) -> - tryComponentAddAccept componentID identID <|> - tryComponentInviteAccept componentID - ) - componentIDs - unless (isNothing anyStarted) $ - throwE - "One of the Component records is already in Add-Accept or \ - \Invite-Accept state" + -- Make sure none are enabled / in Add-Accept mode / in Invite-Accept + -- mode + checkExistingComponents projectID componentDB -- Insert the Add to my inbox mractid <- lift $ insertToInbox now authorIdMsig body (actorInbox actorRecip) False @@ -218,59 +283,6 @@ projectAdd now projectID (Verse authorIdMsig body) add = do where - getExistingComponents (Left (ComponentRepo (Entity repoID _))) = - fmap (map $ bimap E.unValue (Left . E.unValue)) $ - E.select $ E.from $ \ (ident `E.InnerJoin` local `E.InnerJoin` comp) -> do - E.on $ local E.^. ComponentLocalComponent E.==. comp E.^. ComponentId - E.on $ ident E.^. ComponentLocalRepoComponent E.==. local E.^. ComponentLocalId - E.where_ $ - ident E.^. ComponentLocalRepoRepo E.==. E.val repoID E.&&. - comp E.^. ComponentProject E.==. E.val projectID - return (comp E.^. ComponentId, local E.^. ComponentLocalId) - getExistingComponents (Left (ComponentDeck (Entity deckID _))) = - fmap (map $ bimap E.unValue (Left . E.unValue)) $ - E.select $ E.from $ \ (ident `E.InnerJoin` local `E.InnerJoin` comp) -> do - E.on $ local E.^. ComponentLocalComponent E.==. comp E.^. ComponentId - E.on $ ident E.^. ComponentLocalDeckComponent E.==. local E.^. ComponentLocalId - E.where_ $ - ident E.^. ComponentLocalDeckDeck E.==. E.val deckID E.&&. - comp E.^. ComponentProject E.==. E.val projectID - return (comp E.^. ComponentId, local E.^. ComponentLocalId) - getExistingComponents (Left (ComponentLoom (Entity loomID _))) = - fmap (map $ bimap E.unValue (Left . E.unValue)) $ - E.select $ E.from $ \ (ident `E.InnerJoin` local `E.InnerJoin` comp) -> do - E.on $ local E.^. ComponentLocalComponent E.==. comp E.^. ComponentId - E.on $ ident E.^. ComponentLocalLoomComponent E.==. local E.^. ComponentLocalId - E.where_ $ - ident E.^. ComponentLocalLoomLoom E.==. E.val loomID E.&&. - comp E.^. ComponentProject E.==. E.val projectID - return (comp E.^. ComponentId, local E.^. ComponentLocalId) - getExistingComponents (Right remoteActorID) = - fmap (map $ bimap E.unValue (Right . E.unValue)) $ - E.select $ E.from $ \ (ident `E.InnerJoin` comp) -> do - E.on $ ident E.^. ComponentRemoteComponent E.==. comp E.^. ComponentId - E.where_ $ - ident E.^. ComponentRemoteActor E.==. E.val remoteActorID E.&&. - comp E.^. ComponentProject E.==. E.val projectID - return (comp E.^. ComponentId, ident E.^. ComponentRemoteId) - - tryComponentEnabled componentID = - const () <$> MaybeT (getBy $ UniqueComponentEnable componentID) - - tryComponentAddAccept componentID identID = do - _ <- MaybeT $ getBy $ UniqueComponentOriginAdd componentID - case identID of - Left localID -> - const () <$> - MaybeT (getBy $ UniqueComponentAcceptLocal localID) - Right remoteID -> - const () <$> - MaybeT (getBy $ UniqueComponentAcceptRemote remoteID) - - tryComponentInviteAccept componentID = do - originID <- MaybeT $ getKeyBy $ UniqueComponentOriginInvite componentID - const () <$> MaybeT (getBy $ UniqueComponentProjectAccept originID) - insertComponent componentDB addDB = do componentID <- insert $ Component projectID AP.RoleAdmin originID <- insert $ ComponentOriginAdd componentID @@ -359,16 +371,25 @@ projectFollow now recipProjectID verse follow = do -- Meaning: An actor A invited actor B to a resource -- Behavior: --- * Verify the resource is my collabs list --- * If invitee is local, verify it's a Person and not a Component +-- * Verify the resource is my collabs or components list +-- * If resource is collabs and B is local, verify it's a Person +-- * If resource is components and B is local, verify it's a Component -- * Verify A isn't inviting themselves --- * Verify A is authorized by me to invite collabs to me +-- * Verify A is authorized by me to invite collabs/components to me -- --- * Verify B doesn't already have an invite/join/grant for me +-- * In collab mode, +-- * Verify B doesn't already have an invite/join/grant for me +-- * In component mode, +-- * Verify B isn't already an active component of mine +-- * Verify B isn't already in a Add-Accept process waiting for +-- project collab to accept too +-- * Verify B isn't already in an Invite-Accept process waiting for +-- component (or its collaborator) to accept too -- -- * Insert the Invite to my inbox -- --- * Insert a Collab record to DB +-- * In collab mode, Insert a Collab record to DB +-- * In component mode, Create a Component record in DB -- -- * Forward the Invite to my followers -- * Send Accept to A, B (and followers if it's a component), my-followers @@ -400,20 +421,31 @@ projectInvite now projectID (Verse authorIdMsig body) invite = do _ -> throwE "Capability is remote i.e. definitely not by me" -- Check invite - (role, targetByKey) <- do + (role, invited) <- do let author = bimap (view _1) (remoteAuthorURI . view _1) authorIdMsig (role, resourceOrComps, recipientOrComp) <- parseInvite author invite - unless (Left (Left $ GrantResourceProject projectID) == resourceOrComps) $ - throwE "Invite topic isn't my collabs URI" - recipient <- - bitraverse - (\case - Left r -> pure r - Right _ -> throwE "Not accepting component actors as collabs" - ) - pure - recipientOrComp - return (role, recipient) + mode <- + case resourceOrComps of + Left (Left (GrantResourceProject j)) | j == projectID -> + Left <$> + bitraverse + (\case + Left r -> pure r + Right _ -> throwE "Not accepting local component actors as collabs" + ) + pure + recipientOrComp + Left (Right j) | j == projectID -> + Right <$> + bitraverse + (\case + Left _ -> throwE "Not accepting local Persons as components" + Right r -> pure r + ) + pure + recipientOrComp + _ -> throwE "Invite topic isn't my collabs or components 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 @@ -424,22 +456,17 @@ projectInvite now projectID (Verse authorIdMsig body) invite = do -- 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. - targetDB <- + invitedDB <- bitraverse - (withDBExcept . flip getGrantRecip "Invitee not found in DB") - (\ u@(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 + (bitraverse + (withDBExcept . flip getGrantRecip "Invitee not found in DB") + getRemoteActorFromURI ) - targetByKey + (bitraverse + (withDBExcept . flip getComponentE "Invitee not found in DB") + getRemoteActorFromURI + ) + invited maybeNew <- withDBExcept $ do @@ -453,38 +480,29 @@ projectInvite now projectID (Verse authorIdMsig body) invite = do verifyCapability' capability authorIdMsig (GrantResourceProject projectID) AP.RoleAdmin - -- Verify that target doesn't already have a Collab for me - existingCollabIDs <- - lift $ case targetDB of - Left (GrantRecipPerson (Entity personID _)) -> - E.select $ E.from $ \ (topic `E.InnerJoin` recipl) -> do - E.on $ - topic E.^. CollabTopicProjectCollab E.==. - recipl E.^. CollabRecipLocalCollab - E.where_ $ - topic E.^. CollabTopicProjectProject E.==. E.val projectID E.&&. - recipl E.^. CollabRecipLocalPerson E.==. E.val personID - return $ recipl E.^. CollabRecipLocalCollab - Right remoteActorID -> - E.select $ E.from $ \ (topic `E.InnerJoin` recipr) -> do - E.on $ - topic E.^. CollabTopicProjectCollab E.==. - recipr E.^. CollabRecipRemoteCollab - E.where_ $ - topic E.^. CollabTopicProjectProject E.==. E.val projectID E.&&. - recipr E.^. CollabRecipRemoteActor E.==. E.val remoteActorID - return $ recipr E.^. CollabRecipRemoteCollab - case existingCollabIDs of - [] -> pure () - [_] -> throwE "I already have a Collab for the target" - _ -> error "Multiple collabs found for target" + case invitedDB of + + -- Verify that target doesn't already have a Collab for me + Left collab -> do + existingCollabIDs <- lift $ getExistingCollabs collab + case existingCollabIDs of + [] -> pure () + [_] -> throwE "I already have a Collab for the target" + _ -> error "Multiple collabs found for target" + + -- Find existing Component records I have for this component + -- Make sure none are enabled / in Add-Accept mode / in + -- Invite-Accept mode + Right component -> checkExistingComponents projectID component maybeInviteDB <- lift $ insertToInbox now authorIdMsig body (actorInbox topicActor) False lift $ for maybeInviteDB $ \ inviteDB -> do - -- Insert Collab record to DB + -- Insert Collab or Component record to DB acceptID <- insertEmptyOutboxItem' (actorOutbox topicActor) now - insertCollab role targetDB inviteDB acceptID + case invitedDB of + Left collab -> insertCollab role collab inviteDB acceptID + Right component -> insertComponent component inviteDB acceptID -- Prepare forwarding Invite to my followers sieve <- do @@ -492,7 +510,7 @@ projectInvite now projectID (Verse authorIdMsig body) invite = do return $ makeRecipientSet [] [LocalStageProjectFollowers projectHash] -- Prepare an Accept activity and insert to my outbox - accept@(actionAccept, _, _, _) <- lift $ prepareAccept targetByKey + accept@(actionAccept, _, _, _) <- prepareAccept invitedDB _luAccept <- updateOutboxItem' (LocalActorProject projectID) acceptID actionAccept return (topicActorID, sieve, acceptID, accept) @@ -509,6 +527,37 @@ projectInvite now projectID (Verse authorIdMsig body) invite = do 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.^. CollabTopicProjectCollab E.==. + recipl E.^. CollabRecipLocalCollab + E.where_ $ + topic E.^. CollabTopicProjectProject E.==. E.val projectID 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.^. CollabTopicProjectCollab E.==. + recipr E.^. CollabRecipRemoteCollab + E.where_ $ + topic E.^. CollabTopicProjectProject E.==. E.val projectID 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 @@ -525,20 +574,53 @@ projectInvite now projectID (Verse authorIdMsig body) invite = do Right remoteActorID -> insert_ $ CollabRecipRemote collabID remoteActorID - prepareAccept invited = do + insertComponent componentDB inviteDB acceptID = do + componentID <- insert $ Component projectID AP.RoleAdmin + originID <- insert $ ComponentOriginInvite componentID + case inviteDB of + Left (_, _, inviteID) -> + insert_ $ ComponentProjectGestureLocal componentID inviteID + Right (author, _, inviteID) -> + insert_ $ ComponentProjectGestureRemote componentID (remoteAuthorId author) inviteID + case componentDB of + Left l -> do + identID <- insert $ ComponentLocal componentID + case l of + ComponentRepo (Entity repoID _) -> + insert_ $ ComponentLocalRepo identID repoID + ComponentDeck (Entity deckID _) -> + insert_ $ ComponentLocalDeck identID deckID + ComponentLoom (Entity loomID _) -> + insert_ $ ComponentLocalLoom identID loomID + Right remoteActorID -> + insert_ $ ComponentRemote componentID remoteActorID + insert_ $ ComponentProjectAccept originID acceptID + + prepareAccept invitedDB = do encodeRouteHome <- getEncodeRouteHome - audInviter <- makeAudSenderOnly authorIdMsig + audInviter <- lift $ makeAudSenderOnly authorIdMsig audInvited <- - case invited of - Left (GrantRecipPerson p) -> do + case invitedDB of + Left (Left (GrantRecipPerson (Entity p _))) -> do ph <- encodeKeyHashid p return $ AudLocal [LocalActorPerson ph] [] - Right (ObjURI h lu) -> return $ AudRemote h [lu] [] + Left (Right remoteActorID) -> do + ra <- getJust remoteActorID + ObjURI h lu <- getRemoteActorURI ra + return $ AudRemote h [lu] [] + Right (Left componentByEnt) -> do + componentByHash <- hashComponent $ bmap entityKey componentByEnt + let actor = componentActor componentByHash + return $ AudLocal [actor] [localActorFollowers actor] + Right (Right remoteActorID) -> do + ra <- getJust remoteActorID + ObjURI h lu <- getRemoteActorURI ra + return $ AudRemote h [lu] (maybeToList $ remoteActorFollowers ra) audTopic <- - flip AudLocal [] . pure . LocalActorProject <$> + AudLocal [] . pure . LocalStageProjectFollowers <$> encodeKeyHashid projectID - uInvite <- getActivityURI authorIdMsig + uInvite <- lift $ getActivityURI authorIdMsig let (recipientSet, remoteActors, fwdHosts, audLocal, audRemote) = collectAudience [audInviter, audInvited, audTopic] diff --git a/src/Vervis/Data/Collab.hs b/src/Vervis/Data/Collab.hs index 25a7bc0..22b17bb 100644 --- a/src/Vervis/Data/Collab.hs +++ b/src/Vervis/Data/Collab.hs @@ -47,6 +47,7 @@ module Vervis.Data.Collab , grantResourceLocalActor , ComponentBy (..) + , hashComponent , componentActor ) where @@ -485,6 +486,10 @@ parseComponent (DeckR d) = Just $ ComponentDeck d parseComponent (LoomR l) = Just $ ComponentLoom l parseComponent _ = Nothing +hashComponent (ComponentRepo k) = ComponentRepo <$> WAP.encodeKeyHashid k +hashComponent (ComponentDeck k) = ComponentDeck <$> WAP.encodeKeyHashid k +hashComponent (ComponentLoom k) = ComponentLoom <$> WAP.encodeKeyHashid k + unhashComponentPure ctx = f where f (ComponentRepo r) =