S2S: Group: Grant: Extend Grants from my projects
This commit is contained in:
Pere Lev
parent
14ff1b293f
commit
4838a131b4
1 changed files with 96 additions and 12 deletions
|
|
@ -1763,7 +1763,7 @@ data GrantKind
|
|||
-- * Record the delegator-Grant in the Collab record in DB
|
||||
-- * Forward the Grant to my followers
|
||||
-- * For each project of mine J, prepare and send an
|
||||
-- extension-Grant to A, and store it in the ??? record in DB
|
||||
-- extension-Grant to A, and store it in the Source record in DB
|
||||
-- * For each start-grant or extension-grant G that I received from a
|
||||
-- parent of mine, prepare and send an extension-Grant to A, and store
|
||||
-- it in the Source record in DB
|
||||
|
|
@ -1911,7 +1911,7 @@ groupGrant now groupID (Verse authorIdMsig body) grant = do
|
|||
for maybeGrantDB $ \ (inboxItemID, grantDB) -> do
|
||||
|
||||
-- Record the delegator-Grant in the Collab record
|
||||
(insertLeaf, uDeleg) <-
|
||||
(insertLeaf, insertEffortLeafTo, uDeleg) <-
|
||||
lift $ case (grantDB, bimap entityKey entityKey recip) of
|
||||
(Left (grantActor, _, grantID), Left localID) -> do
|
||||
delegID <- insert $ CollabDelegLocal enableID localID grantID
|
||||
|
|
@ -1923,6 +1923,8 @@ groupGrant now groupID (Verse authorIdMsig body) grant = do
|
|||
return
|
||||
( \ leafID ->
|
||||
insert_ $ SourceUsLeafToLocal leafID delegID
|
||||
, \ leafID ->
|
||||
insert_ $ EffortUsLeafToLocal leafID delegID
|
||||
, encodeRouteHome delegR
|
||||
)
|
||||
(Right (_, _, grantID), Right remoteID) -> do
|
||||
|
|
@ -1931,6 +1933,8 @@ groupGrant now groupID (Verse authorIdMsig body) grant = do
|
|||
return
|
||||
( \ leafID ->
|
||||
insert_ $ SourceUsLeafToRemote leafID delegID
|
||||
, \ leafID ->
|
||||
insert_ $ EffortUsLeafToRemote leafID delegID
|
||||
, u
|
||||
)
|
||||
_ -> error "groupGrant impossible 2"
|
||||
|
|
@ -1940,8 +1944,6 @@ groupGrant now groupID (Verse authorIdMsig body) grant = do
|
|||
let sieve = makeRecipientSet [] [LocalStageGroupFollowers groupHash]
|
||||
|
||||
extensions <- lift $ do
|
||||
-- For each Project of mine, prepare a delegation-extension
|
||||
-- Grant
|
||||
(uCollab, audCollab) <-
|
||||
case recip of
|
||||
Left (Entity _ (CollabRecipLocal _ personID)) -> do
|
||||
|
|
@ -1955,7 +1957,49 @@ groupGrant now groupID (Verse authorIdMsig body) grant = do
|
|||
ra <- getJust raID
|
||||
u@(ObjURI h lu) <- getRemoteActorURI ra
|
||||
return (u, AudRemote h [lu] [])
|
||||
fromProjects <- pure []
|
||||
-- For each Grant I got from a project, prepare a
|
||||
-- delegation-extension Grant
|
||||
l' <-
|
||||
fmap (map $ over _2 Left) $
|
||||
E.select $ E.from $ \ (effort `E.InnerJoin` topic `E.InnerJoin` accept `E.InnerJoin` send `E.InnerJoin` deleg) -> do
|
||||
E.on $ accept E.^. EffortThemAcceptLocalId E.==. deleg E.^. EffortThemDelegateLocalEffort
|
||||
E.on $ effort E.^. EffortId E.==. send E.^. EffortUsSendDelegatorEffort
|
||||
E.on $ topic E.^. EffortTopicLocalId E.==. accept E.^. EffortThemAcceptLocalTopic
|
||||
E.on $ effort E.^. EffortId E.==. topic E.^. EffortTopicLocalEffort
|
||||
E.where_ $ effort E.^. EffortHolder E.==. E.val groupID
|
||||
return
|
||||
( send E.^. EffortUsSendDelegatorId
|
||||
, deleg
|
||||
)
|
||||
r' <-
|
||||
fmap (map $ over _2 Right) $
|
||||
E.select $ E.from $ \ (effort `E.InnerJoin` topic `E.InnerJoin` accept `E.InnerJoin` send `E.InnerJoin` deleg) -> do
|
||||
E.on $ accept E.^. EffortThemAcceptRemoteId E.==. deleg E.^. EffortThemDelegateRemoteEffort
|
||||
E.on $ effort E.^. EffortId E.==. send E.^. EffortUsSendDelegatorEffort
|
||||
E.on $ topic E.^. EffortTopicRemoteId E.==. accept E.^. EffortThemAcceptRemoteTopic
|
||||
E.on $ effort E.^. EffortId E.==. topic E.^. EffortTopicRemoteEffort
|
||||
E.where_ $ effort E.^. EffortHolder E.==. E.val groupID
|
||||
return
|
||||
( send E.^. EffortUsSendDelegatorId
|
||||
, deleg
|
||||
)
|
||||
fromProjects <- for (l' ++ r') $ \ (E.Value sendID, deleg) -> do
|
||||
extID <- insertEmptyOutboxItem' (actorOutbox recipActor) now
|
||||
leafID <- insert $ EffortUsLeaf sendID enableID extID
|
||||
case bimap entityKey entityKey deleg of
|
||||
Left fromID -> insert_ $ EffortUsLeafFromLocal leafID fromID
|
||||
Right fromID -> insert_ $ EffortUsLeafFromRemote leafID fromID
|
||||
insertEffortLeafTo leafID
|
||||
(AP.Doc h a, grant) <- getGrantActivityBody $ bimap (effortThemDelegateLocalGrant . entityVal) (effortThemDelegateRemoteGrant . entityVal) deleg
|
||||
uStart <-
|
||||
case AP.activityId a of
|
||||
Nothing -> error "EffortThemDelegate grant has no 'id'"
|
||||
Just lu -> pure $ ObjURI h lu
|
||||
ext@(actionExt, _, _, _) <-
|
||||
prepareExtensionGrantFromParentOrProject uCollab audCollab uDeleg uStart grant role enableID
|
||||
let recipByKey = LocalActorGroup groupID
|
||||
_luExt <- updateOutboxItem' recipByKey extID actionExt
|
||||
return (extID, ext)
|
||||
|
||||
-- For each Grant I got from a parent, prepare a
|
||||
-- delegation-extension Grant
|
||||
|
|
@ -1998,7 +2042,7 @@ groupGrant now groupID (Verse authorIdMsig body) grant = do
|
|||
Nothing -> error "SourceThemDelegate grant has no 'id'"
|
||||
Just lu -> pure $ ObjURI h lu
|
||||
ext@(actionExt, _, _, _) <-
|
||||
prepareExtensionGrantFromParent uCollab audCollab uDeleg uStart grant role enableID
|
||||
prepareExtensionGrantFromParentOrProject uCollab audCollab uDeleg uStart grant role enableID
|
||||
let recipByKey = LocalActorGroup groupID
|
||||
_luExt <- updateOutboxItem' recipByKey extID actionExt
|
||||
return (extID, ext)
|
||||
|
|
@ -2021,7 +2065,7 @@ groupGrant now groupID (Verse authorIdMsig body) grant = do
|
|||
|
||||
where
|
||||
|
||||
prepareExtensionGrantFromParent uCollab audCollab uDeleg uStart grant role enableID = do
|
||||
prepareExtensionGrantFromParentOrProject uCollab audCollab uDeleg uStart grant role enableID = do
|
||||
encodeRouteHome <- getEncodeRouteHome
|
||||
encodeRouteLocal <- getEncodeRouteLocal
|
||||
|
||||
|
|
@ -2485,8 +2529,48 @@ groupGrant now groupID (Verse authorIdMsig body) grant = do
|
|||
_luStart <- lift $ updateOutboxItem' recipByKey startID actionStart
|
||||
|
||||
-- For each Project in me, prepare a delegation-extension Grant
|
||||
localExtensions <- pure []
|
||||
remoteExtensions <- pure []
|
||||
l' <-
|
||||
lift $ fmap (map $ over _2 Left) $
|
||||
E.select $ E.from $ \ (effort `E.InnerJoin` topic `E.InnerJoin` accept `E.InnerJoin` send `E.InnerJoin` deleg) -> do
|
||||
E.on $ accept E.^. EffortThemAcceptLocalId E.==. deleg E.^. EffortThemDelegateLocalEffort
|
||||
E.on $ effort E.^. EffortId E.==. send E.^. EffortUsSendDelegatorEffort
|
||||
E.on $ topic E.^. EffortTopicLocalId E.==. accept E.^. EffortThemAcceptLocalTopic
|
||||
E.on $ effort E.^. EffortId E.==. topic E.^. EffortTopicLocalEffort
|
||||
E.where_ $ effort E.^. EffortHolder E.==. E.val groupID
|
||||
return
|
||||
( send E.^. EffortUsSendDelegatorId
|
||||
, deleg
|
||||
)
|
||||
r' <-
|
||||
lift $ fmap (map $ over _2 Right) $
|
||||
E.select $ E.from $ \ (effort `E.InnerJoin` topic `E.InnerJoin` accept `E.InnerJoin` send `E.InnerJoin` deleg) -> do
|
||||
E.on $ accept E.^. EffortThemAcceptRemoteId E.==. deleg E.^. EffortThemDelegateRemoteEffort
|
||||
E.on $ effort E.^. EffortId E.==. send E.^. EffortUsSendDelegatorEffort
|
||||
E.on $ topic E.^. EffortTopicRemoteId E.==. accept E.^. EffortThemAcceptRemoteTopic
|
||||
E.on $ effort E.^. EffortId E.==. topic E.^. EffortTopicRemoteEffort
|
||||
E.where_ $ effort E.^. EffortHolder E.==. E.val groupID
|
||||
return
|
||||
( send E.^. EffortUsSendDelegatorId
|
||||
, deleg
|
||||
)
|
||||
fromProjects <- lift $ for (l' ++ r') $ \ (E.Value sendID, deleg) -> do
|
||||
extID <- insertEmptyOutboxItem' (actorOutbox recipActor) now
|
||||
|
||||
distributeID <- insert $ EffortUsDistribute sendID destStartID extID
|
||||
case bimap entityKey entityKey deleg of
|
||||
Left localID -> insert_ $ EffortUsDistributeFromLocal distributeID localID
|
||||
Right remoteID -> insert_ $ EffortUsDistributeFromRemote distributeID remoteID
|
||||
|
||||
(AP.Doc h a, grant) <- getGrantActivityBody $ bimap (effortThemDelegateLocalGrant . entityVal) (effortThemDelegateRemoteGrant . entityVal) deleg
|
||||
uStart <-
|
||||
case AP.activityId a of
|
||||
Nothing -> error "EffortThemDelegate grant has no 'id'"
|
||||
Just lu -> pure $ ObjURI h lu
|
||||
ext@(actionExt, _, _, _) <-
|
||||
prepareExtensionGrantFromParentOrProject uStart grant role destStartID
|
||||
let recipByKey = LocalActorGroup groupID
|
||||
_luExt <- updateOutboxItem' recipByKey extID actionExt
|
||||
return (extID, ext)
|
||||
|
||||
-- For each Grant I got from a child, prepare a
|
||||
-- delegation-extension Grant
|
||||
|
|
@ -2530,14 +2614,14 @@ groupGrant now groupID (Verse authorIdMsig body) grant = do
|
|||
Nothing -> error "SourceThemDelegate grant has no 'id'"
|
||||
Just lu -> pure $ ObjURI h lu
|
||||
ext@(actionExt, _, _, _) <-
|
||||
prepareExtensionGrantFromParent uStart grant role destStartID
|
||||
prepareExtensionGrantFromParentOrProject uStart grant role destStartID
|
||||
let recipByKey = LocalActorGroup groupID
|
||||
_luExt <- updateOutboxItem' recipByKey extID actionExt
|
||||
return (extID, ext)
|
||||
|
||||
return
|
||||
( recipActorID
|
||||
, (startID, start) : localExtensions ++ remoteExtensions ++ fromParents
|
||||
, (startID, start) : fromProjects ++ fromParents
|
||||
, inboxItemID
|
||||
)
|
||||
|
||||
|
|
@ -2596,7 +2680,7 @@ groupGrant now groupID (Verse authorIdMsig body) grant = do
|
|||
|
||||
return (action, recipientSet, remoteActors, fwdHosts)
|
||||
|
||||
prepareExtensionGrantFromParent uStart grant role startID = do
|
||||
prepareExtensionGrantFromParentOrProject uStart grant role startID = do
|
||||
encodeRouteHome <- getEncodeRouteHome
|
||||
encodeRouteLocal <- getEncodeRouteLocal
|
||||
|
||||
|
|
|
|||
Loading…
Reference in a new issue