forge/Vervis
1
0
Fork 0
Code Pull requests Activity

S2S: Project: Add: Implement Add-based version of projectInvite

Browse source
This commit is contained in:
Pere Lev 2024-05-12 17:50:18 +03:00
parent f864274ff0
commit f6dda396dd
No known key found for this signature in database
GPG key ID: 5252C5C863E5E57D
6 changed files with 220 additions and 28 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

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 _ 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 "Remove origin isn't a collabs list"
return $ ObjURI h lu

205
src/Vervis/Actor/Project.hs
View file

@ -1454,15 +1454,16 @@ checkExistingComponents projectID componentDB = do
-- Meaning: An actor is adding some object to some target
-- Behavior:
-- * If the target is my components list:
-- * 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 in a Add-Accept process waiting for project
-- collab to accept too
-- * Verify it's not already in an Invite-Accept process waiting for
-- component (or its collaborator) to accept too
-- * Insert the Add to my inbox
-- * Create a Component record in DB
-- * Forward the Add to my followers
-- * Verify sender is authorized by me to add components to me
-- * Verify B isn't already an active component of mine
-- * Verify B isn't already in a Add-Accept process waiting for
-- project collab to accept too
-- * Verify B isn't already in an Invite-Accept process waiting for
-- component (or its collaborator) to accept too
-- * Insert the Add to my inbox
-- * Create a Component record in DB
-- * Forward the Add to my followers
-- * Send Accept to sender, component+followers, my-followers
--
-- * If the target is my children list:
-- * Verify the object is a project, find in DB/HTTP
@ -1512,6 +1513,17 @@ checkExistingComponents projectID componentDB = do
-- * Create a Source/Dest record in DB
-- * Forward the Add to my followers
--
-- * If I'm the object, being added to someone's projects list:
-- * 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 in a them-Add-Accept process waiting for
-- project collab to accept too
-- * Verify it's not already in an us-Invite-Accept process waiting for
-- component (or its collaborator) to accept too
-- * Insert the Add to my inbox
-- * Create a Component record in DB
-- * Forward the Add to my followers
--
-- * Otherwise, error
projectAdd
:: UTCTime
@ -1532,7 +1544,7 @@ projectAdd now projectID (Verse authorIdMsig body) add = do
(\ la -> fromMaybeE (resourceToComponent =<< actorToResource la) "Not a component")
pure
object
addComponent comp
addComponentActive comp
(Left (ATProjectChildren j), _) | j == projectID ->
addChildActive object
(Left (ATProjectParents j), _) | j == projectID ->
@ -1543,25 +1555,182 @@ projectAdd now projectID (Verse authorIdMsig body) add = do
addChildPassive $ Left j
Left (ATProjectChildren j) | j /= projectID ->
addParentPassive $ Left j
Left (ATRepoProjects r) ->
addComponentPassive $ Left $ ComponentRepo r
Left (ATDeckProjects d) ->
addComponentPassive $ Left $ ComponentDeck d
Left (ATLoomProjects l) ->
addComponentPassive $ Left $ ComponentLoom l
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
case (luColl == AP.projectChildren j, luColl == AP.projectParents j) of
(True, False) ->
addParentPassive $ Right $ ObjURI h lu
(False, True) ->
addChildPassive $ Right $ ObjURI h lu
_ -> throwE "Weird collection situation"
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 AP.actorTypeIsComponent typ && Just luColl == AP.rwcParentsOrProjects rwc
then addComponentPassive $ Right $ ObjURI h lu
else if typ == AP.ActorTypeProject && Just luColl == AP.rwcSubprojects rwc
then addParentPassive $ Right $ ObjURI h lu
else if typ == AP.ActorTypeProject && Just luColl == AP.rwcParentsOrProjects rwc
then addChildPassive $ Right $ ObjURI h lu
else throwE "Weird collection situation"
_ -> throwE "I'm being added somewhere irrelevant"
_ -> throwE "This Add isn't for me"
where
addComponent component = do
addComponentActive component = do
-- Check capability
capability <- do
-- Verify that a capability is provided
uCap <- do
let muCap = AP.activityCapability $ actbActivity body
fromMaybeE muCap "No capability provided"
-- Verify the capability URI is one of:
-- * Outbox item URI of a local actor, i.e. a local activity
-- * A remote URI
cap <- nameExceptT "Invite capability" $ parseActivityURI' uCap
-- Verify the capability is local
case cap of
Left (actorByKey, _, outboxItemID) ->
return (actorByKey, outboxItemID)
_ -> throwE "Capability is remote i.e. definitely not by me"
-- If target is local, find it in our DB
-- If target is remote, HTTP GET it, verify it's an actor, 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 Invite handler,
-- which is NOT a good idea. Ideally, it would be done async, and the
-- handler result (approve/disapprove the Invite) would be sent later in a
-- separate (e.g. Accept) activity. But for the PoC level, the current
-- situation will hopefully do.
invitedDB <-
bitraverse
(withDBExcept . flip getComponentE "Invitee not found in DB")
getRemoteActorFromURI
component
maybeNew <- withDBExcept $ do
-- Grab me from DB
resourceID <- lift $ projectResource <$> getJust projectID
Resource topicActorID <- lift $ getJust resourceID
topicActor <- lift $ getJust topicActorID
-- Verify the specified capability gives relevant access
verifyCapability'
capability authorIdMsig (LocalResourceProject projectID) AP.RoleAdmin
-- Find existing Component records I have for this component
-- Make sure none are enabled / in Add-Accept mode / in
-- Invite-Accept mode
checkExistingComponents projectID invitedDB
maybeInviteDB <- lift $ insertToInbox now authorIdMsig body (actorInbox topicActor) False
lift $ for maybeInviteDB $ \ (inboxItemID, inviteDB) -> do
-- Insert Collab or Component record to DB
acceptID <- insertEmptyOutboxItem' (actorOutbox topicActor) now
insertComponent invitedDB inviteDB acceptID
-- Prepare forwarding Invite to my followers
sieve <- do
projectHash <- encodeKeyHashid projectID
return $ makeRecipientSet [] [LocalStageProjectFollowers projectHash]
-- Prepare an Accept activity and insert to my outbox
accept@(actionAccept, _, _, _) <- prepareAccept invitedDB
_luAccept <- updateOutboxItem' (LocalActorProject projectID) acceptID actionAccept
return (topicActorID, 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 "[Add-component-active] Recorded and forwarded the Add, sent an Accept"
where
getRemoteActorFromURI (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 "Target @id mismatch"
Left (Just err) -> throwE $ T.pack $ displayException err
Right Nothing -> throwE "Target isn't an actor"
Right (Just actor) -> return $ entityKey actor
insertComponent componentDB inviteDB acceptID = do
componentID <- insert $ Component projectID AP.RoleAdmin
originID <- insert $ ComponentOriginInvite componentID
case inviteDB of
Left (_, _, inviteID) ->
insert_ $ ComponentProjectGestureLocal componentID inviteID
Right (author, _, inviteID) ->
insert_ $ ComponentProjectGestureRemote componentID (remoteAuthorId author) inviteID
case componentDB of
Left l ->
insert_ $ ComponentLocal componentID (localComponentID l)
Right remoteActorID ->
insert_ $ ComponentRemote componentID remoteActorID
insert_ $ ComponentProjectAccept originID acceptID
prepareAccept invitedDB = do
encodeRouteHome <- getEncodeRouteHome
audInviter <- lift $ makeAudSenderOnly authorIdMsig
audInvited <-
case invitedDB of
Left componentByEnt -> do
componentByHash <- hashComponent $ bmap entityKey componentByEnt
let actor = resourceToActor $ componentResource componentByHash
return $ AudLocal [actor] [localActorFollowers actor]
Right remoteActorID -> do
ra <- getJust remoteActorID
ObjURI h lu <- getRemoteActorURI ra
return $ AudRemote h [lu] (maybeToList $ remoteActorFollowers ra)
audTopic <-
AudLocal [] . pure . LocalStageProjectFollowers <$>
encodeKeyHashid projectID
uInvite <- lift $ getActivityURI authorIdMsig
let (recipientSet, remoteActors, fwdHosts, audLocal, audRemote) =
collectAudience [audInviter, audInvited, audTopic]
recips = map encodeRouteHome audLocal ++ audRemote
action = AP.Action
{ AP.actionCapability = Nothing
, AP.actionSummary = Nothing
, AP.actionAudience = AP.Audience recips [] [] [] [] []
, AP.actionFulfills = [uInvite]
, AP.actionSpecific = AP.AcceptActivity AP.Accept
{ AP.acceptObject = uInvite
, AP.acceptResult = Nothing
}
}
return (action, recipientSet, remoteActors, fwdHosts)
addComponentPassive component = do
-- If component is local, find it in our DB
-- If component is remote, HTTP GET it, verify it's an actor of a component

6
src/Vervis/Client.hs
View file

@ -1151,7 +1151,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
@ -1242,7 +1242,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
@ -1328,7 +1328,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

2
src/Vervis/Handler/Deck.hs
View file

@ -624,7 +624,7 @@ postDeckAddProjectR deckHash = do
encodeRouteHome . renderLocalActor <$> hashLocalActor la
Right (ObjURI h lu) -> do
manager <- asksSite appHttpManager
AP.ResourceWithCollections _ _ mluComponents _ <- ExceptT $ liftIO $ first (T.pack . show) <$> AP.fetchRWC manager h lu
AP.ResourceWithCollections _ _ mluComponents _ _ _ _ <- ExceptT $ liftIO $ first (T.pack . show) <$> AP.fetchRWC manager h lu
luComponents <- fromMaybeE mluComponents "No components collection"
return $ ObjURI h luComponents

25
src/Web/ActivityPub.hs
View file

@ -30,6 +30,7 @@ module Web.ActivityPub
-- ActivityPub actor document including a public key, with a 'FromJSON'
-- instance for fetching and a 'ToJSON' instance for publishing.
, ActorType (..)
, actorTypeIsComponent
, parseActorType
, renderActorType
--, Algorithm (..)
@ -132,6 +133,7 @@ module Web.ActivityPub
, fetchRecipient
, fetchResource
, fetchRWC
, fetchRWC_T
, keyListedByActor
, fetchUnknownKey
, fetchKnownPersonalKey
@ -390,6 +392,12 @@ data ActorType
| ActorTypeOther Text
deriving Eq
actorTypeIsComponent = \case
ActorTypeRepo -> True
ActorTypeTicketTracker -> True
ActorTypePatchTracker -> True
_ -> False
parseActorType :: Text -> ActorType
parseActorType t
| t == "Person" = ActorTypePerson
@ -871,6 +879,9 @@ data ResourceWithCollections u = ResourceWithCollections
, rwcCollabs :: Maybe LocalURI
, rwcComponents :: Maybe LocalURI
, rwcMembers :: Maybe LocalURI
, rwcParentsOrProjects :: Maybe LocalURI
, rwcSubprojects :: Maybe LocalURI
, rwcSubteams :: Maybe LocalURI
}
instance ActivityPub ResourceWithCollections where
@ -881,11 +892,17 @@ instance ActivityPub ResourceWithCollections where
<$> withAuthorityMaybeO h (o .:? "collaborators")
<*> withAuthorityMaybeO h (o .:? "components")
<*> withAuthorityMaybeO h (o .:? "members")
toSeries h (ResourceWithCollections r collabs comps members)
<*> withAuthorityMaybeO h (o .:? "context")
<*> withAuthorityMaybeO h (o .:? "subprojects")
<*> withAuthorityMaybeO h (o .:? "subteams")
toSeries h (ResourceWithCollections r collabs comps members ctx subj subt)
= toSeries h r
<> "collaborators" .=? (ObjURI h <$> collabs)
<> "components" .=? (ObjURI h <$> comps)
<> "members" .=? (ObjURI h <$> members)
<> "context" .=? (ObjURI h <$> ctx)
<> "subprojects" .=? (ObjURI h <$> subj)
<> "subteams" .=? (ObjURI h <$> subt)
data Project u = Project
{ projectActor :: Actor u
@ -2699,6 +2716,12 @@ fetchRWC m = fetchAPID' m (getId . rwcResource)
getId (ResourceActor a) = actorId $ actorLocal a
getId (ResourceChild luId _) = luId
fetchRWC_T :: (MonadIO m, UriMode u) => Manager -> Authority u -> LocalURI -> ExceptT Text m (ResourceWithCollections u)
fetchRWC_T m h lu = ExceptT $ liftIO $ first showError <$> fetchRWC m h lu
where
showError Nothing = "Object @id doesn't match the URI we fetched"
showError (Just e) = T.pack $ displayException e
fetchAPID :: (MonadIO m, UriMode u, ActivityPub a) => Manager -> (a u -> LocalURI) -> Authority u -> LocalURI -> m (Either String (a u))
fetchAPID m getId h lu = first showError <$> fetchAPID' m getId h lu
where