diff --git a/src/Vervis/Actor/Project.hs b/src/Vervis/Actor/Project.hs index d964ccf..01b794b 100644 --- a/src/Vervis/Actor/Project.hs +++ b/src/Vervis/Actor/Project.hs @@ -223,6 +223,37 @@ import Vervis.Web.Collab -- delegation Grant I got from B -- * To: The parent/collaborator/team to whom I'd sent the Grant -- * CC: - +-- +-- * 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) projectAccept :: UTCTime -> ProjectId @@ -236,10 +267,10 @@ projectAccept now projectID (Verse authorIdMsig body) accept = do collabOrComp_or_child <- withDBExcept $ do - myInboxID <- lift $ do + (myInboxID, meResourceID) <- lift $ do project <- getJust projectID actor <- getJust $ projectActor project - return $ actorInbox actor + return (actorInbox actor, projectResource project) -- Find the accepted activity in our DB accepteeDB <- do @@ -261,7 +292,9 @@ projectAccept now projectID (Verse authorIdMsig body) accept = do runExceptT (Right . Left <$> tryAddChildPassive accepteeDB) <|> runExceptT (Right . Left <$> tryAddParentActive accepteeDB) <|> runExceptT (Right . Left <$> tryAddParentPassive accepteeDB) <|> - runExceptT (Right . Right <$> tryRemoveChild myInboxID accepteeDB) + runExceptT (Right . Right . Left <$> tryRemoveChild myInboxID accepteeDB) <|> + runExceptT (Right . Right . Right <$> tryAddTeamActive meResourceID accepteeDB) <|> + runExceptT (Right . Right . Right <$> tryAddTeamPassive meResourceID accepteeDB) fromMaybeE maybeCollab "Accepted activity isn't an Invite/Join/Add/Remove I'm aware of" @@ -270,7 +303,8 @@ projectAccept now projectID (Verse authorIdMsig body) accept = do Left (Left collab) -> addCollab collab Left (Right comp) -> addComp comp Right (Left cp) -> addChildParent cp - Right (Right child) -> removeChild child + Right (Right (Left child)) -> removeChild child + Right (Right (Right team)) -> addTeam team where @@ -497,6 +531,41 @@ projectAccept now projectID (Verse authorIdMsig body) accept = do lift $ MaybeT $ getValBy $ UniqueInboxItemRemote inboxID remoteActivityID tryRemoveChild' i + verifySquadHolder :: ResourceId -> SquadId -> MaybeT ActDB () + verifySquadHolder meResourceID squadID = do + Squad _ r <- lift $ getJust squadID + guard $ r == meResourceID + + tryAddTeamActive' r squadID = do + usID <- lift $ MaybeT $ getKeyBy $ UniqueSquadOriginUs squadID + lift $ verifySquadHolder r squadID + topic <- lift . lift $ getSquadTeam squadID + return (squadID, topic, Left ()) + + tryAddTeamActive r (Left (_actorByKey, _actorEntity, itemID)) = do + SquadUsGestureLocal squadID _ <- + lift $ MaybeT $ getValBy $ UniqueSquadUsGestureLocalActivity itemID + tryAddTeamActive' r squadID + tryAddTeamActive r (Right remoteActivityID) = do + SquadUsGestureRemote squadID _ _ <- + lift $ MaybeT $ getValBy $ UniqueSquadUsGestureRemoteActivity remoteActivityID + tryAddTeamActive' r squadID + + tryAddTeamPassive' r themID = do + SquadOriginThem squadID <- lift . lift $ getJust themID + lift $ verifySquadHolder r squadID + topic <- lift . lift $ getSquadTeam squadID + return (squadID, topic, Right themID) + + tryAddTeamPassive r (Left (_actorByKey, _actorEntity, itemID)) = do + SquadThemGestureLocal themID _ <- + lift $ MaybeT $ getValBy $ UniqueSquadThemGestureLocalAdd itemID + tryAddTeamPassive' r themID + tryAddTeamPassive r (Right remoteActivityID) = do + SquadThemGestureRemote themID _ _ <- + lift $ MaybeT $ getValBy $ UniqueSquadThemGestureRemoteAdd remoteActivityID + tryAddTeamPassive' r themID + componentIsAuthor ident = let author = bimap (view _1) (remoteAuthorId . view _1) authorIdMsig in author == bimap (resourceToActor . componentResource . snd) snd ident @@ -506,6 +575,11 @@ projectAccept now projectID (Verse authorIdMsig body) accept = do let author = bimap (view _1) (remoteAuthorId . view _1) authorIdMsig in author == bimap (LocalActorProject . snd) snd ident + 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 + addCollab (collabID, fulfills, inviterOrJoiner) = do collab <- @@ -1428,6 +1502,157 @@ projectAccept now projectID (Verse authorIdMsig body) accept = do return (action, recipientSet, remoteActors, fwdHosts) + 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 + (LocalResourceProject projectID) + 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 + (recipActorID, recipActor) <- lift $ do + recip <- getJust projectID + let actorID = projectActor recip + (actorID,) <$> getJust actorID + + maybeAcceptDB <- lift $ insertToInbox now authorIdMsig body (actorInbox recipActor) 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 "projectAccept 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 recipActor) now + insert_ $ SquadUsAccept squadID acceptID + return acceptID + + -- Prepare forwarding of Accept to my followers + let recipByID = LocalActorProject projectID + recipByHash <- hashLocalActor recipByID + let sieve = makeRecipientSet [] [localActorFollowers recipByHash] + + maybeAct <- + for idsForGrant $ \ acceptID -> lift $ do + accept@(actionAccept, _, _, _) <- + prepareSquadAccept (bimap snd snd topic) + let recipByKey = LocalActorProject projectID + _luAccept <- updateOutboxItem' recipByKey acceptID actionAccept + return (acceptID, accept) + + return (recipActorID, sieve, maybeAct, inboxItemID) + + case maybeNew of + Nothing -> done "I already have this activity in my inbox" + Just (recipActorID, sieve, maybeGrant, inboxItemID) -> do + let recipByID = LocalActorProject projectID + forwardActivity authorIdMsig body recipByID recipActorID sieve + lift $ for_ maybeGrant $ \ (grantID, (actionGrant, localRecipsGrant, remoteRecipsGrant, fwdHostsGrant)) -> + sendActivity + recipByID 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 . LocalStageProjectFollowers <$> + encodeKeyHashid projectID + 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) + checkExistingComponents :: ProjectId -> Either (ComponentBy Entity) RemoteActorId -> ActDBE () checkExistingComponents projectID componentDB = do