forge/Vervis
1
0
Fork 0
Code Pull requests Activity

S2S: Project: Grant: Implement child mode

Browse source
This commit is contained in:
Pere Lev 2024-03-13 00:10:50 +02:00
parent 533d8e2ff7
commit 1d13d7a551
No known key found for this signature in database
GPG key ID: 5252C5C863E5E57D
3 changed files with 352 additions and 14 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

348
src/Vervis/Actor/Project.hs
View file

@ -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 (Right <$> tryCollab capability grant')
runExceptT (Left . Left <$> tryComp 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 _ (GKDelegationExtend _) = lift mzero
tryCollab capability GKDelegator = do
tryCollab _ (GKDelegationStart _) = lift mzero
tryCollab _ (GKDelegationExtend _ _) = lift mzero
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

12
src/Vervis/Migration.hs
View file

@ -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

6
th/models
View file

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