S2S: Group: Grant: Port parent-child modes from Project
This commit is contained in:
Pere Lev
parent
d72e06727c
commit
5e0a2e1088
1 changed files with 825 additions and 69 deletions
|
|
@ -1734,9 +1734,23 @@ groupFollow now recipGroupID verse follow = do
|
||||||
(\ _ -> pure [])
|
(\ _ -> pure [])
|
||||||
now recipGroupID verse follow
|
now recipGroupID verse follow
|
||||||
|
|
||||||
|
data GrantKind
|
||||||
|
= GKDelegationStart AP.Role
|
||||||
|
| GKDelegationExtend AP.Role (Either (LocalActorBy Key) FedURI)
|
||||||
|
| GKDelegator
|
||||||
|
|
||||||
-- 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 - Collaborator sending me a delegator-Grant - Verify that:
|
-- * Option 1 - Project 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 ??? record in DB
|
||||||
|
-- * Send extension-Grants and record them in the DB:
|
||||||
|
-- * To each of my direct collaborators
|
||||||
|
-- * To each of my children
|
||||||
|
--
|
||||||
|
-- * 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
|
||||||
-- * The Grant's context is A
|
-- * The Grant's context is A
|
||||||
-- * The Grant's target is me
|
-- * The Grant's target is me
|
||||||
|
|
@ -1748,8 +1762,30 @@ groupFollow now recipGroupID verse follow = do
|
||||||
-- * Insert the Grant to my inbox
|
-- * Insert the Grant to my inbox
|
||||||
-- * Record the delegator-Grant in the Collab record in DB
|
-- * Record the delegator-Grant in the Collab record in DB
|
||||||
-- * Forward the Grant to my followers
|
-- * 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
|
||||||
|
-- * 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
|
||||||
--
|
--
|
||||||
-- * If not 1, raise an error
|
-- * Option 3 - Parent 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 children
|
||||||
|
--
|
||||||
|
-- * Option 4 - Almost-Child sending me the delegator-Grant
|
||||||
|
-- * Update the Dest record, enabling the child
|
||||||
|
-- * Send a start-Grant giving access-to-me
|
||||||
|
-- * For each of my projects, send an extension-Grant to the new
|
||||||
|
-- parent
|
||||||
|
-- * For each grant I've been delegated from my parents, send an
|
||||||
|
-- extension-Grant to the new child
|
||||||
|
--
|
||||||
|
-- * If neither of those, raise an error
|
||||||
groupGrant
|
groupGrant
|
||||||
:: UTCTime
|
:: UTCTime
|
||||||
-> GroupId
|
-> GroupId
|
||||||
|
|
@ -1758,64 +1794,103 @@ groupGrant
|
||||||
-> ActE (Text, Act (), Next)
|
-> ActE (Text, Act (), Next)
|
||||||
groupGrant now groupID (Verse authorIdMsig body) grant = do
|
groupGrant now groupID (Verse authorIdMsig body) grant = do
|
||||||
|
|
||||||
-- Check capability
|
grant' <- checkGrant grant
|
||||||
capability <- do
|
let adapt = maybe (Right Nothing) (either Left (Right . Just))
|
||||||
|
maybeMode <-
|
||||||
|
withDBExcept $ ExceptT $ fmap adapt $ runMaybeT $
|
||||||
|
runExceptT (Left . Left <$> tryProject grant') <|>
|
||||||
|
runExceptT (Left . Right <$> tryCollab grant') <|>
|
||||||
|
runExceptT (Right . Left <$> tryParent grant') <|>
|
||||||
|
runExceptT (Right . Right <$> tryAlmostChild grant')
|
||||||
|
mode <-
|
||||||
|
fromMaybeE
|
||||||
|
maybeMode
|
||||||
|
"Not a relevant Grant that I'm aware of"
|
||||||
|
case mode of
|
||||||
|
Left (Left ()) ->
|
||||||
|
handleProject
|
||||||
|
Left (Right (enableID, role, recip)) ->
|
||||||
|
handleCollab enableID role recip
|
||||||
|
Right (Left (role, sendID, topic)) ->
|
||||||
|
handleParent role sendID topic
|
||||||
|
Right (Right (role, topic, acceptID)) ->
|
||||||
|
handleAlmostChild role topic acceptID
|
||||||
|
|
||||||
|
where
|
||||||
|
|
||||||
|
checkCapability = do
|
||||||
-- Verify that a capability is provided
|
-- Verify that a capability is provided
|
||||||
uCap <- do
|
uCap <- lift $ hoistMaybe $ AP.activityCapability $ actbActivity body
|
||||||
let muCap = AP.activityCapability $ actbActivity body
|
|
||||||
fromMaybeE muCap "No capability provided"
|
|
||||||
|
|
||||||
-- Verify the capability URI is one of:
|
-- Verify the capability URI is one of:
|
||||||
-- * Outbox item URI of a local actor, i.e. a local activity
|
-- * Outbox item URI of a local actor, i.e. a local activity
|
||||||
-- * A remote URI
|
-- * A remote URI
|
||||||
cap <- nameExceptT "Invite capability" $ parseActivityURI' uCap
|
cap <-
|
||||||
|
ExceptT . lift . lift . runExceptT $
|
||||||
|
nameExceptT "Grant capability" $ parseActivityURI' uCap
|
||||||
|
|
||||||
-- Verify the capability is local
|
-- Verify the capability is local
|
||||||
case cap of
|
case cap of
|
||||||
Left (actorByKey, _, outboxItemID) ->
|
Left (actorByKey, _, outboxItemID) ->
|
||||||
return (actorByKey, outboxItemID)
|
return (actorByKey, outboxItemID)
|
||||||
_ -> throwE "Capability is remote i.e. definitely not by me"
|
_ -> lift mzero
|
||||||
|
|
||||||
-- Check grant
|
checkGrant g = do
|
||||||
collab <- checkDelegator grant
|
|
||||||
|
|
||||||
handleCollab capability collab
|
|
||||||
|
|
||||||
where
|
|
||||||
|
|
||||||
checkDelegator g = do
|
|
||||||
(role, resource, recipient, _mresult, mstart, mend, usage, mdeleg) <-
|
(role, resource, recipient, _mresult, mstart, mend, usage, mdeleg) <-
|
||||||
parseGrant' g
|
parseGrant' g
|
||||||
case role of
|
|
||||||
AP.RXRole _ -> throwE "Role isn't delegator"
|
|
||||||
AP.RXDelegator -> pure ()
|
|
||||||
collab <-
|
|
||||||
bitraverse
|
|
||||||
(\case
|
|
||||||
LocalActorPerson p -> pure p
|
|
||||||
_ -> throwE "Local resource isn't a Person, therefore not a collaborator of mine"
|
|
||||||
)
|
|
||||||
pure
|
|
||||||
resource
|
|
||||||
case (collab, authorIdMsig) of
|
|
||||||
(Left c, Left (a, _, _)) | LocalActorPerson c == a -> pure ()
|
|
||||||
(Right u, Right (ra, _, _)) | remoteAuthorURI ra == u -> pure ()
|
|
||||||
_ -> throwE "Author and context aren't the same actor"
|
|
||||||
case recipient of
|
case recipient of
|
||||||
Left (LocalActorGroup g) | g == groupID -> pure ()
|
Left (LocalActorGroup j) | j == groupID -> pure ()
|
||||||
_ -> throwE "Target isn't me"
|
_ -> throwE "Target isn't me"
|
||||||
for_ mstart $ \ start ->
|
for_ mstart $ \ start ->
|
||||||
unless (start < now) $ throwE "Start time is in the future"
|
unless (start < now) $ throwE "Start time is in the future"
|
||||||
for_ mend $ \ _ ->
|
for_ mend $ \ _ ->
|
||||||
throwE "End time is specified"
|
throwE "End time is specified"
|
||||||
unless (usage == AP.Invoke) $
|
|
||||||
throwE "Usage isn't Invoke"
|
|
||||||
for_ mdeleg $ \ _ ->
|
|
||||||
throwE "'delegates' is specified"
|
|
||||||
return collab
|
|
||||||
|
|
||||||
handleCollab capability collab = do
|
let resourceIsAuthor =
|
||||||
|
case (resource, authorIdMsig) of
|
||||||
|
(Left a, Left (a', _, _)) -> a == a'
|
||||||
|
(Right u, Right (ra, _, _)) -> remoteAuthorURI ra == u
|
||||||
|
_ -> False
|
||||||
|
|
||||||
|
case (role, resourceIsAuthor, usage, mdeleg) of
|
||||||
|
(AP.RXRole r, True, AP.GatherAndConvey, Nothing) ->
|
||||||
|
pure $ GKDelegationStart r
|
||||||
|
(AP.RXRole r, False, AP.GatherAndConvey, Just _) ->
|
||||||
|
pure $ GKDelegationExtend r resource
|
||||||
|
(AP.RXDelegator, True, AP.Invoke, Nothing) ->
|
||||||
|
pure GKDelegator
|
||||||
|
_ -> throwE "A kind of Grant that I don't use"
|
||||||
|
|
||||||
|
tryProject _ = lift mzero
|
||||||
|
|
||||||
|
handleProject = done "handleProject"
|
||||||
|
|
||||||
|
tryCollab (GKDelegationStart _) = lift mzero
|
||||||
|
tryCollab (GKDelegationExtend _ _) = lift mzero
|
||||||
|
tryCollab GKDelegator = do
|
||||||
|
capability <- checkCapability
|
||||||
|
-- Find the Collab record from the capability
|
||||||
|
Entity enableID (CollabEnable collabID _) <- lift $ do
|
||||||
|
-- Capability isn't mine
|
||||||
|
guard $ fst capability == LocalActorGroup groupID
|
||||||
|
-- I don't have a Collab with this capability
|
||||||
|
MaybeT $ getBy $ UniqueCollabEnableGrant $ snd capability
|
||||||
|
Collab role _ <- lift $ lift $ getJust collabID
|
||||||
|
topic <- lift $ lift $ getCollabTopic collabID
|
||||||
|
-- Found a Collab for this direct-Grant but it's not mine
|
||||||
|
lift $ guard $ topic == LocalResourceGroup groupID
|
||||||
|
recip <- lift $ lift $ getCollabRecip collabID
|
||||||
|
recipForCheck <-
|
||||||
|
lift $ lift $
|
||||||
|
bitraverse
|
||||||
|
(pure . collabRecipLocalPerson . entityVal)
|
||||||
|
(getRemoteActorURI <=< getJust . collabRecipRemoteActor . entityVal)
|
||||||
|
recip
|
||||||
|
unless (first LocalActorPerson recipForCheck == bimap (view _1) (remoteAuthorURI . view _1) authorIdMsig) $
|
||||||
|
throwE "Capability's collaborator and Grant author aren't the same actor"
|
||||||
|
return (enableID, role, recip)
|
||||||
|
|
||||||
|
handleCollab enableID role recip = do
|
||||||
|
|
||||||
maybeNew <- withDBExcept $ do
|
maybeNew <- withDBExcept $ do
|
||||||
|
|
||||||
|
|
@ -1825,26 +1900,6 @@ groupGrant now groupID (Verse authorIdMsig body) grant = do
|
||||||
let actorID = groupActor recip
|
let actorID = groupActor recip
|
||||||
(actorID,) <$> getJust actorID
|
(actorID,) <$> getJust actorID
|
||||||
|
|
||||||
-- Find the Collab record from the capability
|
|
||||||
Entity enableID (CollabEnable collabID _) <- do
|
|
||||||
unless (fst capability == LocalActorGroup groupID) $
|
|
||||||
throwE "Capability isn't mine"
|
|
||||||
m <- lift $ getBy $ UniqueCollabEnableGrant $ snd capability
|
|
||||||
fromMaybeE m "I don't have a Collab with this capability"
|
|
||||||
Collab role _ <- lift $ getJust collabID
|
|
||||||
topic <- lift $ getCollabTopic collabID
|
|
||||||
unless (topic == LocalResourceGroup groupID) $
|
|
||||||
throwE "Found a Collab for this direct-Grant but it's not mine"
|
|
||||||
recip <- lift $ getCollabRecip collabID
|
|
||||||
recipForCheck <-
|
|
||||||
lift $
|
|
||||||
bitraverse
|
|
||||||
(pure . collabRecipLocalPerson . entityVal)
|
|
||||||
(getRemoteActorURI <=< getJust . collabRecipRemoteActor . entityVal)
|
|
||||||
recip
|
|
||||||
unless (recipForCheck == collab) $
|
|
||||||
throwE "Capability's collaborator and Grant author aren't the same actor"
|
|
||||||
|
|
||||||
-- Verify I don't yet have a delegator-Grant from the collaborator
|
-- Verify I don't yet have a delegator-Grant from the collaborator
|
||||||
maybeDeleg <-
|
maybeDeleg <-
|
||||||
lift $ case bimap entityKey entityKey recip of
|
lift $ case bimap entityKey entityKey recip of
|
||||||
|
|
@ -1856,20 +1911,99 @@ groupGrant now groupID (Verse authorIdMsig body) grant = do
|
||||||
for maybeGrantDB $ \ (inboxItemID, grantDB) -> do
|
for maybeGrantDB $ \ (inboxItemID, grantDB) -> do
|
||||||
|
|
||||||
-- Record the delegator-Grant in the Collab record
|
-- Record the delegator-Grant in the Collab record
|
||||||
|
(insertLeaf, uDeleg) <-
|
||||||
lift $ case (grantDB, bimap entityKey entityKey recip) of
|
lift $ case (grantDB, bimap entityKey entityKey recip) of
|
||||||
(Left (grantActor, _, grantID), Left localID) ->
|
(Left (grantActor, _, grantID), Left localID) -> do
|
||||||
insert_ $ CollabDelegLocal enableID localID grantID
|
delegID <- insert $ CollabDelegLocal enableID localID grantID
|
||||||
(Right (_, _, grantID), Right remoteID) ->
|
encodeRouteHome <- getEncodeRouteHome
|
||||||
insert_ $ CollabDelegRemote enableID remoteID grantID
|
delegR <-
|
||||||
|
activityRoute
|
||||||
|
<$> hashLocalActor grantActor
|
||||||
|
<*> encodeKeyHashid grantID
|
||||||
|
return
|
||||||
|
( \ leafID ->
|
||||||
|
insert_ $ SourceUsLeafToLocal leafID delegID
|
||||||
|
, encodeRouteHome delegR
|
||||||
|
)
|
||||||
|
(Right (_, _, grantID), Right remoteID) -> do
|
||||||
|
delegID <- insert $ CollabDelegRemote enableID remoteID grantID
|
||||||
|
u <- getRemoteActivityURI =<< getJust grantID
|
||||||
|
return
|
||||||
|
( \ leafID ->
|
||||||
|
insert_ $ SourceUsLeafToRemote leafID delegID
|
||||||
|
, u
|
||||||
|
)
|
||||||
_ -> error "groupGrant impossible 2"
|
_ -> error "groupGrant impossible 2"
|
||||||
|
|
||||||
-- Prepare forwarding of Accept to my followers
|
-- Prepare forwarding of Accept to my followers
|
||||||
groupHash <- encodeKeyHashid groupID
|
groupHash <- encodeKeyHashid groupID
|
||||||
let sieve = makeRecipientSet [] [LocalStageGroupFollowers groupHash]
|
let sieve = makeRecipientSet [] [LocalStageGroupFollowers groupHash]
|
||||||
|
|
||||||
-- For each parent group of mine, prepare a
|
extensions <- lift $ do
|
||||||
|
-- For each Project of mine, prepare a delegation-extension
|
||||||
|
-- Grant
|
||||||
|
(uCollab, audCollab) <-
|
||||||
|
case recip of
|
||||||
|
Left (Entity _ (CollabRecipLocal _ personID)) -> do
|
||||||
|
personHash <- encodeKeyHashid personID
|
||||||
|
encodeRouteHome <- getEncodeRouteHome
|
||||||
|
return
|
||||||
|
( encodeRouteHome $ PersonR personHash
|
||||||
|
, AudLocal [LocalActorPerson personHash] []
|
||||||
|
)
|
||||||
|
Right (Entity _ (CollabRecipRemote _ raID)) -> do
|
||||||
|
ra <- getJust raID
|
||||||
|
u@(ObjURI h lu) <- getRemoteActorURI ra
|
||||||
|
return (u, AudRemote h [lu] [])
|
||||||
|
fromProjects <- pure []
|
||||||
|
|
||||||
|
-- For each Grant I got from a parent, prepare a
|
||||||
-- delegation-extension Grant
|
-- delegation-extension Grant
|
||||||
extensions <- lift $ pure []
|
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.^. SourceHolderGroupSource
|
||||||
|
E.where_ $ holder E.^. SourceHolderGroupGroup E.==. E.val groupID
|
||||||
|
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.^. SourceHolderGroupSource
|
||||||
|
E.where_ $ holder E.^. SourceHolderGroupGroup E.==. E.val groupID
|
||||||
|
return
|
||||||
|
( send E.^. SourceUsSendDelegatorId
|
||||||
|
, deleg
|
||||||
|
)
|
||||||
|
fromParents <- 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, _, _, _) <-
|
||||||
|
prepareExtensionGrantFromParent uCollab audCollab uDeleg uStart grant role enableID
|
||||||
|
let recipByKey = LocalActorGroup groupID
|
||||||
|
_luExt <- updateOutboxItem' recipByKey extID actionExt
|
||||||
|
return (extID, ext)
|
||||||
|
|
||||||
|
return $ fromProjects ++ fromParents
|
||||||
|
|
||||||
return (recipActorID, sieve, extensions, inboxItemID)
|
return (recipActorID, sieve, extensions, inboxItemID)
|
||||||
|
|
||||||
|
|
@ -1883,7 +2017,629 @@ groupGrant now groupID (Verse authorIdMsig body) grant = do
|
||||||
sendActivity
|
sendActivity
|
||||||
recipByID recipActorID localRecipsExt
|
recipByID recipActorID localRecipsExt
|
||||||
remoteRecipsExt fwdHostsExt extID actionExt
|
remoteRecipsExt fwdHostsExt extID actionExt
|
||||||
doneDB inboxItemID "Forwarded the delegator-Grant, updated DB"
|
doneDB inboxItemID "[Collab] Forwarded the delegator-Grant, updated DB and published delegation extensions"
|
||||||
|
|
||||||
|
where
|
||||||
|
|
||||||
|
prepareExtensionGrantFromParent uCollab audCollab uDeleg uStart grant role enableID = do
|
||||||
|
encodeRouteHome <- getEncodeRouteHome
|
||||||
|
encodeRouteLocal <- getEncodeRouteLocal
|
||||||
|
|
||||||
|
groupHash <- encodeKeyHashid groupID
|
||||||
|
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 $
|
||||||
|
GroupMemberLiveR groupHash enableHash
|
||||||
|
, Nothing
|
||||||
|
)
|
||||||
|
, AP.grantStart = Just now
|
||||||
|
, AP.grantEnd = Nothing
|
||||||
|
, AP.grantAllows = AP.Invoke
|
||||||
|
, AP.grantDelegates = Just uStart
|
||||||
|
}
|
||||||
|
}
|
||||||
|
|
||||||
|
return (action, recipientSet, remoteActors, fwdHosts)
|
||||||
|
|
||||||
|
tryParent gk = do
|
||||||
|
capability <- checkCapability
|
||||||
|
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 == LocalActorGroup groupID
|
||||||
|
-- I don't have a Source with this capability
|
||||||
|
MaybeT $ getBy $ UniqueSourceUsSendDelegatorGrant $ snd capability
|
||||||
|
Source role' <- lift $ lift $ getJust sourceID
|
||||||
|
SourceHolderGroup _ g <-
|
||||||
|
lift $ MaybeT $ getValBy $ UniqueSourceHolderGroup sourceID
|
||||||
|
-- Found a Source for this Grant but it's not mine
|
||||||
|
lift $ guard $ g == groupID
|
||||||
|
topic <- do
|
||||||
|
t <- lift $ lift $ getSourceTopic sourceID
|
||||||
|
bitraverse
|
||||||
|
(bitraverse
|
||||||
|
pure
|
||||||
|
(\case
|
||||||
|
Right g -> pure g
|
||||||
|
Left _j -> error "I have a SourceTopic that is a Project"
|
||||||
|
)
|
||||||
|
)
|
||||||
|
pure
|
||||||
|
t
|
||||||
|
topicForCheck <-
|
||||||
|
lift $ lift $
|
||||||
|
bitraverse
|
||||||
|
(pure . snd)
|
||||||
|
(\ (_, raID) -> getRemoteActorURI =<< getJust raID)
|
||||||
|
topic
|
||||||
|
unless (first LocalActorGroup 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)
|
||||||
|
|
||||||
|
handleParent 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, 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 $ \ (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 $ 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 $ \ (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 $ 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 = 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 $ 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 = 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
|
||||||
|
gatherID <- insert $ SourceUsGather sendID startID extID
|
||||||
|
case from of
|
||||||
|
Left localID -> insert_ $ SourceUsGatherFromLocal gatherID localID
|
||||||
|
Right remoteID -> insert_ $ SourceUsGatherFromRemote gatherID 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
|
||||||
|
gatherID <- insert $ SourceUsGather sendID startID extID
|
||||||
|
case from of
|
||||||
|
Left localID -> insert_ $ SourceUsGatherFromLocal gatherID localID
|
||||||
|
Right remoteID -> insert_ $ SourceUsGatherFromRemote gatherID 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 "[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 (GKDelegationExtend _ _) = lift mzero
|
||||||
|
tryAlmostChild GKDelegator = do
|
||||||
|
uFulfills <-
|
||||||
|
case AP.activityFulfills $ actbActivity body of
|
||||||
|
[] -> throwE "No fulfills"
|
||||||
|
[u] -> pure u
|
||||||
|
_ -> throwE "Multiple fulfills"
|
||||||
|
fulfills <- ExceptT $ lift $ lift $ runExceptT $ first (\ (a, _, i) -> (a, i)) <$> parseActivityURI' uFulfills
|
||||||
|
fulfillsDB <- ExceptT $ MaybeT $ either (Just . Left) (fmap Right) <$> runExceptT (getActivity fulfills)
|
||||||
|
-- Find the Dest record from the fulfills
|
||||||
|
destID <-
|
||||||
|
lift $
|
||||||
|
case fulfillsDB of
|
||||||
|
Left (_, _, addID) ->
|
||||||
|
(do DestUsGestureLocal destID _ <- MaybeT $ getValBy $ UniqueDestUsGestureLocalActivity addID
|
||||||
|
_ <- MaybeT $ getBy $ UniqueDestOriginUs destID
|
||||||
|
return destID
|
||||||
|
)
|
||||||
|
<|>
|
||||||
|
(do DestThemGestureLocal themID _ <- MaybeT $ getValBy $ UniqueDestThemGestureLocalAdd addID
|
||||||
|
DestOriginThem destID <- lift $ getJust themID
|
||||||
|
return destID
|
||||||
|
)
|
||||||
|
Right addID ->
|
||||||
|
(do DestUsGestureRemote destID _ _ <- MaybeT $ getValBy $ UniqueDestUsGestureRemoteActivity addID
|
||||||
|
_ <- MaybeT $ getBy $ UniqueDestOriginUs destID
|
||||||
|
return destID
|
||||||
|
)
|
||||||
|
<|>
|
||||||
|
(do DestThemGestureRemote themID _ _ <- MaybeT $ getValBy $ UniqueDestThemGestureRemoteAdd addID
|
||||||
|
DestOriginThem destID <- lift $ getJust themID
|
||||||
|
return destID
|
||||||
|
)
|
||||||
|
-- Verify this Dest record is mine
|
||||||
|
DestHolderGroup _ g <- lift $ MaybeT $ getValBy $ UniqueDestHolderGroup destID
|
||||||
|
lift $ guard $ g == groupID
|
||||||
|
-- Verify the Grant sender is the Dest topic
|
||||||
|
topic <- do
|
||||||
|
t <- lift $ lift $ getDestTopic destID
|
||||||
|
bitraverse
|
||||||
|
(bitraverse
|
||||||
|
pure
|
||||||
|
(\case
|
||||||
|
Right g -> pure g
|
||||||
|
Left _j -> error "I have a DestTopic that is a Project"
|
||||||
|
)
|
||||||
|
)
|
||||||
|
pure
|
||||||
|
t
|
||||||
|
topicForCheck <-
|
||||||
|
lift $ lift $
|
||||||
|
bitraverse
|
||||||
|
(pure . snd)
|
||||||
|
(\ (_, raID) -> getRemoteActorURI =<< getJust raID)
|
||||||
|
topic
|
||||||
|
unless (first LocalActorGroup topicForCheck == bimap (view _1) (remoteAuthorURI . view _1) authorIdMsig) $
|
||||||
|
throwE "Dest topic and Grant author aren't the same actor"
|
||||||
|
-- Verify I sent my Accept
|
||||||
|
maybeMe <- lift $ lift $ getKeyBy $ UniqueDestUsAccept destID
|
||||||
|
meAcceptID <- fromMaybeE maybeMe "I haven't sent my Accept"
|
||||||
|
-- Verify I haven't yet seen a delegator-Grant from the parent
|
||||||
|
case bimap fst fst topic of
|
||||||
|
Left localID -> do
|
||||||
|
m <- lift $ lift $ getBy $ UniqueDestThemSendDelegatorLocalTopic localID
|
||||||
|
verifyNothingE m "Already have a DestThemSendDelegatorLocal"
|
||||||
|
Right remoteID -> do
|
||||||
|
m <- lift $ lift $ getBy $ UniqueDestThemSendDelegatorRemoteTopic remoteID
|
||||||
|
verifyNothingE m "Already have a DestThemSendDelegatorRemote"
|
||||||
|
Dest role <- lift $ lift $ getJust destID
|
||||||
|
return (role, topic, meAcceptID)
|
||||||
|
|
||||||
|
handleAlmostChild role topic acceptID = do
|
||||||
|
|
||||||
|
maybeNew <- withDBExcept $ do
|
||||||
|
|
||||||
|
-- Grab me from DB
|
||||||
|
(recipActorID, recipActor) <- lift $ do
|
||||||
|
recip <- getJust groupID
|
||||||
|
let actorID = groupActor recip
|
||||||
|
(actorID,) <$> getJust actorID
|
||||||
|
|
||||||
|
maybeGrantDB <- lift $ insertToInbox now authorIdMsig body (actorInbox recipActor) False
|
||||||
|
for maybeGrantDB $ \ (inboxItemID, grantDB) -> do
|
||||||
|
|
||||||
|
-- Record the delegator-Grant in DB
|
||||||
|
to <- case (grantDB, bimap fst fst topic) of
|
||||||
|
(Left (_, _, grantID), Left localID) -> Left <$> do
|
||||||
|
mk <- lift $ insertUnique $ DestThemSendDelegatorLocal acceptID localID grantID
|
||||||
|
fromMaybeE mk "I already have such a DestThemSendDelegatorLocal"
|
||||||
|
(Right (_, _, grantID), Right remoteID) -> Right <$> do
|
||||||
|
mk <- lift $ insertUnique $ DestThemSendDelegatorRemote acceptID remoteID grantID
|
||||||
|
fromMaybeE mk "I already have such a DestThemSendDelegatorRemote"
|
||||||
|
_ -> error "groupGrant.child impossible"
|
||||||
|
|
||||||
|
startID <- lift $ insertEmptyOutboxItem' (actorOutbox recipActor) now
|
||||||
|
destStartID <- lift $ insert $ DestUsStart acceptID startID
|
||||||
|
|
||||||
|
-- Prepare a start-Grant
|
||||||
|
start@(actionStart, _, _, _) <- lift $ prepareStartGrant role destStartID
|
||||||
|
let recipByKey = LocalActorGroup groupID
|
||||||
|
_luStart <- lift $ updateOutboxItem' recipByKey startID actionStart
|
||||||
|
|
||||||
|
-- For each Project in me, prepare a delegation-extension Grant
|
||||||
|
localExtensions <- pure []
|
||||||
|
remoteExtensions <- pure []
|
||||||
|
|
||||||
|
-- For each Grant I got from a child, prepare a
|
||||||
|
-- delegation-extension Grant
|
||||||
|
l <-
|
||||||
|
lift $ 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.^. SourceHolderGroupSource
|
||||||
|
E.where_ $ holder E.^. SourceHolderGroupGroup E.==. E.val groupID
|
||||||
|
return
|
||||||
|
( send E.^. SourceUsSendDelegatorId
|
||||||
|
, deleg
|
||||||
|
)
|
||||||
|
r <-
|
||||||
|
lift $ 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.^. SourceHolderGroupSource
|
||||||
|
E.where_ $ holder E.^. SourceHolderGroupGroup E.==. E.val groupID
|
||||||
|
return
|
||||||
|
( send E.^. SourceUsSendDelegatorId
|
||||||
|
, deleg
|
||||||
|
)
|
||||||
|
fromParents <- lift $ for (l ++ r) $ \ (E.Value sendID, deleg) -> do
|
||||||
|
extID <- insertEmptyOutboxItem' (actorOutbox recipActor) now
|
||||||
|
|
||||||
|
gatherID <- insert $ SourceUsGather sendID destStartID extID
|
||||||
|
case bimap entityKey entityKey deleg of
|
||||||
|
Left localID -> insert_ $ SourceUsGatherFromLocal gatherID localID
|
||||||
|
Right remoteID -> insert_ $ SourceUsGatherFromRemote gatherID remoteID
|
||||||
|
|
||||||
|
(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, _, _, _) <-
|
||||||
|
prepareExtensionGrantFromParent uStart grant role destStartID
|
||||||
|
let recipByKey = LocalActorGroup groupID
|
||||||
|
_luExt <- updateOutboxItem' recipByKey extID actionExt
|
||||||
|
return (extID, ext)
|
||||||
|
|
||||||
|
return
|
||||||
|
( recipActorID
|
||||||
|
, (startID, start) : localExtensions ++ remoteExtensions ++ fromParents
|
||||||
|
, inboxItemID
|
||||||
|
)
|
||||||
|
|
||||||
|
case maybeNew of
|
||||||
|
Nothing -> done "I already have this activity in my inbox"
|
||||||
|
Just (recipActorID, exts, inboxItemID) -> do
|
||||||
|
let recipByID = LocalActorGroup groupID
|
||||||
|
lift $ for_ exts $
|
||||||
|
\ (extID, (actionExt, localRecipsExt, remoteRecipsExt, fwdHostsExt)) ->
|
||||||
|
sendActivity
|
||||||
|
recipByID recipActorID localRecipsExt
|
||||||
|
remoteRecipsExt fwdHostsExt extID actionExt
|
||||||
|
doneDB inboxItemID "[Almost-child] Sent start-Grant and extensions from projects and parents"
|
||||||
|
|
||||||
|
where
|
||||||
|
|
||||||
|
prepareStartGrant role startID = do
|
||||||
|
encodeRouteHome <- getEncodeRouteHome
|
||||||
|
encodeRouteLocal <- getEncodeRouteLocal
|
||||||
|
|
||||||
|
groupHash <- encodeKeyHashid groupID
|
||||||
|
|
||||||
|
uDeleg <- lift $ getActivityURI authorIdMsig
|
||||||
|
|
||||||
|
audChild <- lift $ makeAudSenderOnly authorIdMsig
|
||||||
|
uChild <- lift $ getActorURI authorIdMsig
|
||||||
|
|
||||||
|
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 = [uDeleg]
|
||||||
|
, AP.actionSpecific = AP.GrantActivity AP.Grant
|
||||||
|
{ AP.grantObject = AP.RXRole role
|
||||||
|
, AP.grantContext = encodeRouteHome $ GroupR groupHash
|
||||||
|
, AP.grantTarget = uChild
|
||||||
|
, AP.grantResult =
|
||||||
|
Just
|
||||||
|
( encodeRouteLocal resultR
|
||||||
|
, Nothing
|
||||||
|
)
|
||||||
|
, AP.grantStart = Just now
|
||||||
|
, AP.grantEnd = Nothing
|
||||||
|
, AP.grantAllows = AP.Distribute
|
||||||
|
, AP.grantDelegates = Nothing
|
||||||
|
}
|
||||||
|
}
|
||||||
|
|
||||||
|
return (action, recipientSet, remoteActors, fwdHosts)
|
||||||
|
|
||||||
|
prepareExtensionGrantFromParent uStart grant role startID = do
|
||||||
|
encodeRouteHome <- getEncodeRouteHome
|
||||||
|
encodeRouteLocal <- getEncodeRouteLocal
|
||||||
|
|
||||||
|
groupHash <- encodeKeyHashid groupID
|
||||||
|
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?"
|
||||||
|
|
||||||
|
uDeleg <- lift $ getActivityURI authorIdMsig
|
||||||
|
audChild <- lift $ makeAudSenderOnly authorIdMsig
|
||||||
|
uChild <- lift $ getActorURI authorIdMsig
|
||||||
|
|
||||||
|
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 finalRole
|
||||||
|
, 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:
|
||||||
|
|
|
||||||
Loading…
Reference in a new issue