S2S: Project: Grant: Child/parent delegation when adding collab/component
This commit is contained in:
Pere Lev
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
|
||||
-- extension-Grant to a Dest of mine
|
||||
|
||||
SourceUsGatherLocal
|
||||
deleg SourceUsSendDelegatorId
|
||||
dest DestThemSendDelegatorLocalId
|
||||
SourceUsGather
|
||||
source SourceUsSendDelegatorId
|
||||
dest DestUsAcceptId
|
||||
grant OutboxItemId
|
||||
|
||||
UniqueSourceUsGatherLocal grant
|
||||
SourceUsGatherFromLocal
|
||||
gather SourceUsGatherId
|
||||
from SourceThemDelegateLocalId
|
||||
|
||||
SourceUsGatherRemote
|
||||
deleg SourceUsSendDelegatorId
|
||||
dest DestThemSendDelegatorRemoteId
|
||||
grant RemoteActivityId
|
||||
UniqueSourceUsGatherFromLocal gather
|
||||
|
||||
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
|
||||
-- direct-collaborator of mine
|
||||
|
||||
SourceUsLeafLocal
|
||||
deleg SourceUsSendDelegatorId
|
||||
collab CollabDelegLocalId
|
||||
SourceUsLeaf
|
||||
source SourceUsSendDelegatorId
|
||||
collab CollabEnableId
|
||||
grant OutboxItemId
|
||||
|
||||
UniqueSourceUsLeafLocal grant
|
||||
SourceUsLeafFromLocal
|
||||
leaf SourceUsLeafId
|
||||
from SourceThemDelegateLocalId
|
||||
|
||||
SourceUsLeafRemote
|
||||
deleg SourceUsSendDelegatorId
|
||||
collab CollabDelegRemoteId
|
||||
grant RemoteActivityId
|
||||
UniqueSourceUsLeafFromLocal leaf
|
||||
|
||||
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
|
||||
|
|
|
|||
|
|
@ -1871,13 +1871,20 @@ projectFollow now recipProjectID verse follow = do
|
|||
-- * Record the delegation in the Component record in DB
|
||||
-- * Forward the Grant to my followers
|
||||
-- * 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
|
||||
-- * Resource: C
|
||||
-- * Target: The collaborator
|
||||
-- * Delegates: The Grant I just got from C
|
||||
-- * Result: ProjectCollabLiveR for this collaborator
|
||||
-- * 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:
|
||||
-- * 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
|
||||
-- * Result: ProjectCollabLiveR for this collaborator, A
|
||||
-- * 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
|
||||
:: UTCTime
|
||||
-> ProjectId
|
||||
|
|
@ -2094,7 +2126,57 @@ projectGrant now projectID (Verse authorIdMsig body) grant = do
|
|||
_luExt <- updateOutboxItem' recipByKey extID actionExt
|
||||
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
|
||||
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)
|
||||
|
||||
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
|
||||
|
||||
maybeNew <- withDBExcept $ do
|
||||
|
|
@ -2216,7 +2368,7 @@ projectGrant now projectID (Verse authorIdMsig body) grant = do
|
|||
for maybeGrantDB $ \ grantDB -> do
|
||||
|
||||
-- Record the delegator-Grant in the Collab record
|
||||
(insertExt, uDeleg) <-
|
||||
(insertExt, insertLeaf, uDeleg) <-
|
||||
lift $ case (grantDB, bimap entityKey entityKey recip) of
|
||||
(Left (grantActor, _, grantID), Left localID) -> do
|
||||
delegID <- insert $ CollabDelegLocal enableID localID grantID
|
||||
|
|
@ -2228,6 +2380,8 @@ projectGrant now projectID (Verse authorIdMsig body) grant = do
|
|||
return
|
||||
(\ enableID furtherID ->
|
||||
insert_ $ ComponentFurtherLocal enableID delegID furtherID
|
||||
, \ leafID ->
|
||||
insert_ $ SourceUsLeafToLocal leafID delegID
|
||||
, encodeRouteHome delegR
|
||||
)
|
||||
(Right (_, _, grantID), Right remoteID) -> do
|
||||
|
|
@ -2236,6 +2390,8 @@ projectGrant now projectID (Verse authorIdMsig body) grant = do
|
|||
return
|
||||
(\ enableID furtherID ->
|
||||
insert_ $ ComponentFurtherRemote enableID delegID furtherID
|
||||
, \ leafID ->
|
||||
insert_ $ SourceUsLeafToRemote leafID delegID
|
||||
, u
|
||||
)
|
||||
_ -> error "projectGrant impossible 2"
|
||||
|
|
@ -2244,9 +2400,9 @@ projectGrant now projectID (Verse authorIdMsig body) grant = do
|
|||
projectHash <- encodeKeyHashid projectID
|
||||
let sieve = makeRecipientSet [] [LocalStageProjectFollowers projectHash]
|
||||
|
||||
extensions <- lift $ do
|
||||
-- For each Component of mine, prepare a delegation-extension
|
||||
-- Grant
|
||||
extensions <- lift $ do
|
||||
locals <-
|
||||
fmap (map $ over _1 Left) $
|
||||
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
|
||||
u@(ObjURI h lu) <- getRemoteActorURI ra
|
||||
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
|
||||
insertExt enableID' extID
|
||||
componentIdent <- do
|
||||
|
|
@ -2304,6 +2460,54 @@ projectGrant now projectID (Verse authorIdMsig body) grant = do
|
|||
_luExt <- updateOutboxItem' recipByKey extID actionExt
|
||||
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)
|
||||
|
||||
case maybeNew of
|
||||
|
|
@ -2363,6 +2567,45 @@ projectGrant now projectID (Verse authorIdMsig body) grant = do
|
|||
|
||||
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
|
||||
-- Behavior:
|
||||
-- * Verify the resource is my collabs or components list
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
{- 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.
|
||||
-
|
||||
|
|
@ -28,6 +28,7 @@ module Vervis.Persist.Actor
|
|||
, updateOutboxItem'
|
||||
, fillPerActorKeys
|
||||
, getPersonWidgetInfo
|
||||
, getActivityBody
|
||||
)
|
||||
where
|
||||
|
||||
|
|
@ -37,6 +38,7 @@ import Control.Monad.Logger.CallStack
|
|||
import Control.Monad.Trans.Class
|
||||
import Control.Monad.Trans.Except
|
||||
import Control.Monad.Trans.Reader
|
||||
import Data.Aeson
|
||||
import Data.Barbie
|
||||
import Data.Bitraversable
|
||||
import Data.Text (Text)
|
||||
|
|
@ -64,7 +66,6 @@ import qualified Web.Actor.Persist as WAP
|
|||
import Control.Monad.Trans.Except.Local
|
||||
import Database.Persist.Local
|
||||
|
||||
--import Vervis.Actor2 ()
|
||||
import Vervis.Data.Actor
|
||||
import Vervis.FedURI
|
||||
import Vervis.Foundation
|
||||
|
|
@ -234,3 +235,16 @@ getPersonWidgetInfo = bitraverse getLocal getRemote
|
|||
remoteObject <- getJust $ remoteActorIdent remoteActor
|
||||
inztance <- getJust $ remoteObjectInstance remoteObject
|
||||
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
|
||||
, verifyNoEnabledProjectParents
|
||||
, verifyNoEnabledGroupChildren
|
||||
|
||||
, getGrantActivityBody
|
||||
)
|
||||
where
|
||||
|
||||
|
|
@ -83,6 +85,7 @@ import Database.Persist.Local
|
|||
|
||||
import Vervis.Actor
|
||||
import Vervis.Data.Collab
|
||||
import Vervis.FedURI
|
||||
import Vervis.Model
|
||||
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
|
||||
-- bug)
|
||||
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
|
||||
-- extension-Grant to a Dest of mine
|
||||
|
||||
SourceUsGatherLocal
|
||||
deleg SourceUsSendDelegatorId
|
||||
dest DestThemSendDelegatorLocalId
|
||||
SourceUsGather
|
||||
source SourceUsSendDelegatorId
|
||||
dest DestUsAcceptId
|
||||
grant OutboxItemId
|
||||
|
||||
UniqueSourceUsGatherLocal grant
|
||||
SourceUsGatherFromLocal
|
||||
gather SourceUsGatherId
|
||||
from SourceThemDelegateLocalId
|
||||
|
||||
SourceUsGatherRemote
|
||||
deleg SourceUsSendDelegatorId
|
||||
dest DestThemSendDelegatorRemoteId
|
||||
grant RemoteActivityId
|
||||
UniqueSourceUsGatherFromLocal gather
|
||||
|
||||
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
|
||||
-- direct-collaborator of mine
|
||||
|
||||
SourceUsLeafLocal
|
||||
deleg SourceUsSendDelegatorId
|
||||
collab CollabDelegLocalId
|
||||
SourceUsLeaf
|
||||
source SourceUsSendDelegatorId
|
||||
collab CollabEnableId
|
||||
grant OutboxItemId
|
||||
|
||||
UniqueSourceUsLeafLocal grant
|
||||
SourceUsLeafFromLocal
|
||||
leaf SourceUsLeafId
|
||||
from SourceThemDelegateLocalId
|
||||
|
||||
SourceUsLeafRemote
|
||||
deleg SourceUsSendDelegatorId
|
||||
collab CollabDelegRemoteId
|
||||
grant RemoteActivityId
|
||||
UniqueSourceUsLeafFromLocal leaf
|
||||
|
||||
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
|
||||
|
|
|
|||
Loading…
Reference in a new issue