S2S: Project: Grant: Child/parent delegation when adding collab/component
This commit is contained in:
parent
bdce87cf76
commit
3570d502cb
5 changed files with 376 additions and 47 deletions
|
@ -164,36 +164,66 @@ SourceThemDelegateRemote
|
||||||
-- Witnesses that, seeing the delegation from them, I've sent an
|
-- Witnesses that, seeing the delegation from them, I've sent an
|
||||||
-- extension-Grant to a Dest of mine
|
-- extension-Grant to a Dest of mine
|
||||||
|
|
||||||
SourceUsGatherLocal
|
SourceUsGather
|
||||||
deleg SourceUsSendDelegatorId
|
source SourceUsSendDelegatorId
|
||||||
dest DestThemSendDelegatorLocalId
|
dest DestUsAcceptId
|
||||||
grant OutboxItemId
|
grant OutboxItemId
|
||||||
|
|
||||||
UniqueSourceUsGatherLocal grant
|
SourceUsGatherFromLocal
|
||||||
|
gather SourceUsGatherId
|
||||||
|
from SourceThemDelegateLocalId
|
||||||
|
|
||||||
SourceUsGatherRemote
|
UniqueSourceUsGatherFromLocal gather
|
||||||
deleg SourceUsSendDelegatorId
|
|
||||||
dest DestThemSendDelegatorRemoteId
|
|
||||||
grant RemoteActivityId
|
|
||||||
|
|
||||||
UniqueSourceUsGatherRemote grant
|
SourceUsGatherFromRemote
|
||||||
|
gather SourceUsGatherId
|
||||||
|
from SourceThemDelegateRemoteId
|
||||||
|
|
||||||
|
UniqueSourceUsGatherFromRemote gather
|
||||||
|
|
||||||
|
SourceUsGatherToLocal
|
||||||
|
gather SourceUsGatherId
|
||||||
|
to DestThemSendDelegatorLocalId
|
||||||
|
|
||||||
|
UniqueSourceUsGatherToLocal gather
|
||||||
|
|
||||||
|
SourceUsGatherToRemote
|
||||||
|
gather SourceUsGatherId
|
||||||
|
to DestThemSendDelegatorRemoteId
|
||||||
|
|
||||||
|
UniqueSourceUsGatherToRemote gather
|
||||||
|
|
||||||
-- Witnesses that, seeing the delegation from them, I've sent a leaf-Grant to a
|
-- Witnesses that, seeing the delegation from them, I've sent a leaf-Grant to a
|
||||||
-- direct-collaborator of mine
|
-- direct-collaborator of mine
|
||||||
|
|
||||||
SourceUsLeafLocal
|
SourceUsLeaf
|
||||||
deleg SourceUsSendDelegatorId
|
source SourceUsSendDelegatorId
|
||||||
collab CollabDelegLocalId
|
collab CollabEnableId
|
||||||
grant OutboxItemId
|
grant OutboxItemId
|
||||||
|
|
||||||
UniqueSourceUsLeafLocal grant
|
SourceUsLeafFromLocal
|
||||||
|
leaf SourceUsLeafId
|
||||||
|
from SourceThemDelegateLocalId
|
||||||
|
|
||||||
SourceUsLeafRemote
|
UniqueSourceUsLeafFromLocal leaf
|
||||||
deleg SourceUsSendDelegatorId
|
|
||||||
collab CollabDelegRemoteId
|
|
||||||
grant RemoteActivityId
|
|
||||||
|
|
||||||
UniqueSourceUsLeafRemote grant
|
SourceUsLeafFromRemote
|
||||||
|
leaf SourceUsLeafId
|
||||||
|
from SourceThemDelegateRemoteId
|
||||||
|
|
||||||
|
UniqueSourceUsLeafFromRemote leaf
|
||||||
|
|
||||||
|
SourceUsLeafToLocal
|
||||||
|
leaf SourceUsLeafId
|
||||||
|
to CollabDelegLocalId
|
||||||
|
|
||||||
|
UniqueSourceUsLeafToLocal leaf
|
||||||
|
|
||||||
|
SourceUsLeafToRemote
|
||||||
|
leaf SourceUsLeafId
|
||||||
|
to CollabDelegRemoteId
|
||||||
|
|
||||||
|
UniqueSourceUsLeafToRemote leaf
|
||||||
|
|
||||||
------------------------------------------------------------------------------
|
------------------------------------------------------------------------------
|
||||||
-- Inheritance - Giver tracking her receivers
|
-- Inheritance - Giver tracking her receivers
|
||||||
|
|
|
@ -1871,13 +1871,20 @@ projectFollow now recipProjectID verse follow = do
|
||||||
-- * Record the delegation in the Component record in DB
|
-- * Record the delegation in the Component record in DB
|
||||||
-- * Forward the Grant to my followers
|
-- * Forward the Grant to my followers
|
||||||
-- * For each person (non-team) collaborator of mine, prepare and send an
|
-- * For each person (non-team) collaborator of mine, prepare and send an
|
||||||
-- extension-Grant, and store it in the Componet record in DB:
|
-- extension-Grant, and store it in the Component record in DB:
|
||||||
-- * Role: The lower among (1) admin (2) the collaborator's role in me
|
-- * Role: The lower among (1) admin (2) the collaborator's role in me
|
||||||
-- * Resource: C
|
-- * Resource: C
|
||||||
-- * Target: The collaborator
|
-- * Target: The collaborator
|
||||||
-- * Delegates: The Grant I just got from C
|
-- * Delegates: The Grant I just got from C
|
||||||
-- * Result: ProjectCollabLiveR for this collaborator
|
-- * Result: ProjectCollabLiveR for this collaborator
|
||||||
-- * Usage: invoke
|
-- * Usage: invoke
|
||||||
|
-- * For each parent of mine, prepare and send an extension-Grant:
|
||||||
|
-- * Role: The lower among (1) the role the component gave me (2) the role I gave the parent
|
||||||
|
-- * Resource: C
|
||||||
|
-- * Target: The parent
|
||||||
|
-- * Delegates: The Grant I just got from C
|
||||||
|
-- * Result: ProjectParentLiveR for this parent
|
||||||
|
-- * Usage: gatherAndConvey
|
||||||
--
|
--
|
||||||
-- * Option 2 - Collaborator sending me a delegator-Grant - Verify that:
|
-- * Option 2 - Collaborator sending me a delegator-Grant - Verify that:
|
||||||
-- * The sender is a collaborator of mine, A
|
-- * The sender is a collaborator of mine, A
|
||||||
|
@ -1899,8 +1906,33 @@ projectFollow now recipProjectID verse follow = do
|
||||||
-- * Delegates: The start-Grant I have from C
|
-- * Delegates: The start-Grant I have from C
|
||||||
-- * Result: ProjectCollabLiveR for this collaborator, A
|
-- * Result: ProjectCollabLiveR for this collaborator, A
|
||||||
-- * Usage: invoke
|
-- * Usage: invoke
|
||||||
|
-- * For each start-grant or extension-grant G that I received from a
|
||||||
|
-- child of mine J, prepare and send an extension-Grant to A, and store
|
||||||
|
-- it in the Source record in DB:
|
||||||
|
-- * Role: The lower among (1) the role in G (2) the collaborator's role in me
|
||||||
|
-- * Resource: The one specified in G
|
||||||
|
-- * Target: A
|
||||||
|
-- * Delegates: G
|
||||||
|
-- * Result: ProjectCollabLiveR for this collaborator, A
|
||||||
|
-- * Usage: invoke
|
||||||
--
|
--
|
||||||
-- * If neither 1 nor 2, raise an error
|
-- * Option 3 - Child 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 parents
|
||||||
|
--
|
||||||
|
-- * Option 4 - Almost-Parent sending me the delegator-Grant
|
||||||
|
-- * Update the Dest record, enabling the parent
|
||||||
|
-- * For each of my components, send an extension-Grant to the new
|
||||||
|
-- parent
|
||||||
|
-- * For each grant I've been delegated from my children, send an
|
||||||
|
-- extension-Grant to the new parent
|
||||||
|
--
|
||||||
|
-- * If neither of those, raise an error
|
||||||
projectGrant
|
projectGrant
|
||||||
:: UTCTime
|
:: UTCTime
|
||||||
-> ProjectId
|
-> ProjectId
|
||||||
|
@ -2094,7 +2126,57 @@ projectGrant now projectID (Verse authorIdMsig body) grant = do
|
||||||
_luExt <- updateOutboxItem' recipByKey extID actionExt
|
_luExt <- updateOutboxItem' recipByKey extID actionExt
|
||||||
return (extID, ext)
|
return (extID, ext)
|
||||||
|
|
||||||
return (recipActorID, sieve, localExtensions, remoteExtensions)
|
-- 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) -> do
|
||||||
|
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
|
||||||
|
)
|
||||||
|
localExtensionsForParents <- lift $ for localParents $ \ (E.Value role', E.Value parentID, E.Value delegID, E.Value grantID) -> do
|
||||||
|
extID <- insertEmptyOutboxItem' (actorOutbox recipActor) now
|
||||||
|
--insert_ $ ComponentFurtherLocal enableID delegID extID
|
||||||
|
ext@(actionExt, _, _, _) <-
|
||||||
|
prepareExtensionGrantForParent identForCheck (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) -> do
|
||||||
|
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
|
||||||
|
)
|
||||||
|
remoteExtensionsForParents <- lift $ for remoteParents $ \ (E.Value role', E.Value parentID, E.Value delegID, E.Value grantID) -> do
|
||||||
|
extID <- insertEmptyOutboxItem' (actorOutbox recipActor) now
|
||||||
|
--insert_ $ ComponentFurtherRemote enableID delegID extID
|
||||||
|
ext@(actionExt, _, _, _) <-
|
||||||
|
prepareExtensionGrantForParent identForCheck (Right (parentID, grantID)) (min role role') (Right delegID)
|
||||||
|
let recipByKey = LocalActorProject projectID
|
||||||
|
_luExt <- updateOutboxItem' recipByKey extID actionExt
|
||||||
|
return (extID, ext)
|
||||||
|
|
||||||
|
return
|
||||||
|
( recipActorID
|
||||||
|
, sieve
|
||||||
|
, localExtensions ++ localExtensionsForParents
|
||||||
|
, remoteExtensions ++ remoteExtensionsForParents
|
||||||
|
)
|
||||||
|
|
||||||
case maybeNew of
|
case maybeNew of
|
||||||
Nothing -> done "I already have this activity in my inbox"
|
Nothing -> done "I already have this activity in my inbox"
|
||||||
|
@ -2175,6 +2257,76 @@ projectGrant now projectID (Verse authorIdMsig body) grant = do
|
||||||
|
|
||||||
return (action, recipientSet, remoteActors, fwdHosts)
|
return (action, recipientSet, remoteActors, fwdHosts)
|
||||||
|
|
||||||
|
prepareExtensionGrantForParent component 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)
|
||||||
|
|
||||||
|
uComponent <-
|
||||||
|
case component of
|
||||||
|
Left c -> do
|
||||||
|
a <- componentActor <$> hashComponent c
|
||||||
|
return $ encodeRouteHome $ renderLocalActor a
|
||||||
|
Right u -> pure u
|
||||||
|
|
||||||
|
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 = uComponent
|
||||||
|
, 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)
|
||||||
|
|
||||||
handleCollab capability collab = do
|
handleCollab capability collab = do
|
||||||
|
|
||||||
maybeNew <- withDBExcept $ do
|
maybeNew <- withDBExcept $ do
|
||||||
|
@ -2216,7 +2368,7 @@ projectGrant now projectID (Verse authorIdMsig body) grant = do
|
||||||
for maybeGrantDB $ \ grantDB -> do
|
for maybeGrantDB $ \ grantDB -> do
|
||||||
|
|
||||||
-- Record the delegator-Grant in the Collab record
|
-- Record the delegator-Grant in the Collab record
|
||||||
(insertExt, uDeleg) <-
|
(insertExt, insertLeaf, uDeleg) <-
|
||||||
lift $ case (grantDB, bimap entityKey entityKey recip) of
|
lift $ case (grantDB, bimap entityKey entityKey recip) of
|
||||||
(Left (grantActor, _, grantID), Left localID) -> do
|
(Left (grantActor, _, grantID), Left localID) -> do
|
||||||
delegID <- insert $ CollabDelegLocal enableID localID grantID
|
delegID <- insert $ CollabDelegLocal enableID localID grantID
|
||||||
|
@ -2228,6 +2380,8 @@ projectGrant now projectID (Verse authorIdMsig body) grant = do
|
||||||
return
|
return
|
||||||
(\ enableID furtherID ->
|
(\ enableID furtherID ->
|
||||||
insert_ $ ComponentFurtherLocal enableID delegID furtherID
|
insert_ $ ComponentFurtherLocal enableID delegID furtherID
|
||||||
|
, \ leafID ->
|
||||||
|
insert_ $ SourceUsLeafToLocal leafID delegID
|
||||||
, encodeRouteHome delegR
|
, encodeRouteHome delegR
|
||||||
)
|
)
|
||||||
(Right (_, _, grantID), Right remoteID) -> do
|
(Right (_, _, grantID), Right remoteID) -> do
|
||||||
|
@ -2236,6 +2390,8 @@ projectGrant now projectID (Verse authorIdMsig body) grant = do
|
||||||
return
|
return
|
||||||
(\ enableID furtherID ->
|
(\ enableID furtherID ->
|
||||||
insert_ $ ComponentFurtherRemote enableID delegID furtherID
|
insert_ $ ComponentFurtherRemote enableID delegID furtherID
|
||||||
|
, \ leafID ->
|
||||||
|
insert_ $ SourceUsLeafToRemote leafID delegID
|
||||||
, u
|
, u
|
||||||
)
|
)
|
||||||
_ -> error "projectGrant impossible 2"
|
_ -> error "projectGrant impossible 2"
|
||||||
|
@ -2244,9 +2400,9 @@ projectGrant now projectID (Verse authorIdMsig body) grant = do
|
||||||
projectHash <- encodeKeyHashid projectID
|
projectHash <- encodeKeyHashid projectID
|
||||||
let sieve = makeRecipientSet [] [LocalStageProjectFollowers projectHash]
|
let sieve = makeRecipientSet [] [LocalStageProjectFollowers projectHash]
|
||||||
|
|
||||||
|
extensions <- lift $ do
|
||||||
-- For each Component of mine, prepare a delegation-extension
|
-- For each Component of mine, prepare a delegation-extension
|
||||||
-- Grant
|
-- Grant
|
||||||
extensions <- lift $ do
|
|
||||||
locals <-
|
locals <-
|
||||||
fmap (map $ over _1 Left) $
|
fmap (map $ over _1 Left) $
|
||||||
E.select $ E.from $ \ (deleg `E.InnerJoin` local `E.InnerJoin` comp `E.InnerJoin` enable) -> do
|
E.select $ E.from $ \ (deleg `E.InnerJoin` local `E.InnerJoin` comp `E.InnerJoin` enable) -> do
|
||||||
|
@ -2276,7 +2432,7 @@ projectGrant now projectID (Verse authorIdMsig body) grant = do
|
||||||
ra <- getJust raID
|
ra <- getJust raID
|
||||||
u@(ObjURI h lu) <- getRemoteActorURI ra
|
u@(ObjURI h lu) <- getRemoteActorURI ra
|
||||||
return (u, AudRemote h [lu] [])
|
return (u, AudRemote h [lu] [])
|
||||||
for (locals ++ remotes) $ \ (start, Entity componentID component, Entity enableID' _) -> do
|
fromComponents <- for (locals ++ remotes) $ \ (start, Entity componentID component, Entity enableID' _) -> do
|
||||||
extID <- insertEmptyOutboxItem' (actorOutbox recipActor) now
|
extID <- insertEmptyOutboxItem' (actorOutbox recipActor) now
|
||||||
insertExt enableID' extID
|
insertExt enableID' extID
|
||||||
componentIdent <- do
|
componentIdent <- do
|
||||||
|
@ -2304,6 +2460,54 @@ projectGrant now projectID (Verse authorIdMsig body) grant = do
|
||||||
_luExt <- updateOutboxItem' recipByKey extID actionExt
|
_luExt <- updateOutboxItem' recipByKey extID actionExt
|
||||||
return (extID, ext)
|
return (extID, ext)
|
||||||
|
|
||||||
|
-- For each Grant I got from a child, 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.^. SourceHolderProjectSource
|
||||||
|
E.where_ $ holder E.^. SourceHolderProjectProject E.==. E.val projectID
|
||||||
|
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.^. SourceHolderProjectSource
|
||||||
|
E.where_ $ holder E.^. SourceHolderProjectProject E.==. E.val projectID
|
||||||
|
return
|
||||||
|
( send E.^. SourceUsSendDelegatorId
|
||||||
|
, deleg
|
||||||
|
)
|
||||||
|
fromChildren <- 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, _, _, _) <-
|
||||||
|
prepareExtensionGrantFromChild uCollab audCollab uDeleg uStart grant role enableID
|
||||||
|
let recipByKey = LocalActorProject projectID
|
||||||
|
_luExt <- updateOutboxItem' recipByKey extID actionExt
|
||||||
|
return (extID, ext)
|
||||||
|
|
||||||
|
return $ fromComponents ++ fromChildren
|
||||||
|
|
||||||
return (recipActorID, sieve, extensions)
|
return (recipActorID, sieve, extensions)
|
||||||
|
|
||||||
case maybeNew of
|
case maybeNew of
|
||||||
|
@ -2363,6 +2567,45 @@ projectGrant now projectID (Verse authorIdMsig body) grant = do
|
||||||
|
|
||||||
return (action, recipientSet, remoteActors, fwdHosts)
|
return (action, recipientSet, remoteActors, fwdHosts)
|
||||||
|
|
||||||
|
prepareExtensionGrantFromChild uCollab audCollab uDeleg uStart grant role enableID = do
|
||||||
|
encodeRouteHome <- getEncodeRouteHome
|
||||||
|
encodeRouteLocal <- getEncodeRouteLocal
|
||||||
|
|
||||||
|
projectHash <- encodeKeyHashid projectID
|
||||||
|
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 $
|
||||||
|
ProjectCollabLiveR projectHash enableHash
|
||||||
|
, Nothing
|
||||||
|
)
|
||||||
|
, AP.grantStart = Just now
|
||||||
|
, AP.grantEnd = Nothing
|
||||||
|
, AP.grantAllows = AP.Invoke
|
||||||
|
, AP.grantDelegates = Just uStart
|
||||||
|
}
|
||||||
|
}
|
||||||
|
|
||||||
|
return (action, recipientSet, remoteActors, fwdHosts)
|
||||||
|
|
||||||
-- Meaning: An actor A invited actor B to a resource
|
-- Meaning: An actor A invited actor B to a resource
|
||||||
-- Behavior:
|
-- Behavior:
|
||||||
-- * Verify the resource is my collabs or components list
|
-- * Verify the resource is my collabs or components list
|
||||||
|
|
|
@ -1,6 +1,6 @@
|
||||||
{- This file is part of Vervis.
|
{- This file is part of Vervis.
|
||||||
-
|
-
|
||||||
- Written in 2022, 2023 by fr33domlover <fr33domlover@riseup.net>.
|
- Written in 2022, 2023, 2024 by fr33domlover <fr33domlover@riseup.net>.
|
||||||
-
|
-
|
||||||
- ♡ Copying is an act of love. Please copy, reuse and share.
|
- ♡ Copying is an act of love. Please copy, reuse and share.
|
||||||
-
|
-
|
||||||
|
@ -28,6 +28,7 @@ module Vervis.Persist.Actor
|
||||||
, updateOutboxItem'
|
, updateOutboxItem'
|
||||||
, fillPerActorKeys
|
, fillPerActorKeys
|
||||||
, getPersonWidgetInfo
|
, getPersonWidgetInfo
|
||||||
|
, getActivityBody
|
||||||
)
|
)
|
||||||
where
|
where
|
||||||
|
|
||||||
|
@ -37,6 +38,7 @@ import Control.Monad.Logger.CallStack
|
||||||
import Control.Monad.Trans.Class
|
import Control.Monad.Trans.Class
|
||||||
import Control.Monad.Trans.Except
|
import Control.Monad.Trans.Except
|
||||||
import Control.Monad.Trans.Reader
|
import Control.Monad.Trans.Reader
|
||||||
|
import Data.Aeson
|
||||||
import Data.Barbie
|
import Data.Barbie
|
||||||
import Data.Bitraversable
|
import Data.Bitraversable
|
||||||
import Data.Text (Text)
|
import Data.Text (Text)
|
||||||
|
@ -64,7 +66,6 @@ import qualified Web.Actor.Persist as WAP
|
||||||
import Control.Monad.Trans.Except.Local
|
import Control.Monad.Trans.Except.Local
|
||||||
import Database.Persist.Local
|
import Database.Persist.Local
|
||||||
|
|
||||||
--import Vervis.Actor2 ()
|
|
||||||
import Vervis.Data.Actor
|
import Vervis.Data.Actor
|
||||||
import Vervis.FedURI
|
import Vervis.FedURI
|
||||||
import Vervis.Foundation
|
import Vervis.Foundation
|
||||||
|
@ -234,3 +235,16 @@ getPersonWidgetInfo = bitraverse getLocal getRemote
|
||||||
remoteObject <- getJust $ remoteActorIdent remoteActor
|
remoteObject <- getJust $ remoteActorIdent remoteActor
|
||||||
inztance <- getJust $ remoteObjectInstance remoteObject
|
inztance <- getJust $ remoteObjectInstance remoteObject
|
||||||
return (inztance, remoteObject, remoteActor)
|
return (inztance, remoteObject, remoteActor)
|
||||||
|
|
||||||
|
getActivityBody
|
||||||
|
:: Either OutboxItemId RemoteActivityId
|
||||||
|
-> VA.ActDB (AP.Doc AP.Activity URIMode)
|
||||||
|
getActivityBody k = do
|
||||||
|
obj <-
|
||||||
|
persistJSONDoc <$>
|
||||||
|
case k of
|
||||||
|
Left itemID -> outboxItemActivity <$> getJust itemID
|
||||||
|
Right itemID -> remoteActivityContent <$> getJust itemID
|
||||||
|
case fromJSON $ Object obj of
|
||||||
|
Error s -> error $ "Parsing activity " ++ show k ++ " failed: " ++ s
|
||||||
|
Success doc -> return doc
|
||||||
|
|
|
@ -48,6 +48,8 @@ module Vervis.Persist.Collab
|
||||||
, verifyNoStartedGroupChildren
|
, verifyNoStartedGroupChildren
|
||||||
, verifyNoEnabledProjectParents
|
, verifyNoEnabledProjectParents
|
||||||
, verifyNoEnabledGroupChildren
|
, verifyNoEnabledGroupChildren
|
||||||
|
|
||||||
|
, getGrantActivityBody
|
||||||
)
|
)
|
||||||
where
|
where
|
||||||
|
|
||||||
|
@ -83,6 +85,7 @@ import Database.Persist.Local
|
||||||
|
|
||||||
import Vervis.Actor
|
import Vervis.Actor
|
||||||
import Vervis.Data.Collab
|
import Vervis.Data.Collab
|
||||||
|
import Vervis.FedURI
|
||||||
import Vervis.Model
|
import Vervis.Model
|
||||||
import Vervis.Persist.Actor
|
import Vervis.Persist.Actor
|
||||||
|
|
||||||
|
@ -1027,3 +1030,12 @@ verifyNoEnabledGroupChildren groupID destDB = do
|
||||||
-- any are enabled, make sure there's at most one (otherwise it's a
|
-- any are enabled, make sure there's at most one (otherwise it's a
|
||||||
-- bug)
|
-- bug)
|
||||||
verifyDestsNotEnabled destIDs
|
verifyDestsNotEnabled destIDs
|
||||||
|
|
||||||
|
getGrantActivityBody
|
||||||
|
:: Either OutboxItemId RemoteActivityId
|
||||||
|
-> ActDB (AP.Doc AP.Activity URIMode, AP.Grant URIMode)
|
||||||
|
getGrantActivityBody k = do
|
||||||
|
doc@(AP.Doc _ act) <- getActivityBody k
|
||||||
|
case AP.activitySpecific act of
|
||||||
|
AP.GrantActivity g -> return (doc, g)
|
||||||
|
_ -> error "Not a Grant activity"
|
||||||
|
|
66
th/models
66
th/models
|
@ -1434,36 +1434,66 @@ SourceThemDelegateRemote
|
||||||
-- Witnesses that, seeing the delegation from them, I've sent an
|
-- Witnesses that, seeing the delegation from them, I've sent an
|
||||||
-- extension-Grant to a Dest of mine
|
-- extension-Grant to a Dest of mine
|
||||||
|
|
||||||
SourceUsGatherLocal
|
SourceUsGather
|
||||||
deleg SourceUsSendDelegatorId
|
source SourceUsSendDelegatorId
|
||||||
dest DestThemSendDelegatorLocalId
|
dest DestUsAcceptId
|
||||||
grant OutboxItemId
|
grant OutboxItemId
|
||||||
|
|
||||||
UniqueSourceUsGatherLocal grant
|
SourceUsGatherFromLocal
|
||||||
|
gather SourceUsGatherId
|
||||||
|
from SourceThemDelegateLocalId
|
||||||
|
|
||||||
SourceUsGatherRemote
|
UniqueSourceUsGatherFromLocal gather
|
||||||
deleg SourceUsSendDelegatorId
|
|
||||||
dest DestThemSendDelegatorRemoteId
|
|
||||||
grant RemoteActivityId
|
|
||||||
|
|
||||||
UniqueSourceUsGatherRemote grant
|
SourceUsGatherFromRemote
|
||||||
|
gather SourceUsGatherId
|
||||||
|
from SourceThemDelegateRemoteId
|
||||||
|
|
||||||
|
UniqueSourceUsGatherFromRemote gather
|
||||||
|
|
||||||
|
SourceUsGatherToLocal
|
||||||
|
gather SourceUsGatherId
|
||||||
|
to DestThemSendDelegatorLocalId
|
||||||
|
|
||||||
|
UniqueSourceUsGatherToLocal gather
|
||||||
|
|
||||||
|
SourceUsGatherToRemote
|
||||||
|
gather SourceUsGatherId
|
||||||
|
to DestThemSendDelegatorRemoteId
|
||||||
|
|
||||||
|
UniqueSourceUsGatherToRemote gather
|
||||||
|
|
||||||
-- Witnesses that, seeing the delegation from them, I've sent a leaf-Grant to a
|
-- Witnesses that, seeing the delegation from them, I've sent a leaf-Grant to a
|
||||||
-- direct-collaborator of mine
|
-- direct-collaborator of mine
|
||||||
|
|
||||||
SourceUsLeafLocal
|
SourceUsLeaf
|
||||||
deleg SourceUsSendDelegatorId
|
source SourceUsSendDelegatorId
|
||||||
collab CollabDelegLocalId
|
collab CollabEnableId
|
||||||
grant OutboxItemId
|
grant OutboxItemId
|
||||||
|
|
||||||
UniqueSourceUsLeafLocal grant
|
SourceUsLeafFromLocal
|
||||||
|
leaf SourceUsLeafId
|
||||||
|
from SourceThemDelegateLocalId
|
||||||
|
|
||||||
SourceUsLeafRemote
|
UniqueSourceUsLeafFromLocal leaf
|
||||||
deleg SourceUsSendDelegatorId
|
|
||||||
collab CollabDelegRemoteId
|
|
||||||
grant RemoteActivityId
|
|
||||||
|
|
||||||
UniqueSourceUsLeafRemote grant
|
SourceUsLeafFromRemote
|
||||||
|
leaf SourceUsLeafId
|
||||||
|
from SourceThemDelegateRemoteId
|
||||||
|
|
||||||
|
UniqueSourceUsLeafFromRemote leaf
|
||||||
|
|
||||||
|
SourceUsLeafToLocal
|
||||||
|
leaf SourceUsLeafId
|
||||||
|
to CollabDelegLocalId
|
||||||
|
|
||||||
|
UniqueSourceUsLeafToLocal leaf
|
||||||
|
|
||||||
|
SourceUsLeafToRemote
|
||||||
|
leaf SourceUsLeafId
|
||||||
|
to CollabDelegRemoteId
|
||||||
|
|
||||||
|
UniqueSourceUsLeafToRemote leaf
|
||||||
|
|
||||||
------------------------------------------------------------------------------
|
------------------------------------------------------------------------------
|
||||||
-- Inheritance - Giver tracking her receivers
|
-- Inheritance - Giver tracking her receivers
|
||||||
|
|
Loading…
Reference in a new issue