S2S: Project: Accept: Implement team mode
This commit is contained in:
Pere Lev
parent
3c8b8dbc48
commit
68141fa7da
1 changed files with 229 additions and 4 deletions
|
|
@ -223,6 +223,37 @@ import Vervis.Web.Collab
|
|||
-- delegation Grant I got from B
|
||||
-- * To: The parent/collaborator/team to whom I'd sent the Grant
|
||||
-- * CC: -
|
||||
--
|
||||
-- * Add-a-Team mode
|
||||
-- * Give me a new team active SquadOriginUs
|
||||
-- * Respond with error, we aren't supposed to get any Accept
|
||||
-- * Give me a new team passive SquadOriginThem
|
||||
-- * Option 1: I haven't yet seen parent's Accept
|
||||
-- * Verify sender is the parent
|
||||
-- * Option 2: I saw it, but not my collaborator's Accept
|
||||
-- * Verify the accept is authorized
|
||||
-- * Otherwise respond with error, no Accept is needed
|
||||
--
|
||||
-- * Insert the Accept to my inbox
|
||||
--
|
||||
-- * In team-passive mode,
|
||||
-- * Option 1: Record team's Accept in the Dest record
|
||||
-- * Option 2: Record my collaborator's Accept in the Squad record
|
||||
-- * Prepare to send my own Accept
|
||||
--
|
||||
-- * Forward the Accept to my followers
|
||||
--
|
||||
-- * Possibly send a Grant/Accept:
|
||||
-- * Team-passive
|
||||
-- * In option 2
|
||||
-- * Accept
|
||||
-- * Object: The Add
|
||||
-- * Fulfills: My collaborator's Accept
|
||||
-- * To: Team
|
||||
-- * CC:
|
||||
-- - Team's followers
|
||||
-- - My followers
|
||||
-- - The Accept sender (my collaborator)
|
||||
projectAccept
|
||||
:: UTCTime
|
||||
-> ProjectId
|
||||
|
|
@ -236,10 +267,10 @@ projectAccept now projectID (Verse authorIdMsig body) accept = do
|
|||
|
||||
collabOrComp_or_child <- withDBExcept $ do
|
||||
|
||||
myInboxID <- lift $ do
|
||||
(myInboxID, meResourceID) <- lift $ do
|
||||
project <- getJust projectID
|
||||
actor <- getJust $ projectActor project
|
||||
return $ actorInbox actor
|
||||
return (actorInbox actor, projectResource project)
|
||||
|
||||
-- Find the accepted activity in our DB
|
||||
accepteeDB <- do
|
||||
|
|
@ -261,7 +292,9 @@ projectAccept now projectID (Verse authorIdMsig body) accept = do
|
|||
runExceptT (Right . Left <$> tryAddChildPassive accepteeDB) <|>
|
||||
runExceptT (Right . Left <$> tryAddParentActive accepteeDB) <|>
|
||||
runExceptT (Right . Left <$> tryAddParentPassive accepteeDB) <|>
|
||||
runExceptT (Right . Right <$> tryRemoveChild myInboxID accepteeDB)
|
||||
runExceptT (Right . Right . Left <$> tryRemoveChild myInboxID accepteeDB) <|>
|
||||
runExceptT (Right . Right . Right <$> tryAddTeamActive meResourceID accepteeDB) <|>
|
||||
runExceptT (Right . Right . Right <$> tryAddTeamPassive meResourceID accepteeDB)
|
||||
fromMaybeE
|
||||
maybeCollab
|
||||
"Accepted activity isn't an Invite/Join/Add/Remove I'm aware of"
|
||||
|
|
@ -270,7 +303,8 @@ projectAccept now projectID (Verse authorIdMsig body) accept = do
|
|||
Left (Left collab) -> addCollab collab
|
||||
Left (Right comp) -> addComp comp
|
||||
Right (Left cp) -> addChildParent cp
|
||||
Right (Right child) -> removeChild child
|
||||
Right (Right (Left child)) -> removeChild child
|
||||
Right (Right (Right team)) -> addTeam team
|
||||
|
||||
where
|
||||
|
||||
|
|
@ -497,6 +531,41 @@ projectAccept now projectID (Verse authorIdMsig body) accept = do
|
|||
lift $ MaybeT $ getValBy $ UniqueInboxItemRemote inboxID remoteActivityID
|
||||
tryRemoveChild' i
|
||||
|
||||
verifySquadHolder :: ResourceId -> SquadId -> MaybeT ActDB ()
|
||||
verifySquadHolder meResourceID squadID = do
|
||||
Squad _ r <- lift $ getJust squadID
|
||||
guard $ r == meResourceID
|
||||
|
||||
tryAddTeamActive' r squadID = do
|
||||
usID <- lift $ MaybeT $ getKeyBy $ UniqueSquadOriginUs squadID
|
||||
lift $ verifySquadHolder r squadID
|
||||
topic <- lift . lift $ getSquadTeam squadID
|
||||
return (squadID, topic, Left ())
|
||||
|
||||
tryAddTeamActive r (Left (_actorByKey, _actorEntity, itemID)) = do
|
||||
SquadUsGestureLocal squadID _ <-
|
||||
lift $ MaybeT $ getValBy $ UniqueSquadUsGestureLocalActivity itemID
|
||||
tryAddTeamActive' r squadID
|
||||
tryAddTeamActive r (Right remoteActivityID) = do
|
||||
SquadUsGestureRemote squadID _ _ <-
|
||||
lift $ MaybeT $ getValBy $ UniqueSquadUsGestureRemoteActivity remoteActivityID
|
||||
tryAddTeamActive' r squadID
|
||||
|
||||
tryAddTeamPassive' r themID = do
|
||||
SquadOriginThem squadID <- lift . lift $ getJust themID
|
||||
lift $ verifySquadHolder r squadID
|
||||
topic <- lift . lift $ getSquadTeam squadID
|
||||
return (squadID, topic, Right themID)
|
||||
|
||||
tryAddTeamPassive r (Left (_actorByKey, _actorEntity, itemID)) = do
|
||||
SquadThemGestureLocal themID _ <-
|
||||
lift $ MaybeT $ getValBy $ UniqueSquadThemGestureLocalAdd itemID
|
||||
tryAddTeamPassive' r themID
|
||||
tryAddTeamPassive r (Right remoteActivityID) = do
|
||||
SquadThemGestureRemote themID _ _ <-
|
||||
lift $ MaybeT $ getValBy $ UniqueSquadThemGestureRemoteAdd remoteActivityID
|
||||
tryAddTeamPassive' r themID
|
||||
|
||||
componentIsAuthor ident =
|
||||
let author = bimap (view _1) (remoteAuthorId . view _1) authorIdMsig
|
||||
in author == bimap (resourceToActor . componentResource . snd) snd ident
|
||||
|
|
@ -506,6 +575,11 @@ projectAccept now projectID (Verse authorIdMsig body) accept = do
|
|||
let author = bimap (view _1) (remoteAuthorId . view _1) authorIdMsig
|
||||
in author == bimap (LocalActorProject . snd) snd ident
|
||||
|
||||
theyIsAuthor' :: Either (a, GroupId) (b, RemoteActorId) -> Bool
|
||||
theyIsAuthor' ident =
|
||||
let author = bimap (view _1) (remoteAuthorId . view _1) authorIdMsig
|
||||
in author == bimap (LocalActorGroup . snd) snd ident
|
||||
|
||||
addCollab (collabID, fulfills, inviterOrJoiner) = do
|
||||
|
||||
collab <-
|
||||
|
|
@ -1428,6 +1502,157 @@ projectAccept now projectID (Verse authorIdMsig body) accept = do
|
|||
|
||||
return (action, recipientSet, remoteActors, fwdHosts)
|
||||
|
||||
addTeam (squadID, topic, mode) = do
|
||||
|
||||
(themID, mode') <-
|
||||
case mode of
|
||||
|
||||
-- Team-active mode
|
||||
-- Respond with error, we aren't supposed to get any Accept
|
||||
Left () -> throwE "Team-active (SquadOriginUs) mode, I'm not expecting any Accept"
|
||||
|
||||
-- Team-passive mode
|
||||
-- Option 1: I haven't yet seen team's Accept
|
||||
-- * Verify sender is the team
|
||||
-- Option 2: I saw it, but not my collaborator's Accept
|
||||
-- * Verify the accept is authorized
|
||||
-- Otherwise respond with error, no Accept is needed
|
||||
Right themID -> (themID,) <$> do
|
||||
(maybeTeamAccept, maybeUsGesture) <-
|
||||
lift $ withDB $ liftA2 (,)
|
||||
(case bimap fst fst topic of
|
||||
Left localID -> (() <$) <$> getBy (UniqueSquadThemAcceptLocalTopic localID)
|
||||
Right remoteID -> (() <$) <$> getBy (UniqueSquadThemAcceptRemoteTopic remoteID)
|
||||
)
|
||||
(do l <- getBy $ UniqueSquadUsGestureLocal squadID
|
||||
r <- getBy $ UniqueSquadUsGestureRemote squadID
|
||||
case (isJust l, isJust r) of
|
||||
(False, False) -> pure Nothing
|
||||
(False, True) -> pure $ Just ()
|
||||
(True, False) -> pure $ Just ()
|
||||
(True, True) -> error "Both SquadUsGestureLocal and SquadUsGestureRemote"
|
||||
)
|
||||
case (isJust maybeTeamAccept, isJust maybeUsGesture) of
|
||||
(False, True) -> error "Impossible/bug, didn't see team's Accept but recorded my collaborator's Accept"
|
||||
(False, False) -> do
|
||||
unless (theyIsAuthor' topic) $
|
||||
throwE "The Accept I'm waiting for is from my new team"
|
||||
return $ Left ()
|
||||
(True, False) -> do
|
||||
let muCap = AP.activityCapability $ actbActivity body
|
||||
uCap <- fromMaybeE muCap "No capability provided"
|
||||
verifyCapability''
|
||||
uCap
|
||||
authorIdMsig
|
||||
(LocalResourceProject projectID)
|
||||
AP.RoleAdmin
|
||||
return $ Right ()
|
||||
(True, True) -> throwE "Just waiting for Grant from team, or already have it, anyway not needing any further Accept"
|
||||
|
||||
maybeNew <- withDBExcept $ do
|
||||
|
||||
-- Grab me from DB
|
||||
(recipActorID, recipActor) <- lift $ do
|
||||
recip <- getJust projectID
|
||||
let actorID = projectActor recip
|
||||
(actorID,) <$> getJust actorID
|
||||
|
||||
maybeAcceptDB <- lift $ insertToInbox now authorIdMsig body (actorInbox recipActor) False
|
||||
for maybeAcceptDB $ \ (inboxItemID, acceptDB) -> do
|
||||
|
||||
idsForGrant <-
|
||||
lift $ case mode' of
|
||||
|
||||
-- Getting an Accept from the team
|
||||
-- Record team's Accept in the Squad record
|
||||
Left () -> do
|
||||
case (topic, acceptDB) of
|
||||
(Left (localID, _), Left (_, _, acceptID)) ->
|
||||
insert_ $ SquadThemAcceptLocal themID localID acceptID
|
||||
(Right (remoteID, _), Right (_, _, acceptID)) ->
|
||||
insert_ $ SquadThemAcceptRemote themID remoteID acceptID
|
||||
_ -> error "projectAccept impossible v"
|
||||
return Nothing
|
||||
|
||||
-- Getting an Accept from my collaborator
|
||||
-- Record my collaborator's Accept in the Squad record
|
||||
-- Prepare to send my own Accept
|
||||
Right () -> Just <$> do
|
||||
case acceptDB of
|
||||
Left (_, _, acceptID) ->
|
||||
insert_ $ SquadUsGestureLocal squadID acceptID
|
||||
Right (author, _, acceptID) ->
|
||||
insert_ $ SquadUsGestureRemote squadID (remoteAuthorId author) acceptID
|
||||
acceptID <- insertEmptyOutboxItem' (actorOutbox recipActor) now
|
||||
insert_ $ SquadUsAccept squadID acceptID
|
||||
return acceptID
|
||||
|
||||
-- Prepare forwarding of Accept to my followers
|
||||
let recipByID = LocalActorProject projectID
|
||||
recipByHash <- hashLocalActor recipByID
|
||||
let sieve = makeRecipientSet [] [localActorFollowers recipByHash]
|
||||
|
||||
maybeAct <-
|
||||
for idsForGrant $ \ acceptID -> lift $ do
|
||||
accept@(actionAccept, _, _, _) <-
|
||||
prepareSquadAccept (bimap snd snd topic)
|
||||
let recipByKey = LocalActorProject projectID
|
||||
_luAccept <- updateOutboxItem' recipByKey acceptID actionAccept
|
||||
return (acceptID, accept)
|
||||
|
||||
return (recipActorID, sieve, maybeAct, inboxItemID)
|
||||
|
||||
case maybeNew of
|
||||
Nothing -> done "I already have this activity in my inbox"
|
||||
Just (recipActorID, sieve, maybeGrant, inboxItemID) -> do
|
||||
let recipByID = LocalActorProject projectID
|
||||
forwardActivity authorIdMsig body recipByID recipActorID sieve
|
||||
lift $ for_ maybeGrant $ \ (grantID, (actionGrant, localRecipsGrant, remoteRecipsGrant, fwdHostsGrant)) ->
|
||||
sendActivity
|
||||
recipByID recipActorID localRecipsGrant
|
||||
remoteRecipsGrant fwdHostsGrant grantID actionGrant
|
||||
doneDB inboxItemID "[Team] Forwarded the Accept and maybe published a Grant/Accept"
|
||||
|
||||
where
|
||||
|
||||
prepareSquadAccept topic = do
|
||||
encodeRouteHome <- getEncodeRouteHome
|
||||
|
||||
audMyCollab <- lift $ makeAudSenderOnly authorIdMsig
|
||||
audSquad <-
|
||||
case topic of
|
||||
Left j -> do
|
||||
h <- encodeKeyHashid j
|
||||
return $
|
||||
AudLocal [LocalActorGroup h] [LocalStageGroupFollowers h]
|
||||
Right raID -> do
|
||||
ra <- getJust raID
|
||||
ObjURI h lu <- getRemoteActorURI ra
|
||||
return $
|
||||
AudRemote h [lu] (maybeToList $ remoteActorFollowers ra)
|
||||
audMe <-
|
||||
AudLocal [] . pure . LocalStageProjectFollowers <$>
|
||||
encodeKeyHashid projectID
|
||||
uCollabAccept <- lift $ getActivityURI authorIdMsig
|
||||
let uAdd = AP.acceptObject accept
|
||||
|
||||
(recipientSet, remoteActors, fwdHosts, audLocal, audRemote) =
|
||||
collectAudience [audMyCollab, audSquad, audMe]
|
||||
|
||||
recips = map encodeRouteHome audLocal ++ audRemote
|
||||
action = AP.Action
|
||||
{ AP.actionCapability = Nothing
|
||||
, AP.actionSummary = Nothing
|
||||
, AP.actionAudience = AP.Audience recips [] [] [] [] []
|
||||
, AP.actionFulfills = [uCollabAccept]
|
||||
, AP.actionSpecific = AP.AcceptActivity AP.Accept
|
||||
{ AP.acceptObject = uAdd
|
||||
, AP.acceptResult = Nothing
|
||||
}
|
||||
}
|
||||
|
||||
return (action, recipientSet, remoteActors, fwdHosts)
|
||||
|
||||
checkExistingComponents
|
||||
:: ProjectId -> Either (ComponentBy Entity) RemoteActorId -> ActDBE ()
|
||||
checkExistingComponents projectID componentDB = do
|
||||
|
|
|
|||
Loading…
Reference in a new issue