forge/Vervis
1
0
Fork 0
Code Pull requests Activity

S2S: Group: Add: Implement resource-passive mode

Browse source
This commit is contained in:
Pere Lev 2024-06-15 15:51:31 +03:00
parent f7d3d6d957
commit 83590ba6ff
No known key found for this signature in database
GPG key ID: 5252C5C863E5E57D
7 changed files with 116 additions and 14 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

96
src/Vervis/Actor/Group.hs
View file

@ -147,6 +147,17 @@ import Vervis.Web.Collab
-- * Create a Source/Dest record in DB
-- * Forward the Add to my followers
--
-- * If I'm the object, being added to some resource's teams list:
-- * Verify the target is a non-team resource's teams list, find in DB/HTTP
-- * Verify it's not already an active resource 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 resource's Accept
-- * Insert the Add to my inbox
-- * Create an Effort record in DB
-- * Forward the Add to my followers
--
-- * Otherwise, error
groupAdd
:: UTCTime
@ -173,6 +184,8 @@ groupAdd now groupID (Verse authorIdMsig body) add = do
addChildPassive $ Left j
Left (ATGroupChildren j) | j /= groupID ->
addParentPassive $ Left j
Left at | isJust $ addTargetResourceTeams at ->
addResourcePassive $ Left $ fromJust $ addTargetResourceTeams at
Right (ObjURI h luColl) -> do
-- NOTE this is HTTP GET done synchronously in the activity
-- handler
@ -189,6 +202,8 @@ groupAdd now groupID (Verse authorIdMsig body) add = do
then addParentPassive $ Right $ ObjURI h lu
else if typ == AP.ActorTypeTeam && Just luColl == AP.rwcParentsOrProjects rwc
then addChildPassive $ Right $ ObjURI h lu
else if AP.actorTypeIsResourceNT typ && Just luColl == AP.rwcTeams rwc
then addResourcePassive $ Right $ ObjURI h lu
else throwE "Weird collection situation"
_ -> throwE "I'm being added somewhere irrelevant"
_ -> throwE "This Add isn't for me"
@ -755,6 +770,87 @@ groupAdd now groupID (Verse authorIdMsig body) add = do
return (action, recipientSet, remoteActors, fwdHosts)
addResourcePassive resource = do
-- If resource is local, find it in our DB
-- If resource is remote, HTTP GET it, verify it's an actor of Group
-- 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.
resourceDB <-
bitraverse
(\ ng ->
withDBExcept $
getLocalResourceEntityE (resourceFromNG ng) "Resource 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 "Resource @id mismatch"
Left (Just err) -> throwE $ T.pack $ displayException err
Right Nothing -> throwE "Resource isn't an actor"
Right (Just actor) -> do
if AP.actorTypeIsResourceNT $ remoteActorType $ entityVal actor
then pure ()
else throwE "Remote resource type isn't a resource"
return (u, actor)
)
resource
let resourceDB' = bimap localResourceID (entityKey . snd) resourceDB
maybeNew <- withDBExcept $ do
-- Grab me from DB
(group, actorRecip) <- lift $ do
p <- getJust groupID
(p,) <$> getJust (groupActor p)
-- Verify the target isn't already a resource of mine, and that no
-- Effort record is already in Add-Accept state
verifyNoStartedGroupResources groupID resourceDB'
-- Insert the Add to my inbox
mractid <- lift $ insertToInbox now authorIdMsig body (actorInbox actorRecip) False
lift $ for mractid $ \ (inboxItemID, addDB) -> do
-- Create an Effort record in DB
insertEffort resourceDB' addDB
-- Prepare forwarding the Add to my followers
sieve <- do
groupHash <- encodeKeyHashid groupID
return $ makeRecipientSet [] [LocalStageGroupFollowers groupHash]
return (groupActor group, sieve, inboxItemID)
case maybeNew of
Nothing -> done "I already have this activity in my inbox"
Just (groupActorID, sieve, inboxItemID) -> do
forwardActivity
authorIdMsig body (LocalActorGroup groupID) groupActorID sieve
doneDB inboxItemID "[Resource-passive] Recorded a resource-in-progress, forwarded the Add"
where
insertEffort topicDB addDB = do
effortID <- insert $ Effort AP.RoleAdmin groupID
case topicDB of
Left r -> insert_ $ EffortTopicLocal effortID r
Right a -> insert_ $ EffortTopicRemote effortID a
themID <- insert $ EffortOriginThem effortID
case addDB of
Left (_, _, addID) ->
insert_ $ EffortThemGestureLocal themID addID
Right (author, _, addID) ->
insert_ $ EffortThemGestureRemote themID (remoteAuthorId author) addID
-- Meaning: An actor accepted something
-- Behavior:
-- * Check if I know the activity that's being Accepted:

2
src/Vervis/Actor/Person.hs
View file

@ -652,7 +652,7 @@ personInvite now recipPersonID (Verse authorIdMsig body) invite = do
manager <- asksEnv envHttpManager
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'"
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
then Just . (role,) . Right <$> do
instanceID <-

8
src/Vervis/Actor/Person/Client.hs
View file

@ -266,7 +266,7 @@ clientAdd now personMeID (ClientMsg maybeCap localRecips remoteRecips fwdHosts a
manager <- asksEnv envHttpManager
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'"
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 <-
lift $ withDB $ either entityKey id <$> insertBy' (Instance h)
@ -895,7 +895,7 @@ clientInvite now personMeID (ClientMsg maybeCap localRecips remoteRecips fwdHost
manager <- asksEnv envHttpManager
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'"
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) $
throwE "Invite target isn't a collabs/components list"
@ -1044,7 +1044,7 @@ clientJoin now personMeID (ClientMsg maybeCap localRecips remoteRecips fwdHosts
manager <- asksEnv envHttpManager
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'"
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
unless (isCollabs || mluComps == Just luColl) $
throwE "Join resource isn't a collabs/components list"
@ -1249,7 +1249,7 @@ clientRemove now personMeID (ClientMsg maybeCap localRecips remoteRecips fwdHost
manager <- asksEnv envHttpManager
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'"
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
)
resource

6
src/Vervis/Client.hs
View file

@ -1150,7 +1150,7 @@ invite personID uRecipient uResourceCollabs role = do
manager <- asksSite appHttpManager
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'"
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) $
throwE "Invite target isn't a collabs list"
return $ ObjURI h lu
@ -1241,7 +1241,7 @@ add personID uRecipient uCollection role = do
manager <- asksSite appHttpManager
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'"
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
)
target
@ -1327,7 +1327,7 @@ remove personID uRecipient uCollection = do
manager <- asksSite appHttpManager
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'"
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
)
resource

8
src/Vervis/Data/Collab.hs
View file

@ -32,6 +32,7 @@ module Vervis.Data.Collab
, AddTarget (..)
, addTargetResource
, addTargetComponentProjects
, addTargetResourceTeams
, parseAdd
, ComponentBy (..)
@ -478,6 +479,13 @@ addTargetComponentProjects = \case
ATLoomProjects l -> Just $ ComponentLoom l
_ -> Nothing
addTargetResourceTeams = \case
ATProjectTeams j -> Just $ LocalResourceProject' j
ATRepoTeams r -> Just $ LocalResourceRepo' r
ATDeckTeams d -> Just $ LocalResourceDeck' d
ATLoomTeams l -> Just $ LocalResourceLoom' l
_ -> Nothing
parseAdd
:: StageRoute Env ~ Route App
=> Either (LocalActorBy Key) FedURI

5
src/Vervis/Migration/Model2022.hs
View file

@ -80,13 +80,8 @@ import Vervis.Model.TH
import Vervis.Model.Ticket
import Vervis.Model.Workflow
-- For migrations 77, 114
import Data.Int
import Database.Persist.JSON
import Network.FedURI
import Web.ActivityPub
makeEntitiesMigration "285"
$(modelFile "migrations/2022_06_14_collab_mig.model")

5
src/Web/ActivityPub.hs
View file

@ -903,6 +903,7 @@ data ResourceWithCollections u = ResourceWithCollections
, rwcParentsOrProjects :: Maybe LocalURI
, rwcSubprojects :: Maybe LocalURI
, rwcSubteams :: Maybe LocalURI
, rwcTeams :: Maybe LocalURI
}
instance ActivityPub ResourceWithCollections where
@ -916,7 +917,8 @@ instance ActivityPub ResourceWithCollections where
<*> withAuthorityMaybeO h (o .:? "context")
<*> withAuthorityMaybeO h (o .:? "subprojects")
<*> withAuthorityMaybeO h (o .:? "subteams")
toSeries h (ResourceWithCollections r collabs comps members ctx subj subt)
<*> withAuthorityMaybeO h (o .:? "teams")
toSeries h (ResourceWithCollections r collabs comps members ctx subj subt teams)
= toSeries h r
<> "collaborators" .=? (ObjURI h <$> collabs)
<> "components" .=? (ObjURI h <$> comps)
@ -924,6 +926,7 @@ instance ActivityPub ResourceWithCollections where
<> "context" .=? (ObjURI h <$> ctx)
<> "subprojects" .=? (ObjURI h <$> subj)
<> "subteams" .=? (ObjURI h <$> subt)
<> "teams" .=? (ObjURI h <$> teams)
data Project u = Project
{ projectActor :: Actor u