From 702ad39b961b3a9a45a91f881b171dac83ddcb17 Mon Sep 17 00:00:00 2001 From: Pere Lev Date: Sat, 9 Dec 2023 02:46:11 +0200 Subject: [PATCH] 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