S2S: Project: Add: Implement team mode
This commit is contained in:
parent
5d88036fc3
commit
3c8b8dbc48
6 changed files with 342 additions and 10 deletions
|
@ -652,7 +652,7 @@ personInvite now recipPersonID (Verse authorIdMsig body) invite = do
|
||||||
manager <- asksEnv envHttpManager
|
manager <- asksEnv envHttpManager
|
||||||
coll <- ExceptT $ liftIO $ first T.pack <$> AP.fetchAPID manager AP.collectionId h luColl
|
coll <- ExceptT $ liftIO $ first T.pack <$> AP.fetchAPID manager AP.collectionId h luColl
|
||||||
lu <- fromMaybeE (AP.collectionContext (coll :: AP.Collection FedURI URIMode)) "Remote topic collabs has no 'context'"
|
lu <- fromMaybeE (AP.collectionContext (coll :: AP.Collection FedURI URIMode)) "Remote topic collabs has no 'context'"
|
||||||
AP.ResourceWithCollections _ mluCollabs _mluComps mluMembers _ _ _ _ <- ExceptT $ liftIO $ first (T.pack . show) <$> AP.fetchRWC manager h lu
|
AP.ResourceWithCollections _ mluCollabs _mluComps mluMembers _ _ _ _ _ <- ExceptT $ liftIO $ first (T.pack . show) <$> AP.fetchRWC manager h lu
|
||||||
if mluCollabs == Just luColl || mluMembers == Just luColl
|
if mluCollabs == Just luColl || mluMembers == Just luColl
|
||||||
then Just . (role,) . Right <$> do
|
then Just . (role,) . Right <$> do
|
||||||
instanceID <-
|
instanceID <-
|
||||||
|
|
|
@ -266,7 +266,7 @@ clientAdd now personMeID (ClientMsg maybeCap localRecips remoteRecips fwdHosts a
|
||||||
manager <- asksEnv envHttpManager
|
manager <- asksEnv envHttpManager
|
||||||
coll <- ExceptT $ liftIO $ first T.pack <$> AP.fetchAPID manager AP.collectionId h luComps
|
coll <- ExceptT $ liftIO $ first T.pack <$> AP.fetchAPID manager AP.collectionId h luComps
|
||||||
lu <- fromMaybeE (AP.collectionContext (coll :: AP.Collection FedURI URIMode)) "Remote topic collabs has no 'context'"
|
lu <- fromMaybeE (AP.collectionContext (coll :: AP.Collection FedURI URIMode)) "Remote topic collabs has no 'context'"
|
||||||
AP.ResourceWithCollections _ _ _ _ _ _ _ _ <- ExceptT $ liftIO $ first (T.pack . show) <$> AP.fetchRWC manager h lu
|
AP.ResourceWithCollections _ _ _ _ _ _ _ _ _ <- ExceptT $ liftIO $ first (T.pack . show) <$> AP.fetchRWC manager h lu
|
||||||
|
|
||||||
instanceID <-
|
instanceID <-
|
||||||
lift $ withDB $ either entityKey id <$> insertBy' (Instance h)
|
lift $ withDB $ either entityKey id <$> insertBy' (Instance h)
|
||||||
|
@ -895,7 +895,7 @@ clientInvite now personMeID (ClientMsg maybeCap localRecips remoteRecips fwdHost
|
||||||
manager <- asksEnv envHttpManager
|
manager <- asksEnv envHttpManager
|
||||||
coll <- ExceptT $ liftIO $ first T.pack <$> AP.fetchAPID manager AP.collectionId h luColl
|
coll <- ExceptT $ liftIO $ first T.pack <$> AP.fetchAPID manager AP.collectionId h luColl
|
||||||
lu <- fromMaybeE (AP.collectionContext (coll :: AP.Collection FedURI URIMode)) "Remote topic collabs has no 'context'"
|
lu <- fromMaybeE (AP.collectionContext (coll :: AP.Collection FedURI URIMode)) "Remote topic collabs has no 'context'"
|
||||||
AP.ResourceWithCollections _ mluCollabs mluComps mluMembers _ _ _ _ <- ExceptT $ liftIO $ first (T.pack . show) <$> AP.fetchRWC manager h lu
|
AP.ResourceWithCollections _ mluCollabs mluComps mluMembers _ _ _ _ _ <- ExceptT $ liftIO $ first (T.pack . show) <$> AP.fetchRWC manager h lu
|
||||||
unless (mluCollabs == Just luColl || mluComps == Just luColl || mluMembers == Just luColl) $
|
unless (mluCollabs == Just luColl || mluComps == Just luColl || mluMembers == Just luColl) $
|
||||||
throwE "Invite target isn't a collabs/components list"
|
throwE "Invite target isn't a collabs/components list"
|
||||||
|
|
||||||
|
@ -1044,7 +1044,7 @@ clientJoin now personMeID (ClientMsg maybeCap localRecips remoteRecips fwdHosts
|
||||||
manager <- asksEnv envHttpManager
|
manager <- asksEnv envHttpManager
|
||||||
coll <- ExceptT $ liftIO $ first T.pack <$> AP.fetchAPID manager AP.collectionId h luColl
|
coll <- ExceptT $ liftIO $ first T.pack <$> AP.fetchAPID manager AP.collectionId h luColl
|
||||||
lu <- fromMaybeE (AP.collectionContext (coll :: AP.Collection FedURI URIMode)) "Remote topic collabs has no 'context'"
|
lu <- fromMaybeE (AP.collectionContext (coll :: AP.Collection FedURI URIMode)) "Remote topic collabs has no 'context'"
|
||||||
AP.ResourceWithCollections _ mluCollabs mluComps mluMembers _ _ _ _ <- ExceptT $ liftIO $ first (T.pack . show) <$> AP.fetchRWC manager h lu
|
AP.ResourceWithCollections _ mluCollabs mluComps mluMembers _ _ _ _ _ <- ExceptT $ liftIO $ first (T.pack . show) <$> AP.fetchRWC manager h lu
|
||||||
let isCollabs = mluCollabs == Just luColl || mluMembers == Just luColl
|
let isCollabs = mluCollabs == Just luColl || mluMembers == Just luColl
|
||||||
unless (isCollabs || mluComps == Just luColl) $
|
unless (isCollabs || mluComps == Just luColl) $
|
||||||
throwE "Join resource isn't a collabs/components list"
|
throwE "Join resource isn't a collabs/components list"
|
||||||
|
@ -1249,7 +1249,7 @@ clientRemove now personMeID (ClientMsg maybeCap localRecips remoteRecips fwdHost
|
||||||
manager <- asksEnv envHttpManager
|
manager <- asksEnv envHttpManager
|
||||||
coll <- ExceptT $ liftIO $ first T.pack <$> AP.fetchAPID manager AP.collectionId h luColl
|
coll <- ExceptT $ liftIO $ first T.pack <$> AP.fetchAPID manager AP.collectionId h luColl
|
||||||
lu <- fromMaybeE (AP.collectionContext (coll :: AP.Collection FedURI URIMode)) "Remote topic collabs has no 'context'"
|
lu <- fromMaybeE (AP.collectionContext (coll :: AP.Collection FedURI URIMode)) "Remote topic collabs has no 'context'"
|
||||||
AP.ResourceWithCollections _ _ _ _ _ _ _ _ <- ExceptT $ liftIO $ first (T.pack . show) <$> AP.fetchRWC manager h lu
|
AP.ResourceWithCollections _ _ _ _ _ _ _ _ _ <- ExceptT $ liftIO $ first (T.pack . show) <$> AP.fetchRWC manager h lu
|
||||||
return $ ObjURI h lu
|
return $ ObjURI h lu
|
||||||
)
|
)
|
||||||
resource
|
resource
|
||||||
|
|
|
@ -1546,6 +1546,23 @@ checkExistingComponents projectID componentDB = do
|
||||||
-- * My followers
|
-- * My followers
|
||||||
-- * Record my Accept in the Dest record
|
-- * Record my Accept in the Dest record
|
||||||
--
|
--
|
||||||
|
-- * 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 I'm the object, being added to someone's parents/children list:
|
-- * If I'm the object, being added to someone's parents/children list:
|
||||||
-- * Verify the target is a project, find in DB/HTTP
|
-- * Verify the target is a project, find in DB/HTTP
|
||||||
-- * Verify it's not already an active parent of mine
|
-- * Verify it's not already an active parent of mine
|
||||||
|
@ -1558,6 +1575,17 @@ checkExistingComponents projectID componentDB = do
|
||||||
-- * Create a Source/Dest record in DB
|
-- * Create a Source/Dest record in DB
|
||||||
-- * Forward the Add to my followers
|
-- * 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
|
||||||
|
--
|
||||||
-- * If I'm the object, being added to someone's projects list:
|
-- * If I'm the object, being added to someone's projects list:
|
||||||
-- * Verify the object is a component, find in DB/HTTP
|
-- * Verify the object is a component, find in DB/HTTP
|
||||||
-- * Verify it's not already an active component of mine
|
-- * Verify it's not already an active component of mine
|
||||||
|
@ -1594,6 +1622,8 @@ projectAdd now projectID (Verse authorIdMsig body) add = do
|
||||||
addChildActive object
|
addChildActive object
|
||||||
(Left (ATProjectParents j), _) | j == projectID ->
|
(Left (ATProjectParents j), _) | j == projectID ->
|
||||||
addParentActive object
|
addParentActive object
|
||||||
|
(Left (ATProjectTeams j), _) | j == projectID ->
|
||||||
|
addTeamActive object
|
||||||
(_, Left (LocalActorProject j)) | j == projectID ->
|
(_, Left (LocalActorProject j)) | j == projectID ->
|
||||||
case target of
|
case target of
|
||||||
Left (ATProjectParents j) | j /= projectID ->
|
Left (ATProjectParents j) | j /= projectID ->
|
||||||
|
@ -1606,6 +1636,8 @@ projectAdd now projectID (Verse authorIdMsig body) add = do
|
||||||
addComponentPassive $ Left $ ComponentDeck d
|
addComponentPassive $ Left $ ComponentDeck d
|
||||||
Left (ATLoomProjects l) ->
|
Left (ATLoomProjects l) ->
|
||||||
addComponentPassive $ Left $ ComponentLoom l
|
addComponentPassive $ Left $ ComponentLoom l
|
||||||
|
Left (ATGroupEfforts g) ->
|
||||||
|
addTeamPassive $ Left g
|
||||||
Right (ObjURI h luColl) -> do
|
Right (ObjURI h luColl) -> do
|
||||||
-- NOTE this is HTTP GET done synchronously in the activity
|
-- NOTE this is HTTP GET done synchronously in the activity
|
||||||
-- handler
|
-- handler
|
||||||
|
@ -1624,6 +1656,8 @@ projectAdd now projectID (Verse authorIdMsig body) add = do
|
||||||
then addParentPassive $ Right $ ObjURI h lu
|
then addParentPassive $ Right $ ObjURI h lu
|
||||||
else if typ == AP.ActorTypeProject && Just luColl == AP.rwcParentsOrProjects rwc
|
else if typ == AP.ActorTypeProject && Just luColl == AP.rwcParentsOrProjects rwc
|
||||||
then addChildPassive $ Right $ ObjURI h lu
|
then addChildPassive $ Right $ ObjURI h lu
|
||||||
|
else if typ == AP.ActorTypeTeam && Just luColl == AP.rwcTeamResources rwc
|
||||||
|
then addTeamPassive $ Right $ ObjURI h lu
|
||||||
else throwE "Weird collection situation"
|
else throwE "Weird collection situation"
|
||||||
_ -> throwE "I'm being added somewhere irrelevant"
|
_ -> throwE "I'm being added somewhere irrelevant"
|
||||||
_ -> throwE "This Add isn't for me"
|
_ -> throwE "This Add isn't for me"
|
||||||
|
@ -2047,7 +2081,7 @@ projectAdd now projectID (Verse authorIdMsig body) add = do
|
||||||
uCap
|
uCap
|
||||||
authorIdMsig
|
authorIdMsig
|
||||||
(LocalResourceProject projectID)
|
(LocalResourceProject projectID)
|
||||||
AP.RoleTriage
|
AP.RoleAdmin
|
||||||
|
|
||||||
maybeNew <- withDBExcept $ do
|
maybeNew <- withDBExcept $ do
|
||||||
|
|
||||||
|
@ -2112,6 +2146,142 @@ projectAdd now projectID (Verse authorIdMsig body) add = do
|
||||||
|
|
||||||
insert_ $ DestUsAccept destID acceptID
|
insert_ $ DestUsAccept destID acceptID
|
||||||
|
|
||||||
|
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
|
||||||
|
(LocalResourceProject projectID)
|
||||||
|
AP.RoleAdmin
|
||||||
|
|
||||||
|
maybeNew <- withDBExcept $ do
|
||||||
|
|
||||||
|
-- Grab me from DB
|
||||||
|
(project, actorRecip) <- lift $ do
|
||||||
|
p <- getJust projectID
|
||||||
|
(p,) <$> getJust (projectActor p)
|
||||||
|
|
||||||
|
-- Verify the object isn't already a team of mine, and that no
|
||||||
|
-- Squad record is already in Add-Accept state
|
||||||
|
verifyNoStartedResourceTeams (projectResource project) teamDB'
|
||||||
|
|
||||||
|
-- Insert the Add to my inbox
|
||||||
|
mractid <- lift $ insertToInbox now authorIdMsig body (actorInbox actorRecip) False
|
||||||
|
lift $ for mractid $ \ (inboxItemID, addDB) -> do
|
||||||
|
|
||||||
|
-- Create a Squad record in DB
|
||||||
|
acceptID <- insertEmptyOutboxItem' (actorOutbox actorRecip) now
|
||||||
|
insertSquad (projectResource project) teamDB' addDB acceptID
|
||||||
|
|
||||||
|
-- Prepare forwarding the Add to my followers
|
||||||
|
sieve <- do
|
||||||
|
projectHash <- encodeKeyHashid projectID
|
||||||
|
return $ makeRecipientSet [] [LocalStageProjectFollowers projectHash]
|
||||||
|
|
||||||
|
-- Prepare an Accept activity and insert to my outbox
|
||||||
|
accept@(actionAccept, _, _, _) <- prepareAccept teamDB
|
||||||
|
_luAccept <- updateOutboxItem' (LocalActorProject projectID) acceptID actionAccept
|
||||||
|
|
||||||
|
return (projectActor project, sieve, acceptID, accept, inboxItemID)
|
||||||
|
|
||||||
|
case maybeNew of
|
||||||
|
Nothing -> done "I already have this activity in my inbox"
|
||||||
|
Just (projectActorID, sieve, acceptID, (actionAccept, localRecipsAccept, remoteRecipsAccept, fwdHostsAccept), inboxItemID) -> do
|
||||||
|
forwardActivity
|
||||||
|
authorIdMsig body (LocalActorProject projectID) projectActorID sieve
|
||||||
|
lift $ sendActivity
|
||||||
|
(LocalActorProject projectID) projectActorID 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 . LocalStageProjectFollowers <$>
|
||||||
|
encodeKeyHashid projectID
|
||||||
|
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)
|
||||||
|
|
||||||
addChildPassive child = do
|
addChildPassive child = do
|
||||||
|
|
||||||
-- If child is local, find it in our DB
|
-- If child is local, find it in our DB
|
||||||
|
@ -2282,6 +2452,84 @@ projectAdd now projectID (Verse authorIdMsig body) add = do
|
||||||
Right (author, _, addID) ->
|
Right (author, _, addID) ->
|
||||||
insert_ $ DestThemGestureRemote themID (remoteAuthorId author) addID
|
insert_ $ DestThemGestureRemote themID (remoteAuthorId author) addID
|
||||||
|
|
||||||
|
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
|
||||||
|
(project, actorRecip) <- lift $ do
|
||||||
|
p <- getJust projectID
|
||||||
|
(p,) <$> getJust (projectActor p)
|
||||||
|
|
||||||
|
-- Verify the object isn't already a team of mine, and that no
|
||||||
|
-- Squad record is already in Add-Accept state
|
||||||
|
verifyNoStartedResourceTeams (projectResource project) teamDB'
|
||||||
|
|
||||||
|
-- Insert the Add to my inbox
|
||||||
|
mractid <- lift $ insertToInbox now authorIdMsig body (actorInbox actorRecip) False
|
||||||
|
lift $ for mractid $ \ (inboxItemID, addDB) -> do
|
||||||
|
|
||||||
|
-- Create a Squad record in DB
|
||||||
|
insertSquad (projectResource project) teamDB' addDB
|
||||||
|
|
||||||
|
-- Prepare forwarding the Add to my followers
|
||||||
|
sieve <- do
|
||||||
|
projectHash <- encodeKeyHashid projectID
|
||||||
|
return $ makeRecipientSet [] [LocalStageProjectFollowers projectHash]
|
||||||
|
|
||||||
|
return (projectActor project, sieve, inboxItemID)
|
||||||
|
|
||||||
|
case maybeNew of
|
||||||
|
Nothing -> done "I already have this activity in my inbox"
|
||||||
|
Just (projectActorID, sieve, inboxItemID) -> do
|
||||||
|
forwardActivity
|
||||||
|
authorIdMsig body (LocalActorProject projectID) projectActorID 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: Someone has created a project with my ID URI
|
-- Meaning: Someone has created a project with my ID URI
|
||||||
-- Behavior:
|
-- Behavior:
|
||||||
-- * Verify I'm in a just-been-created state
|
-- * Verify I'm in a just-been-created state
|
||||||
|
|
|
@ -1150,7 +1150,7 @@ invite personID uRecipient uResourceCollabs role = do
|
||||||
manager <- asksSite appHttpManager
|
manager <- asksSite appHttpManager
|
||||||
coll <- ExceptT $ liftIO $ first T.pack <$> AP.fetchAPID manager AP.collectionId h luColl
|
coll <- ExceptT $ liftIO $ first T.pack <$> AP.fetchAPID manager AP.collectionId h luColl
|
||||||
lu <- fromMaybeE (AP.collectionContext (coll :: AP.Collection FedURI URIMode)) "Remote topic collabs has no 'context'"
|
lu <- fromMaybeE (AP.collectionContext (coll :: AP.Collection FedURI URIMode)) "Remote topic collabs has no 'context'"
|
||||||
AP.ResourceWithCollections _ mluCollabs _ mluMembers _ _ _ _ <- ExceptT $ liftIO $ first (T.pack . show) <$> AP.fetchRWC manager h lu
|
AP.ResourceWithCollections _ mluCollabs _ mluMembers _ _ _ _ _ <- ExceptT $ liftIO $ first (T.pack . show) <$> AP.fetchRWC manager h lu
|
||||||
unless (mluCollabs == Just luColl || mluMembers == Just luColl) $
|
unless (mluCollabs == Just luColl || mluMembers == Just luColl) $
|
||||||
throwE "Invite target isn't a collabs list"
|
throwE "Invite target isn't a collabs list"
|
||||||
return $ ObjURI h lu
|
return $ ObjURI h lu
|
||||||
|
@ -1241,7 +1241,7 @@ add personID uRecipient uCollection role = do
|
||||||
manager <- asksSite appHttpManager
|
manager <- asksSite appHttpManager
|
||||||
coll <- ExceptT $ liftIO $ first T.pack <$> AP.fetchAPID manager AP.collectionId h luColl
|
coll <- ExceptT $ liftIO $ first T.pack <$> AP.fetchAPID manager AP.collectionId h luColl
|
||||||
lu <- fromMaybeE (AP.collectionContext (coll :: AP.Collection FedURI URIMode)) "Remote collection has no 'context'"
|
lu <- fromMaybeE (AP.collectionContext (coll :: AP.Collection FedURI URIMode)) "Remote collection has no 'context'"
|
||||||
AP.ResourceWithCollections _ _ _ _ _ _ _ _ <- ExceptT $ liftIO $ first (T.pack . show) <$> AP.fetchRWC manager h lu
|
AP.ResourceWithCollections _ _ _ _ _ _ _ _ _ <- ExceptT $ liftIO $ first (T.pack . show) <$> AP.fetchRWC manager h lu
|
||||||
return $ ObjURI h lu
|
return $ ObjURI h lu
|
||||||
)
|
)
|
||||||
target
|
target
|
||||||
|
@ -1327,7 +1327,7 @@ remove personID uRecipient uCollection = do
|
||||||
manager <- asksSite appHttpManager
|
manager <- asksSite appHttpManager
|
||||||
coll <- ExceptT $ liftIO $ first T.pack <$> AP.fetchAPID manager AP.collectionId h luColl
|
coll <- ExceptT $ liftIO $ first T.pack <$> AP.fetchAPID manager AP.collectionId h luColl
|
||||||
lu <- fromMaybeE (AP.collectionContext (coll :: AP.Collection FedURI URIMode)) "Remote topic collabs has no 'context'"
|
lu <- fromMaybeE (AP.collectionContext (coll :: AP.Collection FedURI URIMode)) "Remote topic collabs has no 'context'"
|
||||||
AP.ResourceWithCollections _ _mluCollabs _ _mluMembers _ _ _ _ <- ExceptT $ liftIO $ first (T.pack . show) <$> AP.fetchRWC manager h lu
|
AP.ResourceWithCollections _ _mluCollabs _ _mluMembers _ _ _ _ _ <- ExceptT $ liftIO $ first (T.pack . show) <$> AP.fetchRWC manager h lu
|
||||||
return $ ObjURI h lu
|
return $ ObjURI h lu
|
||||||
)
|
)
|
||||||
resource
|
resource
|
||||||
|
|
|
@ -74,6 +74,7 @@ module Vervis.Persist.Collab
|
||||||
, getEffortTopic
|
, getEffortTopic
|
||||||
|
|
||||||
, verifyNoStartedGroupResources
|
, verifyNoStartedGroupResources
|
||||||
|
, verifyNoStartedResourceTeams
|
||||||
)
|
)
|
||||||
where
|
where
|
||||||
|
|
||||||
|
@ -1960,3 +1961,83 @@ verifyNoStartedGroupResources groupID resource = do
|
||||||
-- Verify none of the Effort records are already in
|
-- Verify none of the Effort records are already in
|
||||||
-- Our-Add+Accept-waiting-for-them or Their-Add+Accept-waiting-for-us state
|
-- Our-Add+Accept-waiting-for-them or Their-Add+Accept-waiting-for-us state
|
||||||
verifyEffortsNotStarted effortIDs
|
verifyEffortsNotStarted effortIDs
|
||||||
|
|
||||||
|
getExistingResourceSquads resourceID (Left (Entity teamID _)) =
|
||||||
|
fmap (map $ bimap E.unValue (Left . E.unValue)) $
|
||||||
|
E.select $ E.from $ \ (squad `E.InnerJoin` topic) -> do
|
||||||
|
E.on $ squad E.^. SquadId E.==. topic E.^. SquadTopicLocalSquad
|
||||||
|
E.where_ $
|
||||||
|
squad E.^. SquadHolder E.==. E.val resourceID E.&&.
|
||||||
|
topic E.^. SquadTopicLocalGroup E.==. E.val teamID
|
||||||
|
return
|
||||||
|
( squad E.^. SquadId
|
||||||
|
, topic E.^. SquadTopicLocalId
|
||||||
|
)
|
||||||
|
getExistingResourceSquads resourceID (Right teamID) =
|
||||||
|
fmap (map $ bimap E.unValue (Right . E.unValue)) $
|
||||||
|
E.select $ E.from $ \ (squad `E.InnerJoin` topic) -> do
|
||||||
|
E.on $ squad E.^. SquadId E.==. topic E.^. SquadTopicRemoteSquad
|
||||||
|
E.where_ $
|
||||||
|
squad E.^. SquadHolder E.==. E.val resourceID E.&&.
|
||||||
|
topic E.^. SquadTopicRemoteTopic E.==. E.val teamID
|
||||||
|
return
|
||||||
|
( squad E.^. SquadId
|
||||||
|
, topic E.^. SquadTopicRemoteId
|
||||||
|
)
|
||||||
|
|
||||||
|
verifySquadsNotEnabled squadIDs = do
|
||||||
|
byEnabled <-
|
||||||
|
lift $ for squadIDs $ \ (_, squad) ->
|
||||||
|
isJust <$> runMaybeT (trySquadEnabled squad)
|
||||||
|
case length $ filter id byEnabled of
|
||||||
|
0 -> return ()
|
||||||
|
1 -> throwE "I already have a SquadThemSendDelegator* for this squad"
|
||||||
|
_ -> error "Multiple SquadThemSendDelegator* for a squad"
|
||||||
|
where
|
||||||
|
trySquadEnabled (Left localID) =
|
||||||
|
const () <$>
|
||||||
|
MaybeT (getBy $ UniqueSquadThemSendDelegatorLocalTopic localID)
|
||||||
|
trySquadEnabled (Right remoteID) =
|
||||||
|
const () <$>
|
||||||
|
MaybeT (getBy $ UniqueSquadThemSendDelegatorRemoteTopic remoteID)
|
||||||
|
|
||||||
|
verifySquadsNotStarted squadIDs = do
|
||||||
|
anyStarted <-
|
||||||
|
lift $ runMaybeT $ asum $
|
||||||
|
map (\ (squadID, topic) ->
|
||||||
|
trySquadUs squadID <|>
|
||||||
|
trySquadThem squadID topic
|
||||||
|
)
|
||||||
|
squadIDs
|
||||||
|
unless (isNothing anyStarted) $
|
||||||
|
throwE "One of the Squad records is already in Add-Accept state"
|
||||||
|
where
|
||||||
|
trySquadUs squadID = do
|
||||||
|
_ <- MaybeT $ getBy $ UniqueSquadOriginUs squadID
|
||||||
|
const () <$> MaybeT (getBy $ UniqueSquadUsAccept squadID)
|
||||||
|
|
||||||
|
trySquadThem squadID topic = do
|
||||||
|
_ <- MaybeT $ getBy $ UniqueSquadOriginThem squadID
|
||||||
|
case topic of
|
||||||
|
Left localID ->
|
||||||
|
const () <$>
|
||||||
|
MaybeT (getBy $ UniqueSquadThemAcceptLocalTopic localID)
|
||||||
|
Right remoteID ->
|
||||||
|
const () <$>
|
||||||
|
MaybeT (getBy $ UniqueSquadThemAcceptRemoteTopic remoteID)
|
||||||
|
|
||||||
|
verifyNoStartedResourceTeams
|
||||||
|
:: ResourceId -> Either (Entity Group) RemoteActorId -> ActDBE ()
|
||||||
|
verifyNoStartedResourceTeams resourceID squadDB = do
|
||||||
|
|
||||||
|
-- Find existing Squad records I have for this squad
|
||||||
|
squadIDs <- lift $ getExistingResourceSquads resourceID squadDB
|
||||||
|
|
||||||
|
-- Grab all the enabled ones, make sure none are enabled, and even if
|
||||||
|
-- any are enabled, make sure there's at most one (otherwise it's a
|
||||||
|
-- bug)
|
||||||
|
verifySquadsNotEnabled squadIDs
|
||||||
|
|
||||||
|
-- Verify none of the Squad records are already in
|
||||||
|
-- Our-Add+Accept-waiting-for-them or Their-Add+Accept-waiting-for-us state
|
||||||
|
verifySquadsNotStarted squadIDs
|
||||||
|
|
|
@ -904,6 +904,7 @@ data ResourceWithCollections u = ResourceWithCollections
|
||||||
, rwcSubprojects :: Maybe LocalURI
|
, rwcSubprojects :: Maybe LocalURI
|
||||||
, rwcSubteams :: Maybe LocalURI
|
, rwcSubteams :: Maybe LocalURI
|
||||||
, rwcTeams :: Maybe LocalURI
|
, rwcTeams :: Maybe LocalURI
|
||||||
|
, rwcTeamResources :: Maybe LocalURI
|
||||||
}
|
}
|
||||||
|
|
||||||
instance ActivityPub ResourceWithCollections where
|
instance ActivityPub ResourceWithCollections where
|
||||||
|
@ -918,7 +919,8 @@ instance ActivityPub ResourceWithCollections where
|
||||||
<*> withAuthorityMaybeO h (o .:? "subprojects")
|
<*> withAuthorityMaybeO h (o .:? "subprojects")
|
||||||
<*> withAuthorityMaybeO h (o .:? "subteams")
|
<*> withAuthorityMaybeO h (o .:? "subteams")
|
||||||
<*> withAuthorityMaybeO h (o .:? "teams")
|
<*> withAuthorityMaybeO h (o .:? "teams")
|
||||||
toSeries h (ResourceWithCollections r collabs comps members ctx subj subt teams)
|
<*> withAuthorityMaybeO h (o .:? "teamResources")
|
||||||
|
toSeries h (ResourceWithCollections r collabs comps members ctx subj subt teams resources)
|
||||||
= toSeries h r
|
= toSeries h r
|
||||||
<> "collaborators" .=? (ObjURI h <$> collabs)
|
<> "collaborators" .=? (ObjURI h <$> collabs)
|
||||||
<> "components" .=? (ObjURI h <$> comps)
|
<> "components" .=? (ObjURI h <$> comps)
|
||||||
|
@ -927,6 +929,7 @@ instance ActivityPub ResourceWithCollections where
|
||||||
<> "subprojects" .=? (ObjURI h <$> subj)
|
<> "subprojects" .=? (ObjURI h <$> subj)
|
||||||
<> "subteams" .=? (ObjURI h <$> subt)
|
<> "subteams" .=? (ObjURI h <$> subt)
|
||||||
<> "teams" .=? (ObjURI h <$> teams)
|
<> "teams" .=? (ObjURI h <$> teams)
|
||||||
|
<> "teamResources" .=? (ObjURI h <$> resources)
|
||||||
|
|
||||||
data Project u = Project
|
data Project u = Project
|
||||||
{ projectActor :: Actor u
|
{ projectActor :: Actor u
|
||||||
|
|
Loading…
Reference in a new issue