S2S: Component: Add: Port team-mode from Project
This commit is contained in:
Pere Lev
parent
7a5147aad9
commit
cdd43292bc
1 changed files with 262 additions and 10 deletions
|
|
@ -2170,8 +2170,24 @@ componentGrant grabResource topicComponent now recipKey (Verse authorIdMsig body
|
|||
-- * Project's followers
|
||||
-- * My followers
|
||||
--
|
||||
-- * If the object is me:
|
||||
-- * Verify the target is some project's components collection URI
|
||||
-- * If the target is my teams list:
|
||||
-- * Verify the object is a team, find in DB/HTTP
|
||||
-- * Verify the Add is authorized
|
||||
-- * Verify it's not already an active team of mine
|
||||
-- * Verify it's not already in an Origin-Us process where I saw the Add
|
||||
-- and sent my Accept
|
||||
-- * Verify it's not already in an Origin-Them process, where I saw the
|
||||
-- Add and the potential team's Accept
|
||||
-- * Insert the Add to my inbox
|
||||
-- * Create a Squad record in DB
|
||||
-- * Forward the Add to my followers
|
||||
-- * Publish an Accept to:
|
||||
-- * The object team + followers
|
||||
-- * Add sender + followers
|
||||
-- * My followers
|
||||
-- * Record my Accept in the Squad record
|
||||
--
|
||||
-- * If the object is me & target is some project's components collection URI
|
||||
-- * For each Stem record I have for this project:
|
||||
-- * Verify it's not enabled yet, i.e. I'm not already a component
|
||||
-- of this project
|
||||
|
|
@ -2182,6 +2198,17 @@ componentGrant grabResource topicComponent now recipKey (Verse authorIdMsig body
|
|||
-- * Create a Stem record in DB
|
||||
-- * Insert the Add to my inbox
|
||||
-- * Forward the Add to my followers
|
||||
--
|
||||
-- * If I'm the object, being added to some teams' resource list:
|
||||
-- * Verify the target is a team, find in DB/HTTP
|
||||
-- * Verify it's not already an active team of mine
|
||||
-- * Verify it's not already in an Origin-Us process where I saw the Add
|
||||
-- and sent my Accept
|
||||
-- * Verify it's not already in an Origin-Them process, where I saw the
|
||||
-- Add and the potential team's Accept
|
||||
-- * Insert the Add to my inbox
|
||||
-- * Create a Squad record in DB
|
||||
-- * Forward the Add to my followers
|
||||
componentAdd
|
||||
:: (PersistRecordBackend topic SqlBackend, ToBackendKey SqlBackend topic)
|
||||
=> (topic -> KomponentId)
|
||||
|
|
@ -2199,7 +2226,7 @@ componentAdd grabKomponent toComponent now meID (Verse authorIdMsig body) add =
|
|||
throwE "Add role isn't admin"
|
||||
case (target, object) of
|
||||
(Left at, _)
|
||||
| addTargetComponentProjects at == Just (toComponent meID) -> do
|
||||
| addTargetComponentProjects at == Just meComponent -> do
|
||||
project <-
|
||||
bitraverse
|
||||
(\case
|
||||
|
|
@ -2209,31 +2236,42 @@ componentAdd grabKomponent toComponent now meID (Verse authorIdMsig body) add =
|
|||
pure
|
||||
object
|
||||
addProjectActive role project
|
||||
| (resourceFromNG <$> addTargetResourceTeams at) == Just meResource ->
|
||||
addTeamActive object
|
||||
(_, Left la)
|
||||
| resourceToActor (componentResource $ toComponent meID) == la -> do
|
||||
case target of
|
||||
Left (ATProjectComponents j) ->
|
||||
addProjectPassive role $ Left j
|
||||
Left (ATGroupEfforts g) ->
|
||||
addTeamPassive $ Left g
|
||||
Right (ObjURI h luColl) -> do
|
||||
-- NOTE this is HTTP GET done synchronously in the activity
|
||||
-- handler
|
||||
manager <- asksEnv envHttpManager
|
||||
c <- AP.fetchAPID_T manager (AP.collectionId :: AP.Collection FedURI URIMode -> LocalURI) h luColl
|
||||
lu <- fromMaybeE (AP.collectionContext c) "No context"
|
||||
j <- AP.fetchAPID_T manager (AP.actorId . AP.actorLocal . AP.projectActor) h lu
|
||||
if luColl == AP.projectComponents j
|
||||
rwc <- AP.fetchRWC_T manager h lu
|
||||
AP.Actor l d <-
|
||||
case AP.rwcResource rwc of
|
||||
AP.ResourceActor a -> pure a
|
||||
AP.ResourceChild _ _ -> throwE "Add.target remote ResourceChild"
|
||||
let typ = AP.actorType d
|
||||
if typ == AP.ActorTypeProject && Just luColl == AP.rwcComponents rwc
|
||||
then addProjectPassive role $ Right $ ObjURI h lu
|
||||
else throwE "Non-components collection"
|
||||
else if typ == AP.ActorTypeTeam && Just luColl == AP.rwcTeamResources rwc
|
||||
then addTeamPassive $ Right $ ObjURI h lu
|
||||
else throwE "Non-components collection"
|
||||
_ -> throwE "I'm being added somewhere irrelevant"
|
||||
_ -> throwE "This Add isn't for me"
|
||||
|
||||
where
|
||||
|
||||
addProjectActive role project = do
|
||||
meComponent = toComponent meID
|
||||
meResource = componentResource meComponent
|
||||
meActor = resourceToActor meResource
|
||||
|
||||
let meComponent = toComponent meID
|
||||
meResource = componentResource meComponent
|
||||
meActor = resourceToActor meResource
|
||||
addProjectActive role project = do
|
||||
|
||||
-- Check capability
|
||||
capability <- do
|
||||
|
|
@ -2484,6 +2522,220 @@ componentAdd grabKomponent toComponent now meID (Verse authorIdMsig body) add =
|
|||
Right (author, _, addID) ->
|
||||
insert_ $ StemProjectGestureRemote originID (remoteAuthorId author) addID
|
||||
|
||||
addTeamActive team = do
|
||||
|
||||
-- If team is local, find it in our DB
|
||||
-- If team is remote, HTTP GET it, verify it's an actor of Project
|
||||
-- type, and store in our DB (if it's already there, no need for HTTP)
|
||||
--
|
||||
-- NOTE: This is a blocking HTTP GET done right here in the handler,
|
||||
-- which is NOT a good idea. Ideally, it would be done async, and the
|
||||
-- handler result would be sent later in a separate (e.g. Accept) activity.
|
||||
-- But for the PoC level, the current situation will hopefully do.
|
||||
teamDB <-
|
||||
bitraverse
|
||||
(\case
|
||||
LocalActorGroup g -> withDBExcept $ getEntityE g "Team not found in DB"
|
||||
_ -> throwE "Local proposed team of non-Group type"
|
||||
)
|
||||
(\ u@(ObjURI h lu) -> do
|
||||
instanceID <-
|
||||
lift $ withDB $ either entityKey id <$> insertBy' (Instance h)
|
||||
result <-
|
||||
ExceptT $ first (T.pack . displayException) <$>
|
||||
fetchRemoteActor' instanceID h lu
|
||||
case result of
|
||||
Left Nothing -> throwE "Team @id mismatch"
|
||||
Left (Just err) -> throwE $ T.pack $ displayException err
|
||||
Right Nothing -> throwE "Team isn't an actor"
|
||||
Right (Just actor) -> do
|
||||
case remoteActorType $ entityVal actor of
|
||||
AP.ActorTypeTeam -> pure ()
|
||||
_ -> throwE "Remote team type isn't Team"
|
||||
return (u, actor)
|
||||
)
|
||||
team
|
||||
let teamDB' = second (entityKey . snd) teamDB
|
||||
|
||||
-- Verify that a capability is provided
|
||||
uCap <- do
|
||||
let muCap = AP.activityCapability $ actbActivity body
|
||||
fromMaybeE muCap "No capability provided"
|
||||
|
||||
-- Verify the sender is authorized by me to add a team
|
||||
verifyCapability''
|
||||
uCap
|
||||
authorIdMsig
|
||||
meResource
|
||||
AP.RoleAdmin
|
||||
|
||||
maybeNew <- withDBExcept $ do
|
||||
|
||||
-- Grab me from DB
|
||||
meKomponentID <- lift $ grabKomponent <$> getJust meID
|
||||
Komponent meResourceID <- lift $ getJust meKomponentID
|
||||
Resource meActorID <- lift $ getJust meResourceID
|
||||
meActorDB <- lift $ getJust meActorID
|
||||
|
||||
-- Verify the object isn't already a team of mine, and that no
|
||||
-- Squad record is already in Add-Accept state
|
||||
verifyNoStartedResourceTeams meResourceID teamDB'
|
||||
|
||||
-- Insert the Add to my inbox
|
||||
mractid <- lift $ insertToInbox now authorIdMsig body (actorInbox meActorDB) False
|
||||
lift $ for mractid $ \ (inboxItemID, addDB) -> do
|
||||
|
||||
-- Create a Squad record in DB
|
||||
acceptID <- insertEmptyOutboxItem' (actorOutbox meActorDB) now
|
||||
insertSquad meResourceID teamDB' addDB acceptID
|
||||
|
||||
-- Prepare forwarding the Add to my followers
|
||||
sieve <- do
|
||||
h <- hashLocalActor meActor
|
||||
return $ makeRecipientSet [] [localActorFollowers h]
|
||||
|
||||
-- Prepare an Accept activity and insert to my outbox
|
||||
accept@(actionAccept, _, _, _) <- prepareAccept teamDB
|
||||
_luAccept <- updateOutboxItem' meActor acceptID actionAccept
|
||||
|
||||
return (meActorID, sieve, acceptID, accept, inboxItemID)
|
||||
|
||||
case maybeNew of
|
||||
Nothing -> done "I already have this activity in my inbox"
|
||||
Just (meActorID, sieve, acceptID, (actionAccept, localRecipsAccept, remoteRecipsAccept, fwdHostsAccept), inboxItemID) -> do
|
||||
forwardActivity authorIdMsig body meActor meActorID sieve
|
||||
lift $ sendActivity
|
||||
meActor meActorID localRecipsAccept
|
||||
remoteRecipsAccept fwdHostsAccept acceptID actionAccept
|
||||
doneDB inboxItemID "[Team-active] Recorded a team-in-progress, forwarded the Add, sent an Accept"
|
||||
|
||||
where
|
||||
|
||||
insertSquad resourceID topicDB addDB acceptID = do
|
||||
squadID <- insert $ Squad AP.RoleAdmin resourceID
|
||||
case topicDB of
|
||||
Left (Entity g _) -> insert_ $ SquadTopicLocal squadID g
|
||||
Right a -> insert_ $ SquadTopicRemote squadID a
|
||||
insert_ $ SquadOriginUs squadID
|
||||
case addDB of
|
||||
Left (_, _, addID) ->
|
||||
insert_ $ SquadUsGestureLocal squadID addID
|
||||
Right (author, _, addID) ->
|
||||
insert_ $ SquadUsGestureRemote squadID (remoteAuthorId author) addID
|
||||
|
||||
insert_ $ SquadUsAccept squadID acceptID
|
||||
|
||||
prepareAccept teamDB = do
|
||||
encodeRouteHome <- getEncodeRouteHome
|
||||
|
||||
audAdder <- makeAudSenderWithFollowers authorIdMsig
|
||||
audTeam <-
|
||||
case teamDB of
|
||||
Left (Entity g _) -> do
|
||||
gh <- encodeKeyHashid g
|
||||
return $ AudLocal [LocalActorGroup gh] [LocalStageGroupFollowers gh]
|
||||
Right (ObjURI h lu, Entity _ ra) ->
|
||||
return $ AudRemote h [lu] (maybeToList $ remoteActorFollowers ra)
|
||||
audMe <-
|
||||
AudLocal [] . pure . localActorFollowers <$>
|
||||
hashLocalActor meActor
|
||||
uAdd <- lift $ getActivityURI authorIdMsig
|
||||
|
||||
let (recipientSet, remoteActors, fwdHosts, audLocal, audRemote) =
|
||||
collectAudience [audAdder, audTeam, audMe]
|
||||
|
||||
recips = map encodeRouteHome audLocal ++ audRemote
|
||||
action = AP.Action
|
||||
{ AP.actionCapability = Nothing
|
||||
, AP.actionSummary = Nothing
|
||||
, AP.actionAudience = AP.Audience recips [] [] [] [] []
|
||||
, AP.actionFulfills = [uAdd]
|
||||
, AP.actionSpecific = AP.AcceptActivity AP.Accept
|
||||
{ AP.acceptObject = uAdd
|
||||
, AP.acceptResult = Nothing
|
||||
}
|
||||
}
|
||||
|
||||
return (action, recipientSet, remoteActors, fwdHosts)
|
||||
|
||||
addTeamPassive team = do
|
||||
|
||||
-- If team is local, find it in our DB
|
||||
-- If team is remote, HTTP GET it, verify it's an actor of Project
|
||||
-- type, and store in our DB (if it's already there, no need for HTTP)
|
||||
--
|
||||
-- NOTE: This is a blocking HTTP GET done right here in the handler,
|
||||
-- which is NOT a good idea. Ideally, it would be done async, and the
|
||||
-- handler result would be sent later in a separate (e.g. Accept) activity.
|
||||
-- But for the PoC level, the current situation will hopefully do.
|
||||
teamDB <-
|
||||
bitraverse
|
||||
(\ g -> withDBExcept $ getEntityE g "Team not found in DB")
|
||||
(\ u@(ObjURI h lu) -> do
|
||||
instanceID <-
|
||||
lift $ withDB $ either entityKey id <$> insertBy' (Instance h)
|
||||
result <-
|
||||
ExceptT $ first (T.pack . displayException) <$>
|
||||
fetchRemoteActor' instanceID h lu
|
||||
case result of
|
||||
Left Nothing -> throwE "Team @id mismatch"
|
||||
Left (Just err) -> throwE $ T.pack $ displayException err
|
||||
Right Nothing -> throwE "Team isn't an actor"
|
||||
Right (Just actor) -> do
|
||||
case remoteActorType $ entityVal actor of
|
||||
AP.ActorTypeTeam -> pure ()
|
||||
_ -> throwE "Remote team type isn't Team"
|
||||
return (u, actor)
|
||||
)
|
||||
team
|
||||
let teamDB' = second (entityKey . snd) teamDB
|
||||
|
||||
maybeNew <- withDBExcept $ do
|
||||
|
||||
-- Grab me from DB
|
||||
meKomponentID <- lift $ grabKomponent <$> getJust meID
|
||||
Komponent meResourceID <- lift $ getJust meKomponentID
|
||||
Resource meActorID <- lift $ getJust meResourceID
|
||||
meActorDB <- lift $ getJust meActorID
|
||||
|
||||
-- Verify the object isn't already a team of mine, and that no
|
||||
-- Squad record is already in Add-Accept state
|
||||
verifyNoStartedResourceTeams meResourceID teamDB'
|
||||
|
||||
-- Insert the Add to my inbox
|
||||
mractid <- lift $ insertToInbox now authorIdMsig body (actorInbox meActorDB) False
|
||||
lift $ for mractid $ \ (inboxItemID, addDB) -> do
|
||||
|
||||
-- Create a Squad record in DB
|
||||
insertSquad meResourceID teamDB' addDB
|
||||
|
||||
-- Prepare forwarding the Add to my followers
|
||||
sieve <- do
|
||||
h <- hashLocalActor meActor
|
||||
return $ makeRecipientSet [] [localActorFollowers h]
|
||||
|
||||
return (meActorID, sieve, inboxItemID)
|
||||
|
||||
case maybeNew of
|
||||
Nothing -> done "I already have this activity in my inbox"
|
||||
Just (meActorID, sieve, inboxItemID) -> do
|
||||
forwardActivity authorIdMsig body meActor meActorID sieve
|
||||
doneDB inboxItemID "[Team-passive] Recorded a team-in-progress, forwarded the Add"
|
||||
|
||||
where
|
||||
|
||||
insertSquad resourceID topicDB addDB = do
|
||||
squadID <- insert $ Squad AP.RoleAdmin resourceID
|
||||
case topicDB of
|
||||
Left (Entity g _) -> insert_ $ SquadTopicLocal squadID g
|
||||
Right a -> insert_ $ SquadTopicRemote squadID a
|
||||
themID <- insert $ SquadOriginThem squadID
|
||||
case addDB of
|
||||
Left (_, _, addID) ->
|
||||
insert_ $ SquadThemGestureLocal themID addID
|
||||
Right (author, _, addID) ->
|
||||
insert_ $ SquadThemGestureRemote themID (remoteAuthorId author) addID
|
||||
|
||||
-- Meaning: An actor is revoking Grant activities
|
||||
-- Behavior:
|
||||
-- * For each revoked activity:
|
||||
|
|
|
|||
Loading…
Reference in a new issue