S2S: Project: Grant: Implement team mode
This commit is contained in:
Pere Lev
parent
68141fa7da
commit
3359974af7
1 changed files with 381 additions and 6 deletions
|
|
@ -2910,6 +2910,13 @@ data GrantKind
|
|||
-- * For each grant I've been delegated from my children, send an
|
||||
-- extension-Grant to the new parent
|
||||
--
|
||||
-- * Option 5 - Almost-Team sending me the delegator-Grant
|
||||
-- * Update the Squad record, enabling the team
|
||||
-- * Send a start-Grant giving access-to-me
|
||||
-- * For each of my components, send an extension-Grant to the team
|
||||
-- * For each grant I've been delegated from my children, send an
|
||||
-- extension-Grant to the team
|
||||
--
|
||||
-- * If neither of those, raise an error
|
||||
projectGrant
|
||||
:: UTCTime
|
||||
|
|
@ -2922,11 +2929,17 @@ projectGrant now projectID (Verse authorIdMsig body) grant = do
|
|||
grant' <- checkGrant grant
|
||||
let adapt = maybe (Right Nothing) (either Left (Right . Just))
|
||||
maybeMode <-
|
||||
withDBExcept $ ExceptT $ fmap adapt $ runMaybeT $
|
||||
withDBExcept $ do
|
||||
(_myInboxID, meResourceID) <- lift $ do
|
||||
project <- getJust projectID
|
||||
actor <- getJust $ projectActor project
|
||||
return (actorInbox actor, projectResource project)
|
||||
ExceptT $ fmap adapt $ runMaybeT $
|
||||
runExceptT (Left . Left <$> tryComp grant') <|>
|
||||
runExceptT (Left . Right <$> tryCollab grant') <|>
|
||||
runExceptT (Right . Left <$> tryChild grant') <|>
|
||||
runExceptT (Right . Right <$> tryParent grant')
|
||||
runExceptT (Right . Right . Left <$> tryParent grant') <|>
|
||||
runExceptT (Right . Right . Right <$> tryTeam meResourceID grant')
|
||||
mode <-
|
||||
fromMaybeE
|
||||
maybeMode
|
||||
|
|
@ -2938,8 +2951,10 @@ projectGrant now projectID (Verse authorIdMsig body) grant = do
|
|||
handleCollab enableID role recip
|
||||
Right (Left (role, sendID, topic)) ->
|
||||
handleChild role sendID topic
|
||||
Right (Right (role, topic, acceptID)) ->
|
||||
Right (Right (Left (role, topic, acceptID))) ->
|
||||
handleParent role topic acceptID
|
||||
Right (Right (Right (role, topic, acceptID))) ->
|
||||
handleTeam role topic acceptID
|
||||
|
||||
where
|
||||
|
||||
|
|
@ -4487,6 +4502,366 @@ projectGrant now projectID (Verse authorIdMsig body) grant = do
|
|||
|
||||
return (action, recipientSet, remoteActors, fwdHosts)
|
||||
|
||||
tryTeam _ (GKDelegationStart _) = lift mzero
|
||||
tryTeam _ (GKDelegationExtend _ _) = lift mzero
|
||||
tryTeam meResourceID 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 Squad record from the fulfills
|
||||
squadID <-
|
||||
lift $
|
||||
case fulfillsDB of
|
||||
Left (_, _, addID) ->
|
||||
(do SquadUsGestureLocal squadID _ <- MaybeT $ getValBy $ UniqueSquadUsGestureLocalActivity addID
|
||||
_ <- MaybeT $ getBy $ UniqueSquadOriginUs squadID
|
||||
return squadID
|
||||
)
|
||||
<|>
|
||||
(do SquadThemGestureLocal themID _ <- MaybeT $ getValBy $ UniqueSquadThemGestureLocalAdd addID
|
||||
SquadOriginThem squadID <- lift $ getJust themID
|
||||
return squadID
|
||||
)
|
||||
Right addID ->
|
||||
(do SquadUsGestureRemote squadID _ _ <- MaybeT $ getValBy $ UniqueSquadUsGestureRemoteActivity addID
|
||||
_ <- MaybeT $ getBy $ UniqueSquadOriginUs squadID
|
||||
return squadID
|
||||
)
|
||||
<|>
|
||||
(do SquadThemGestureRemote themID _ _ <- MaybeT $ getValBy $ UniqueSquadThemGestureRemoteAdd addID
|
||||
SquadOriginThem squadID <- lift $ getJust themID
|
||||
return squadID
|
||||
)
|
||||
-- Verify this Squad record is mine
|
||||
Squad role r <- lift $ lift $ getJust squadID
|
||||
lift $ guard $ r == meResourceID
|
||||
-- Verify the Grant sender is the Squad topic
|
||||
topic <- lift $ lift $ getSquadTeam squadID
|
||||
topicForCheck <-
|
||||
lift $ lift $
|
||||
bitraverse
|
||||
(pure . snd)
|
||||
(\ (_, raID) -> getRemoteActorURI =<< getJust raID)
|
||||
topic
|
||||
unless (first LocalActorGroup topicForCheck == bimap (view _1) (remoteAuthorURI . view _1) authorIdMsig) $
|
||||
throwE "Squad topic and Grant author aren't the same actor"
|
||||
-- Verify I sent my Accept
|
||||
maybeMe <- lift $ lift $ getKeyBy $ UniqueSquadUsAccept squadID
|
||||
meAcceptID <- fromMaybeE maybeMe "I haven't sent my Accept"
|
||||
-- Verify I haven't yet seen a delegator-Grant from the team
|
||||
case bimap fst fst topic of
|
||||
Left localID -> do
|
||||
m <- lift $ lift $ getBy $ UniqueSquadThemSendDelegatorLocalTopic localID
|
||||
verifyNothingE m "Already have a SquadThemSendDelegatorLocal"
|
||||
Right remoteID -> do
|
||||
m <- lift $ lift $ getBy $ UniqueSquadThemSendDelegatorRemoteTopic remoteID
|
||||
verifyNothingE m "Already have a SquadThemSendDelegatorRemote"
|
||||
return (role, topic, meAcceptID)
|
||||
|
||||
handleTeam role topic acceptID = do
|
||||
|
||||
maybeNew <- withDBExcept $ do
|
||||
|
||||
-- Grab me from DB
|
||||
(recipActorID, recipActor) <- lift $ do
|
||||
recip <- getJust projectID
|
||||
let actorID = projectActor 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 $ SquadThemSendDelegatorLocal acceptID localID grantID
|
||||
fromMaybeE mk "I already have such a SquadThemSendDelegatorLocal"
|
||||
(Right (_, _, grantID), Right remoteID) -> Right <$> do
|
||||
mk <- lift $ insertUnique $ SquadThemSendDelegatorRemote acceptID remoteID grantID
|
||||
fromMaybeE mk "I already have such a SquadThemSendDelegatorRemote"
|
||||
_ -> error "projectGrant.team impossible"
|
||||
|
||||
startID <- lift $ insertEmptyOutboxItem' (actorOutbox recipActor) now
|
||||
squadStartID <- lift $ insert $ SquadUsStart acceptID startID
|
||||
|
||||
-- Prepare a start-Grant
|
||||
start@(actionStart, _, _, _) <- lift $ prepareStartGrant role squadStartID
|
||||
let recipByKey = LocalActorProject projectID
|
||||
_luStart <- lift $ updateOutboxItem' recipByKey startID actionStart
|
||||
|
||||
-- For each Component in me, prepare a delegation-extension Grant
|
||||
localComponents <-
|
||||
lift $
|
||||
E.select $ E.from $ \ (deleg `E.InnerJoin` local `E.InnerJoin` comp `E.InnerJoin` enable) -> do
|
||||
E.on $ comp E.^. ComponentId E.==. enable E.^. ComponentEnableComponent
|
||||
E.on $ local E.^. ComponentLocalComponent E.==. comp E.^. ComponentId
|
||||
E.on $ deleg E.^. ComponentDelegateLocalComponent E.==.local E.^. ComponentLocalId
|
||||
E.where_ $ comp E.^. ComponentProject E.==. E.val projectID
|
||||
return
|
||||
( deleg E.^. ComponentDelegateLocalGrant
|
||||
, comp
|
||||
, enable
|
||||
)
|
||||
localExtensions <- lift $ for localComponents $ \ (E.Value startID, Entity componentID component, Entity enableID _) -> do
|
||||
extID <- insertEmptyOutboxItem' (actorOutbox recipActor) now
|
||||
insert_ $ ComponentConvey enableID squadStartID extID
|
||||
componentIdent <- do
|
||||
i <- getComponentIdent componentID
|
||||
bitraverse
|
||||
(pure . snd)
|
||||
(\ (_, raID) -> getRemoteActorURI =<< getJust raID)
|
||||
i
|
||||
uStart <- do
|
||||
encodeRouteHome <- getEncodeRouteHome
|
||||
c <-
|
||||
case componentIdent of
|
||||
Left ci -> hashComponent ci
|
||||
Right _ -> error "Delegation-start Grant URI is local, but component found to be remote, impossible"
|
||||
s <- encodeKeyHashid startID
|
||||
return $ encodeRouteHome $ activityRoute (resourceToActor $ componentResource c) s
|
||||
ext@(actionExt, _, _, _) <-
|
||||
prepareExtensionGrant componentIdent uStart (min role (componentRole component)) enableID squadStartID
|
||||
let recipByKey = LocalActorProject projectID
|
||||
_luExt <- updateOutboxItem' recipByKey extID actionExt
|
||||
return (extID, ext)
|
||||
|
||||
remoteComponents <-
|
||||
lift $
|
||||
E.select $ E.from $ \ (deleg `E.InnerJoin` remote `E.InnerJoin` comp `E.InnerJoin` enable) -> do
|
||||
E.on $ comp E.^. ComponentId E.==. enable E.^. ComponentEnableComponent
|
||||
E.on $ remote E.^. ComponentRemoteComponent E.==. comp E.^. ComponentId
|
||||
E.on $ deleg E.^. ComponentDelegateRemoteComponent E.==.remote E.^. ComponentRemoteId
|
||||
E.where_ $ comp E.^. ComponentProject E.==. E.val projectID
|
||||
return
|
||||
( deleg E.^. ComponentDelegateRemoteGrant
|
||||
, comp
|
||||
, enable
|
||||
)
|
||||
remoteExtensions <- lift $ for remoteComponents $ \ (E.Value startID, Entity componentID component, Entity enableID _) -> do
|
||||
extID <- insertEmptyOutboxItem' (actorOutbox recipActor) now
|
||||
insert_ $ ComponentConvey enableID squadStartID extID
|
||||
componentIdent <- do
|
||||
i <- getComponentIdent componentID
|
||||
bitraverse
|
||||
(pure . snd)
|
||||
(\ (_, raID) -> getRemoteActorURI =<< getJust raID)
|
||||
i
|
||||
uStart <- do
|
||||
ra <- getJust startID
|
||||
getRemoteActivityURI ra
|
||||
ext@(actionExt, _, _, _) <-
|
||||
prepareExtensionGrant componentIdent uStart (min role (componentRole component)) enableID squadStartID
|
||||
let recipByKey = LocalActorProject projectID
|
||||
_luExt <- updateOutboxItem' recipByKey extID actionExt
|
||||
return (extID, ext)
|
||||
|
||||
-- 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.^. SourceHolderProjectSource
|
||||
E.where_ $ holder E.^. SourceHolderProjectProject E.==. E.val projectID
|
||||
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.^. SourceHolderProjectSource
|
||||
E.where_ $ holder E.^. SourceHolderProjectProject E.==. E.val projectID
|
||||
return
|
||||
( send E.^. SourceUsSendDelegatorId
|
||||
, deleg
|
||||
)
|
||||
fromChildren <- lift $ for (l ++ r) $ \ (E.Value sendID, deleg) -> do
|
||||
extID <- insertEmptyOutboxItem' (actorOutbox recipActor) now
|
||||
|
||||
conveyID <- insert $ SourceUsConvey sendID squadStartID extID
|
||||
case bimap entityKey entityKey deleg of
|
||||
Left localID -> insert_ $ SourceUsConveyFromLocal conveyID localID
|
||||
Right remoteID -> insert_ $ SourceUsConveyFromRemote conveyID 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, _, _, _) <-
|
||||
prepareExtensionGrantFromChild uStart grant role squadStartID
|
||||
let recipByKey = LocalActorProject projectID
|
||||
_luExt <- updateOutboxItem' recipByKey extID actionExt
|
||||
return (extID, ext)
|
||||
|
||||
return
|
||||
( recipActorID
|
||||
, (startID, start) : localExtensions ++ remoteExtensions ++ fromChildren
|
||||
, inboxItemID
|
||||
)
|
||||
|
||||
case maybeNew of
|
||||
Nothing -> done "I already have this activity in my inbox"
|
||||
Just (recipActorID, exts, inboxItemID) -> do
|
||||
let recipByID = LocalActorProject projectID
|
||||
lift $ for_ exts $
|
||||
\ (extID, (actionExt, localRecipsExt, remoteRecipsExt, fwdHostsExt)) ->
|
||||
sendActivity
|
||||
recipByID recipActorID localRecipsExt
|
||||
remoteRecipsExt fwdHostsExt extID actionExt
|
||||
doneDB inboxItemID "[Team] Sent start-Grant and extensions from components and children"
|
||||
|
||||
where
|
||||
|
||||
prepareExtensionGrant component uStart role enableID startID = do
|
||||
encodeRouteHome <- getEncodeRouteHome
|
||||
encodeRouteLocal <- getEncodeRouteLocal
|
||||
|
||||
projectHash <- encodeKeyHashid projectID
|
||||
|
||||
uDeleg <- lift $ getActivityURI authorIdMsig
|
||||
uComponent <-
|
||||
case component of
|
||||
Left c -> do
|
||||
a <- resourceToActor . componentResource <$> hashComponent c
|
||||
return $ encodeRouteHome $ renderLocalActor a
|
||||
Right u -> pure u
|
||||
|
||||
enableHash <- encodeKeyHashid enableID
|
||||
|
||||
audTeam <- lift $ makeAudSenderOnly authorIdMsig
|
||||
uTeam <- lift $ getActorURI authorIdMsig
|
||||
|
||||
resultR <- do
|
||||
startHash <- encodeKeyHashid startID
|
||||
return $ ProjectTeamLiveR projectHash startHash
|
||||
|
||||
let (recipientSet, remoteActors, fwdHosts, audLocal, audRemote) =
|
||||
collectAudience [audTeam]
|
||||
|
||||
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 = uTeam
|
||||
, 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)
|
||||
|
||||
prepareStartGrant role startID = do
|
||||
encodeRouteHome <- getEncodeRouteHome
|
||||
encodeRouteLocal <- getEncodeRouteLocal
|
||||
|
||||
projectHash <- encodeKeyHashid projectID
|
||||
|
||||
uDeleg <- lift $ getActivityURI authorIdMsig
|
||||
|
||||
audTeam <- lift $ makeAudSenderOnly authorIdMsig
|
||||
uTeam <- lift $ getActorURI authorIdMsig
|
||||
|
||||
resultR <- do
|
||||
startHash <- encodeKeyHashid startID
|
||||
return $ ProjectTeamLiveR projectHash startHash
|
||||
|
||||
let (recipientSet, remoteActors, fwdHosts, audLocal, audRemote) =
|
||||
collectAudience [audTeam]
|
||||
|
||||
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 $ ProjectR projectHash
|
||||
, AP.grantTarget = uTeam
|
||||
, 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)
|
||||
|
||||
prepareExtensionGrantFromChild uStart grant role startID = do
|
||||
encodeRouteHome <- getEncodeRouteHome
|
||||
encodeRouteLocal <- getEncodeRouteLocal
|
||||
|
||||
projectHash <- encodeKeyHashid projectID
|
||||
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
|
||||
audTeam <- lift $ makeAudSenderOnly authorIdMsig
|
||||
uTeam <- lift $ getActorURI authorIdMsig
|
||||
|
||||
resultR <- do
|
||||
startHash <- encodeKeyHashid startID
|
||||
return $ ProjectTeamLiveR projectHash startHash
|
||||
|
||||
let (recipientSet, remoteActors, fwdHosts, audLocal, audRemote) =
|
||||
collectAudience [audTeam]
|
||||
|
||||
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 = uTeam
|
||||
, 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
|
||||
-- Behavior:
|
||||
-- * Verify the resource is my collabs or components list
|
||||
|
|
|
|||
Loading…
Reference in a new issue