diff --git a/src/Vervis/Actor/Group.hs b/src/Vervis/Actor/Group.hs index c95797f..1cebbd7 100644 --- a/src/Vervis/Actor/Group.hs +++ b/src/Vervis/Actor/Group.hs @@ -35,6 +35,7 @@ import Data.ByteString (ByteString) import Data.Either import Data.Foldable import Data.Maybe +import Data.List.NonEmpty (NonEmpty (..)) import Data.Text (Text) import Data.Time.Clock import Data.Traversable @@ -605,17 +606,50 @@ groupAdd now groupID (Verse authorIdMsig body) add = do -- * Verify the Accept is by the Invite target -- * Is it a Join to be a collaborator in me? -- * Verify the Accept is authorized +-- * Is it an Invite to be a component of me? +-- * Nothing to check at this point +-- +-- * Give me a new child active SourceOriginUs +-- * Verify we haven't yet seen child's Accept +-- * Give me a new child passive SourceOriginThem +-- * Option 1: We haven't seen child's Accept yet +-- * Verify sender is the child +-- * Option 2: We saw it, but not my collaborator's Accept +-- * Verify the Accept is authorized +-- * Otherwise respond with error, no Accept is needed +-- * Give me a new parent active DestOriginUs +-- * Respond with error, we aren't supposed to get any Accept +-- * Give me a new parent passive DestOriginThem +-- * 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 +-- -- * If it's none of these, respond with error -- --- * Verify the Collab isn't enabled yet +-- * In collab mode, verify the Collab isn't enabled yet -- -- * Insert the Accept to my inbox -- --- * Record the Accept and enable the Collab in DB +-- * In collab mode, record the Accept and enable the Collab in DB +-- +-- * In child-active mode, +-- * If sender is the child, record the Accept into the Source record +-- * Prepare to send degelator-Grant +-- * Otherwise nothing to do +-- * In child-passive mode, +-- * Option 1: Record child's Accept in Source record +-- * Option 2: Record my collaborator's Accept +-- * Prepare to send delegator-Grant +-- * In parent-passive mode, +-- * Option 1: Record parent's Accept in the Dest record +-- * Option 2: Record my collaborator's Accept in the Dest record +-- * Prepare to send my own Accept -- -- * Forward the Accept to my followers -- --- * Possibly send a Grant: +-- * Possibly send a Grant/Accept: -- * For Invite-collab mode: -- * Regular collaborator-Grant -- * To: Accepter (i.e. Invite target) @@ -624,6 +658,45 @@ groupAdd now groupID (Verse authorIdMsig body) add = do -- * Regular collaborator-Grant -- * To: Join sender -- * CC: Accept sender, Join sender's followers, my followers +-- +-- * Child-active +-- * If sender is the child +-- * delegator-Grant +-- * To: Child +-- * CC: +-- - Child's followers +-- - My followers +-- * Child-passive +-- * In option 2 +-- * delegator-Grant +-- * To: Child +-- * CC: +-- - Child's followers +-- - My followers +-- - The Accept sender (my collaborator) +-- * Parent-passive +-- * In option 2 +-- * Accept +-- * Object: The Add +-- * Fulfills: My collaborator's Accept +-- * To: Parent +-- * CC: +-- - Parent's followers +-- - My followers +-- - The Accept sender (my collaborator) +-- +-- * Remove-Parent-Passive mode: +-- * Verify the Source is enabled +-- * Verify the sender is the child +-- * Delete the entire Source record +-- * Forward the Accept to my followers +-- * Send a Revoke on the delegator-Grant I had for B: +-- * To: Actor B +-- * CC: Actor A, B's followers, my followers +-- * Send a Revoke on every extention-Grant I extended on every +-- delegation Grant I got from B +-- * To: The parent/collaborator/team to whom I'd sent the Grant +-- * CC: - groupAccept :: UTCTime -> GroupId @@ -635,21 +708,12 @@ 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) + collabOrComp_or_child <- withDBExcept $ do - maybeNew <- withDBExcept $ do - - -- Grab me from DB - (recipActorID, recipActor) <- lift $ do - recip <- getJust groupID - let actorID = groupActor recip - (actorID,) <$> getJust actorID + myInboxID <- lift $ do + group <- getJust groupID + actor <- getJust $ groupActor group + return $ actorInbox actor -- Find the accepted activity in our DB accepteeDB <- do @@ -658,115 +722,24 @@ groupAccept now groupID (Verse authorIdMsig body) accept = do -- 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" + let adapt = maybe (Right Nothing) (either Left (Right . Just)) + maybeCollab <- + ExceptT $ fmap adapt $ runMaybeT $ + runExceptT (Left <$> tryInviteCollab accepteeDB) <|> + runExceptT (Left <$> tryJoinCollab accepteeDB) <|> + runExceptT (Right . Left <$> tryAddChildActive accepteeDB) <|> + runExceptT (Right . Left <$> tryAddChildPassive accepteeDB) <|> + runExceptT (Right . Left <$> tryAddParentActive accepteeDB) <|> + runExceptT (Right . Left <$> tryAddParentPassive accepteeDB) <|> + runExceptT (Right . Right <$> tryRemoveParent myInboxID accepteeDB) + fromMaybeE + maybeCollab + "Accepted activity isn't an Invite/Join/Add/Remove 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 - (LocalResourceGroup 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 $ \ (inboxItemID, 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 (isJust 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, 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 "Forwarded the Accept and maybe published a Grant" + case collabOrComp_or_child of + Left collab -> addCollab collab + Right (Left cp) -> addChildParent cp + Right (Right parent) -> removeParent parent where @@ -822,6 +795,520 @@ groupAccept now groupID (Verse authorIdMsig body) accept = do (,remoteActorFollowers actor) <$> getRemoteActorURI actor return (collabID, Right fulfillsID, Right joiner) + verifySourceHolder :: SourceId -> MaybeT ActDB () + verifySourceHolder sourceID = do + SourceHolderGroup _ j <- MaybeT $ getValBy $ UniqueSourceHolderGroup sourceID + guard $ j == groupID + + tryAddParentActive' usID = do + SourceOriginUs sourceID <- lift . lift $ getJust usID + lift $ verifySourceHolder sourceID + topic <- do + t <- lift . lift $ getSourceTopic sourceID + bitraverse + (\ (l, k) -> + case k of + Right j -> pure (l, j) + Left _ -> error "Group Source topic is a Project, impossible" + ) + pure + t + return $ Left (sourceID, topic, Left ()) + + tryAddParentActive (Left (_actorByKey, _actorEntity, itemID)) = do + SourceUsGestureLocal usID _ <- + lift $ MaybeT $ getValBy $ UniqueSourceUsGestureLocalAdd itemID + tryAddParentActive' usID + tryAddParentActive (Right remoteActivityID) = do + SourceUsGestureRemote usID _ _ <- + lift $ MaybeT $ getValBy $ UniqueSourceUsGestureRemoteAdd remoteActivityID + tryAddParentActive' usID + + tryAddParentPassive' themID = do + SourceOriginThem sourceID <- lift . lift $ getJust themID + lift $ verifySourceHolder sourceID + topic <- do + t <- lift . lift $ getSourceTopic sourceID + bitraverse + (\ (l, k) -> + case k of + Right j -> pure (l, j) + Left _ -> error "Group Source topic is a Project, impossible" + ) + pure + t + return $ Left (sourceID, topic, Right ()) + + tryAddParentPassive (Left (_actorByKey, _actorEntity, itemID)) = do + SourceThemGestureLocal themID _ <- + lift $ MaybeT $ getValBy $ UniqueSourceThemGestureLocalAdd itemID + tryAddParentPassive' themID + tryAddParentPassive (Right remoteActivityID) = do + SourceThemGestureRemote themID _ _ <- + lift $ MaybeT $ getValBy $ UniqueSourceThemGestureRemoteAdd remoteActivityID + tryAddParentPassive' themID + + verifyDestHolder :: DestId -> MaybeT ActDB () + verifyDestHolder destID = do + DestHolderGroup _ j <- MaybeT $ getValBy $ UniqueDestHolderGroup destID + guard $ j == groupID + + tryAddChildActive' destID = do + usID <- lift $ MaybeT $ getKeyBy $ UniqueDestOriginUs destID + lift $ verifyDestHolder destID + topic <- do + t <- lift . lift $ getDestTopic destID + bitraverse + (\ (l, k) -> + case k of + Right j -> pure (l, j) + Left _ -> error "Group Dest topic is a Project, impossible" + ) + pure + t + return $ Right (destID, topic, Left ()) + + tryAddChildActive (Left (_actorByKey, _actorEntity, itemID)) = do + DestUsGestureLocal destID _ <- + lift $ MaybeT $ getValBy $ UniqueDestUsGestureLocalActivity itemID + tryAddChildActive' destID + tryAddChildActive (Right remoteActivityID) = do + DestUsGestureRemote destID _ _ <- + lift $ MaybeT $ getValBy $ UniqueDestUsGestureRemoteActivity remoteActivityID + tryAddChildActive' destID + + tryAddChildPassive' themID = do + DestOriginThem destID <- lift . lift $ getJust themID + lift $ verifyDestHolder destID + topic <- do + t <- lift . lift $ getDestTopic destID + bitraverse + (\ (l, k) -> + case k of + Right j -> pure (l, j) + Left _ -> error "Group Dest topic is a Project, impossible" + ) + pure + t + return $ Right (destID, topic, Right themID) + + tryAddChildPassive (Left (_actorByKey, _actorEntity, itemID)) = do + DestThemGestureLocal themID _ <- + lift $ MaybeT $ getValBy $ UniqueDestThemGestureLocalAdd itemID + tryAddChildPassive' themID + tryAddChildPassive (Right remoteActivityID) = do + DestThemGestureRemote themID _ _ <- + lift $ MaybeT $ getValBy $ UniqueDestThemGestureRemoteAdd remoteActivityID + tryAddChildPassive' themID + + tryRemoveParent' itemID = do + SourceRemove sendID _ <- + lift $ MaybeT $ getValBy $ UniqueSourceRemove itemID + SourceUsSendDelegator sourceID grantID <- lift $ lift $ getJust sendID + lift $ verifySourceHolder sourceID + topic <- do + t <- lift . lift $ getSourceTopic sourceID + bitraverse + (\ (l, k) -> + case k of + Right j -> pure (l, j) + Left _ -> error "Group Source topic is a Project, impossible" + ) + pure + t + return (sourceID, sendID, grantID, topic) + + tryRemoveParent inboxID (Left (_actorByKey, _actorEntity, itemID)) = do + InboxItemLocal _ _ i <- + lift $ MaybeT $ getValBy $ UniqueInboxItemLocal inboxID itemID + tryRemoveParent' i + tryRemoveParent inboxID (Right remoteActivityID) = do + InboxItemRemote _ _ i <- + lift $ MaybeT $ getValBy $ UniqueInboxItemRemote inboxID remoteActivityID + tryRemoveParent' i + + componentIsAuthor ident = + let author = bimap (view _1) (remoteAuthorId . view _1) authorIdMsig + in author == bimap (resourceToActor . componentResource . 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 <- + bitraverse + + -- If accepting an Invite, find the Collab recipient and verify + -- it's the sender of the Accept + (\ fulfillsID -> withDBExcept $ 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 + let muCap = AP.activityCapability $ actbActivity body + uCap <- fromMaybeE muCap "No capability provided" + verifyCapability'' + uCap + authorIdMsig + (LocalResourceGroup groupID) + AP.RoleAdmin + return fulfillsID + ) + + fulfills + + maybeNew <- withDBExcept $ do + + -- Grab me from DB + (recipActorID, recipActor) <- lift $ do + recip <- getJust groupID + let actorID = groupActor recip + (actorID,) <$> getJust actorID + + -- 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 $ \ (inboxItemID, acceptDB) -> do + + -- Record the Accept and enable the Collab + (grantID, enableID) <- do + case (collab, acceptDB) of + (Left (fulfillsID, Left recipID), Left (_, _, acceptID)) -> do + maybeAccept <- lift $ insertUnique $ CollabRecipLocalAccept recipID fulfillsID acceptID + unless (isJust 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] + + -- Prepare a regular Grant + let isInvite = isLeft collab + grant@(actionGrant, _, _, _) <- lift $ do + Collab role _ <- getJust collabID + prepareCollabGrant isInvite inviterOrJoiner role + let recipByKey = LocalActorGroup groupID + _luGrant <- lift $ updateOutboxItem' recipByKey grantID actionGrant + + return (recipActorID, sieve, grantID, grant, inboxItemID) + + case maybeNew of + Nothing -> done "I already have this activity in my inbox" + Just (recipActorID, sieve, grantID, (actionGrant, localRecipsGrant, remoteRecipsGrant, fwdHostsGrant), inboxItemID) -> do + let recipByID = LocalActorGroup groupID + forwardActivity authorIdMsig body recipByID recipActorID sieve + lift $ + sendActivity + recipByID recipActorID localRecipsGrant + remoteRecipsGrant fwdHostsGrant grantID actionGrant + doneDB inboxItemID "[Collab mode] Forwarded the Accept and published a Grant" + + -- Add-a-parent mode + -- Comments below might refer to child, because code is ported from Project + -- But this is add-a-new-parent mode! + addChildParent (Left (sourceID, topic, mode)) = do + + mode' <- + bitraverse + + -- Child-active mode + -- Verify we haven't yet seen child's Accept + (\ () -> do + maybeChildAccept <- + lift $ withDB $ + case bimap fst fst topic of + Left localID -> (() <$) <$> getBy (UniqueSourceThemAcceptLocal localID) + Right remoteID -> (() <$) <$> getBy (UniqueSourceThemAcceptRemote remoteID) + verifyNothingE maybeChildAccept "I already saw child's Accept" + ) + + -- Child-passive mode + -- Option 1: We haven't seen child's Accept yet + -- * Verify sender is the child + -- 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 + (maybeChildAccept, maybeGrant) <- + lift $ withDB $ liftA2 (,) + (case bimap fst fst topic of + Left localID -> (() <$) <$> getBy (UniqueSourceThemAcceptLocal localID) + Right remoteID -> (() <$) <$> getBy (UniqueSourceThemAcceptRemote remoteID) + ) + (getBy $ UniqueSourceUsSendDelegator sourceID) + case (isJust maybeChildAccept, isJust maybeGrant) of + (False, True) -> error "Impossible/bug, didn't see child's Accept but sent a Grant" + (False, False) -> do + unless (theyIsAuthor topic) $ + throwE "The Accept I'm waiting for is from my new child" + 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 "Child 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 + + -- Child-active mode + -- If sender is child, record the Accept into the + -- Source record & prepare to send degelator-Grant + -- Othrerwise do nothing + (\ () -> + if theyIsAuthor topic + then Just <$> do + case (topic, acceptDB) of + (Left (localID, _), Left (_, _, acceptID)) -> + insert_ $ SourceThemAcceptLocal localID acceptID + (Right (remoteID, _), Right (_, _, acceptID)) -> + insert_ $ SourceThemAcceptRemote remoteID acceptID + _ -> error "groupAccept impossible iv" + grantID <- insertEmptyOutboxItem' (actorOutbox recipActor) now + insert_ $ SourceUsSendDelegator sourceID grantID + return grantID + else pure Nothing + ) + + -- Child-passive mode + (\case + + -- Getting an Accept from the child + -- Record child's Accept in Source record + Left () -> do + case (topic, acceptDB) of + (Left (localID, _), Left (_, _, acceptID)) -> + insert_ $ SourceThemAcceptLocal localID acceptID + (Right (remoteID, _), Right (_, _, acceptID)) -> + insert_ $ SourceThemAcceptRemote 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_ $ SourceUsSendDelegator sourceID 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, _, _, _) <- + prepareSourceDelegGrant (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, _, _, _) <- + prepareSourceDelegGrant (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 "[Parent mode] Forwarded the Accept and maybe published a Grant/Accept" + + -- Add-a-child mode + -- Comments below might refer to parent, because code is ported from Project + -- But this is add-a-new-child mode! + addChildParent (Right (destID, topic, mode)) = do + + (themID, mode') <- + case mode of + + -- Parent-active mode + -- Respond with error, we aren't supposed to get any Accept + Left () -> throwE "Parent-active (DestOriginUs) mode, I'm not expecting any Accept" + + -- Parent-passive mode + -- 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 + Right themID -> (themID,) <$> do + (maybeParentAccept, maybeUsGesture) <- + lift $ withDB $ liftA2 (,) + (case bimap fst fst topic of + Left localID -> (() <$) <$> getBy (UniqueDestThemAcceptLocalTopic localID) + Right remoteID -> (() <$) <$> getBy (UniqueDestThemAcceptRemoteTopic remoteID) + ) + (do l <- getBy $ UniqueDestUsGestureLocal destID + r <- getBy $ UniqueDestUsGestureRemote destID + case (isJust l, isJust r) of + (False, False) -> pure Nothing + (False, True) -> pure $ Just () + (True, False) -> pure $ Just () + (True, True) -> error "Both DestUsGestureLocal and DestUsGestureRemote" + ) + case (isJust maybeParentAccept, isJust maybeUsGesture) of + (False, True) -> error "Impossible/bug, didn't see parent'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 parent" + 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 "Just waiting for Grant from parent, or already have it, anyway not needing any further Accept" + + 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 $ case mode' of + + -- Getting an Accept from the parent + -- Record parent's Accept in the Dest record + Left () -> do + case (topic, acceptDB) of + (Left (localID, _), Left (_, _, acceptID)) -> + insert_ $ DestThemAcceptLocal themID localID acceptID + (Right (remoteID, _), Right (_, _, acceptID)) -> + insert_ $ DestThemAcceptRemote themID remoteID acceptID + _ -> error "groupAccept impossible v" + return Nothing + + -- Getting an Accept from my collaborator + -- Record my collaborator's Accept in the Dest record + -- Prepare to send my own Accept + Right () -> Just <$> do + case acceptDB of + Left (_, _, acceptID) -> + insert_ $ DestUsGestureLocal destID acceptID + Right (author, _, acceptID) -> + insert_ $ DestUsGestureRemote destID (remoteAuthorId author) acceptID + acceptID <- insertEmptyOutboxItem' (actorOutbox recipActor) now + insert_ $ DestUsAccept destID acceptID + return acceptID + + -- Prepare forwarding of Accept to my followers + let recipByID = LocalActorGroup groupID + recipByHash <- hashLocalActor recipByID + let sieve = makeRecipientSet [] [localActorFollowers recipByHash] + + maybeAct <- + for idsForGrant $ \ acceptID -> lift $ do + accept@(actionAccept, _, _, _) <- + prepareDestAccept (bimap snd snd topic) + let recipByKey = LocalActorGroup groupID + _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 = 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 "[Child mode] Forwarded the Accept and maybe published a Grant/Accept" + prepareCollabGrant isInvite sender role = do encodeRouteHome <- getEncodeRouteHome encodeRouteLocal <- getEncodeRouteLocal @@ -884,6 +1371,307 @@ groupAccept now groupID (Verse authorIdMsig body) accept = do return (action, recipientSet, remoteActors, fwdHosts) + prepareSourceDelegGrant ident includeAuthor = do + encodeRouteHome <- getEncodeRouteHome + encodeRouteLocal <- getEncodeRouteLocal + + (uSource, audSource) <- + case ident of + Left j -> do + h <- encodeKeyHashid j + return + ( encodeRouteHome $ GroupR h + , AudLocal [LocalActorGroup h] [LocalStageGroupFollowers h] + ) + 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 [audSource, audGroup, audAuthor] + else [audSource, 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 = uSource + , AP.grantResult = Nothing + , AP.grantStart = Just now + , AP.grantEnd = Nothing + , AP.grantAllows = AP.Invoke + , AP.grantDelegates = Nothing + } + } + + return (action, recipientSet, remoteActors, fwdHosts) + + prepareDestAccept topic = do + encodeRouteHome <- getEncodeRouteHome + + audMyCollab <- lift $ makeAudSenderOnly authorIdMsig + audDest <- + 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 . LocalStageGroupFollowers <$> + encodeKeyHashid groupID + uCollabAccept <- lift $ getActivityURI authorIdMsig + let uAdd = AP.acceptObject accept + + (recipientSet, remoteActors, fwdHosts, audLocal, audRemote) = + collectAudience [audMyCollab, audDest, 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) + + removeParent (sourceID, sendID, grantID, child) = do + + -- Verify the sender is the topic + let author = bimap (view _1) (remoteAuthorId . view _1) authorIdMsig + unless (author == bimap (LocalActorGroup . snd) snd child) $ + throwE "The Accept isn't by the to-be-removed child group" + + maybeNew <- withDBExcept $ do + + -- Grab me from DB + (group, actorRecip) <- lift $ do + p <- getJust groupID + (p,) <$> getJust (groupActor p) + + maybeAcceptDB <- lift $ insertToInbox now authorIdMsig body (actorInbox actorRecip) False + lift $ for maybeAcceptDB $ \ (inboxItemID, acceptDB) -> do + + -- Grab extension-Grants that I'm about to revoke + gathers <- selectList [SourceUsGatherSource ==. sendID] [] + leafs <- selectList [SourceUsLeafSource ==. sendID] [] + + -- Delete the whole Source record + deleteWhere [SourceRemoveSend ==. sendID] + let gatherIDs = map entityKey gathers + deleteWhere [SourceUsGatherFromLocalGather <-. gatherIDs] + deleteWhere [SourceUsGatherFromRemoteGather <-. gatherIDs] + deleteWhere [SourceUsGatherId <-. gatherIDs] + let leafIDs = map entityKey leafs + deleteWhere [SourceUsLeafFromLocalLeaf <-. leafIDs] + deleteWhere [SourceUsLeafFromRemoteLeaf <-. leafIDs] + deleteWhere [SourceUsLeafToLocalLeaf <-. leafIDs] + deleteWhere [SourceUsLeafToRemoteLeaf <-. leafIDs] + deleteWhere [SourceUsLeafId <-. leafIDs] + case child of + Left (localID, _) -> do + acceptID <- getKeyByJust $ UniqueSourceThemAcceptLocal localID + deleteWhere [SourceThemDelegateLocalSource ==. acceptID] + delete acceptID + Right (remoteID, _) -> do + acceptID <- getKeyByJust $ UniqueSourceThemAcceptRemote remoteID + deleteWhere [SourceThemDelegateRemoteSource ==. acceptID] + delete acceptID + delete sendID + origin <- + requireEitherAlt + (getKeyBy $ UniqueSourceOriginUs sourceID) + (getKeyBy $ UniqueSourceOriginThem sourceID) + "Neither us nor them" + "Both us and them" + case origin of + Left usID -> do + deleteBy $ UniqueSourceUsAccept usID + deleteBy $ UniqueSourceUsGestureLocal usID + deleteBy $ UniqueSourceUsGestureRemote usID + delete usID + Right themID -> do + deleteBy $ UniqueSourceThemGestureLocal themID + deleteBy $ UniqueSourceThemGestureRemote themID + delete themID + case child of + Left (l, _) -> do + deleteBy $ UniqueSourceTopicGroupTopic l + delete l + Right (r, _) -> + delete r + deleteBy $ UniqueSourceHolderGroup sourceID + delete sourceID + + -- Prepare forwarding Remove to my followers + sieve <- lift $ do + topicHash <- encodeKeyHashid groupID + let topicByHash = + LocalActorGroup topicHash + return $ makeRecipientSet [] [localActorFollowers topicByHash] + + -- Prepare main Revoke activity and insert to my outbox + revoke@(actionRevoke, _, _, _) <- prepareMainRevoke (bimap snd snd child) grantID + let recipByKey = LocalActorGroup groupID + revokeID <- insertEmptyOutboxItem' (actorOutbox actorRecip) now + _luRevoke <- updateOutboxItem' recipByKey revokeID actionRevoke + + -- Prepare and insert Revokes on all the extension-Grants + revokesG <- for gathers $ \ (Entity _ (SourceUsGather _ startID grantID)) -> do + DestUsStart acceptID _ <- getJust startID + DestUsAccept destID _ <- getJust acceptID + parent <- do + p <- getDestTopic destID + bitraverse + (\case + Right j -> pure $ LocalActorGroup j + Left _ -> error "I'm a group but I have a parent who is a Project" + ) + pure + (bimap snd snd p) + return (parent, grantID) + revokesL <- for leafs $ \ (Entity _ (SourceUsLeaf _ enableID grantID)) -> do + CollabEnable collabID _ <- getJust enableID + recip <- getCollabRecip collabID + return + ( bimap + (LocalActorPerson . collabRecipLocalPerson . entityVal) + (collabRecipRemoteActor . entityVal) + recip + , grantID + ) + revokes <- for (revokesG ++ revokesL) $ \ (actor, grantID) -> do + ext@(actionExt, _, _, _) <- prepareExtRevoke actor grantID + let recipByKey = LocalActorGroup groupID + extID <- insertEmptyOutboxItem' (actorOutbox actorRecip) now + _luExt <- updateOutboxItem' recipByKey extID actionExt + return (extID, ext) + + return (groupActor group, sieve, revokeID, revoke, revokes, inboxItemID) + + case maybeNew of + Nothing -> done "I already have this activity in my inbox" + Just (topicActorID, sieve, revokeID, (actionRevoke, localRecipsRevoke, remoteRecipsRevoke, fwdHostsRevoke), revokes, inboxItemID) -> do + let topicByID = LocalActorGroup groupID + forwardActivity authorIdMsig body topicByID topicActorID sieve + lift $ do + sendActivity + topicByID topicActorID localRecipsRevoke + remoteRecipsRevoke fwdHostsRevoke revokeID actionRevoke + for_ revokes $ \ (extID, (actionExt, localRecipsExt, remoteRecipsExt, fwdHostsExt)) -> + sendActivity + topicByID topicActorID localRecipsExt + remoteRecipsExt fwdHostsExt extID actionExt + doneDB inboxItemID "[Remove-Parent mode] Deleted the Parent/Source, forwarded Accept, sent Revokes" + + where + + prepareMainRevoke child grantID = do + encodeRouteHome <- getEncodeRouteHome + encodeRouteLocal <- getEncodeRouteLocal + + recipHash <- encodeKeyHashid groupID + let topicByHash = LocalActorGroup recipHash + + childHash <- bitraverse encodeKeyHashid pure child + + audRemover <- lift $ makeAudSenderOnly authorIdMsig + audChild <- + case childHash of + Left j -> + pure $ + AudLocal [LocalActorGroup j] [LocalStageGroupFollowers j] + Right actorID -> do + actor <- getJust actorID + ObjURI h lu <- getRemoteActorURI actor + return $ AudRemote h [lu] (maybeToList $ remoteActorFollowers actor) + let audMe = AudLocal [] [localActorFollowers topicByHash] + + (recipientSet, remoteActors, fwdHosts, audLocal, audRemote) = + collectAudience [audRemover, audChild, audMe] + + recips = map encodeRouteHome audLocal ++ audRemote + + let uRemove = AP.acceptObject accept + luGrant <- do + grantHash <- encodeKeyHashid grantID + return $ encodeRouteLocal $ activityRoute topicByHash grantHash + let action = AP.Action + { AP.actionCapability = Nothing + , AP.actionSummary = Nothing + , AP.actionAudience = AP.Audience recips [] [] [] [] [] + , AP.actionFulfills = [uRemove] + , AP.actionSpecific = AP.RevokeActivity AP.Revoke + { AP.revokeObject = luGrant :| [] + } + } + + return (action, recipientSet, remoteActors, fwdHosts) + + prepareExtRevoke recipient grantID = do + encodeRouteHome <- getEncodeRouteHome + encodeRouteLocal <- getEncodeRouteLocal + + groupHash <- encodeKeyHashid groupID + let topicByHash = LocalActorGroup groupHash + + audRecip <- + case recipient of + Left a -> do + h <- hashLocalActor a + return $ AudLocal [h] [localActorFollowers h] + Right actorID -> do + actor <- getJust actorID + ObjURI h lu <- getRemoteActorURI actor + return $ + AudRemote h [lu] (maybeToList $ remoteActorFollowers actor) + + let (recipientSet, remoteActors, fwdHosts, audLocal, audRemote) = + collectAudience [audRecip] + + recips = map encodeRouteHome audLocal ++ audRemote + + let uRemove = AP.acceptObject accept + luGrant <- do + grantHash <- encodeKeyHashid grantID + return $ encodeRouteLocal $ activityRoute topicByHash grantHash + let action = AP.Action + { AP.actionCapability = Nothing + , AP.actionSummary = Nothing + , AP.actionAudience = AP.Audience recips [] [] [] [] [] + , AP.actionFulfills = [uRemove] + , AP.actionSpecific = AP.RevokeActivity AP.Revoke + { AP.revokeObject = luGrant :| [] + } + } + + 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