diff --git a/src/Vervis/Actor/Common.hs b/src/Vervis/Actor/Common.hs index beba856..8a5ddf3 100644 --- a/src/Vervis/Actor/Common.hs +++ b/src/Vervis/Actor/Common.hs @@ -231,6 +231,37 @@ actorFollow parseFollowee grabActor unread getFollowee getSieve makeLocalActor m -- * If I've already seen the project's accept, respond with error -- * Otherwise, just ignore the Accept -- * Otherwise respond with error +-- +-- * Add-a-Team mode +-- * Give me a new team active SquadOriginUs +-- * Respond with error, we aren't supposed to get any Accept +-- * Give me a new team passive SquadOriginThem +-- * Option 1: I haven't yet seen parent's Accept +-- * Verify sender is the parent +-- * Option 2: I saw it, but not my collaborator's Accept +-- * Verify the accept is authorized +-- * Otherwise respond with error, no Accept is needed +-- +-- * Insert the Accept to my inbox +-- +-- * In team-passive mode, +-- * Option 1: Record team's Accept in the Dest record +-- * Option 2: Record my collaborator's Accept in the Squad record +-- * Prepare to send my own Accept +-- +-- * Forward the Accept to my followers +-- +-- * Possibly send a Grant/Accept: +-- * Team-passive +-- * In option 2 +-- * Accept +-- * Object: The Add +-- * Fulfills: My collaborator's Accept +-- * To: Team +-- * CC: +-- - Team's followers +-- - My followers +-- - The Accept sender (my collaborator) topicAccept :: forall topic. (PersistRecordBackend topic SqlBackend, ToBackendKey SqlBackend topic) @@ -246,14 +277,6 @@ topicAccept grabResource topicComponent now recipKey (Verse authorIdMsig body) a -- Check input acceptee <- parseAccept accept - -- Verify the capability URI, if provided, 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) - -- Grab me from DB (resourceID, recipActorID, recipActor) <- lift $ withDB $ do resourceID <- grabResource <$> getJust recipKey @@ -261,7 +284,7 @@ topicAccept grabResource topicComponent now recipKey (Verse authorIdMsig body) a recipActor <- getJust recipActorID return (resourceID, recipActorID, recipActor) - collabOrStem <- withDBExcept $ do + mode <- withDBExcept $ do -- Find the accepted activity in our DB accepteeDB <- do @@ -274,20 +297,30 @@ topicAccept grabResource topicComponent now recipKey (Verse authorIdMsig body) a -- component, grabbing the Stem record from our DB maybeCollabOrStem <- lift $ runMaybeT $ - Left . Left <$> tryInviteCollab accepteeDB <|> - Left . Right <$> tryJoinCollab accepteeDB <|> - Right . Left <$> tryInviteComp accepteeDB <|> - Right . Right <$> tryAddComp accepteeDB + Left . Left . Left <$> tryInviteCollab accepteeDB <|> + Left . Left . Right <$> tryJoinCollab accepteeDB <|> + Left . Right . Left <$> tryInviteComp accepteeDB <|> + Left . Right . Right <$> tryAddComp accepteeDB <|> + Right <$> tryAddTeamActive resourceID accepteeDB <|> + Right <$> tryAddTeamPassive resourceID accepteeDB fromMaybeE maybeCollabOrStem "Accepted activity isn't an Invite/Join/Add I'm aware of" - case collabOrStem of - Left collab -> - topicAcceptCollab maybeCap recipActorID recipActor collab - Right stem -> - topicAcceptStem maybeCap recipActorID recipActor stem + case mode of + Left (Left collab) -> + topicAcceptCollab recipActorID recipActor collab + Left (Right stem) -> + topicAcceptStem recipActorID recipActor stem + Right team -> addTeam team where + meID = recipKey + toComponent = topicComponent + + meComponent = toComponent recipKey + meResource = componentResource meComponent + meActor = resourceToActor meResource + topicResource :: forall f. f topic -> LocalResourceBy f topicResource = componentResource . topicComponent @@ -343,6 +376,41 @@ topicAccept grabResource topicComponent now recipKey (Verse authorIdMsig body) a lift $ (,remoteActorFollowers actor,remoteActivityID) <$> getRemoteActorURI actor return (stemID, originID, Right adder) + verifySquadHolder :: ResourceId -> SquadId -> MaybeT ActDB () + verifySquadHolder meResourceID squadID = do + Squad _ r <- lift $ getJust squadID + guard $ r == meResourceID + + tryAddTeamActive' r squadID = do + usID <- MaybeT $ getKeyBy $ UniqueSquadOriginUs squadID + verifySquadHolder r squadID + topic <- lift $ getSquadTeam squadID + return (squadID, topic, Left ()) + + tryAddTeamActive r (Left (_actorByKey, _actorEntity, itemID)) = do + SquadUsGestureLocal squadID _ <- + MaybeT $ getValBy $ UniqueSquadUsGestureLocalActivity itemID + tryAddTeamActive' r squadID + tryAddTeamActive r (Right remoteActivityID) = do + SquadUsGestureRemote squadID _ _ <- + MaybeT $ getValBy $ UniqueSquadUsGestureRemoteActivity remoteActivityID + tryAddTeamActive' r squadID + + tryAddTeamPassive' r themID = do + SquadOriginThem squadID <- lift $ getJust themID + verifySquadHolder r squadID + topic <- lift $ getSquadTeam squadID + return (squadID, topic, Right themID) + + tryAddTeamPassive r (Left (_actorByKey, _actorEntity, itemID)) = do + SquadThemGestureLocal themID _ <- + MaybeT $ getValBy $ UniqueSquadThemGestureLocalAdd itemID + tryAddTeamPassive' r themID + tryAddTeamPassive r (Right remoteActivityID) = do + SquadThemGestureRemote themID _ _ <- + MaybeT $ getValBy $ UniqueSquadThemGestureRemoteAdd remoteActivityID + tryAddTeamPassive' r themID + prepareGrant isInvite sender role = do encodeRouteHome <- getEncodeRouteHome encodeRouteLocal <- getEncodeRouteLocal @@ -405,7 +473,15 @@ topicAccept grabResource topicComponent now recipKey (Verse authorIdMsig body) a return (action, recipientSet, remoteActors, fwdHosts) - topicAcceptCollab maybeCap recipActorID recipActor collab = do + topicAcceptCollab recipActorID recipActor collab = do + + -- Verify the capability URI, if provided, 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 @@ -568,7 +644,15 @@ topicAccept grabResource topicComponent now recipKey (Verse authorIdMsig body) a return (action, recipientSet, remoteActors, fwdHosts) - topicAcceptStem maybeCap recipActorID recipActor stem = do + topicAcceptStem recipActorID recipActor stem = do + + -- Verify the capability URI, if provided, 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 @@ -695,6 +779,159 @@ topicAccept grabResource topicComponent now recipKey (Verse authorIdMsig body) a remoteRecipsReact fwdHostsReact reactID actionReact doneDB inboxItemID "Forwarded the Accept and published an Accept" + theyIsAuthor' :: Either (a, GroupId) (b, RemoteActorId) -> Bool + theyIsAuthor' ident = + let author = bimap (view _1) (remoteAuthorId . view _1) authorIdMsig + in author == bimap (LocalActorGroup . snd) snd ident + + addTeam (squadID, topic, mode) = do + + (themID, mode') <- + case mode of + + -- Team-active mode + -- Respond with error, we aren't supposed to get any Accept + Left () -> throwE "Team-active (SquadOriginUs) mode, I'm not expecting any Accept" + + -- Team-passive mode + -- Option 1: I haven't yet seen team's Accept + -- * Verify sender is the team + -- Option 2: I saw it, but not my collaborator's Accept + -- * Verify the accept is authorized + -- Otherwise respond with error, no Accept is needed + Right themID -> (themID,) <$> do + (maybeTeamAccept, maybeUsGesture) <- + lift $ withDB $ liftA2 (,) + (case bimap fst fst topic of + Left localID -> (() <$) <$> getBy (UniqueSquadThemAcceptLocalTopic localID) + Right remoteID -> (() <$) <$> getBy (UniqueSquadThemAcceptRemoteTopic remoteID) + ) + (do l <- getBy $ UniqueSquadUsGestureLocal squadID + r <- getBy $ UniqueSquadUsGestureRemote squadID + case (isJust l, isJust r) of + (False, False) -> pure Nothing + (False, True) -> pure $ Just () + (True, False) -> pure $ Just () + (True, True) -> error "Both SquadUsGestureLocal and SquadUsGestureRemote" + ) + case (isJust maybeTeamAccept, isJust maybeUsGesture) of + (False, True) -> error "Impossible/bug, didn't see team's Accept but recorded my collaborator's Accept" + (False, False) -> do + unless (theyIsAuthor' topic) $ + throwE "The Accept I'm waiting for is from my new team" + return $ Left () + (True, False) -> do + let muCap = AP.activityCapability $ actbActivity body + uCap <- fromMaybeE muCap "No capability provided" + verifyCapability'' + uCap + authorIdMsig + meResource + AP.RoleAdmin + return $ Right () + (True, True) -> throwE "Just waiting for Grant from team, or already have it, anyway not needing any further Accept" + + maybeNew <- withDBExcept $ do + + -- Grab me from DB + meResourceID <- lift $ grabResource <$> getJust meID + Resource meActorID <- lift $ getJust meResourceID + meActorDB <- lift $ getJust meActorID + + maybeAcceptDB <- lift $ insertToInbox now authorIdMsig body (actorInbox meActorDB) False + for maybeAcceptDB $ \ (inboxItemID, acceptDB) -> do + + idsForGrant <- + lift $ case mode' of + + -- Getting an Accept from the team + -- Record team's Accept in the Squad record + Left () -> do + case (topic, acceptDB) of + (Left (localID, _), Left (_, _, acceptID)) -> + insert_ $ SquadThemAcceptLocal themID localID acceptID + (Right (remoteID, _), Right (_, _, acceptID)) -> + insert_ $ SquadThemAcceptRemote themID remoteID acceptID + _ -> error "topicAccept impossible v" + return Nothing + + -- Getting an Accept from my collaborator + -- Record my collaborator's Accept in the Squad record + -- Prepare to send my own Accept + Right () -> Just <$> do + case acceptDB of + Left (_, _, acceptID) -> + insert_ $ SquadUsGestureLocal squadID acceptID + Right (author, _, acceptID) -> + insert_ $ SquadUsGestureRemote squadID (remoteAuthorId author) acceptID + acceptID <- insertEmptyOutboxItem' (actorOutbox meActorDB) now + insert_ $ SquadUsAccept squadID acceptID + return acceptID + + -- Prepare forwarding of Accept to my followers + sieve <- do + h <- hashLocalActor meActor + return $ makeRecipientSet [] [localActorFollowers h] + + maybeAct <- + for idsForGrant $ \ acceptID -> lift $ do + accept@(actionAccept, _, _, _) <- + prepareSquadAccept (bimap snd snd topic) + _luAccept <- updateOutboxItem' meActor acceptID actionAccept + return (acceptID, accept) + + return (meActorID, sieve, maybeAct, inboxItemID) + + case maybeNew of + Nothing -> done "I already have this activity in my inbox" + Just (recipActorID, sieve, maybeGrant, inboxItemID) -> do + forwardActivity authorIdMsig body meActor recipActorID sieve + lift $ for_ maybeGrant $ \ (grantID, (actionGrant, localRecipsGrant, remoteRecipsGrant, fwdHostsGrant)) -> + sendActivity + meActor recipActorID localRecipsGrant + remoteRecipsGrant fwdHostsGrant grantID actionGrant + doneDB inboxItemID "[Team] Forwarded the Accept and maybe published a Grant/Accept" + + where + + prepareSquadAccept topic = do + encodeRouteHome <- getEncodeRouteHome + + audMyCollab <- lift $ makeAudSenderOnly authorIdMsig + audSquad <- + case topic of + Left j -> do + h <- encodeKeyHashid j + return $ + AudLocal [LocalActorGroup h] [LocalStageGroupFollowers h] + Right raID -> do + ra <- getJust raID + ObjURI h lu <- getRemoteActorURI ra + return $ + AudRemote h [lu] (maybeToList $ remoteActorFollowers ra) + audMe <- + AudLocal [] . pure . localActorFollowers <$> + hashLocalActor meActor + uCollabAccept <- lift $ getActivityURI authorIdMsig + let uAdd = AP.acceptObject accept + + (recipientSet, remoteActors, fwdHosts, audLocal, audRemote) = + collectAudience [audMyCollab, audSquad, audMe] + + recips = map encodeRouteHome audLocal ++ audRemote + action = AP.Action + { AP.actionCapability = Nothing + , AP.actionSummary = Nothing + , AP.actionAudience = AP.Audience recips [] [] [] [] [] + , AP.actionFulfills = [uCollabAccept] + , AP.actionSpecific = AP.AcceptActivity AP.Accept + { AP.acceptObject = uAdd + , AP.acceptResult = Nothing + } + } + + return (action, recipientSet, remoteActors, fwdHosts) + topicReject :: (PersistRecordBackend topic SqlBackend, ToBackendKey SqlBackend topic) => (topic -> ResourceId) diff --git a/src/Vervis/Actor/Deck.hs b/src/Vervis/Actor/Deck.hs index 9a5a90d..bd131ea 100644 --- a/src/Vervis/Actor/Deck.hs +++ b/src/Vervis/Actor/Deck.hs @@ -541,38 +541,6 @@ deckFollow now recipDeckID verse follow = do -- Access ------------------------------------------------------------------------------ --- Meaning: An actor accepted something --- Behavior: --- * If it's on an Invite where I'm the resource: --- * Verify the Accept is by the Invite target --- * Forward the Accept to my followers --- * Send a Grant: --- * To: Accepter (i.e. Invite target) --- * CC: Invite sender, Accepter's followers, my followers --- * If it's on a Join where I'm the resource: --- * Verify the Accept is authorized --- * Forward the Accept to my followers --- * Send a Grant: --- * To: Join sender --- * CC: Accept sender, Join sender's followers, my followers --- * If it's an Invite (that I know about) where I'm invited to a project: --- * If I haven't yet seen the project's approval: --- * Verify the author is the project --- * Record the approval in the Stem record in DB --- * If I saw project's approval, but not my collaborators' approval: --- * Verify the Accept is authorized --- * Record the approval in the Stem record in DB --- * Forward to my followers --- * Publish and send an Accept: --- * To: Inviter, project, Accept author --- * CC: Project followers, my followers --- * Record it in the Stem record in DB as well --- * If I already saw both approvals, respond with error --- * If it's an Add (that I know about and already Accepted) where I'm --- invited to a project: --- * If I've already seen the project's accept, respond with error --- * Otherwise, just ignore the Accept --- * Otherwise respond with error deckAccept :: UTCTime -> DeckId