diff --git a/src/Vervis/Actor/Common.hs b/src/Vervis/Actor/Common.hs index 16aec9e..29fb5e3 100644 --- a/src/Vervis/Actor/Common.hs +++ b/src/Vervis/Actor/Common.hs @@ -1179,18 +1179,6 @@ topicReject grabResource topicResource now recipKey (Verse authorIdMsig body) re -- * Remember the invite in DB -- * Forward the Invite to my followers -- * Send Accept to A, B, my-followers --- * If I'm B, i.e. I'm the one being invited: --- * Verify the resource is some project's components collection URI --- * For each Stem record I have for this project: --- * Verify it's not enabled yet, i.e. I'm not already a component --- of this project --- * Verify it's not in Invite-Accept state, already got the --- project's Accept and waiting for my approval --- * Verify it's not in Add-Accept state, has my approval and --- waiting for the project's side --- * Create a Stem record in DB --- * Insert the Invite to my inbox --- * Forward the Invite to my followers componentInvite :: forall topic. (PersistRecordBackend topic SqlBackend, ToBackendKey SqlBackend topic) @@ -1204,17 +1192,11 @@ componentInvite componentInvite grabKomponent topicComponent now topicKey (Verse authorIdMsig body) invite = do -- Check invite - recipOrProject <- do + (role, targetByKey) <- do let author = bimap (view _1) (remoteAuthorURI . view _1) authorIdMsig (role, resourceOrComps, recipientOrComp) <- parseInvite author invite - let collabMode = - Left (Left $ topicResource topicKey) == resourceOrComps - compMode = - Left (Right $ topicComponent topicKey) == recipientOrComp - case (collabMode, compMode) of - (False, False) -> throwE "Invite is unrelated to me" - (True, True) -> throwE "I'm being invited as a collaborator in myself" - (True, False) -> Left . (role,) <$> + if Left (Left $ topicResource topicKey) == resourceOrComps + then (role,) <$> bitraverse (\case Left r -> pure r @@ -1222,112 +1204,56 @@ componentInvite grabKomponent topicComponent now topicKey (Verse authorIdMsig bo ) pure recipientOrComp - (False, True) -> Right <$> do - unless (role == AP.RoleAdmin) $ - throwE "Invite-component role isn't admin" - bitraverse - (\case - Left _ -> throwE "Inviting me to be a collaborator doesn't make sense to me" - Right j -> pure j - ) - pure - resourceOrComps + else throwE "Invite is unrelated to me" - recipOrProjectDB <- - bitraverse - (\ (role, targetByKey) -> do + (capability, targetDB) <- do - -- Check capability - capability <- 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 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 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" - - -- 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. - targetDB <- - 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 - ) - targetByKey - - return (role, capability, targetByKey, targetDB) - ) - - -- If project is local, find it in our DB - -- If project is remote, HTTP GET it 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 handler, - -- which is NOT a good idea. Ideally, it would be done async, and the - -- handler result would be sent later in a separate (e.g. Accept) activity. - -- But for the PoC level, the current situation will hopefully do. - (bitraverse - (withDBExcept . flip getEntityE "Project not found in DB") - (\ u@(ObjURI h luComps) -> do - manager <- asksEnv envHttpManager - collection <- - ExceptT $ first T.pack <$> - AP.fetchAPID - manager - (AP.collectionId :: AP.Collection FedURI URIMode -> LocalURI) - h - luComps - luProject <- fromMaybeE (AP.collectionContext collection) "Collection has no context" - project <- - ExceptT $ first T.pack <$> - AP.fetchAPID manager (AP.actorId . AP.actorLocal . AP.projectActor) h luProject - unless (AP.projectComponents project == luComps) $ - throwE "The collection isn't the project's components collection" + -- Verify the capability is local + case cap of + Left (actorByKey, _, outboxItemID) -> + return (actorByKey, outboxItemID) + _ -> throwE "Capability is remote i.e. definitely not by me" + -- 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. + targetDB <- + 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 luProject + 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) -> do - unless (remoteActorType (entityVal actor) == AP.ActorTypeProject) $ - throwE "Remote project type isn't Project" - return $ entityKey actor + Right (Just actor) -> return $ entityKey actor ) - ) + targetByKey - recipOrProject + return (capability, targetDB) maybeNew <- withDBExcept $ do @@ -1337,45 +1263,35 @@ componentInvite grabKomponent topicComponent now topicKey (Verse authorIdMsig bo Resource topicActorID <- lift $ getJust resourceID topicActor <- lift $ getJust topicActorID - case recipOrProjectDB of - Left (role, capability, _targetByKey, targetDB) -> do + -- Verify the specified capability gives relevant access + verifyCapability' + capability authorIdMsig (topicResource topicKey) AP.RoleAdmin - -- Verify the specified capability gives relevant access - verifyCapability' - capability authorIdMsig (topicResource topicKey) 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 $ \ (collab `E.InnerJoin` recipl) -> do - E.on $ - collab E.^. CollabId E.==. - recipl E.^. CollabRecipLocalCollab - E.where_ $ - collab E.^. CollabTopic E.==. E.val resourceID E.&&. - recipl E.^. CollabRecipLocalPerson E.==. E.val personID - return $ recipl E.^. CollabRecipLocalCollab - Right remoteActorID -> - E.select $ E.from $ \ (collab `E.InnerJoin` recipr) -> do - E.on $ - collab E.^. CollabId E.==. - recipr E.^. CollabRecipRemoteCollab - E.where_ $ - collab E.^. CollabTopic E.==. E.val resourceID 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" - - Right projectDB -> - - -- Find existing Stem records I have for this project - -- Make sure none are enabled / in Add-Accept mode / in Invite-Accept - -- mode - checkExistingStems komponentID projectDB + -- Verify that target doesn't already have a Collab for me + existingCollabIDs <- + lift $ case targetDB of + Left (GrantRecipPerson (Entity personID _)) -> + E.select $ E.from $ \ (collab `E.InnerJoin` recipl) -> do + E.on $ + collab E.^. CollabId E.==. + recipl E.^. CollabRecipLocalCollab + E.where_ $ + collab E.^. CollabTopic E.==. E.val resourceID E.&&. + recipl E.^. CollabRecipLocalPerson E.==. E.val personID + return $ recipl E.^. CollabRecipLocalCollab + Right remoteActorID -> + E.select $ E.from $ \ (collab `E.InnerJoin` recipr) -> do + E.on $ + collab E.^. CollabId E.==. + recipr E.^. CollabRecipRemoteCollab + E.where_ $ + collab E.^. CollabTopic E.==. E.val resourceID 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" maybeInviteDB <- lift $ insertToInbox now authorIdMsig body (actorInbox topicActor) False lift $ for maybeInviteDB $ \ (inboxItemID, inviteDB) -> do @@ -1387,33 +1303,27 @@ componentInvite grabKomponent topicComponent now topicKey (Verse authorIdMsig bo resourceToActor $ topicResource topicHash return $ makeRecipientSet [] [localActorFollowers topicByHash] - -- Insert Collab or Stem record to DB - -- In Collab mode: Prepare an Accept activity and insert to my - -- outbox - maybeAccept <- case recipOrProjectDB of - Left (role, _capability, targetByKey, targetDB) -> Just <$> do - acceptID <- insertEmptyOutboxItem' (actorOutbox topicActor) now - insertCollab resourceID role targetDB inviteDB acceptID - accept@(actionAccept, _, _, _) <- lift $ prepareAccept targetByKey - let topicByKey = resourceToActor $ topicResource topicKey - _luAccept <- updateOutboxItem' topicByKey acceptID actionAccept - return (acceptID, accept) - Right projectDB -> do - insertStem komponentID projectDB inviteDB - return Nothing + -- Insert Collab record to DB + -- Prepare an Accept activity and insert to my outbox + (acceptID, accept) <- do + acceptID <- insertEmptyOutboxItem' (actorOutbox topicActor) now + insertCollab resourceID role targetDB inviteDB acceptID + accept@(actionAccept, _, _, _) <- lift $ prepareAccept targetByKey + let topicByKey = resourceToActor $ topicResource topicKey + _luAccept <- updateOutboxItem' topicByKey acceptID actionAccept + return (acceptID, accept) - return (topicActorID, sieve, maybeAccept, inboxItemID) + return (topicActorID, sieve, acceptID, accept, inboxItemID) case maybeNew of Nothing -> done "I already have this activity in my inbox" - Just (topicActorID, sieve, maybeAccept, inboxItemID) -> do + Just (topicActorID, sieve, acceptID, (actionAccept, localRecipsAccept, remoteRecipsAccept, fwdHostsAccept), inboxItemID) -> do let topicByID = resourceToActor $ topicResource topicKey forwardActivity authorIdMsig body topicByID topicActorID sieve - lift $ for_ maybeAccept $ \ (acceptID, (actionAccept, localRecipsAccept, remoteRecipsAccept, fwdHostsAccept)) -> - sendActivity + lift $ sendActivity topicByID topicActorID localRecipsAccept remoteRecipsAccept fwdHostsAccept acceptID actionAccept - doneDB inboxItemID "Recorded and forwarded the Invite, sent an Accept if collab" + doneDB inboxItemID "Recorded and forwarded the Invite, sent an Accept" where @@ -1435,20 +1345,6 @@ componentInvite grabKomponent topicComponent now topicKey (Verse authorIdMsig bo Right remoteActorID -> insert_ $ CollabRecipRemote collabID remoteActorID - insertStem komponentID projectDB inviteDB = do - stemID <- insert $ Stem AP.RoleAdmin komponentID - case projectDB of - Left (Entity projectID _) -> - insert_ $ StemProjectLocal stemID projectID - Right remoteActorID -> - insert_ $ StemProjectRemote stemID remoteActorID - originID <- insert $ StemOriginInvite stemID - case inviteDB of - Left (_, _, inviteID) -> - insert_ $ StemProjectGestureLocal originID inviteID - Right (author, _, inviteID) -> - insert_ $ StemProjectGestureRemote originID (remoteAuthorId author) inviteID - prepareAccept invited = do encodeRouteHome <- getEncodeRouteHome diff --git a/src/Vervis/Actor/Deck.hs b/src/Vervis/Actor/Deck.hs index 2462130..3e59ba1 100644 --- a/src/Vervis/Actor/Deck.hs +++ b/src/Vervis/Actor/Deck.hs @@ -574,27 +574,6 @@ deckReject -> ActE (Text, Act (), Next) deckReject = topicReject deckResource LocalResourceDeck --- Meaning: An actor A invited actor B to a resource --- Behavior: --- * If resource is my collaborators collection: --- * Verify A isn't inviting themselves --- * Verify A is authorized by me to invite actors to me --- * Verify B doesn't already have an invite/join/grant for me --- * Remember the invite in DB --- * Forward the Invite to my followers --- * Send Accept to A, B, my-followers --- * If I'm B, i.e. I'm the one being invited: --- * Verify the resource is some project's components collection URI --- * For each Stem record I have for this project: --- * Verify it's not enabled yet, i.e. I'm not already a component --- of this project --- * Verify it's not in Invite-Accept state, already got the --- project's Accept and waiting for my approval --- * Verify it's not in Add-Accept state, has my approval and --- waiting for the project's side --- * Create a Stem record in DB --- * Insert the Invite to my inbox --- * Forward the Invite to my followers deckInvite :: UTCTime -> DeckId diff --git a/src/Vervis/Actor/Project.hs b/src/Vervis/Actor/Project.hs index 78ac854..b31d43b 100644 --- a/src/Vervis/Actor/Project.hs +++ b/src/Vervis/Actor/Project.hs @@ -4864,28 +4864,19 @@ projectGrant now projectID (Verse authorIdMsig body) grant = do -- Meaning: An actor A invited actor B to a resource -- Behavior: --- * 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 the resource is my collabs list +-- * If B is local, verify it's a Person -- * Verify A isn't inviting themselves --- * Verify A is authorized by me to invite collabs/components to me +-- * Verify A is authorized by me to invite collabs to 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 +-- * Verify B doesn't already have an invite/join/grant for me -- -- * Insert the Invite to my inbox -- --- * In collab mode, Insert a Collab record to DB --- * In component mode, Create a Component record in DB +-- * Insert a Collab record to DB -- -- * Forward the Invite to my followers --- * Send Accept to A, B (and followers if it's a component), my-followers +-- * Send Accept to A, B, my-followers projectInvite :: UTCTime -> ProjectId @@ -4920,24 +4911,14 @@ projectInvite now projectID (Verse authorIdMsig body) invite = do mode <- case resourceOrComps of Left (Left (LocalResourceProject 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" + 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 @@ -4949,17 +4930,11 @@ 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. - invitedDB <- + collab <- bitraverse - (bitraverse - (withDBExcept . flip getGrantRecip "Invitee not found in DB") - getRemoteActorFromURI - ) - (bitraverse - (withDBExcept . flip getComponentE "Invitee not found in DB") - getRemoteActorFromURI - ) - invited + (withDBExcept . flip getGrantRecip "Invitee not found in DB") + getRemoteActorFromURI + invited maybeNew <- withDBExcept $ do @@ -4972,29 +4947,19 @@ projectInvite now projectID (Verse authorIdMsig body) invite = do verifyCapability' capability authorIdMsig (LocalResourceProject projectID) AP.RoleAdmin - case invitedDB of - - -- Verify that target doesn't already have a Collab for me - Left collab -> do - existingCollabIDs <- lift $ getExistingCollabs resourceID 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 + -- Verify that target doesn't already have a Collab for me + existingCollabIDs <- lift $ getExistingCollabs resourceID collab + 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 $ \ (inboxItemID, inviteDB) -> do -- Insert Collab or Component record to DB acceptID <- insertEmptyOutboxItem' (actorOutbox topicActor) now - case invitedDB of - Left collab -> insertCollab resourceID role collab inviteDB acceptID - Right component -> insertComponent component inviteDB acceptID + insertCollab resourceID role collab inviteDB acceptID -- Prepare forwarding Invite to my followers sieve <- do @@ -5002,7 +4967,7 @@ projectInvite now projectID (Verse authorIdMsig body) invite = do return $ makeRecipientSet [] [LocalStageProjectFollowers projectHash] -- Prepare an Accept activity and insert to my outbox - accept@(actionAccept, _, _, _) <- prepareAccept invitedDB + accept@(actionAccept, _, _, _) <- prepareAccept collab _luAccept <- updateOutboxItem' (LocalActorProject projectID) acceptID actionAccept return (topicActorID, sieve, acceptID, accept, inboxItemID) @@ -5065,42 +5030,19 @@ projectInvite now projectID (Verse authorIdMsig body) invite = do Right remoteActorID -> insert_ $ CollabRecipRemote collabID remoteActorID - 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 -> - insert_ $ ComponentLocal componentID (localComponentID l) - Right remoteActorID -> - insert_ $ ComponentRemote componentID remoteActorID - insert_ $ ComponentProjectAccept originID acceptID - prepareAccept invitedDB = do encodeRouteHome <- getEncodeRouteHome audInviter <- lift $ makeAudSenderOnly authorIdMsig audInvited <- case invitedDB of - Left (Left (GrantRecipPerson (Entity p _))) -> do + Left (GrantRecipPerson (Entity p _)) -> do ph <- encodeKeyHashid p return $ AudLocal [LocalActorPerson ph] [] - Left (Right remoteActorID) -> do + 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 = resourceToActor $ componentResource 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 <- AudLocal [] . pure . LocalStageProjectFollowers <$> encodeKeyHashid projectID