diff --git a/src/Vervis/Actor/Group.hs b/src/Vervis/Actor/Group.hs index 6b5ac5f..9bd461b 100644 --- a/src/Vervis/Actor/Group.hs +++ b/src/Vervis/Actor/Group.hs @@ -944,6 +944,41 @@ groupAdd now groupID (Verse authorIdMsig body) add = do -- delegation Grant I got from B -- * To: The parent/collaborator/team to whom I'd sent the Grant -- * CC: - +-- +-- * Give me a new resource active EffortOriginUs +-- * Verify we haven't yet seen resource's Accept +-- * Insert the Accept to my inbox +-- * If sender is the resource, record the Accept into the Effort record +-- * Prepare to send degelator-Grant +-- * Otherwise nothing to do +-- * Forward the Accept to my followers +-- * Possibly send a Grant: +-- * If sender is the resource +-- * delegator-Grant +-- * To: Resource +-- * CC: +-- - Resource's followers +-- - My followers +-- +-- * Give me a new resource passive EffortOriginThem +-- * Option 1: We haven't seen resource's Accept yet +-- * Verify sender is the resource +-- * Option 2: We 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 +-- * Option 1: Record resource's Accept in Effort record +-- * Option 2: Record my collaborator's Accept +-- * Prepare to send delegator-Grant +-- * Forward the Accept to my followers +-- * Possibly send a Grant: +-- * In option 2 +-- * delegator-Grant +-- * To: Resource +-- * CC: +-- - Resource's followers +-- - My followers +-- - The Accept sender (my collaborator) groupAccept :: UTCTime -> GroupId @@ -972,8 +1007,10 @@ groupAccept now groupID (Verse authorIdMsig body) accept = do let adapt = maybe (Right Nothing) (either Left (Right . Just)) maybeCollab <- ExceptT $ fmap adapt $ runMaybeT $ - runExceptT (Left <$> tryInviteCollab accepteeDB) <|> - runExceptT (Left <$> tryJoinCollab accepteeDB) <|> + runExceptT (Left . Left <$> tryInviteCollab accepteeDB) <|> + runExceptT (Left . Left <$> tryJoinCollab accepteeDB) <|> + runExceptT (Left . Right <$> tryAddResourceActive accepteeDB) <|> + runExceptT (Left . Right <$> tryAddResourcePassive accepteeDB) <|> runExceptT (Right . Left <$> tryAddChildActive accepteeDB) <|> runExceptT (Right . Left <$> tryAddChildPassive accepteeDB) <|> runExceptT (Right . Left <$> tryAddParentActive accepteeDB) <|> @@ -984,7 +1021,8 @@ groupAccept now groupID (Verse authorIdMsig body) accept = do "Accepted activity isn't an Invite/Join/Add/Remove I'm aware of" case collabOrComp_or_child of - Left collab -> addCollab collab + Left (Left collab) -> addCollab collab + Left (Right resource) -> addResource resource Right (Left cp) -> addChildParent cp Right (Right parent) -> removeParent parent @@ -1174,6 +1212,41 @@ groupAccept now groupID (Verse authorIdMsig body) accept = do lift $ MaybeT $ getValBy $ UniqueInboxItemRemote inboxID remoteActivityID tryRemoveParent' i + verifyEffortHolder :: EffortId -> MaybeT ActDB () + verifyEffortHolder effortID = do + Effort _ g <- lift $ getJust effortID + guard $ g == groupID + + tryAddResourceActive' usID = do + EffortOriginUs effortID <- lift . lift $ getJust usID + lift $ verifyEffortHolder effortID + topic <- lift . lift $ getEffortTopic effortID + return (effortID, topic, Left ()) + + tryAddResourceActive (Left (_actorByKey, _actorEntity, itemID)) = do + EffortUsGestureLocal usID _ <- + lift $ MaybeT $ getValBy $ UniqueEffortUsGestureLocalAdd itemID + tryAddResourceActive' usID + tryAddResourceActive (Right remoteActivityID) = do + EffortUsGestureRemote usID _ _ <- + lift $ MaybeT $ getValBy $ UniqueEffortUsGestureRemoteAdd remoteActivityID + tryAddResourceActive' usID + + tryAddResourcePassive' themID = do + EffortOriginThem effortID <- lift . lift $ getJust themID + lift $ verifyEffortHolder effortID + topic <- lift . lift $ getEffortTopic effortID + return (effortID, topic, Right ()) + + tryAddResourcePassive (Left (_actorByKey, _actorEntity, itemID)) = do + EffortThemGestureLocal themID _ <- + lift $ MaybeT $ getValBy $ UniqueEffortThemGestureLocalAdd itemID + tryAddResourcePassive' themID + tryAddResourcePassive (Right remoteActivityID) = do + EffortThemGestureRemote themID _ _ <- + lift $ MaybeT $ getValBy $ UniqueEffortThemGestureRemoteAdd remoteActivityID + tryAddResourcePassive' themID + componentIsAuthor ident = let author = bimap (view _1) (remoteAuthorId . view _1) authorIdMsig in author == bimap (resourceToActor . componentResource . snd) snd ident @@ -1183,6 +1256,11 @@ groupAccept now groupID (Verse authorIdMsig body) accept = do let author = bimap (view _1) (remoteAuthorId . view _1) authorIdMsig in author == bimap (LocalActorGroup . snd) snd ident + theyIsAuthor' :: Either (a, LocalResourceBy Key) (b, RemoteActorId) -> Bool + theyIsAuthor' ident = + let author = bimap (view _1) (remoteAuthorId . view _1) authorIdMsig + in author == bimap (resourceToActor . snd) snd ident + addCollab (collabID, fulfills, inviterOrJoiner) = do collab <- @@ -1915,6 +1993,212 @@ groupAccept now groupID (Verse authorIdMsig body) accept = do return (action, recipientSet, remoteActors, fwdHosts) + addResource (effortID, topic', mode) = do + + topic <- + lift $ traverseOf _Left (traverseOf _2 $ withDB . getLocalResource) topic' + mode' <- + bitraverse + + -- Resource-active mode + -- Verify we haven't yet seen resource's Accept + (\ () -> do + maybeResourceAccept <- + lift $ withDB $ + case bimap fst fst topic of + Left localID -> (() <$) <$> getBy (UniqueEffortThemAcceptLocal localID) + Right remoteID -> (() <$) <$> getBy (UniqueEffortThemAcceptRemote remoteID) + verifyNothingE maybeResourceAccept "I already saw resource's Accept" + ) + + -- Resource-passive mode + -- Option 1: We haven't seen resource's Accept yet + -- * Verify sender is the resource + -- Option 2: We saw it, but not my collaborator's Accept + -- * Verify the Accept is authorized + -- Otherwise respond with error, no Accept is needed + (\ () -> do + (maybeResourceAccept, maybeGrant) <- + lift $ withDB $ liftA2 (,) + (case bimap fst fst topic of + Left localID -> (() <$) <$> getBy (UniqueEffortThemAcceptLocal localID) + Right remoteID -> (() <$) <$> getBy (UniqueEffortThemAcceptRemote remoteID) + ) + (getBy $ UniqueEffortUsSendDelegator effortID) + case (isJust maybeResourceAccept, isJust maybeGrant) of + (False, True) -> error "Impossible/bug, didn't see resource's Accept but sent a Grant" + (False, False) -> do + unless (theyIsAuthor' topic) $ + throwE "The Accept I'm waiting for is from my new resource" + return $ Left () + (True, False) -> do + let muCap = AP.activityCapability $ actbActivity body + uCap <- fromMaybeE muCap "No capability provided" + verifyCapability'' + uCap + authorIdMsig + (LocalResourceGroup groupID) + AP.RoleAdmin + return $ Right () + (True, True) -> throwE "Resource already enabled, not needing any further Accept" + ) + + mode + + maybeNew <- withDBExcept $ do + + -- Grab me from DB + (recipActorID, recipActor) <- lift $ do + recip <- getJust groupID + let actorID = groupActor recip + (actorID,) <$> getJust actorID + + maybeAcceptDB <- lift $ insertToInbox now authorIdMsig body (actorInbox recipActor) False + for maybeAcceptDB $ \ (inboxItemID, acceptDB) -> do + + idsForGrant <- + lift $ + bitraverse + + -- Resource-active mode + -- If sender is resource, record the Accept into the + -- Effort record & prepare to send degelator-Grant + -- Othrerwise do nothing + (\ () -> + if theyIsAuthor' topic + then Just <$> do + case (topic, acceptDB) of + (Left (localID, _), Left (_, _, acceptID)) -> + insert_ $ EffortThemAcceptLocal localID acceptID + (Right (remoteID, _), Right (_, _, acceptID)) -> + insert_ $ EffortThemAcceptRemote remoteID acceptID + _ -> error "groupAccept impossible iv" + grantID <- insertEmptyOutboxItem' (actorOutbox recipActor) now + insert_ $ EffortUsSendDelegator effortID grantID + return grantID + else pure Nothing + ) + + -- Resource-passive mode + (\case + + -- Getting an Accept from the resource + -- Record resource's Accept in Effort record + Left () -> do + case (topic, acceptDB) of + (Left (localID, _), Left (_, _, acceptID)) -> + insert_ $ EffortThemAcceptLocal localID acceptID + (Right (remoteID, _), Right (_, _, acceptID)) -> + insert_ $ EffortThemAcceptRemote remoteID acceptID + _ -> error "groupAccept impossible v" + return Nothing + + -- Getting an Accept from my collaborator + -- Record my collaborator's Accept + -- Prepare to send delegator-Grant + Right () -> Just <$> do + {- + case (topic, acceptDB) of + (Left (localID, _), Left (_, _, acceptID)) -> + insert_ $ ? localID acceptID + (Right (remoteID, _), Right (_, _, acceptID)) -> + insert_ $ ? remoteID acceptID + _ -> error "groupAccept impossible iv" + -} + grantID <- insertEmptyOutboxItem' (actorOutbox recipActor) now + insert_ $ EffortUsSendDelegator effortID grantID + return grantID + ) + + mode' + + -- Prepare forwarding of Accept to my followers + let recipByID = LocalActorGroup groupID + recipByHash <- hashLocalActor recipByID + let sieve = makeRecipientSet [] [localActorFollowers recipByHash] + + maybeAct <- + case idsForGrant of + Left mg -> for mg $ \ grantID -> lift $ do + grant@(actionGrant, _, _, _) <- + prepareEffortDelegGrant (bimap snd snd topic) False + let recipByKey = LocalActorGroup groupID + _luGrant <- updateOutboxItem' recipByKey grantID actionGrant + return (grantID, grant) + + Right mg -> for mg $ \ grantID -> lift $ do + grant@(actionGrant, _, _, _) <- + prepareEffortDelegGrant (bimap snd snd topic) True + let recipByKey = LocalActorGroup groupID + _luGrant <- updateOutboxItem' recipByKey grantID actionGrant + return (grantID, grant) + + 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 = LocalActorGroup groupID + forwardActivity authorIdMsig body recipByID recipActorID sieve + lift $ for_ maybeGrant $ \ (grantID, (actionGrant, localRecipsGrant, remoteRecipsGrant, fwdHostsGrant)) -> + sendActivity + recipByID recipActorID localRecipsGrant + remoteRecipsGrant fwdHostsGrant grantID actionGrant + doneDB inboxItemID "[Resource] Forwarded the Accept and maybe published a Grant/Accept" + + where + + prepareEffortDelegGrant ident includeAuthor = do + encodeRouteHome <- getEncodeRouteHome + encodeRouteLocal <- getEncodeRouteLocal + + (uResource, audResource) <- + case ident of + Left lr -> do + la <- resourceToActor <$> hashLocalResource lr + return + ( encodeRouteHome $ renderLocalActor la + , AudLocal [la] [localActorFollowers la] + ) + Right raID -> do + ra <- getJust raID + u@(ObjURI h lu) <- getRemoteActorURI ra + return + ( u + , AudRemote h [lu] (maybeToList $ remoteActorFollowers ra) + ) + audAuthor <- lift $ makeAudSenderOnly authorIdMsig + groupHash <- encodeKeyHashid groupID + let audGroup = AudLocal [] [LocalStageGroupFollowers groupHash] + + audience = + if includeAuthor + then [audResource, audGroup, audAuthor] + else [audResource, audGroup] + + (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.RXDelegator + , AP.grantContext = encodeRouteHome $ GroupR groupHash + , AP.grantTarget = uResource + , 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