S2S: Project: Grant: Implement child mode

src/Vervis/Actor/Project.hs

@@ -1856,7 +1856,7 @@ projectFollow now recipProjectID verse follow = do
 
 data GrantKind
     = GKDelegationStart AP.Role
-    | GKDelegationExtend AP.Role
+    | GKDelegationExtend AP.Role (Either (LocalActorBy Key) FedURI)
     | GKDelegator
 
 -- Meaning: An actor is granting access-to-some-resource to another actor
@@ -1970,17 +1970,20 @@ projectGrant now projectID (Verse authorIdMsig body) grant = do
     let adapt = maybe (Right Nothing) (either Left (Right . Just))
     maybeMode <-
         withDBExcept $ ExceptT $ fmap adapt $ runMaybeT $
-            runExceptT (Left <$> tryComp capability grant') <|>
+            runExceptT (Left . Left <$> tryComp capability grant') <|>
-            runExceptT (Right <$> tryCollab capability grant')
+            runExceptT (Left . Right <$> tryCollab capability grant') <|>
+            runExceptT (Right <$> tryChild capability grant')
     mode <-
         fromMaybeE
             maybeMode
             "Not a relevant Grant that I'm aware of"
     case mode of
-        Left (role, enableID, ident, identForCheck) ->
+        Left (Left (role, enableID, ident, identForCheck)) ->
             handleComp role enableID ident identForCheck
-        Right (enableID, role, recip) ->
+        Left (Right (enableID, role, recip)) ->
             handleCollab enableID role recip
+        Right (role, sendID, topic) ->
+            handleChild role sendID topic
 
     where
 
@@ -2005,12 +2008,12 @@ projectGrant now projectID (Verse authorIdMsig body) grant = do
             (AP.RXRole r, True, AP.GatherAndConvey, Nothing) ->
                 pure $ GKDelegationStart r
             (AP.RXRole r, False, AP.GatherAndConvey, Just _) ->
-                pure $ GKDelegationExtend r
+                pure $ GKDelegationExtend r resource
             (AP.RXDelegator, True, AP.Invoke, Nothing) ->
                 pure GKDelegator
             _ -> throwE "A kind of Grant that I don't use"
 
-    tryComp _          (GKDelegationExtend _)   = lift mzero
+    tryComp _          (GKDelegationExtend _ _) = lift mzero
     tryComp _          GKDelegator              = lift mzero
     tryComp capability (GKDelegationStart role) = do
         -- Find the Component record from the capability
@@ -2311,9 +2314,9 @@ projectGrant now projectID (Verse authorIdMsig body) grant = do
 
             return (action, recipientSet, remoteActors, fwdHosts)
 
-    tryCollab _          (GKDelegationStart _)  = lift mzero
+    tryCollab _          (GKDelegationStart _)    = lift mzero
-    tryCollab _          (GKDelegationExtend _) = lift mzero
+    tryCollab _          (GKDelegationExtend _ _) = lift mzero
-    tryCollab capability GKDelegator            = do
+    tryCollab capability GKDelegator              = do
         -- Find the Collab record from the capability
         Entity enableID (CollabEnable collabID _) <- lift $ do
             -- Capability isn't mine
@@ -2594,6 +2597,331 @@ projectGrant now projectID (Verse authorIdMsig body) grant = do
 
             return (action, recipientSet, remoteActors, fwdHosts)
 
+    tryChild capability gk = do
+        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 == LocalActorProject projectID
+            -- I don't have a Source with this capability
+            MaybeT $ getBy $ UniqueSourceUsSendDelegatorGrant $ snd capability
+        Source role' <- lift $ lift $ getJust sourceID
+        SourceHolderProject _ j <-
+            lift $ MaybeT $ getValBy $ UniqueSourceHolderProject sourceID
+        -- Found a Source for this Grant but it's not mine
+        lift $ guard $ j == projectID
+        topic <- do
+            t <- lift $ lift $ getSourceTopic sourceID
+            bitraverse
+                (bitraverse
+                    pure
+                    (\case
+                        Left j -> pure j
+                        Right _g -> error "I have a SourceTopic that is a Group"
+                    )
+                )
+                pure
+                t
+        topicForCheck <-
+            lift $ lift $
+            bitraverse
+                (pure . snd)
+                (\ (_, raID) -> getRemoteActorURI =<< getJust raID)
+                topic
+        unless (first LocalActorProject 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)
+
+    handleChild role sendID topic = do
+
+        maybeNew <- withDBExcept $ do
+
+            -- Grab me from DB
+            (recipActorID, recipActor) <- lift $ do
+                recip <- getJust projectID
+                let actorID = projectActor recip
+                (actorID,) <$> getJust actorID
+
+            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 $ \ 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 $ \ (topic `E.InnerJoin` 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 $ topic E.^. CollabTopicProjectCollab E.==. enable E.^. CollabEnableCollab
+                        E.on $ topic E.^. CollabTopicProjectCollab E.==. collab E.^. CollabId
+                        E.where_ $ topic E.^. CollabTopicProjectProject E.==. E.val projectID
+                        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 = LocalActorProject projectID
+                    _luExt <- updateOutboxItem' recipByKey extID actionExt
+                    return (extID, ext)
+
+                remoteCollabs <-
+                    lift $
+                    E.select $ E.from $ \ (topic `E.InnerJoin` 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 $ topic E.^. CollabTopicProjectCollab E.==. enable E.^. CollabEnableCollab
+                        E.on $ topic E.^. CollabTopicProjectCollab E.==. collab E.^. CollabId
+                        E.where_ $ topic E.^. CollabTopicProjectProject E.==. E.val projectID
+                        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 = LocalActorProject projectID
+                    _luExt <- updateOutboxItem' recipByKey extID actionExt
+                    return (extID, ext)
+
+                -- For each parent of mine, prepare a delegation-extension Grant
+                localParents <-
+                    lift $
+                    E.select $ E.from $ \ (dest `E.InnerJoin` holder `E.InnerJoin` topic `E.InnerJoin` deleg `E.InnerJoin` accept) -> do
+                        E.on $ dest E.^. DestId E.==. accept E.^. DestUsAcceptDest
+                        E.on $ topic E.^. DestTopicProjectTopic E.==. deleg E.^. DestThemSendDelegatorLocalTopic
+                        E.on $ holder E.^. DestHolderProjectId E.==. topic E.^. DestTopicProjectHolder
+                        E.on $ dest E.^. DestId E.==. holder E.^. DestHolderProjectDest
+                        E.where_ $ holder E.^. DestHolderProjectProject E.==. E.val projectID
+                        return
+                            ( dest E.^. DestRole
+                            , topic E.^. DestTopicProjectParent
+                            , deleg E.^. DestThemSendDelegatorLocalId
+                            , deleg E.^. DestThemSendDelegatorLocalGrant
+                            , accept E.^. DestUsAcceptId
+                            )
+                localExtensionsForParents <- lift $ for localParents $ \ (E.Value role', E.Value parentID, E.Value delegID, E.Value grantID, E.Value acceptID) -> do
+                    extID <- insertEmptyOutboxItem' (actorOutbox recipActor) now
+                    gatherID <- insert $ SourceUsGather sendID acceptID extID
+                    case from of
+                        Left localID -> insert_ $ SourceUsGatherFromLocal gatherID localID
+                        Right remoteID -> insert_ $ SourceUsGatherFromRemote gatherID remoteID
+                    insert_ $ SourceUsGatherToLocal gatherID delegID
+                    ext@(actionExt, _, _, _) <-
+                        prepareExtensionGrantForParent (Left (parentID, grantID)) (min role role') (Left delegID)
+                    let recipByKey = LocalActorProject projectID
+                    _luExt <- updateOutboxItem' recipByKey extID actionExt
+                    return (extID, ext)
+
+                remoteParents <-
+                    lift $
+                    E.select $ E.from $ \ (dest `E.InnerJoin` holder `E.InnerJoin` topic `E.InnerJoin` deleg `E.InnerJoin` accept) -> do
+                        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.^. DestHolderProjectDest
+                        E.where_ $ holder E.^. DestHolderProjectProject E.==. E.val projectID
+                        return
+                            ( dest E.^. DestRole
+                            , topic E.^. DestTopicRemoteTopic
+                            , deleg E.^. DestThemSendDelegatorRemoteId
+                            , deleg E.^. DestThemSendDelegatorRemoteGrant
+                            , accept E.^. DestUsAcceptId
+                            )
+                remoteExtensionsForParents <- lift $ for remoteParents $ \ (E.Value role', E.Value parentID, E.Value delegID, E.Value grantID, E.Value acceptID) -> do
+                    extID <- insertEmptyOutboxItem' (actorOutbox recipActor) now
+                    gatherID <- insert $ SourceUsGather sendID acceptID extID
+                    case from of
+                        Left localID -> insert_ $ SourceUsGatherFromLocal gatherID localID
+                        Right remoteID -> insert_ $ SourceUsGatherFromRemote gatherID remoteID
+                    insert_ $ SourceUsGatherToRemote gatherID delegID
+                    ext@(actionExt, _, _, _) <-
+                        prepareExtensionGrantForParent (Right (parentID, grantID)) (min role role') (Right delegID)
+                    let recipByKey = LocalActorProject projectID
+                    _luExt <- updateOutboxItem' recipByKey extID actionExt
+                    return (extID, ext)
+
+                return
+                    ( recipActorID
+                    , localExtensions ++ localExtensionsForParents
+                    , remoteExtensions ++ remoteExtensionsForParents
+                    )
+
+        case maybeNew of
+            Nothing -> done "I already have this activity in my inbox"
+            Just (recipActorID, localExts, remoteExts) -> do
+                let recipByID = LocalActorProject projectID
+                lift $ for_ (localExts ++ remoteExts) $
+                    \ (extID, (actionExt, localRecipsExt, remoteRecipsExt, fwdHostsExt)) ->
+                        sendActivity
+                            recipByID recipActorID localRecipsExt
+                            remoteRecipsExt fwdHostsExt extID actionExt
+                done "Sent extensions to collabs & parents"
+
+        where
+
+        prepareExtensionGrant collab role enableID = do
+            encodeRouteHome <- getEncodeRouteHome
+            encodeRouteLocal <- getEncodeRouteLocal
+
+            projectHash <- encodeKeyHashid projectID
+            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 $
+                                    ProjectCollabLiveR projectHash enableHash
+                                , Nothing
+                                )
+                        , AP.grantStart     = Just now
+                        , AP.grantEnd       = Nothing
+                        , AP.grantAllows    = AP.Invoke
+                        , AP.grantDelegates = Just uStart
+                        }
+                    }
+
+            return (action, recipientSet, remoteActors, fwdHosts)
+
+        prepareExtensionGrantForParent parent role deleg = do
+            encodeRouteHome <- getEncodeRouteHome
+            encodeRouteLocal <- getEncodeRouteLocal
+
+            projectHash <- encodeKeyHashid projectID
+            uStart <- lift $ getActivityURI authorIdMsig
+
+            (uParent, audParent, uDeleg) <-
+                case parent of
+                    Left (j, itemID) -> do
+                        h <- encodeKeyHashid j
+                        itemHash <- encodeKeyHashid itemID
+                        return
+                            ( encodeRouteHome $ ProjectR h
+                            , AudLocal [LocalActorProject h] []
+                            , encodeRouteHome $
+                                ProjectOutboxItemR 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 <-
+                case deleg of
+                    Left delegID -> do
+                        delegHash <- encodeKeyHashid delegID
+                        return $
+                            ProjectParentLocalLiveR projectHash delegHash
+                    Right delegID -> do
+                        delegHash <- encodeKeyHashid delegID
+                        return $
+                            ProjectParentRemoteLiveR projectHash delegHash
+
+            let audience = [audParent]
+
+                (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    = uParent
+                        , AP.grantResult    =
+                            Just (encodeRouteLocal resultR, Nothing)
+                        , AP.grantStart     = Just now
+                        , AP.grantEnd       = Nothing
+                        , AP.grantAllows    = AP.GatherAndConvey
+                        , AP.grantDelegates = Just uStart
+                        }
+                    }
+
+            return (action, recipientSet, remoteActors, fwdHosts)
+
 -- Meaning: An actor A invited actor B to a resource
 -- Behavior:
 --      * Verify the resource is my collabs or components list

src/Vervis/Migration.hs

@@ -3198,6 +3198,18 @@ changes hLocal ctx =
                         insertMany_ $ map (PermitTopicExtendLocal565 sendID enableID . E.unValue) gs
       -- 570
     , addEntities model_570_source_dest
+      -- 571
+    , removeUnique' "SourceThemDelegateLocal" ""
+      -- 572
+    , removeUnique' "SourceThemDelegateLocal" "Grant"
+      -- 573
+    , removeUnique' "SourceThemDelegateRemote" ""
+      -- 574
+    , removeUnique' "SourceThemDelegateRemote" "Grant"
+      -- 575
+    , addUnique' "SourceThemDelegateLocal" "" ["source", "grant"]
+      -- 576
+    , addUnique' "SourceThemDelegateRemote" "" ["source", "grant"]
     ]
 
 migrateDB

th/models

@@ -1421,15 +1421,13 @@ SourceThemDelegateLocal
     source SourceThemAcceptLocalId
     grant  OutboxItemId
 
-    UniqueSourceThemDelegateLocal      source
+    UniqueSourceThemDelegateLocal source grant
-    UniqueSourceThemDelegateLocalGrant grant
 
 SourceThemDelegateRemote
     source SourceThemAcceptRemoteId
     grant  RemoteActivityId
 
-    UniqueSourceThemDelegateRemote      source
+    UniqueSourceThemDelegateRemote source grant
-    UniqueSourceThemDelegateRemoteGrant grant
 
 -- Witnesses that, seeing the delegation from them, I've sent an
 -- extension-Grant to a Dest of mine