From bf8ae421ff3c4e9ba9bccf57ab7d14bb48c6f054 Mon Sep 17 00:00:00 2001 From: Pere Lev Date: Thu, 4 Apr 2024 13:03:48 +0300 Subject: [PATCH] S2S: Project: Accept: Split the different modes into separate functions --- src/Vervis/Actor/Project.hs | 910 +++++++++++++++++++----------------- 1 file changed, 479 insertions(+), 431 deletions(-) diff --git a/src/Vervis/Actor/Project.hs b/src/Vervis/Actor/Project.hs index f91a607..c51f963 100644 --- a/src/Vervis/Actor/Project.hs +++ b/src/Vervis/Actor/Project.hs @@ -206,7 +206,6 @@ projectAccept now projectID (Verse authorIdMsig body) accept = do -- Check input acceptee <- parseAccept accept - let muCap = AP.activityCapability $ actbActivity body collabOrComp_or_child <- withDBExcept $ do @@ -234,436 +233,10 @@ projectAccept now projectID (Verse authorIdMsig body) accept = do maybeCollab "Accepted activity isn't an Invite/Join/Add I'm aware of" - idsForAccept <- bitraverse - - (bitraverse - - (\ (collabID, fulfills, inviterOrJoiner) -> (collabID,inviterOrJoiner,) <$> 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 - uCap <- fromMaybeE muCap "No capability provided" - verifyCapability'' - uCap - authorIdMsig - (LocalActorProject projectID) - AP.RoleAdmin - return fulfillsID - ) - - fulfills - ) - - (\ (componentID, ident, inviteOrAdd) -> (componentID, ident,) <$> bitraverse - - -- If accepting an Invite-component, there's nothing to check - -- at this point - pure - - -- If accepting an Add-component: - -- * If the sender is the component, verify I haven't seen - -- a component-Accept on this Add - -- * Otherwise, verify I've seen the component-Accept for - -- this Add and that the new Accept is authorized - (\ () -> do - maybeComponentAccept <- - lift $ withDB $ - case bimap fst fst ident of - Left localID -> (() <$) <$> getBy (UniqueComponentAcceptLocal localID) - Right remoteID -> (() <$) <$> getBy (UniqueComponentAcceptRemote remoteID) - if componentIsAuthor ident - then - verifyNothingE - maybeComponentAccept - "I've already seen a ComponentAccept* on \ - \that Add" - else do - fromMaybeE - maybeComponentAccept - "I haven't yet seen the Component's Accept on \ - \the Add" - uCap <- fromMaybeE muCap "No capability provided" - verifyCapability'' - uCap - authorIdMsig - (LocalActorProject projectID) - AP.RoleAdmin - ) - - inviteOrAdd - ) - - ) - - -- Child/Parent mode - (bitraverse - - -- Adding-a-new-child mode - (\ (sourceID, topic, mode) -> (sourceID,topic,) <$> 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 - uCap <- fromMaybeE muCap "No capability provided" - verifyCapability'' - uCap - authorIdMsig - (LocalActorProject projectID) - AP.RoleAdmin - return $ Right () - (True, True) -> throwE "Child already enabled, not needing any further Accept" - ) - - mode - ) - - -- Adding-a-new-parent mode - (\ (destID, topic, 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 -> (destID,themID,topic,) <$> 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 - uCap <- fromMaybeE muCap "No capability provided" - verifyCapability'' - uCap - authorIdMsig - (LocalActorProject projectID) - AP.RoleAdmin - return $ Right () - (True, True) -> throwE "Just waiting for Grant from parent, or already have it, anyway not needing any further Accept" - ) - ) - - collabOrComp_or_child - - maybeNew <- withDBExcept $ do - - -- Grab me from DB - (recipActorID, recipActor) <- lift $ do - recip <- getJust projectID - let actorID = projectActor recip - (actorID,) <$> getJust actorID - - -- In collab mode, verify the Collab isn't already validated - -- In component mode, verify the Component isn't already validated - -- In child/parent modes, no check at this point - bitraverse_ - (bitraverse_ - (\ (collabID, _, _) -> do - maybeEnabled <- lift $ getBy $ UniqueCollabEnable collabID - verifyNothingE maybeEnabled "I already sent a Grant for this Invite/Join" - ) - (\ (componentID, _, _) -> do - maybeEnabled <- lift $ getBy $ UniqueComponentEnable componentID - verifyNothingE maybeEnabled "I already sent a delegator-Grant for this Invite/Add" - ) - ) - pure - collabOrComp_or_child - - maybeAcceptDB <- lift $ insertToInbox now authorIdMsig body (actorInbox recipActor) False - for maybeAcceptDB $ \ acceptDB -> do - - idsForGrant <- - bitraverse - - (\case - -- In collab mode, record the Accept and enable the Collab - Left (collabID, inviterOrJoiner, collab) -> Left <$> 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 "projectAccept impossible" - grantID <- lift $ insertEmptyOutboxItem' (actorOutbox recipActor) now - enableID <- lift $ insert $ CollabEnable collabID grantID - return (collabID, inviterOrJoiner, collab, grantID, enableID) - - -- In Invite-component mode, only if the Accept author is the - -- component, record the Accept and enable the Component - Right (componentID, ident, Left ()) -> fmap Right $ - lift $ if componentIsAuthor ident - then Just <$> do - case (ident, acceptDB) of - (Left (localID, _), Left (_, _, acceptID)) -> - insert_ $ ComponentAcceptLocal localID acceptID - (Right (remoteID, _), Right (_, _, acceptID)) -> - insert_ $ ComponentAcceptRemote remoteID acceptID - _ -> error "personAccept impossible ii" - grantID <- insertEmptyOutboxItem' (actorOutbox recipActor) now - enableID <- insert $ ComponentEnable componentID grantID - return (componentID, ident, grantID, enableID, False) - else pure Nothing - - -- In Add-component mode: - -- * If the sender is the component, record the Accept - -- * Otherwise, record the Accept and enable the Component - Right (componentID, ident, Right ()) -> fmap Right $ - lift $ if componentIsAuthor ident - then do - case (ident, acceptDB) of - (Left (localID, _), Left (_, _, acceptID)) -> - insert_ $ ComponentAcceptLocal localID acceptID - (Right (remoteID, _), Right (_, _, acceptID)) -> - insert_ $ ComponentAcceptRemote remoteID acceptID - _ -> error "personAccept impossible iii" - return Nothing - else Just <$> do - case acceptDB of - Left (_, _, acceptID) -> - insert_ $ ComponentProjectGestureLocal componentID acceptID - Right (author, _, acceptID) -> - insert_ $ ComponentProjectGestureRemote componentID (remoteAuthorId author) acceptID - grantID <- insertEmptyOutboxItem' (actorOutbox recipActor) now - enableID <- insert $ ComponentEnable componentID grantID - return (componentID, ident, grantID, enableID, True) - ) - - -- Child/parent mode - (bitraverse - - -- Child mode - (\ (sourceID, topic, mode) -> 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 "projectAccept impossible iv" - grantID <- insertEmptyOutboxItem' (actorOutbox recipActor) now - insert_ $ SourceUsSendDelegator sourceID grantID - return (topic, 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 "projectAccept 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_ $ SourceThemAcceptLocal localID acceptID - (Right (remoteID, _), Right (_, _, acceptID)) -> - insert_ $ SourceThemAcceptRemote remoteID acceptID - _ -> error "projectAccept impossible iv" - grantID <- insertEmptyOutboxItem' (actorOutbox recipActor) now - insert_ $ SourceUsSendDelegator sourceID grantID - return (topic, grantID) - ) - - mode - ) - - -- Parent-passive mode - (\ (destID, themID, topic, mode) -> 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 "projectAccept 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 (topic, acceptID) - ) - ) - - idsForAccept - - - -- Prepare forwarding of Accept to my followers - let recipByID = LocalActorProject projectID - recipByHash <- hashLocalActor recipByID - let sieve = makeRecipientSet [] [localActorFollowers recipByHash] - - maybeGrant <- - case idsForGrant of - - -- In collab mode, prepare a regular Grant - Left (Left (collabID, inviterOrJoiner, collab, grantID, collabEnableID)) -> lift $ do - let isInvite = isLeft collab - grant@(actionGrant, _, _, _) <- do - Collab role <- getJust collabID - prepareCollabGrant isInvite inviterOrJoiner role - let recipByKey = LocalActorProject projectID - _luGrant <- updateOutboxItem' recipByKey grantID actionGrant - return $ Just (grantID, grant) - - -- In Invite-component mode, only if the Accept author is - -- the component, prepare a delegator-Grant - -- - -- In Add-component mode, only if the Accept author isn't - -- the component, prepare a delegator-Grant - Left (Right comp) -> for comp $ \ (_componentID, ident, grantID, enableID, includeAuthor) -> lift $ do - grant@(actionGrant, _, _, _) <- - prepareDelegGrant (bimap snd snd ident) enableID includeAuthor - let recipByKey = LocalActorProject projectID - _luGrant <- updateOutboxItem' recipByKey grantID actionGrant - return (grantID, grant) - - -- Add child/parent modes - - Right (Left (Left mg)) -> for mg $ \ (topic, grantID) -> lift $ do - grant@(actionGrant, _, _, _) <- - prepareSourceDelegGrant (bimap snd snd topic) False - let recipByKey = LocalActorProject projectID - _luGrant <- updateOutboxItem' recipByKey grantID actionGrant - return (grantID, grant) - - Right (Left (Right mg)) -> for mg $ \ (topic, grantID) -> lift $ do - grant@(actionGrant, _, _, _) <- - prepareSourceDelegGrant (bimap snd snd topic) True - let recipByKey = LocalActorProject projectID - _luGrant <- updateOutboxItem' recipByKey grantID actionGrant - return (grantID, grant) - - Right (Right ma) -> for ma $ \ (topic, acceptID) -> lift $ do - accept@(actionAccept, _, _, _) <- - prepareDestAccept (bimap snd snd topic) - let recipByKey = LocalActorProject projectID - _luAccept <- updateOutboxItem' recipByKey acceptID actionAccept - return (acceptID, accept) - - return (recipActorID, sieve, maybeGrant) - - case maybeNew of - Nothing -> done "I already have this activity in my inbox" - Just (recipActorID, sieve, maybeGrant) -> 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 - done "Forwarded the Accept and maybe published a Grant/Accept" + case collabOrComp_or_child of + Left (Left collab) -> addCollab collab + Left (Right comp) -> addComp comp + Right cp -> addChildParent cp where @@ -877,6 +450,481 @@ projectAccept now projectID (Verse authorIdMsig body) accept = do let author = bimap (view _1) (remoteAuthorId . view _1) authorIdMsig in author == bimap (LocalActorProject . 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 + (LocalActorProject projectID) + AP.RoleAdmin + return fulfillsID + ) + + fulfills + + maybeNew <- withDBExcept $ do + + -- Grab me from DB + (recipActorID, recipActor) <- lift $ do + recip <- getJust projectID + let actorID = projectActor 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 $ \ 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 "projectAccept 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 = LocalActorProject projectID + 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 = LocalActorProject projectID + _luGrant <- lift $ updateOutboxItem' recipByKey grantID actionGrant + + return (recipActorID, sieve, grantID, grant) + + case maybeNew of + Nothing -> done "I already have this activity in my inbox" + Just (recipActorID, sieve, grantID, (actionGrant, localRecipsGrant, remoteRecipsGrant, fwdHostsGrant)) -> do + let recipByID = LocalActorProject projectID + forwardActivity authorIdMsig body recipByID recipActorID sieve + lift $ + sendActivity + recipByID recipActorID localRecipsGrant + remoteRecipsGrant fwdHostsGrant grantID actionGrant + done "[Collab mode] Forwarded the Accept and published a Grant" + + addComp (componentID, ident, inviteOrAdd) = do + + comp <- + bitraverse + + -- If accepting an Invite-component, there's nothing to check + -- at this point + pure + + -- If accepting an Add-component: + -- * If the sender is the component, verify I haven't seen + -- a component-Accept on this Add + -- * Otherwise, verify I've seen the component-Accept for + -- this Add and that the new Accept is authorized + (\ () -> do + maybeComponentAccept <- + lift $ withDB $ + case bimap fst fst ident of + Left localID -> (() <$) <$> getBy (UniqueComponentAcceptLocal localID) + Right remoteID -> (() <$) <$> getBy (UniqueComponentAcceptRemote remoteID) + if componentIsAuthor ident + then + verifyNothingE + maybeComponentAccept + "I've already seen a ComponentAccept* on \ + \that Add" + else do + fromMaybeE + maybeComponentAccept + "I haven't yet seen the Component's Accept on \ + \the Add" + let muCap = AP.activityCapability $ actbActivity body + uCap <- fromMaybeE muCap "No capability provided" + verifyCapability'' + uCap + authorIdMsig + (LocalActorProject projectID) + AP.RoleAdmin + ) + + inviteOrAdd + + maybeNew <- withDBExcept $ do + + -- Grab me from DB + (recipActorID, recipActor) <- lift $ do + recip <- getJust projectID + let actorID = projectActor recip + (actorID,) <$> getJust actorID + + -- In component mode, verify the Component isn't already validated + maybeEnabled <- lift $ getBy $ UniqueComponentEnable componentID + verifyNothingE maybeEnabled "I already sent a delegator-Grant for this Invite/Add" + + maybeAcceptDB <- lift $ insertToInbox now authorIdMsig body (actorInbox recipActor) False + for maybeAcceptDB $ \ acceptDB -> do + + maybeGrantData <- + case comp of + + -- In Invite-component mode, only if the Accept author is the + -- component, record the Accept and enable the Component + Left () -> + lift $ if componentIsAuthor ident + then Just <$> do + case (ident, acceptDB) of + (Left (localID, _), Left (_, _, acceptID)) -> + insert_ $ ComponentAcceptLocal localID acceptID + (Right (remoteID, _), Right (_, _, acceptID)) -> + insert_ $ ComponentAcceptRemote remoteID acceptID + _ -> error "personAccept impossible ii" + grantID <- insertEmptyOutboxItem' (actorOutbox recipActor) now + enableID <- insert $ ComponentEnable componentID grantID + return (grantID, enableID, False) + else pure Nothing + + -- In Add-component mode: + -- * If the sender is the component, record the Accept + -- * Otherwise, record the Accept and enable the Component + Right () -> + lift $ if componentIsAuthor ident + then do + case (ident, acceptDB) of + (Left (localID, _), Left (_, _, acceptID)) -> + insert_ $ ComponentAcceptLocal localID acceptID + (Right (remoteID, _), Right (_, _, acceptID)) -> + insert_ $ ComponentAcceptRemote remoteID acceptID + _ -> error "personAccept impossible iii" + return Nothing + else Just <$> do + case acceptDB of + Left (_, _, acceptID) -> + insert_ $ ComponentProjectGestureLocal componentID acceptID + Right (author, _, acceptID) -> + insert_ $ ComponentProjectGestureRemote componentID (remoteAuthorId author) acceptID + grantID <- insertEmptyOutboxItem' (actorOutbox recipActor) now + enableID <- insert $ ComponentEnable componentID grantID + return (grantID, enableID, True) + + -- Prepare forwarding of Accept to my followers + let recipByID = LocalActorProject projectID + recipByHash <- hashLocalActor recipByID + let sieve = makeRecipientSet [] [localActorFollowers recipByHash] + + -- In Invite-component mode, only if the Accept author is + -- the component, prepare a delegator-Grant + -- + -- In Add-component mode, only if the Accept author isn't + -- the component, prepare a delegator-Grant + maybeGrant <- for maybeGrantData $ \ (grantID, enableID, includeAuthor) -> lift $ do + grant@(actionGrant, _, _, _) <- + prepareDelegGrant (bimap snd snd ident) enableID includeAuthor + let recipByKey = LocalActorProject projectID + _luGrant <- updateOutboxItem' recipByKey grantID actionGrant + return (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 = LocalActorProject projectID + forwardActivity authorIdMsig body recipByID recipActorID sieve + lift $ for_ maybeGrant $ \ (grantID, (actionGrant, localRecipsGrant, remoteRecipsGrant, fwdHostsGrant)) -> + sendActivity + recipByID recipActorID localRecipsGrant + remoteRecipsGrant fwdHostsGrant grantID actionGrant + done "[Component mode] Forwarded the Accept and maybe published a Grant" + + addChildParent cp = do + + idsForAccept <- + bitraverse + + -- Adding-a-new-child mode + (\ (sourceID, topic, mode) -> (sourceID,topic,) <$> 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 + (LocalActorProject projectID) + AP.RoleAdmin + return $ Right () + (True, True) -> throwE "Child already enabled, not needing any further Accept" + ) + + mode + ) + + -- Adding-a-new-parent mode + (\ (destID, topic, 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 -> (destID,themID,topic,) <$> 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 + (LocalActorProject projectID) + AP.RoleAdmin + return $ Right () + (True, True) -> throwE "Just waiting for Grant from parent, or already have it, anyway not needing any further Accept" + ) + + cp + + 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 $ \ acceptDB -> do + + idsForGrant <- + bitraverse + + -- Child mode + (\ (sourceID, topic, mode) -> 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 "projectAccept impossible iv" + grantID <- insertEmptyOutboxItem' (actorOutbox recipActor) now + insert_ $ SourceUsSendDelegator sourceID grantID + return (topic, 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 "projectAccept 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_ $ SourceThemAcceptLocal localID acceptID + (Right (remoteID, _), Right (_, _, acceptID)) -> + insert_ $ SourceThemAcceptRemote remoteID acceptID + _ -> error "projectAccept impossible iv" + grantID <- insertEmptyOutboxItem' (actorOutbox recipActor) now + insert_ $ SourceUsSendDelegator sourceID grantID + return (topic, grantID) + ) + + mode + ) + + -- Parent-passive mode + (\ (destID, themID, topic, mode) -> 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 "projectAccept 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 (topic, acceptID) + ) + + idsForAccept + + + -- Prepare forwarding of Accept to my followers + let recipByID = LocalActorProject projectID + recipByHash <- hashLocalActor recipByID + let sieve = makeRecipientSet [] [localActorFollowers recipByHash] + + maybeAct <- + case idsForGrant of + Left (Left mg) -> for mg $ \ (topic, grantID) -> lift $ do + grant@(actionGrant, _, _, _) <- + prepareSourceDelegGrant (bimap snd snd topic) False + let recipByKey = LocalActorProject projectID + _luGrant <- updateOutboxItem' recipByKey grantID actionGrant + return (grantID, grant) + + Left (Right mg) -> for mg $ \ (topic, grantID) -> lift $ do + grant@(actionGrant, _, _, _) <- + prepareSourceDelegGrant (bimap snd snd topic) True + let recipByKey = LocalActorProject projectID + _luGrant <- updateOutboxItem' recipByKey grantID actionGrant + return (grantID, grant) + + Right ma -> for ma $ \ (topic, acceptID) -> lift $ do + accept@(actionAccept, _, _, _) <- + prepareDestAccept (bimap snd snd topic) + let recipByKey = LocalActorProject projectID + _luAccept <- updateOutboxItem' recipByKey acceptID actionAccept + return (acceptID, accept) + + return (recipActorID, sieve, maybeAct) + + case maybeNew of + Nothing -> done "I already have this activity in my inbox" + Just (recipActorID, sieve, maybeGrant) -> 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 + done "[Child/Parent mode] Forwarded the Accept and maybe published a Grant/Accept" + prepareCollabGrant isInvite sender role = do encodeRouteHome <- getEncodeRouteHome encodeRouteLocal <- getEncodeRouteLocal