S2S: Group: Grant: Implement resource mode
This commit is contained in:
Pere Lev
parent
c385dad10b
commit
a36eda1e2b
1 changed files with 311 additions and 124 deletions
|
|
@ -2510,11 +2510,11 @@ data GrantKind
|
||||||
|
|
||||||
-- Meaning: An actor is granting access-to-some-resource to another actor
|
-- Meaning: An actor is granting access-to-some-resource to another actor
|
||||||
-- Behavior:
|
-- Behavior:
|
||||||
-- * Option 1 - Project sending me a delegation-start or delegation-extension
|
-- * Option 1 - Resource sending me a delegation-start or delegation-extension
|
||||||
-- * Verify they're authorized, i.e. they're using the delegator-Grant
|
-- * Verify they're authorized, i.e. they're using the delegator-Grant
|
||||||
-- I gave them
|
-- I gave them
|
||||||
-- * Verify the role isn't delegator
|
-- * Verify the role isn't delegator
|
||||||
-- * Store the Grant in the ??? record in DB
|
-- * Store the Grant in the Effort record in DB
|
||||||
-- * Send extension-Grants and record them in the DB:
|
-- * Send extension-Grants and record them in the DB:
|
||||||
-- * To each of my direct collaborators
|
-- * To each of my direct collaborators
|
||||||
-- * To each of my children
|
-- * To each of my children
|
||||||
|
|
@ -2567,7 +2567,7 @@ groupGrant now groupID (Verse authorIdMsig body) grant = do
|
||||||
let adapt = maybe (Right Nothing) (either Left (Right . Just))
|
let adapt = maybe (Right Nothing) (either Left (Right . Just))
|
||||||
maybeMode <-
|
maybeMode <-
|
||||||
withDBExcept $ ExceptT $ fmap adapt $ runMaybeT $
|
withDBExcept $ ExceptT $ fmap adapt $ runMaybeT $
|
||||||
runExceptT (Left . Left <$> tryProject grant') <|>
|
runExceptT (Left . Left <$> tryResource grant') <|>
|
||||||
runExceptT (Left . Right <$> tryCollab grant') <|>
|
runExceptT (Left . Right <$> tryCollab grant') <|>
|
||||||
runExceptT (Right . Left <$> tryParent grant') <|>
|
runExceptT (Right . Left <$> tryParent grant') <|>
|
||||||
runExceptT (Right . Right <$> tryAlmostChild grant')
|
runExceptT (Right . Right <$> tryAlmostChild grant')
|
||||||
|
|
@ -2576,8 +2576,8 @@ groupGrant now groupID (Verse authorIdMsig body) grant = do
|
||||||
maybeMode
|
maybeMode
|
||||||
"Not a relevant Grant that I'm aware of"
|
"Not a relevant Grant that I'm aware of"
|
||||||
case mode of
|
case mode of
|
||||||
Left (Left ()) ->
|
Left (Left (role, sendID, topic)) ->
|
||||||
handleProject
|
handleResource role sendID topic
|
||||||
Left (Right (enableID, role, recip)) ->
|
Left (Right (enableID, role, recip)) ->
|
||||||
handleCollab enableID role recip
|
handleCollab enableID role recip
|
||||||
Right (Left (role, sendID, topic)) ->
|
Right (Left (role, sendID, topic)) ->
|
||||||
|
|
@ -2630,9 +2630,198 @@ groupGrant now groupID (Verse authorIdMsig body) grant = do
|
||||||
pure GKDelegator
|
pure GKDelegator
|
||||||
_ -> throwE "A kind of Grant that I don't use"
|
_ -> throwE "A kind of Grant that I don't use"
|
||||||
|
|
||||||
tryProject _ = lift mzero
|
tryResource gk = do
|
||||||
|
capability <- checkCapability
|
||||||
|
role <-
|
||||||
|
case gk of
|
||||||
|
GKDelegationStart role -> pure role
|
||||||
|
GKDelegationExtend role _ -> pure role
|
||||||
|
GKDelegator -> lift mzero
|
||||||
|
-- Find the Effort record from the capability
|
||||||
|
Entity sendID (EffortUsSendDelegator effortID _) <- lift $ do
|
||||||
|
-- Capability isn't mine
|
||||||
|
guard $ fst capability == LocalActorGroup groupID
|
||||||
|
-- I don't have a Effort with this capability
|
||||||
|
MaybeT $ getBy $ UniqueEffortUsSendDelegatorGrant $ snd capability
|
||||||
|
Effort role' g <- lift $ lift $ getJust effortID
|
||||||
|
-- Found a Effort for this Grant but it's not mine
|
||||||
|
lift $ guard $ g == groupID
|
||||||
|
topic <- lift $ lift $ getEffortTopic effortID
|
||||||
|
topicForCheck <-
|
||||||
|
lift $ lift $
|
||||||
|
bitraverse
|
||||||
|
(\ (_, resourceID) -> getLocalResource resourceID)
|
||||||
|
(\ (_, raID) -> getRemoteActorURI =<< getJust raID)
|
||||||
|
topic
|
||||||
|
unless (first resourceToActor topicForCheck == bimap (view _1) (remoteAuthorURI . view _1) authorIdMsig) $
|
||||||
|
throwE "Capability's effort and Grant author aren't the same actor"
|
||||||
|
return (min role role', sendID, topic)
|
||||||
|
|
||||||
handleProject = done "handleProject"
|
handleResource 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, rID) ->
|
||||||
|
(localID, rID,) <$>
|
||||||
|
getKeyByJust (UniqueEffortThemAcceptLocal localID)
|
||||||
|
)
|
||||||
|
(\ (remoteID, aID) ->
|
||||||
|
(remoteID, aID,) <$>
|
||||||
|
getKeyByJust (UniqueEffortThemAcceptRemote 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 $ EffortThemDelegateLocal localID grantID
|
||||||
|
fromMaybeE mk "I already have such a EffortThemDelegateLocal"
|
||||||
|
(Right (_, _, grantID), Right remoteID) -> Right <$> do
|
||||||
|
mk <- lift $ insertUnique $ EffortThemDelegateRemote remoteID grantID
|
||||||
|
fromMaybeE mk "I already have such a EffortThemDelegateRemote"
|
||||||
|
_ -> error "groupGrant.resource 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 $ EffortUsLeaf sendID enableID extID
|
||||||
|
case from of
|
||||||
|
Left localID -> insert_ $ EffortUsLeafFromLocal leafID localID
|
||||||
|
Right remoteID -> insert_ $ EffortUsLeafFromRemote leafID remoteID
|
||||||
|
insert_ $ EffortUsLeafToLocal leafID delegID
|
||||||
|
ext@(actionExt, _, _, _) <-
|
||||||
|
prepareExtensionGrantForCollab (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 $ EffortUsLeaf sendID enableID extID
|
||||||
|
case from of
|
||||||
|
Left localID -> insert_ $ EffortUsLeafFromLocal leafID localID
|
||||||
|
Right remoteID -> insert_ $ EffortUsLeafFromRemote leafID remoteID
|
||||||
|
insert_ $ EffortUsLeafToRemote leafID delegID
|
||||||
|
ext@(actionExt, _, _, _) <-
|
||||||
|
prepareExtensionGrantForCollab (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
|
||||||
|
distributeID <- insert $ EffortUsDistribute sendID startID extID
|
||||||
|
case from of
|
||||||
|
Left localID -> insert_ $ EffortUsDistributeFromLocal distributeID localID
|
||||||
|
Right remoteID -> insert_ $ EffortUsDistributeFromRemote distributeID 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
|
||||||
|
distributeID <- insert $ EffortUsDistribute sendID startID extID
|
||||||
|
case from of
|
||||||
|
Left localID -> insert_ $ EffortUsDistributeFromLocal distributeID localID
|
||||||
|
Right remoteID -> insert_ $ EffortUsDistributeFromRemote distributeID 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 "[Resource] Sent extensions to collabs & children"
|
||||||
|
|
||||||
tryCollab (GKDelegationStart _) = lift mzero
|
tryCollab (GKDelegationStart _) = lift mzero
|
||||||
tryCollab (GKDelegationExtend _ _) = lift mzero
|
tryCollab (GKDelegationExtend _ _) = lift mzero
|
||||||
|
|
@ -2972,7 +3161,7 @@ groupGrant now groupID (Verse authorIdMsig body) grant = do
|
||||||
Right remoteID -> insert_ $ SourceUsLeafFromRemote leafID remoteID
|
Right remoteID -> insert_ $ SourceUsLeafFromRemote leafID remoteID
|
||||||
insert_ $ SourceUsLeafToLocal leafID delegID
|
insert_ $ SourceUsLeafToLocal leafID delegID
|
||||||
ext@(actionExt, _, _, _) <-
|
ext@(actionExt, _, _, _) <-
|
||||||
prepareExtensionGrant (Left (personID, grantID)) (min role role') enableID
|
prepareExtensionGrantForCollab (Left (personID, grantID)) (min role role') enableID
|
||||||
let recipByKey = LocalActorGroup groupID
|
let recipByKey = LocalActorGroup groupID
|
||||||
_luExt <- updateOutboxItem' recipByKey extID actionExt
|
_luExt <- updateOutboxItem' recipByKey extID actionExt
|
||||||
return (extID, ext)
|
return (extID, ext)
|
||||||
|
|
@ -2997,7 +3186,7 @@ groupGrant now groupID (Verse authorIdMsig body) grant = do
|
||||||
Right remoteID -> insert_ $ SourceUsLeafFromRemote leafID remoteID
|
Right remoteID -> insert_ $ SourceUsLeafFromRemote leafID remoteID
|
||||||
insert_ $ SourceUsLeafToRemote leafID delegID
|
insert_ $ SourceUsLeafToRemote leafID delegID
|
||||||
ext@(actionExt, _, _, _) <-
|
ext@(actionExt, _, _, _) <-
|
||||||
prepareExtensionGrant (Right (raID, grantID)) (min role role') enableID
|
prepareExtensionGrantForCollab (Right (raID, grantID)) (min role role') enableID
|
||||||
let recipByKey = LocalActorGroup groupID
|
let recipByKey = LocalActorGroup groupID
|
||||||
_luExt <- updateOutboxItem' recipByKey extID actionExt
|
_luExt <- updateOutboxItem' recipByKey extID actionExt
|
||||||
return (extID, ext)
|
return (extID, ext)
|
||||||
|
|
@ -3079,121 +3268,6 @@ groupGrant now groupID (Verse authorIdMsig body) grant = do
|
||||||
remoteRecipsExt fwdHostsExt extID actionExt
|
remoteRecipsExt fwdHostsExt extID actionExt
|
||||||
doneDB inboxItemID "[Parent] Sent extensions to collabs & children"
|
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 (GKDelegationStart _) = lift mzero
|
||||||
tryAlmostChild (GKDelegationExtend _ _) = lift mzero
|
tryAlmostChild (GKDelegationExtend _ _) = lift mzero
|
||||||
tryAlmostChild GKDelegator = do
|
tryAlmostChild GKDelegator = do
|
||||||
|
|
@ -3494,6 +3568,119 @@ groupGrant now groupID (Verse authorIdMsig body) grant = do
|
||||||
|
|
||||||
return (action, recipientSet, remoteActors, fwdHosts)
|
return (action, recipientSet, remoteActors, fwdHosts)
|
||||||
|
|
||||||
|
prepareExtensionGrantForCollab 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)
|
||||||
|
|
||||||
-- 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 list
|
-- * Verify the resource is my collabs list
|
||||||
|
|
|
||||||
Loading…
Reference in a new issue