From bdce87cf766a768df19a39bf4018722c49149aa4 Mon Sep 17 00:00:00 2001 From: Pere Lev Date: Wed, 28 Feb 2024 09:47:42 +0200 Subject: [PATCH] S2S: Project: Accept: Implement child/parent mode --- src/Vervis/Actor/Project.hs | 708 ++++++++++++++++++++++++++++------- src/Vervis/Persist/Collab.hs | 54 +++ 2 files changed, 622 insertions(+), 140 deletions(-) diff --git a/src/Vervis/Actor/Project.hs b/src/Vervis/Actor/Project.hs index eedaf25..74f62f1 100644 --- a/src/Vervis/Actor/Project.hs +++ b/src/Vervis/Actor/Project.hs @@ -207,7 +207,7 @@ projectAccept now projectID (Verse authorIdMsig body) accept = do acceptee <- parseAccept accept let muCap = AP.activityCapability $ actbActivity body - collabOrComp <- withDBExcept $ do + collabOrComp_or_child <- withDBExcept $ do -- Find the accepted activity in our DB accepteeDB <- do @@ -221,92 +221,197 @@ projectAccept now projectID (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 (Right <$> tryInviteComp accepteeDB) <|> - runExceptT (Right <$> tryAddComp accepteeDB) + runExceptT (Left . Left <$> tryInviteCollab accepteeDB) <|> + runExceptT (Left . Left <$> tryJoinCollab accepteeDB) <|> + runExceptT (Left . Right <$> tryInviteComp accepteeDB) <|> + runExceptT (Left . Right <$> tryAddComp accepteeDB) <|> + runExceptT (Right <$> tryAddChildActive accepteeDB) <|> + runExceptT (Right <$> tryAddChildPassive accepteeDB) <|> + runExceptT (Right <$> tryAddParentActive accepteeDB) <|> + runExceptT (Right <$> tryAddParentPassive accepteeDB) fromMaybeE maybeCollab "Accepted activity isn't an Invite/Join/Add I'm aware of" idsForAccept <- bitraverse - (\ (collabID, fulfills, inviterOrJoiner) -> (collabID,inviterOrJoiner,) <$> bitraverse + (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" + (\ (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 ) - -- 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 + (\ (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 ) - fulfills ) - (\ (componentID, ident, inviteOrAdd) -> (componentID, ident,) <$> bitraverse + -- Child/Parent mode + (bitraverse - -- If accepting an Invite-component, there's nothing to check - -- at this point - pure + -- Adding-a-new-child mode + (\ (sourceID, topic, mode) -> (sourceID,topic,) <$> bitraverse - -- 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 + -- 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 ) - inviteOrAdd + -- 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 + collabOrComp_or_child maybeNew <- withDBExcept $ do @@ -318,84 +423,180 @@ projectAccept now projectID (Verse authorIdMsig body) accept = do -- 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_ - (\ (collabID, _, _) -> do - maybeEnabled <- lift $ getBy $ UniqueCollabEnable collabID - verifyNothingE maybeEnabled "I already sent a Grant for this Invite/Join" + (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" + ) ) - (\ (componentID, _, _) -> do - maybeEnabled <- lift $ getBy $ UniqueComponentEnable componentID - verifyNothingE maybeEnabled "I already sent a delegator-Grant for this Invite/Add" - ) - collabOrComp + pure + collabOrComp_or_child maybeAcceptDB <- lift $ insertToInbox now authorIdMsig body (actorInbox recipActor) False for maybeAcceptDB $ \ acceptDB -> do - idsForGrant <- case idsForAccept of + idsForGrant <- + bitraverse - -- 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) + (\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 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 - -- 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) -- Prepare forwarding of Accept to my followers let recipByID = LocalActorProject projectID @@ -406,7 +607,7 @@ projectAccept now projectID (Verse authorIdMsig body) accept = do case idsForGrant of -- In collab mode, prepare a regular Grant - Left (collabID, inviterOrJoiner, collab, grantID, collabEnableID) -> lift $ do + Left (Left (collabID, inviterOrJoiner, collab, grantID, collabEnableID)) -> lift $ do let isInvite = isLeft collab grant@(actionGrant, _, _, _) <- do Collab role <- getJust collabID @@ -420,13 +621,36 @@ projectAccept now projectID (Verse authorIdMsig body) accept = do -- -- In Add-component mode, only if the Accept author isn't -- the component, prepare a delegator-Grant - Right comp -> for comp $ \ (_componentID, ident, grantID, enableID, includeAuthor) -> lift $ do + 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 @@ -438,7 +662,7 @@ projectAccept now projectID (Verse authorIdMsig body) accept = do sendActivity recipByID recipActorID localRecipsGrant remoteRecipsGrant fwdHostsGrant grantID actionGrant - done "Forwarded the Accept and maybe published a Grant" + done "Forwarded the Accept and maybe published a Grant/Accept" where @@ -533,10 +757,125 @@ projectAccept now projectID (Verse authorIdMsig body) accept = do ident <- lift $ lift $ getComponentIdent componentID return (componentID, ident, Right ()) + verifySourceHolder :: SourceId -> ActDBE () + verifySourceHolder sourceID = do + mh <- lift $ getValBy $ UniqueSourceHolderProject sourceID + case mh of + Just (SourceHolderProject _ j) | j == projectID -> pure () + _ -> throwE "Accept object is an Add for some other project/team" + + tryAddChildActive' usID = do + SourceOriginUs sourceID <- lift . lift $ getJust usID + ExceptT $ lift $ runExceptT $ verifySourceHolder sourceID + topic <- do + t <- lift . lift $ getSourceTopic sourceID + bitraverse + (\ (l, k) -> + case k of + Left j -> pure (l, j) + Right _ -> error "Project Source topic is a Group, impossible" + ) + pure + t + return $ Left (sourceID, topic, Left ()) + + tryAddChildActive (Left (_actorByKey, _actorEntity, itemID)) = do + SourceUsGestureLocal usID _ <- + lift $ MaybeT $ getValBy $ UniqueSourceUsGestureLocalAdd itemID + tryAddChildActive' usID + tryAddChildActive (Right remoteActivityID) = do + SourceUsGestureRemote usID _ _ <- + lift $ MaybeT $ getValBy $ UniqueSourceUsGestureRemoteAdd remoteActivityID + tryAddChildActive' usID + + tryAddChildPassive' themID = do + SourceOriginThem sourceID <- lift . lift $ getJust themID + ExceptT $ lift $ runExceptT $ verifySourceHolder sourceID + topic <- do + t <- lift . lift $ getSourceTopic sourceID + bitraverse + (\ (l, k) -> + case k of + Left j -> pure (l, j) + Right _ -> error "Project Source topic is a Group, impossible" + ) + pure + t + return $ Left (sourceID, topic, Right ()) + + tryAddChildPassive (Left (_actorByKey, _actorEntity, itemID)) = do + SourceThemGestureLocal themID _ <- + lift $ MaybeT $ getValBy $ UniqueSourceThemGestureLocalAdd itemID + tryAddChildPassive' themID + tryAddChildPassive (Right remoteActivityID) = do + SourceThemGestureRemote themID _ _ <- + lift $ MaybeT $ getValBy $ UniqueSourceThemGestureRemoteAdd remoteActivityID + tryAddChildPassive' themID + + verifyDestHolder :: DestId -> ActDBE () + verifyDestHolder destID = do + mh <- lift $ getValBy $ UniqueDestHolderProject destID + case mh of + Just (DestHolderProject _ j) | j == projectID -> pure () + _ -> throwE "Accept object is an Add for some other project/team" + + tryAddParentActive' destID = do + usID <- lift $ MaybeT $ getKeyBy $ UniqueDestOriginUs destID + ExceptT $ lift $ runExceptT $ verifyDestHolder destID + topic <- do + t <- lift . lift $ getDestTopic destID + bitraverse + (\ (l, k) -> + case k of + Left j -> pure (l, j) + Right _ -> error "Project Dest topic is a Group, impossible" + ) + pure + t + return $ Right (destID, topic, Left ()) + + tryAddParentActive (Left (_actorByKey, _actorEntity, itemID)) = do + DestUsGestureLocal destID _ <- + lift $ MaybeT $ getValBy $ UniqueDestUsGestureLocalActivity itemID + tryAddParentActive' destID + tryAddParentActive (Right remoteActivityID) = do + DestUsGestureRemote destID _ _ <- + lift $ MaybeT $ getValBy $ UniqueDestUsGestureRemoteActivity remoteActivityID + tryAddParentActive' destID + + tryAddParentPassive' themID = do + DestOriginThem destID <- lift . lift $ getJust themID + ExceptT $ lift $ runExceptT $ verifyDestHolder destID + topic <- do + t <- lift . lift $ getDestTopic destID + bitraverse + (\ (l, k) -> + case k of + Left j -> pure (l, j) + Right _ -> error "Project Dest topic is a Group, impossible" + ) + pure + t + return $ Right (destID, topic, Right themID) + + tryAddParentPassive (Left (_actorByKey, _actorEntity, itemID)) = do + DestThemGestureLocal themID _ <- + lift $ MaybeT $ getValBy $ UniqueDestThemGestureLocalAdd itemID + tryAddParentPassive' themID + tryAddParentPassive (Right remoteActivityID) = do + DestThemGestureRemote themID _ _ <- + lift $ MaybeT $ getValBy $ UniqueDestThemGestureRemoteAdd remoteActivityID + tryAddParentPassive' themID + componentIsAuthor ident = let author = bimap (view _1) (remoteAuthorId . view _1) authorIdMsig in author == bimap (componentActor . snd) snd ident + theyIsAuthor :: Either (a, ProjectId) (b, RemoteActorId) -> Bool + theyIsAuthor ident = + let author = bimap (view _1) (remoteAuthorId . view _1) authorIdMsig + in author == bimap (LocalActorProject . snd) snd ident + prepareCollabGrant isInvite sender role = do encodeRouteHome <- getEncodeRouteHome encodeRouteLocal <- getEncodeRouteLocal @@ -650,6 +989,95 @@ projectAccept now projectID (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 $ ProjectR h + , AudLocal [LocalActorProject h] [LocalStageProjectFollowers 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 + projectHash <- encodeKeyHashid projectID + let audProject = AudLocal [] [LocalStageProjectFollowers projectHash] + + audience = + if includeAuthor + then [audSource, audProject, audAuthor] + else [audSource, audProject] + + (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 $ ProjectR projectHash + , 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 [LocalActorProject h] [LocalStageProjectFollowers 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, 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) + checkExistingComponents :: ProjectId -> Either (ComponentBy Entity) RemoteActorId -> ActDBE () checkExistingComponents projectID componentDB = do diff --git a/src/Vervis/Persist/Collab.hs b/src/Vervis/Persist/Collab.hs index 9668566..40ea274 100644 --- a/src/Vervis/Persist/Collab.hs +++ b/src/Vervis/Persist/Collab.hs @@ -33,6 +33,8 @@ module Vervis.Persist.Collab , getGrant , getComponentIdent + , getSourceTopic + , getDestTopic , checkExistingStems , checkExistingPermits @@ -486,6 +488,58 @@ getComponentIdent componentID = do (\ (Entity k v) -> pure (k, componentRemoteActor v)) ident +getSourceTopic + :: MonadIO m + => SourceId + -> ReaderT SqlBackend m + (Either + (SourceTopicLocalId, Either ProjectId GroupId) + (SourceTopicRemoteId, RemoteActorId) + ) +getSourceTopic sourceID = do + ident <- + requireEitherAlt + (getKeyBy $ UniqueSourceTopicLocal sourceID) + (getBy $ UniqueSourceTopicRemote sourceID) + "Found Source without topic" + "Found Source with both local and remote topic" + bitraverse + (\ localID -> (localID,) <$> do + requireEitherAlt + (fmap sourceTopicProjectChild <$> getValBy (UniqueSourceTopicProjectTopic localID)) + (fmap sourceTopicGroupParent <$> getValBy (UniqueSourceTopicGroupTopic localID)) + "Found SourceTopicLocal without topic" + "Found SourceTopicLocal with multiple topics" + ) + (\ (Entity k v) -> pure (k, sourceTopicRemoteTopic v)) + ident + +getDestTopic + :: MonadIO m + => DestId + -> ReaderT SqlBackend m + (Either + (DestTopicLocalId, Either ProjectId GroupId) + (DestTopicRemoteId, RemoteActorId) + ) +getDestTopic destID = do + ident <- + requireEitherAlt + (getKeyBy $ UniqueDestTopicLocal destID) + (getBy $ UniqueDestTopicRemote destID) + "Found Dest without topic" + "Found Dest with both local and remote topic" + bitraverse + (\ localID -> (localID,) <$> do + requireEitherAlt + (fmap destTopicProjectParent <$> getValBy (UniqueDestTopicProjectTopic localID)) + (fmap destTopicGroupChild <$> getValBy (UniqueDestTopicGroupTopic localID)) + "Found DestTopicLocal without topic" + "Found DestTopicLocal with multiple topics" + ) + (\ (Entity k v) -> pure (k, destTopicRemoteTopic v)) + ident + checkExistingStems :: ComponentBy Key -> Either (Entity Project) RemoteActorId -> ActDBE () checkExistingStems componentByID projectDB = do