From 5e0a2e1088b2f24049fd63d4b8e2ff5a6f4f1baa Mon Sep 17 00:00:00 2001 From: Pere Lev Date: Tue, 14 May 2024 01:43:41 +0300 Subject: [PATCH] S2S: Group: Grant: Port parent-child modes from Project --- src/Vervis/Actor/Group.hs | 894 +++++++++++++++++++++++++++++++++++--- 1 file changed, 825 insertions(+), 69 deletions(-) diff --git a/src/Vervis/Actor/Group.hs b/src/Vervis/Actor/Group.hs index 1cebbd7..f5aae90 100644 --- a/src/Vervis/Actor/Group.hs +++ b/src/Vervis/Actor/Group.hs @@ -1734,9 +1734,23 @@ groupFollow now recipGroupID verse follow = do (\ _ -> pure []) now recipGroupID verse follow +data GrantKind + = GKDelegationStart AP.Role + | GKDelegationExtend AP.Role (Either (LocalActorBy Key) FedURI) + | GKDelegator + -- Meaning: An actor is granting access-to-some-resource to another actor -- Behavior: --- * Option 1 - Collaborator sending me a delegator-Grant - Verify that: +-- * Option 1 - Project sending me a delegation-start or delegation-extension +-- * Verify they're authorized, i.e. they're using the delegator-Grant +-- I gave them +-- * Verify the role isn't delegator +-- * Store the Grant in the ??? record in DB +-- * Send extension-Grants and record them in the DB: +-- * To each of my direct collaborators +-- * To each of my children +-- +-- * Option 2 - Collaborator sending me a delegator-Grant - Verify that: -- * The sender is a collaborator of mine, A -- * The Grant's context is A -- * The Grant's target is me @@ -1748,8 +1762,30 @@ groupFollow now recipGroupID verse follow = do -- * Insert the Grant to my inbox -- * Record the delegator-Grant in the Collab record in DB -- * Forward the Grant to my followers +-- * For each project of mine J, prepare and send an +-- extension-Grant to A, and store it in the ??? record in DB +-- * For each start-grant or extension-grant G that I received from a +-- parent of mine, prepare and send an extension-Grant to A, and store +-- it in the Source record in DB -- --- * If not 1, raise an error +-- * Option 3 - Parent sending me a delegation-start or delegation-extension +-- * Verify they're authorized, i.e. they're using the delegator-Grant +-- I gave them +-- * Verify the role isn't delegator +-- * Store the Grant in the Source record in DB +-- * Send extension-Grants and record them in the DB: +-- * To each of my direct collaborators +-- * To each of my children +-- +-- * Option 4 - Almost-Child sending me the delegator-Grant +-- * Update the Dest record, enabling the child +-- * Send a start-Grant giving access-to-me +-- * For each of my projects, send an extension-Grant to the new +-- parent +-- * For each grant I've been delegated from my parents, send an +-- extension-Grant to the new child +-- +-- * If neither of those, raise an error groupGrant :: UTCTime -> GroupId @@ -1758,64 +1794,103 @@ groupGrant -> ActE (Text, Act (), Next) groupGrant now groupID (Verse authorIdMsig body) grant = do - -- Check capability - capability <- do + grant' <- checkGrant grant + let adapt = maybe (Right Nothing) (either Left (Right . Just)) + maybeMode <- + withDBExcept $ ExceptT $ fmap adapt $ runMaybeT $ + runExceptT (Left . Left <$> tryProject grant') <|> + runExceptT (Left . Right <$> tryCollab grant') <|> + runExceptT (Right . Left <$> tryParent grant') <|> + runExceptT (Right . Right <$> tryAlmostChild grant') + mode <- + fromMaybeE + maybeMode + "Not a relevant Grant that I'm aware of" + case mode of + Left (Left ()) -> + handleProject + Left (Right (enableID, role, recip)) -> + handleCollab enableID role recip + Right (Left (role, sendID, topic)) -> + handleParent role sendID topic + Right (Right (role, topic, acceptID)) -> + handleAlmostChild role topic acceptID + where + + checkCapability = do -- Verify that a capability is provided - uCap <- do - let muCap = AP.activityCapability $ actbActivity body - fromMaybeE muCap "No capability provided" + uCap <- lift $ hoistMaybe $ AP.activityCapability $ actbActivity body -- Verify the capability URI is one of: -- * Outbox item URI of a local actor, i.e. a local activity -- * A remote URI - cap <- nameExceptT "Invite capability" $ parseActivityURI' uCap + cap <- + ExceptT . lift . lift . runExceptT $ + nameExceptT "Grant capability" $ parseActivityURI' uCap -- Verify the capability is local case cap of Left (actorByKey, _, outboxItemID) -> return (actorByKey, outboxItemID) - _ -> throwE "Capability is remote i.e. definitely not by me" + _ -> lift mzero - -- Check grant - collab <- checkDelegator grant - - handleCollab capability collab - - where - - checkDelegator g = do + checkGrant g = do (role, resource, recipient, _mresult, mstart, mend, usage, mdeleg) <- parseGrant' g - case role of - AP.RXRole _ -> throwE "Role isn't delegator" - AP.RXDelegator -> pure () - collab <- - bitraverse - (\case - LocalActorPerson p -> pure p - _ -> throwE "Local resource isn't a Person, therefore not a collaborator of mine" - ) - pure - resource - case (collab, authorIdMsig) of - (Left c, Left (a, _, _)) | LocalActorPerson c == a -> pure () - (Right u, Right (ra, _, _)) | remoteAuthorURI ra == u -> pure () - _ -> throwE "Author and context aren't the same actor" case recipient of - Left (LocalActorGroup g) | g == groupID -> pure () + Left (LocalActorGroup j) | j == groupID -> pure () _ -> throwE "Target isn't me" for_ mstart $ \ start -> unless (start < now) $ throwE "Start time is in the future" for_ mend $ \ _ -> throwE "End time is specified" - unless (usage == AP.Invoke) $ - throwE "Usage isn't Invoke" - for_ mdeleg $ \ _ -> - throwE "'delegates' is specified" - return collab - handleCollab capability collab = do + let resourceIsAuthor = + case (resource, authorIdMsig) of + (Left a, Left (a', _, _)) -> a == a' + (Right u, Right (ra, _, _)) -> remoteAuthorURI ra == u + _ -> False + + case (role, resourceIsAuthor, usage, mdeleg) of + (AP.RXRole r, True, AP.GatherAndConvey, Nothing) -> + pure $ GKDelegationStart r + (AP.RXRole r, False, AP.GatherAndConvey, Just _) -> + pure $ GKDelegationExtend r resource + (AP.RXDelegator, True, AP.Invoke, Nothing) -> + pure GKDelegator + _ -> throwE "A kind of Grant that I don't use" + + tryProject _ = lift mzero + + handleProject = done "handleProject" + + tryCollab (GKDelegationStart _) = lift mzero + tryCollab (GKDelegationExtend _ _) = lift mzero + tryCollab GKDelegator = do + capability <- checkCapability + -- Find the Collab record from the capability + Entity enableID (CollabEnable collabID _) <- lift $ do + -- Capability isn't mine + guard $ fst capability == LocalActorGroup groupID + -- I don't have a Collab with this capability + MaybeT $ getBy $ UniqueCollabEnableGrant $ snd capability + Collab role _ <- lift $ lift $ getJust collabID + topic <- lift $ lift $ getCollabTopic collabID + -- Found a Collab for this direct-Grant but it's not mine + lift $ guard $ topic == LocalResourceGroup groupID + recip <- lift $ lift $ getCollabRecip collabID + recipForCheck <- + lift $ lift $ + bitraverse + (pure . collabRecipLocalPerson . entityVal) + (getRemoteActorURI <=< getJust . collabRecipRemoteActor . entityVal) + recip + unless (first LocalActorPerson recipForCheck == bimap (view _1) (remoteAuthorURI . view _1) authorIdMsig) $ + throwE "Capability's collaborator and Grant author aren't the same actor" + return (enableID, role, recip) + + handleCollab enableID role recip = do maybeNew <- withDBExcept $ do @@ -1825,26 +1900,6 @@ groupGrant now groupID (Verse authorIdMsig body) grant = do let actorID = groupActor recip (actorID,) <$> getJust actorID - -- Find the Collab record from the capability - Entity enableID (CollabEnable collabID _) <- do - unless (fst capability == LocalActorGroup groupID) $ - throwE "Capability isn't mine" - m <- lift $ getBy $ UniqueCollabEnableGrant $ snd capability - fromMaybeE m "I don't have a Collab with this capability" - Collab role _ <- lift $ getJust collabID - topic <- lift $ getCollabTopic collabID - unless (topic == LocalResourceGroup groupID) $ - throwE "Found a Collab for this direct-Grant but it's not mine" - recip <- lift $ getCollabRecip collabID - recipForCheck <- - lift $ - bitraverse - (pure . collabRecipLocalPerson . entityVal) - (getRemoteActorURI <=< getJust . collabRecipRemoteActor . entityVal) - recip - unless (recipForCheck == collab) $ - throwE "Capability's collaborator and Grant author aren't the same actor" - -- Verify I don't yet have a delegator-Grant from the collaborator maybeDeleg <- lift $ case bimap entityKey entityKey recip of @@ -1856,20 +1911,99 @@ groupGrant now groupID (Verse authorIdMsig body) grant = do for maybeGrantDB $ \ (inboxItemID, grantDB) -> do -- Record the delegator-Grant in the Collab record - lift $ case (grantDB, bimap entityKey entityKey recip) of - (Left (grantActor, _, grantID), Left localID) -> - insert_ $ CollabDelegLocal enableID localID grantID - (Right (_, _, grantID), Right remoteID) -> - insert_ $ CollabDelegRemote enableID remoteID grantID - _ -> error "groupGrant impossible 2" + (insertLeaf, uDeleg) <- + lift $ case (grantDB, bimap entityKey entityKey recip) of + (Left (grantActor, _, grantID), Left localID) -> do + delegID <- insert $ CollabDelegLocal enableID localID grantID + encodeRouteHome <- getEncodeRouteHome + delegR <- + activityRoute + <$> hashLocalActor grantActor + <*> encodeKeyHashid grantID + return + ( \ leafID -> + insert_ $ SourceUsLeafToLocal leafID delegID + , encodeRouteHome delegR + ) + (Right (_, _, grantID), Right remoteID) -> do + delegID <- insert $ CollabDelegRemote enableID remoteID grantID + u <- getRemoteActivityURI =<< getJust grantID + return + ( \ leafID -> + insert_ $ SourceUsLeafToRemote leafID delegID + , u + ) + _ -> error "groupGrant impossible 2" -- Prepare forwarding of Accept to my followers groupHash <- encodeKeyHashid groupID let sieve = makeRecipientSet [] [LocalStageGroupFollowers groupHash] - -- For each parent group of mine, prepare a - -- delegation-extension Grant - extensions <- lift $ pure [] + extensions <- lift $ do + -- For each Project of mine, prepare a delegation-extension + -- Grant + (uCollab, audCollab) <- + case recip of + Left (Entity _ (CollabRecipLocal _ personID)) -> do + personHash <- encodeKeyHashid personID + encodeRouteHome <- getEncodeRouteHome + return + ( encodeRouteHome $ PersonR personHash + , AudLocal [LocalActorPerson personHash] [] + ) + Right (Entity _ (CollabRecipRemote _ raID)) -> do + ra <- getJust raID + u@(ObjURI h lu) <- getRemoteActorURI ra + return (u, AudRemote h [lu] []) + fromProjects <- pure [] + + -- For each Grant I got from a parent, prepare a + -- delegation-extension Grant + l <- + fmap (map $ over _2 Left) $ + E.select $ E.from $ \ (source `E.InnerJoin` holder `E.InnerJoin` topic `E.InnerJoin` accept `E.InnerJoin` send `E.InnerJoin` deleg) -> do + E.on $ accept E.^. SourceThemAcceptLocalId E.==. deleg E.^. SourceThemDelegateLocalSource + E.on $ source E.^. SourceId E.==. send E.^. SourceUsSendDelegatorSource + E.on $ topic E.^. SourceTopicLocalId E.==. accept E.^. SourceThemAcceptLocalTopic + E.on $ source E.^. SourceId E.==. topic E.^. SourceTopicLocalSource + E.on $ source E.^. SourceId E.==. holder E.^. SourceHolderGroupSource + E.where_ $ holder E.^. SourceHolderGroupGroup E.==. E.val groupID + return + ( send E.^. SourceUsSendDelegatorId + , deleg + ) + r <- + fmap (map $ over _2 Right) $ + E.select $ E.from $ \ (source `E.InnerJoin` holder `E.InnerJoin` topic `E.InnerJoin` accept `E.InnerJoin` send `E.InnerJoin` deleg) -> do + E.on $ accept E.^. SourceThemAcceptRemoteId E.==. deleg E.^. SourceThemDelegateRemoteSource + E.on $ source E.^. SourceId E.==. send E.^. SourceUsSendDelegatorSource + E.on $ topic E.^. SourceTopicRemoteId E.==. accept E.^. SourceThemAcceptRemoteTopic + E.on $ source E.^. SourceId E.==. topic E.^. SourceTopicRemoteSource + E.on $ source E.^. SourceId E.==. holder E.^. SourceHolderGroupSource + E.where_ $ holder E.^. SourceHolderGroupGroup E.==. E.val groupID + return + ( send E.^. SourceUsSendDelegatorId + , deleg + ) + fromParents <- for (l ++ r) $ \ (E.Value sendID, deleg) -> do + extID <- insertEmptyOutboxItem' (actorOutbox recipActor) now + leafID <- insert $ SourceUsLeaf sendID enableID extID + case bimap entityKey entityKey deleg of + Left fromID -> insert_ $ SourceUsLeafFromLocal leafID fromID + Right fromID -> insert_ $ SourceUsLeafFromRemote leafID fromID + insertLeaf leafID + (AP.Doc h a, grant) <- getGrantActivityBody $ bimap (sourceThemDelegateLocalGrant . entityVal) (sourceThemDelegateRemoteGrant . entityVal) deleg + uStart <- + case AP.activityId a of + Nothing -> error "SourceThemDelegate grant has no 'id'" + Just lu -> pure $ ObjURI h lu + ext@(actionExt, _, _, _) <- + prepareExtensionGrantFromParent uCollab audCollab uDeleg uStart grant role enableID + let recipByKey = LocalActorGroup groupID + _luExt <- updateOutboxItem' recipByKey extID actionExt + return (extID, ext) + + return $ fromProjects ++ fromParents return (recipActorID, sieve, extensions, inboxItemID) @@ -1883,7 +2017,629 @@ groupGrant now groupID (Verse authorIdMsig body) grant = do sendActivity recipByID recipActorID localRecipsExt remoteRecipsExt fwdHostsExt extID actionExt - doneDB inboxItemID "Forwarded the delegator-Grant, updated DB" + doneDB inboxItemID "[Collab] Forwarded the delegator-Grant, updated DB and published delegation extensions" + + where + + prepareExtensionGrantFromParent uCollab audCollab uDeleg uStart grant role enableID = do + encodeRouteHome <- getEncodeRouteHome + encodeRouteLocal <- getEncodeRouteLocal + + groupHash <- encodeKeyHashid groupID + enableHash <- encodeKeyHashid enableID + finalRole <- + case AP.grantObject grant of + AP.RXRole r -> pure $ min role r + AP.RXDelegator -> error "Why was I delegated a Grant with object=delegator?" + + let (recipientSet, remoteActors, fwdHosts, audLocal, audRemote) = + collectAudience [audCollab] + + recips = map encodeRouteHome audLocal ++ audRemote + action = AP.Action + { AP.actionCapability = Just uDeleg + , AP.actionSummary = Nothing + , AP.actionAudience = AP.Audience recips [] [] [] [] [] + , AP.actionFulfills = [uStart] + , AP.actionSpecific = AP.GrantActivity AP.Grant + { AP.grantObject = AP.RXRole finalRole + , AP.grantContext = AP.grantContext grant + , AP.grantTarget = uCollab + , AP.grantResult = + Just + (encodeRouteLocal $ + GroupMemberLiveR groupHash enableHash + , Nothing + ) + , AP.grantStart = Just now + , AP.grantEnd = Nothing + , AP.grantAllows = AP.Invoke + , AP.grantDelegates = Just uStart + } + } + + return (action, recipientSet, remoteActors, fwdHosts) + + tryParent gk = do + capability <- checkCapability + role <- + case gk of + GKDelegationStart role -> pure role + GKDelegationExtend role _ -> pure role + GKDelegator -> lift mzero + -- Find the Source record from the capability + Entity sendID (SourceUsSendDelegator sourceID _) <- lift $ do + -- Capability isn't mine + guard $ fst capability == LocalActorGroup groupID + -- I don't have a Source with this capability + MaybeT $ getBy $ UniqueSourceUsSendDelegatorGrant $ snd capability + Source role' <- lift $ lift $ getJust sourceID + SourceHolderGroup _ g <- + lift $ MaybeT $ getValBy $ UniqueSourceHolderGroup sourceID + -- Found a Source for this Grant but it's not mine + lift $ guard $ g == groupID + topic <- do + t <- lift $ lift $ getSourceTopic sourceID + bitraverse + (bitraverse + pure + (\case + Right g -> pure g + Left _j -> error "I have a SourceTopic that is a Project" + ) + ) + pure + t + topicForCheck <- + lift $ lift $ + bitraverse + (pure . snd) + (\ (_, raID) -> getRemoteActorURI =<< getJust raID) + topic + unless (first LocalActorGroup topicForCheck == bimap (view _1) (remoteAuthorURI . view _1) authorIdMsig) $ + throwE "Capability's source and Grant author aren't the same actor" + return (min role role', sendID, topic) + + handleParent role sendID topic = do + + uCap <- lift $ getActivityURI authorIdMsig + checkCapabilityBeforeExtending uCap (LocalActorGroup groupID) + + maybeNew <- withDBExcept $ do + + -- Grab me from DB + resourceID <- lift $ groupResource <$> getJust groupID + Resource recipActorID <- lift $ getJust resourceID + recipActor <- lift $ getJust recipActorID + + topicWithAccept <- + lift $ + bitraverse + (\ (localID, jID) -> + (localID, jID,) <$> + getKeyByJust (UniqueSourceThemAcceptLocal localID) + ) + (\ (remoteID, aID) -> + (remoteID, aID,) <$> + getKeyByJust (UniqueSourceThemAcceptRemote remoteID) + ) + topic + + maybeGrantDB <- lift $ insertToInbox now authorIdMsig body (actorInbox recipActor) False + for maybeGrantDB $ \ (inboxItemID, grantDB) -> do + + -- Record the delegation in DB + from <- case (grantDB, bimap (view _3) (view _3) topicWithAccept) of + (Left (_, _, grantID), Left localID) -> Left <$> do + mk <- lift $ insertUnique $ SourceThemDelegateLocal localID grantID + fromMaybeE mk "I already have such a SourceThemDelegateLocal" + (Right (_, _, grantID), Right remoteID) -> Right <$> do + mk <- lift $ insertUnique $ SourceThemDelegateRemote remoteID grantID + fromMaybeE mk "I already have such a SourceThemDelegateRemote" + _ -> error "projectGrant.child impossible" + + -- For each Collab in me, prepare a delegation-extension Grant + localCollabs <- + lift $ + E.select $ E.from $ \ (collab `E.InnerJoin` enable `E.InnerJoin` recipL `E.InnerJoin` deleg) -> do + E.on $ enable E.^. CollabEnableId E.==. deleg E.^. CollabDelegLocalEnable + E.on $ enable E.^. CollabEnableCollab E.==. recipL E.^. CollabRecipLocalCollab + E.on $ collab E.^. CollabId E.==. enable E.^. CollabEnableCollab + E.where_ $ collab E.^. CollabTopic E.==. E.val resourceID + return + ( collab E.^. CollabRole + , recipL E.^. CollabRecipLocalPerson + , deleg + ) + localExtensions <- lift $ for localCollabs $ \ (E.Value role', E.Value personID, Entity delegID (CollabDelegLocal enableID _recipID grantID)) -> do + extID <- insertEmptyOutboxItem' (actorOutbox recipActor) now + leafID <- insert $ SourceUsLeaf sendID enableID extID + case from of + Left localID -> insert_ $ SourceUsLeafFromLocal leafID localID + Right remoteID -> insert_ $ SourceUsLeafFromRemote leafID remoteID + insert_ $ SourceUsLeafToLocal leafID delegID + ext@(actionExt, _, _, _) <- + prepareExtensionGrant (Left (personID, grantID)) (min role role') enableID + let recipByKey = LocalActorGroup groupID + _luExt <- updateOutboxItem' recipByKey extID actionExt + return (extID, ext) + + remoteCollabs <- + lift $ + E.select $ E.from $ \ (collab `E.InnerJoin` enable `E.InnerJoin` recipR `E.InnerJoin` deleg) -> do + E.on $ enable E.^. CollabEnableId E.==. deleg E.^. CollabDelegRemoteEnable + E.on $ enable E.^. CollabEnableCollab E.==. recipR E.^. CollabRecipRemoteCollab + E.on $ collab E.^. CollabId E.==. enable E.^. CollabEnableCollab + E.where_ $ collab E.^. CollabTopic E.==. E.val resourceID + return + ( collab E.^. CollabRole + , recipR E.^. CollabRecipRemoteActor + , deleg + ) + remoteExtensions <- lift $ for remoteCollabs $ \ (E.Value role', E.Value raID, Entity delegID (CollabDelegRemote enableID _recipID grantID)) -> do + extID <- insertEmptyOutboxItem' (actorOutbox recipActor) now + leafID <- insert $ SourceUsLeaf sendID enableID extID + case from of + Left localID -> insert_ $ SourceUsLeafFromLocal leafID localID + Right remoteID -> insert_ $ SourceUsLeafFromRemote leafID remoteID + insert_ $ SourceUsLeafToRemote leafID delegID + ext@(actionExt, _, _, _) <- + prepareExtensionGrant (Right (raID, grantID)) (min role role') enableID + let recipByKey = LocalActorGroup groupID + _luExt <- updateOutboxItem' recipByKey extID actionExt + return (extID, ext) + + -- For each child of mine, prepare a delegation-extension Grant + localChildren <- + lift $ + E.select $ E.from $ \ (dest `E.InnerJoin` holder `E.InnerJoin` topic `E.InnerJoin` deleg `E.InnerJoin` accept `E.InnerJoin` start) -> do + E.on $ accept E.^. DestUsAcceptId E.==. start E.^. DestUsStartDest + E.on $ dest E.^. DestId E.==. accept E.^. DestUsAcceptDest + E.on $ topic E.^. DestTopicGroupTopic E.==. deleg E.^. DestThemSendDelegatorLocalTopic + E.on $ holder E.^. DestHolderGroupId E.==. topic E.^. DestTopicGroupHolder + E.on $ dest E.^. DestId E.==. holder E.^. DestHolderGroupDest + E.where_ $ holder E.^. DestHolderGroupGroup E.==. E.val groupID + return + ( dest E.^. DestRole + , topic E.^. DestTopicGroupChild + , deleg E.^. DestThemSendDelegatorLocalId + , deleg E.^. DestThemSendDelegatorLocalGrant + , accept E.^. DestUsAcceptId + , start E.^. DestUsStartId + ) + localExtensionsForChildren <- lift $ for localChildren $ \ (E.Value role', E.Value childID, E.Value _delegID, E.Value grantID, E.Value _acceptID, E.Value startID) -> do + extID <- insertEmptyOutboxItem' (actorOutbox recipActor) now + gatherID <- insert $ SourceUsGather sendID startID extID + case from of + Left localID -> insert_ $ SourceUsGatherFromLocal gatherID localID + Right remoteID -> insert_ $ SourceUsGatherFromRemote gatherID remoteID + ext@(actionExt, _, _, _) <- + prepareExtensionGrantForChild (Left (childID, grantID)) (min role role') startID + let recipByKey = LocalActorGroup groupID + _luExt <- updateOutboxItem' recipByKey extID actionExt + return (extID, ext) + + remoteChildren <- + lift $ + E.select $ E.from $ \ (dest `E.InnerJoin` holder `E.InnerJoin` topic `E.InnerJoin` deleg `E.InnerJoin` accept `E.InnerJoin` start) -> do + E.on $ accept E.^. DestUsAcceptId E.==. start E.^. DestUsStartDest + E.on $ dest E.^. DestId E.==. accept E.^. DestUsAcceptDest + E.on $ topic E.^. DestTopicRemoteId E.==. deleg E.^. DestThemSendDelegatorRemoteTopic + E.on $ dest E.^. DestId E.==. topic E.^. DestTopicRemoteDest + E.on $ dest E.^. DestId E.==. holder E.^. DestHolderGroupDest + E.where_ $ holder E.^. DestHolderGroupGroup E.==. E.val groupID + return + ( dest E.^. DestRole + , topic E.^. DestTopicRemoteTopic + , deleg E.^. DestThemSendDelegatorRemoteId + , deleg E.^. DestThemSendDelegatorRemoteGrant + , accept E.^. DestUsAcceptId + , start E.^. DestUsStartId + ) + remoteExtensionsForChildren <- lift $ for remoteChildren $ \ (E.Value role', E.Value childID, E.Value _delegID, E.Value grantID, E.Value _acceptID, E.Value startID) -> do + extID <- insertEmptyOutboxItem' (actorOutbox recipActor) now + gatherID <- insert $ SourceUsGather sendID startID extID + case from of + Left localID -> insert_ $ SourceUsGatherFromLocal gatherID localID + Right remoteID -> insert_ $ SourceUsGatherFromRemote gatherID remoteID + ext@(actionExt, _, _, _) <- + prepareExtensionGrantForChild (Right (childID, grantID)) (min role role') startID + let recipByKey = LocalActorGroup groupID + _luExt <- updateOutboxItem' recipByKey extID actionExt + return (extID, ext) + + return + ( recipActorID + , localExtensions ++ localExtensionsForChildren + , remoteExtensions ++ remoteExtensionsForChildren + , inboxItemID + ) + + case maybeNew of + Nothing -> done "I already have this activity in my inbox" + Just (recipActorID, localExts, remoteExts, inboxItemID) -> do + let recipByID = LocalActorGroup groupID + lift $ for_ (localExts ++ remoteExts) $ + \ (extID, (actionExt, localRecipsExt, remoteRecipsExt, fwdHostsExt)) -> + sendActivity + recipByID recipActorID localRecipsExt + remoteRecipsExt fwdHostsExt extID actionExt + doneDB inboxItemID "[Parent] Sent extensions to collabs & children" + + where + + prepareExtensionGrant collab role enableID = do + encodeRouteHome <- getEncodeRouteHome + encodeRouteLocal <- getEncodeRouteLocal + + groupHash <- encodeKeyHashid groupID + uStart <- lift $ getActivityURI authorIdMsig + + (uCollab, audCollab, uDeleg) <- + case collab of + Left (personID, itemID) -> do + personHash <- encodeKeyHashid personID + itemHash <- encodeKeyHashid itemID + return + ( encodeRouteHome $ PersonR personHash + , AudLocal [LocalActorPerson personHash] [] + , encodeRouteHome $ + PersonOutboxItemR personHash itemHash + ) + Right (raID, ractID) -> do + ra <- getJust raID + u@(ObjURI h lu) <- getRemoteActorURI ra + uAct <- do + ract <- getJust ractID + getRemoteActivityURI ract + return (u, AudRemote h [lu] [], uAct) + + enableHash <- encodeKeyHashid enableID + + let audience = [audCollab] + + (recipientSet, remoteActors, fwdHosts, audLocal, audRemote) = + collectAudience audience + + recips = map encodeRouteHome audLocal ++ audRemote + action = AP.Action + { AP.actionCapability = Just uDeleg + , AP.actionSummary = Nothing + , AP.actionAudience = AP.Audience recips [] [] [] [] [] + , AP.actionFulfills = [uStart] + , AP.actionSpecific = AP.GrantActivity AP.Grant + { AP.grantObject = AP.RXRole role + , AP.grantContext = AP.grantContext grant + , AP.grantTarget = uCollab + , AP.grantResult = + Just + (encodeRouteLocal $ + GroupMemberLiveR groupHash enableHash + , Nothing + ) + , AP.grantStart = Just now + , AP.grantEnd = Nothing + , AP.grantAllows = AP.Invoke + , AP.grantDelegates = Just uStart + } + } + + return (action, recipientSet, remoteActors, fwdHosts) + + prepareExtensionGrantForChild child role startID = do + encodeRouteHome <- getEncodeRouteHome + encodeRouteLocal <- getEncodeRouteLocal + + groupHash <- encodeKeyHashid groupID + uStart <- lift $ getActivityURI authorIdMsig + + (uChild, audChild, uDeleg) <- + case child of + Left (g, itemID) -> do + h <- encodeKeyHashid g + itemHash <- encodeKeyHashid itemID + return + ( encodeRouteHome $ GroupR h + , AudLocal [LocalActorGroup h] [] + , encodeRouteHome $ + GroupOutboxItemR h itemHash + ) + Right (raID, ractID) -> do + ra <- getJust raID + u@(ObjURI h lu) <- getRemoteActorURI ra + uAct <- do + ract <- getJust ractID + getRemoteActivityURI ract + return (u, AudRemote h [lu] [], uAct) + + resultR <- do + startHash <- encodeKeyHashid startID + return $ + GroupChildLiveR groupHash startHash + + let (recipientSet, remoteActors, fwdHosts, audLocal, audRemote) = + collectAudience [audChild] + + recips = map encodeRouteHome audLocal ++ audRemote + action = AP.Action + { AP.actionCapability = Just uDeleg + , AP.actionSummary = Nothing + , AP.actionAudience = AP.Audience recips [] [] [] [] [] + , AP.actionFulfills = [uStart] + , AP.actionSpecific = AP.GrantActivity AP.Grant + { AP.grantObject = AP.RXRole role + , AP.grantContext = AP.grantContext grant + , AP.grantTarget = uChild + , AP.grantResult = + Just (encodeRouteLocal resultR, Nothing) + , AP.grantStart = Just now + , AP.grantEnd = Nothing + , AP.grantAllows = AP.Distribute + , AP.grantDelegates = Just uStart + } + } + + return (action, recipientSet, remoteActors, fwdHosts) + + tryAlmostChild (GKDelegationStart _) = lift mzero + tryAlmostChild (GKDelegationExtend _ _) = lift mzero + tryAlmostChild GKDelegator = do + uFulfills <- + case AP.activityFulfills $ actbActivity body of + [] -> throwE "No fulfills" + [u] -> pure u + _ -> throwE "Multiple fulfills" + fulfills <- ExceptT $ lift $ lift $ runExceptT $ first (\ (a, _, i) -> (a, i)) <$> parseActivityURI' uFulfills + fulfillsDB <- ExceptT $ MaybeT $ either (Just . Left) (fmap Right) <$> runExceptT (getActivity fulfills) + -- Find the Dest record from the fulfills + destID <- + lift $ + case fulfillsDB of + Left (_, _, addID) -> + (do DestUsGestureLocal destID _ <- MaybeT $ getValBy $ UniqueDestUsGestureLocalActivity addID + _ <- MaybeT $ getBy $ UniqueDestOriginUs destID + return destID + ) + <|> + (do DestThemGestureLocal themID _ <- MaybeT $ getValBy $ UniqueDestThemGestureLocalAdd addID + DestOriginThem destID <- lift $ getJust themID + return destID + ) + Right addID -> + (do DestUsGestureRemote destID _ _ <- MaybeT $ getValBy $ UniqueDestUsGestureRemoteActivity addID + _ <- MaybeT $ getBy $ UniqueDestOriginUs destID + return destID + ) + <|> + (do DestThemGestureRemote themID _ _ <- MaybeT $ getValBy $ UniqueDestThemGestureRemoteAdd addID + DestOriginThem destID <- lift $ getJust themID + return destID + ) + -- Verify this Dest record is mine + DestHolderGroup _ g <- lift $ MaybeT $ getValBy $ UniqueDestHolderGroup destID + lift $ guard $ g == groupID + -- Verify the Grant sender is the Dest topic + topic <- do + t <- lift $ lift $ getDestTopic destID + bitraverse + (bitraverse + pure + (\case + Right g -> pure g + Left _j -> error "I have a DestTopic that is a Project" + ) + ) + pure + t + topicForCheck <- + lift $ lift $ + bitraverse + (pure . snd) + (\ (_, raID) -> getRemoteActorURI =<< getJust raID) + topic + unless (first LocalActorGroup topicForCheck == bimap (view _1) (remoteAuthorURI . view _1) authorIdMsig) $ + throwE "Dest topic and Grant author aren't the same actor" + -- Verify I sent my Accept + maybeMe <- lift $ lift $ getKeyBy $ UniqueDestUsAccept destID + meAcceptID <- fromMaybeE maybeMe "I haven't sent my Accept" + -- Verify I haven't yet seen a delegator-Grant from the parent + case bimap fst fst topic of + Left localID -> do + m <- lift $ lift $ getBy $ UniqueDestThemSendDelegatorLocalTopic localID + verifyNothingE m "Already have a DestThemSendDelegatorLocal" + Right remoteID -> do + m <- lift $ lift $ getBy $ UniqueDestThemSendDelegatorRemoteTopic remoteID + verifyNothingE m "Already have a DestThemSendDelegatorRemote" + Dest role <- lift $ lift $ getJust destID + return (role, topic, meAcceptID) + + handleAlmostChild role topic acceptID = do + + maybeNew <- withDBExcept $ do + + -- Grab me from DB + (recipActorID, recipActor) <- lift $ do + recip <- getJust groupID + let actorID = groupActor recip + (actorID,) <$> getJust actorID + + maybeGrantDB <- lift $ insertToInbox now authorIdMsig body (actorInbox recipActor) False + for maybeGrantDB $ \ (inboxItemID, grantDB) -> do + + -- Record the delegator-Grant in DB + to <- case (grantDB, bimap fst fst topic) of + (Left (_, _, grantID), Left localID) -> Left <$> do + mk <- lift $ insertUnique $ DestThemSendDelegatorLocal acceptID localID grantID + fromMaybeE mk "I already have such a DestThemSendDelegatorLocal" + (Right (_, _, grantID), Right remoteID) -> Right <$> do + mk <- lift $ insertUnique $ DestThemSendDelegatorRemote acceptID remoteID grantID + fromMaybeE mk "I already have such a DestThemSendDelegatorRemote" + _ -> error "groupGrant.child impossible" + + startID <- lift $ insertEmptyOutboxItem' (actorOutbox recipActor) now + destStartID <- lift $ insert $ DestUsStart acceptID startID + + -- Prepare a start-Grant + start@(actionStart, _, _, _) <- lift $ prepareStartGrant role destStartID + let recipByKey = LocalActorGroup groupID + _luStart <- lift $ updateOutboxItem' recipByKey startID actionStart + + -- For each Project in me, prepare a delegation-extension Grant + localExtensions <- pure [] + remoteExtensions <- pure [] + + -- For each Grant I got from a child, prepare a + -- delegation-extension Grant + l <- + lift $ fmap (map $ over _2 Left) $ + E.select $ E.from $ \ (source `E.InnerJoin` holder `E.InnerJoin` topic `E.InnerJoin` accept `E.InnerJoin` send `E.InnerJoin` deleg) -> do + E.on $ accept E.^. SourceThemAcceptLocalId E.==. deleg E.^. SourceThemDelegateLocalSource + E.on $ source E.^. SourceId E.==. send E.^. SourceUsSendDelegatorSource + E.on $ topic E.^. SourceTopicLocalId E.==. accept E.^. SourceThemAcceptLocalTopic + E.on $ source E.^. SourceId E.==. topic E.^. SourceTopicLocalSource + E.on $ source E.^. SourceId E.==. holder E.^. SourceHolderGroupSource + E.where_ $ holder E.^. SourceHolderGroupGroup E.==. E.val groupID + return + ( send E.^. SourceUsSendDelegatorId + , deleg + ) + r <- + lift $ fmap (map $ over _2 Right) $ + E.select $ E.from $ \ (source `E.InnerJoin` holder `E.InnerJoin` topic `E.InnerJoin` accept `E.InnerJoin` send `E.InnerJoin` deleg) -> do + E.on $ accept E.^. SourceThemAcceptRemoteId E.==. deleg E.^. SourceThemDelegateRemoteSource + E.on $ source E.^. SourceId E.==. send E.^. SourceUsSendDelegatorSource + E.on $ topic E.^. SourceTopicRemoteId E.==. accept E.^. SourceThemAcceptRemoteTopic + E.on $ source E.^. SourceId E.==. topic E.^. SourceTopicRemoteSource + E.on $ source E.^. SourceId E.==. holder E.^. SourceHolderGroupSource + E.where_ $ holder E.^. SourceHolderGroupGroup E.==. E.val groupID + return + ( send E.^. SourceUsSendDelegatorId + , deleg + ) + fromParents <- lift $ for (l ++ r) $ \ (E.Value sendID, deleg) -> do + extID <- insertEmptyOutboxItem' (actorOutbox recipActor) now + + gatherID <- insert $ SourceUsGather sendID destStartID extID + case bimap entityKey entityKey deleg of + Left localID -> insert_ $ SourceUsGatherFromLocal gatherID localID + Right remoteID -> insert_ $ SourceUsGatherFromRemote gatherID remoteID + + (AP.Doc h a, grant) <- getGrantActivityBody $ bimap (sourceThemDelegateLocalGrant . entityVal) (sourceThemDelegateRemoteGrant . entityVal) deleg + uStart <- + case AP.activityId a of + Nothing -> error "SourceThemDelegate grant has no 'id'" + Just lu -> pure $ ObjURI h lu + ext@(actionExt, _, _, _) <- + prepareExtensionGrantFromParent uStart grant role destStartID + let recipByKey = LocalActorGroup groupID + _luExt <- updateOutboxItem' recipByKey extID actionExt + return (extID, ext) + + return + ( recipActorID + , (startID, start) : localExtensions ++ remoteExtensions ++ fromParents + , inboxItemID + ) + + case maybeNew of + Nothing -> done "I already have this activity in my inbox" + Just (recipActorID, exts, inboxItemID) -> do + let recipByID = LocalActorGroup groupID + lift $ for_ exts $ + \ (extID, (actionExt, localRecipsExt, remoteRecipsExt, fwdHostsExt)) -> + sendActivity + recipByID recipActorID localRecipsExt + remoteRecipsExt fwdHostsExt extID actionExt + doneDB inboxItemID "[Almost-child] Sent start-Grant and extensions from projects and parents" + + where + + prepareStartGrant role startID = do + encodeRouteHome <- getEncodeRouteHome + encodeRouteLocal <- getEncodeRouteLocal + + groupHash <- encodeKeyHashid groupID + + uDeleg <- lift $ getActivityURI authorIdMsig + + audChild <- lift $ makeAudSenderOnly authorIdMsig + uChild <- lift $ getActorURI authorIdMsig + + resultR <- do + startHash <- encodeKeyHashid startID + return $ GroupChildLiveR groupHash startHash + + let (recipientSet, remoteActors, fwdHosts, audLocal, audRemote) = + collectAudience [audChild] + + recips = map encodeRouteHome audLocal ++ audRemote + action = AP.Action + { AP.actionCapability = Just uDeleg + , AP.actionSummary = Nothing + , AP.actionAudience = AP.Audience recips [] [] [] [] [] + , AP.actionFulfills = [uDeleg] + , AP.actionSpecific = AP.GrantActivity AP.Grant + { AP.grantObject = AP.RXRole role + , AP.grantContext = encodeRouteHome $ GroupR groupHash + , AP.grantTarget = uChild + , AP.grantResult = + Just + ( encodeRouteLocal resultR + , Nothing + ) + , AP.grantStart = Just now + , AP.grantEnd = Nothing + , AP.grantAllows = AP.Distribute + , AP.grantDelegates = Nothing + } + } + + return (action, recipientSet, remoteActors, fwdHosts) + + prepareExtensionGrantFromParent uStart grant role startID = do + encodeRouteHome <- getEncodeRouteHome + encodeRouteLocal <- getEncodeRouteLocal + + groupHash <- encodeKeyHashid groupID + finalRole <- + case AP.grantObject grant of + AP.RXRole r -> pure $ min role r + AP.RXDelegator -> error "Why was I delegated a Grant with object=delegator?" + + uDeleg <- lift $ getActivityURI authorIdMsig + audChild <- lift $ makeAudSenderOnly authorIdMsig + uChild <- lift $ getActorURI authorIdMsig + + resultR <- do + startHash <- encodeKeyHashid startID + return $ GroupChildLiveR groupHash startHash + + let (recipientSet, remoteActors, fwdHosts, audLocal, audRemote) = + collectAudience [audChild] + + recips = map encodeRouteHome audLocal ++ audRemote + action = AP.Action + { AP.actionCapability = Just uDeleg + , AP.actionSummary = Nothing + , AP.actionAudience = AP.Audience recips [] [] [] [] [] + , AP.actionFulfills = [uStart] + , AP.actionSpecific = AP.GrantActivity AP.Grant + { AP.grantObject = AP.RXRole finalRole + , AP.grantContext = AP.grantContext grant + , AP.grantTarget = uChild + , AP.grantResult = + Just + ( encodeRouteLocal resultR + , Nothing + ) + , AP.grantStart = Just now + , AP.grantEnd = Nothing + , AP.grantAllows = AP.Distribute + , AP.grantDelegates = Just uStart + } + } + + return (action, recipientSet, remoteActors, fwdHosts) -- Meaning: An actor A invited actor B to a resource -- Behavior: