forge/Vervis
1
0
Fork 0
Code Pull requests Activity

S2S: Project: Add: Handle adding a child/parent; also update C2S Add

Browse source
This commit is contained in:
Pere Lev 2024-02-01 16:51:52 +02:00
parent 1567ab9aa9
commit bce8079cb5
No known key found for this signature in database
GPG key ID: 5252C5C863E5E57D
6 changed files with 1000 additions and 167 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

10
src/Vervis/Actor/Deck.hs
View file

@ -1,6 +1,7 @@
{- This file is part of Vervis.
-
- Written in 2019, 2020, 2022, 2023 by fr33domlover <fr33domlover@riseup.net>.
- Written in 2019, 2020, 2022, 2023, 2024
- by fr33domlover <fr33domlover@riseup.net>.
-
- ♡ Copying is an act of love. Please copy, reuse and share.
-
@ -128,11 +129,14 @@ deckAdd now deckID (Verse authorIdMsig body) add = do
projectComps <- do
let author = bimap (view _1) (remoteAuthorURI . view _1) authorIdMsig
(component, projectComps, role) <- parseAdd author add
unless (component == Left (ComponentDeck deckID)) $
unless (component == Left (LocalActorDeck deckID)) $
throwE "Add object isn't me"
unless (role == AP.RoleAdmin) $
throwE "Add role isn't admin"
return projectComps
case projectComps of
Left (ATProjectComponents j) -> return $ Left j
Right u -> return $ Right u
_ -> throwE "I'm being added somewhere invalid"
-- If project is local, find it in our DB
-- If project is remote, HTTP GET it and store in our DB (if it's already

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

@ -1,6 +1,6 @@
{- This file is part of Vervis.
-
- Written in 2023 by fr33domlover <fr33domlover@riseup.net>.
- Written in 2023, 2024 by fr33domlover <fr33domlover@riseup.net>.
-
- ♡ Copying is an act of love. Please copy, reuse and share.
-
@ -230,14 +230,14 @@ clientAccept now personMeID (ClientMsg maybeCap localRecips remoteRecips fwdHost
PermitFulfillsInvite permitID <- lift $ getJust fulfillsID
return (permitID, fulfillsID)
-- Meaning: The human wants to add component C to project P
-- Meaning: The human wants to add someone C to a collection of someone P
-- Behavior:
-- * Some basic sanity checks
-- * Parse the Add
-- * Make sure not inviting myself
-- * Verify that a capability is specified
-- * If component is local, verify it exists in DB
-- * If project is local, verify it exists in DB
-- * If C is local, verify it exists in DB
-- * If P is local, verify it exists in DB
-- * Verify C and P are addressed in the Invite
-- * Insert Add to my inbox
-- * Asynchrnously deliver to:
@ -253,22 +253,20 @@ clientAdd
clientAdd now personMeID (ClientMsg maybeCap localRecips remoteRecips fwdHosts action) add = do
-- Check input
(component, project, _role) <- parseAdd (Left $ LocalActorPerson personMeID) add
(object, target, _role) <- parseAdd (Left $ LocalActorPerson personMeID) add
_capID <- fromMaybeE maybeCap "No capability provided"
-- If project components URI is remote, HTTP GET it and its resource and its
-- managing actor, and insert to our DB. If project is local, find it in
-- If target objects URI is remote, HTTP GET it and its resource and its
-- managing actor, and insert to our DB. If target is local, find it in
-- our DB.
projectDB <-
targetDB <-
bitraverse
(withDBExcept . flip getEntityE "Project not found in DB")
(withDBExcept . flip getLocalActorEntityE "Local target not found in DB" . addTargetActor)
(\ u@(ObjURI h luComps) -> do
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 _ _ mluComps _ <- ExceptT $ liftIO $ first (T.pack . show) <$> AP.fetchRWC manager h lu
unless (mluComps == Just luComps) $
throwE "Add target isn't a components list"
AP.ResourceWithCollections _ _ _ _ <- ExceptT $ liftIO $ first (T.pack . show) <$> AP.fetchRWC manager h lu
instanceID <-
lift $ withDB $ either entityKey id <$> insertBy' (Instance h)
@ -281,13 +279,13 @@ clientAdd now personMeID (ClientMsg maybeCap localRecips remoteRecips fwdHosts a
Right (objectID, luManager, (Entity actorID _)) ->
return (objectID, actorID, ObjURI h luManager)
)
project
target
-- If component is remote, HTTP GET it, make sure it's an actor, and insert
-- If object is remote, HTTP GET it, make sure it's an actor, and insert
-- it to our DB. If recipient is local, find it in our DB.
componentDB <-
objectDB <-
bitraverse
(withDBExcept . flip getComponentE "Component not found in DB")
(withDBExcept . flip getLocalActorEntityE "Component not found in DB")
(\ u@(ObjURI h lu) -> do
instanceID <-
lift $ withDB $ either entityKey id <$> insertBy' (Instance h)
@ -300,17 +298,17 @@ clientAdd now personMeID (ClientMsg maybeCap localRecips remoteRecips fwdHosts a
Right Nothing -> throwE "Recipient isn't an actor"
Right (Just actor) -> return (entityKey actor, u)
)
component
object
-- Verify that project and component are addressed by the Add
-- Verify that target and object are addressed by the Add
bitraverse_
(verifyProjectAddressed localRecips . entityKey)
(verifyActorAddressed localRecips . bmap entityKey)
(\ (_, _, u) -> verifyRemoteAddressed remoteRecips u)
projectDB
targetDB
bitraverse_
(verifyComponentAddressed localRecips . bmap entityKey)
(verifyActorAddressed localRecips . bmap entityKey)
(verifyRemoteAddressed remoteRecips . snd)
componentDB
objectDB
(actorMeID, localRecipsFinal, addID) <- withDBExcept $ do
@ -325,24 +323,24 @@ clientAdd now personMeID (ClientMsg maybeCap localRecips remoteRecips fwdHosts a
-- Prepare local recipients for Add delivery
sieve <- lift $ do
projectHash <- bitraverse encodeKeyHashid pure project
componentHash <- bitraverse hashComponent pure component
targetHash <- bitraverse (hashLocalActor . addTargetActor) pure target
objectHash <- bitraverse hashLocalActor pure object
senderHash <- encodeKeyHashid personMeID
let sieveActors = catMaybes
[ case projectHash of
Left j -> Just $ LocalActorProject j
[ case targetHash of
Left a -> Just a
Right _ -> Nothing
, case componentHash of
Left c -> Just $ componentActor c
, case objectHash of
Left c -> Just c
Right _ -> Nothing
]
sieveStages = catMaybes
[ Just $ LocalStagePersonFollowers senderHash
, case projectHash of
Left j -> Just $ LocalStageProjectFollowers j
, case targetHash of
Left a -> Just $ localActorFollowers a
Right _ -> Nothing
, case componentHash of
Left c -> Just $ localActorFollowers $ componentActor c
, case objectHash of
Left c -> Just $ localActorFollowers c
Right _ -> Nothing
]
return $ makeRecipientSet sieveActors sieveStages

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

@ -1,6 +1,6 @@
{- This file is part of Vervis.
-
- Written in 2023 by fr33domlover <fr33domlover@riseup.net>.
- Written in 2023, 2024 by fr33domlover <fr33domlover@riseup.net>.
-
- ♡ Copying is an act of love. Please copy, reuse and share.
-
@ -77,6 +77,7 @@ import Vervis.Persist.Actor
import Vervis.Persist.Collab
import Vervis.Persist.Discussion
import Vervis.Ticket
import Vervis.Web.Collab
-- Meaning: An actor accepted something
-- Behavior:
@ -695,7 +696,7 @@ checkExistingComponents projectID componentDB = do
-- Meaning: An actor is adding some object to some target
-- Behavior:
-- * Verify my components list is the target
-- * 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
@ -705,6 +706,56 @@ checkExistingComponents projectID componentDB = do
-- * Insert the Add to my inbox
-- * Create a Component record in DB
-- * Forward the Add to my followers
--
-- * If the target is my children list:
-- * Verify the object is a project, find in DB/HTTP
-- * Verify the Add is authorized
-- * Verify it's not already an active child of mine
-- * Verify it's not already an active parent 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 child's Accept
-- * Insert the Add to my inbox
-- * Create a Source record in DB
-- * Forward the Add to my followers
-- * Publish an Accept to:
-- * The object project + followers
-- * Add sender + followers
-- * My followers
-- * Record my Accept in the Source record
--
-- * If the target is my parents list:
-- * Verify the object is a project, find in DB/HTTP
-- * Verify the Add is authorized
-- * Verify it's not already an active parent of mine
-- * Verify it's not already an active child 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 parent's Accept
-- * Insert the Add to my inbox
-- * Create a Dest record in DB
-- * Forward the Add to my followers
-- * Publish an Accept to:
-- * The object project + followers
-- * Add sender + followers
-- * My followers
-- * Record my Accept in the Dest record
--
-- * If I'm the object, being added to someone's parents/children list:
-- * 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 child 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 parent/child's Accept
-- * Insert the Add to my inbox
-- * Create a Source/Dest record in DB
-- * Forward the Add to my followers
--
-- * Otherwise, error
projectAdd
:: UTCTime
-> ProjectId
@ -713,15 +764,47 @@ projectAdd
-> ActE (Text, Act (), Next)
projectAdd now projectID (Verse authorIdMsig body) add = do
-- Check input
component <- do
let author = bimap (view _1) (remoteAuthorURI . view _1) authorIdMsig
(component, projectComps, role) <- parseAdd author add
unless (projectComps == Left projectID) $
throwE "Add target isn't my components collection"
(object, target, role) <- parseAdd author add
unless (role == AP.RoleAdmin) $
throwE "Add role isn't admin"
return component
case (target, object) of
(Left (ATProjectComponents j), _)| j == projectID -> do
comp <-
bitraverse
(\ la -> fromMaybeE (actorToComponent la) "Not a component")
pure
object
addComponent comp
(Left (ATProjectChildren j), _) | j == projectID ->
addChildActive object
(Left (ATProjectParents j), _) | j == projectID ->
addParentActive object
(_, Left (LocalActorProject j)) | j == projectID ->
case target of
Left (ATProjectParents j) | j /= projectID ->
addChildPassive $ Left j
Left (ATProjectChildren j) | j /= projectID ->
addParentPassive $ Left j
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"
_ -> throwE "I'm being added somewhere irrelevant"
_ -> throwE "This Add isn't for me"
where
addComponent 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
@ -812,6 +895,429 @@ projectAdd now projectID (Verse authorIdMsig body) add = do
Right remoteActorID ->
insert_ $ ComponentRemote componentID remoteActorID
prepareAccept childDB = do
encodeRouteHome <- getEncodeRouteHome
audAdder <- makeAudSenderWithFollowers authorIdMsig
audChild <-
case childDB of
Left (Entity j _) -> do
jh <- encodeKeyHashid j
return $ AudLocal [LocalActorProject jh] []
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, audChild, 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)
addChildActive child = do
-- If child is local, find it in our DB
-- If child 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.
childDB <-
bitraverse
(\case
LocalActorProject j -> withDBExcept $ getEntityE j "Child not found in DB"
_ -> throwE "Local proposed child of non-project 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 "Child @id mismatch"
Left (Just err) -> throwE $ T.pack $ displayException err
Right Nothing -> throwE "Child isn't an actor"
Right (Just actor) -> do
case remoteActorType $ entityVal actor of
AP.ActorTypeProject -> pure ()
_ -> throwE "Remote child type isn't Project"
return (u, actor)
)
child
let childDB' = second (entityKey . snd) childDB
-- 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 child
verifyCapability''
uCap
authorIdMsig
(LocalActorProject projectID)
AP.RoleTriage
maybeNew <- withDBExcept $ do
-- Grab me from DB
(project, actorRecip) <- lift $ do
p <- getJust projectID
(p,) <$> getJust (projectActor p)
-- Verify the object isn't a parent of mine
verifyNoEnabledProjectParents projectID childDB'
-- Verify the object isn't already a child of mine, and that no
-- Source record is already in Add-Accept state
verifyNoStartedProjectChildren projectID childDB'
-- Insert the Add to my inbox
mractid <- lift $ insertToInbox now authorIdMsig body (actorInbox actorRecip) False
lift $ for mractid $ \ addDB -> do
-- Create a Source record in DB
acceptID <- insertEmptyOutboxItem' (actorOutbox actorRecip) now
insertSource childDB' 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 childDB
_luAccept <- updateOutboxItem' (LocalActorProject projectID) acceptID actionAccept
return (projectActor project, sieve, acceptID, accept)
case maybeNew of
Nothing -> done "I already have this activity in my inbox"
Just (projectActorID, sieve, acceptID, (actionAccept, localRecipsAccept, remoteRecipsAccept, fwdHostsAccept)) -> do
forwardActivity
authorIdMsig body (LocalActorProject projectID) projectActorID sieve
lift $ sendActivity
(LocalActorProject projectID) projectActorID localRecipsAccept
remoteRecipsAccept fwdHostsAccept acceptID actionAccept
done "Recorded a child-project-in-progress, forwarded the Add, sent an Accept"
where
insertSource topicDB addDB acceptID = do
sourceID <- insert $ Source AP.RoleAdmin
holderID <- insert $ SourceHolderProject sourceID projectID
case topicDB of
Left (Entity j _) -> do
localID <- insert $ SourceTopicLocal sourceID
insert_ $ SourceTopicProject holderID localID j
Right a ->
insert_ $ SourceTopicRemote sourceID a
usID <- insert $ SourceOriginUs sourceID
case addDB of
Left (_, _, addID) ->
insert_ $ SourceUsGestureLocal usID addID
Right (author, _, addID) ->
insert_ $ SourceUsGestureRemote usID (remoteAuthorId author) addID
insert_ $ SourceUsAccept usID acceptID
addParentActive parent = do
-- If parent is local, find it in our DB
-- If parent 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.
parentDB <-
bitraverse
(\case
LocalActorProject j -> withDBExcept $ getEntityE j "Parent not found in DB"
_ -> throwE "Local proposed parent of non-project 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 "Parent @id mismatch"
Left (Just err) -> throwE $ T.pack $ displayException err
Right Nothing -> throwE "Parent isn't an actor"
Right (Just actor) -> do
case remoteActorType $ entityVal actor of
AP.ActorTypeProject -> pure ()
_ -> throwE "Remote parent type isn't Project"
return (u, actor)
)
parent
let parentDB' = second (entityKey . snd) parentDB
-- 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 parent
verifyCapability''
uCap
authorIdMsig
(LocalActorProject projectID)
AP.RoleTriage
maybeNew <- withDBExcept $ do
-- Grab me from DB
(project, actorRecip) <- lift $ do
p <- getJust projectID
(p,) <$> getJust (projectActor p)
-- Verify the object isn't a child of mine
verifyNoEnabledProjectChildren projectID parentDB'
-- Verify the object isn't already a parent of mine, and that no
-- Dest record is already in Add-Accept state
verifyNoStartedProjectParents projectID parentDB'
-- Insert the Add to my inbox
mractid <- lift $ insertToInbox now authorIdMsig body (actorInbox actorRecip) False
lift $ for mractid $ \ addDB -> do
-- Create a Dest record in DB
acceptID <- insertEmptyOutboxItem' (actorOutbox actorRecip) now
insertDest parentDB' 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 parentDB
_luAccept <- updateOutboxItem' (LocalActorProject projectID) acceptID actionAccept
return (projectActor project, sieve, acceptID, accept)
case maybeNew of
Nothing -> done "I already have this activity in my inbox"
Just (projectActorID, sieve, acceptID, (actionAccept, localRecipsAccept, remoteRecipsAccept, fwdHostsAccept)) -> do
forwardActivity
authorIdMsig body (LocalActorProject projectID) projectActorID sieve
lift $ sendActivity
(LocalActorProject projectID) projectActorID localRecipsAccept
remoteRecipsAccept fwdHostsAccept acceptID actionAccept
done "Recorded a parent-project-in-progress, forwarded the Add, sent an Accept"
where
insertDest topicDB addDB acceptID = do
destID <- insert $ Dest AP.RoleAdmin
holderID <- insert $ DestHolderProject destID projectID
case topicDB of
Left (Entity j _) -> do
localID <- insert $ DestTopicLocal destID
insert_ $ DestTopicProject holderID localID j
Right a ->
insert_ $ DestTopicRemote destID a
insert_ $ DestOriginUs destID
case addDB of
Left (_, _, addID) ->
insert_ $ DestUsGestureLocal destID addID
Right (author, _, addID) ->
insert_ $ DestUsGestureRemote destID (remoteAuthorId author) addID
insert_ $ DestUsAccept destID acceptID
addChildPassive child = do
-- If child is local, find it in our DB
-- If child 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.
childDB <-
bitraverse
(\ j -> withDBExcept $ getEntityE j "Child 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 "Child @id mismatch"
Left (Just err) -> throwE $ T.pack $ displayException err
Right Nothing -> throwE "Child isn't an actor"
Right (Just actor) -> do
case remoteActorType $ entityVal actor of
AP.ActorTypeProject -> pure ()
_ -> throwE "Remote child type isn't Project"
return (u, actor)
)
child
let childDB' = second (entityKey . snd) childDB
maybeNew <- withDBExcept $ do
-- Grab me from DB
(project, actorRecip) <- lift $ do
p <- getJust projectID
(p,) <$> getJust (projectActor p)
-- Verify the target isn't a parent of mine
verifyNoEnabledProjectParents projectID childDB'
-- Verify the target isn't already a child of mine, and that no
-- Source record is already in Add-Accept state
verifyNoStartedProjectChildren projectID childDB'
-- Insert the Add to my inbox
mractid <- lift $ insertToInbox now authorIdMsig body (actorInbox actorRecip) False
lift $ for mractid $ \ addDB -> do
-- Create a Source record in DB
insertSource childDB' addDB
-- Prepare forwarding the Add to my followers
sieve <- do
projectHash <- encodeKeyHashid projectID
return $ makeRecipientSet [] [LocalStageProjectFollowers projectHash]
return (projectActor project, sieve)
case maybeNew of
Nothing -> done "I already have this activity in my inbox"
Just (projectActorID, sieve) -> do
forwardActivity
authorIdMsig body (LocalActorProject projectID) projectActorID sieve
done "Recorded a child-project-in-progress, forwarded the Add"
where
insertSource topicDB addDB = do
sourceID <- insert $ Source AP.RoleAdmin
holderID <- insert $ SourceHolderProject sourceID projectID
case topicDB of
Left (Entity j _) -> do
localID <- insert $ SourceTopicLocal sourceID
insert_ $ SourceTopicProject holderID localID j
Right a ->
insert_ $ SourceTopicRemote sourceID a
themID <- insert $ SourceOriginThem sourceID
case addDB of
Left (_, _, addID) ->
insert_ $ SourceThemGestureLocal themID addID
Right (author, _, addID) ->
insert_ $ SourceThemGestureRemote themID (remoteAuthorId author) addID
addParentPassive parent = do
-- If parent is local, find it in our DB
-- If parent 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.
parentDB <-
bitraverse
(\ j -> withDBExcept $ getEntityE j "Parent 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 "Parent @id mismatch"
Left (Just err) -> throwE $ T.pack $ displayException err
Right Nothing -> throwE "Parent isn't an actor"
Right (Just actor) -> do
case remoteActorType $ entityVal actor of
AP.ActorTypeProject -> pure ()
_ -> throwE "Remote parent type isn't Project"
return (u, actor)
)
parent
let parentDB' = second (entityKey . snd) parentDB
maybeNew <- withDBExcept $ do
-- Grab me from DB
(project, actorRecip) <- lift $ do
p <- getJust projectID
(p,) <$> getJust (projectActor p)
-- Verify the object isn't a child of mine
verifyNoEnabledProjectChildren projectID parentDB'
-- Verify the object isn't already a parent of mine, and that no
-- Dest record is already in Add-Accept state
verifyNoStartedProjectParents projectID parentDB'
-- Insert the Add to my inbox
mractid <- lift $ insertToInbox now authorIdMsig body (actorInbox actorRecip) False
lift $ for mractid $ \ addDB -> do
-- Create a Dest record in DB
insertDest parentDB' addDB
-- Prepare forwarding the Add to my followers
sieve <- do
projectHash <- encodeKeyHashid projectID
return $ makeRecipientSet [] [LocalStageProjectFollowers projectHash]
return (projectActor project, sieve)
case maybeNew of
Nothing -> done "I already have this activity in my inbox"
Just (projectActorID, sieve) -> do
forwardActivity
authorIdMsig body (LocalActorProject projectID) projectActorID sieve
done "Recorded a parent-project-in-progress, forwarded the Add"
where
insertDest topicDB addDB = do
destID <- insert $ Dest AP.RoleAdmin
holderID <- insert $ DestHolderProject destID projectID
case topicDB of
Left (Entity j _) -> do
localID <- insert $ DestTopicLocal destID
insert_ $ DestTopicProject holderID localID j
Right a ->
insert_ $ DestTopicRemote destID a
themID <- insert $ DestOriginThem destID
case addDB of
Left (_, _, addID) ->
insert_ $ DestThemGestureLocal themID addID
Right (author, _, addID) ->
insert_ $ DestThemGestureRemote themID (remoteAuthorId author) addID
-- Meaning: Someone has created a project with my ID URI
-- Behavior:
-- * Verify I'm in a just-been-created state

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

@ -1,6 +1,6 @@
{- This file is part of Vervis.
-
- Written in 2022, 2023 by fr33domlover <fr33domlover@riseup.net>.
- Written in 2022, 2023, 2024 by fr33domlover <fr33domlover@riseup.net>.
-
- ♡ Copying is an act of love. Please copy, reuse and share.
-
@ -29,6 +29,8 @@ module Vervis.Data.Collab
, parseAccept
, parseReject
, parseRemove
, AddTarget (..)
, addTargetActor
, parseAdd
, grantResourceActorID
@ -362,54 +364,78 @@ parseRemove sender (AP.Remove object origin) =
(,) <$> nameExceptT "Remove origin" (parseTopic' origin)
<*> nameExceptT "Remove object" (parseRecipient' sender object)
data AddTarget
= ATProjectComponents ProjectId
| ATProjectParents ProjectId
| ATProjectChildren ProjectId
| ATGroupParents GroupId
| ATGroupChildren GroupId
addTargetActor :: AddTarget -> LocalActorBy Key
addTargetActor = \case
ATProjectComponents j -> LocalActorProject j
ATProjectParents j -> LocalActorProject j
ATProjectChildren j -> LocalActorProject j
ATGroupParents g -> LocalActorGroup g
ATGroupChildren g -> LocalActorGroup g
parseAdd
:: StageRoute Env ~ Route App
=> Either (LocalActorBy Key) FedURI
-> AP.Add URIMode
-> ActE
( Either (ComponentBy Key) FedURI
, Either ProjectId FedURI
( Either (LocalActorBy Key) FedURI
, Either AddTarget FedURI
, AP.Role
)
parseAdd sender (AP.Add object target role) = do
parseAdd sender (AP.Add object target role _context) = do
result@(component, collection) <-
(,) <$> nameExceptT "Add.object" (parseComponent' object)
<*> nameExceptT "Add.target" (parseProjectComps target)
<*> nameExceptT "Add.target" (parseCollection target)
case result of
(Right u, Right v) | u == v -> throwE "Object and target are the same"
_ -> pure ()
when (sender == first componentActor component) $
when (sender == component) $
throwE "Sender and component are the same"
case collection of
Left projectID | sender == Left (LocalActorProject projectID) ->
throwE "Sender and project are the same"
Left t | sender == Left (targetActor t) ->
throwE "Sender and target collection actor are the same"
_ -> pure ()
return (component, collection, role)
where
parseComponent' (Right _) = throwE "Not a component URI"
parseComponent' (Left u) = do
routeOrRemote <- parseFedURI u
bitraverse
(\ route -> do
componentHash <-
fromMaybeE
(parseComponent route)
"Not a component route"
unhashComponentE
componentHash
"Contains invalid hashid"
)
pure
routeOrRemote
parseProjectComps u = do
bitraverse parseLocalActorE' pure routeOrRemote
parseCollection u = do
routeOrRemote <- parseFedURI u
bitraverse
(\case
ProjectComponentsR j -> WAP.decodeKeyHashidE j "Inavlid hashid"
_ -> throwE "Not a project components collection route"
ProjectComponentsR j ->
ATProjectComponents <$>
WAP.decodeKeyHashidE j "Inavlid project components hashid"
ProjectParentsR j ->
ATProjectParents <$>
WAP.decodeKeyHashidE j "Inavlid project parents hashid"
ProjectChildrenR j ->
ATProjectChildren <$>
WAP.decodeKeyHashidE j "Inavlid project children hashid"
GroupParentsR g ->
ATGroupParents <$>
WAP.decodeKeyHashidE g "Inavlid team parents hashid"
GroupChildrenR g ->
ATGroupChildren <$>
WAP.decodeKeyHashidE g "Inavlid team children hashid"
_ -> throwE "Not an Add target collection route"
)
pure
routeOrRemote
targetActor = \case
ATProjectComponents j -> LocalActorProject j
ATProjectParents j -> LocalActorProject j
ATProjectChildren j -> LocalActorProject j
ATGroupParents g -> LocalActorGroup g
ATGroupChildren g -> LocalActorGroup g
grantResourceActorID :: LocalActorBy Identity -> ActorId
grantResourceActorID (LocalActorPerson (Identity p)) = personActor p

294
src/Vervis/Persist/Collab.hs
View file

@ -1,6 +1,6 @@
{- This file is part of Vervis.
-
- Written in 2022, 2023 by fr33domlover <fr33domlover@riseup.net>.
- Written in 2022, 2023, 2024 by fr33domlover <fr33domlover@riseup.net>.
-
- ♡ Copying is an act of love. Please copy, reuse and share.
-
@ -36,6 +36,16 @@ module Vervis.Persist.Collab
, checkExistingStems
, checkExistingPermits
, verifyNoStartedProjectChildren
, verifyNoStartedGroupParents
, verifyNoEnabledProjectChildren
, verifyNoEnabledGroupParents
, verifyNoStartedProjectParents
, verifyNoStartedGroupChildren
, verifyNoEnabledProjectParents
, verifyNoEnabledGroupChildren
)
where
@ -681,3 +691,285 @@ checkExistingPermits personID topicDB = do
const () <$> MaybeT (getBy $ UniquePermitTopicAcceptLocalTopic localID)
Right remoteID ->
const () <$> MaybeT (getBy $ UniquePermitTopicAcceptRemoteTopic remoteID)
getExistingProjectSources projectID (Left (Entity childID _)) =
fmap (map $ bimap E.unValue (Left . E.unValue)) $
E.select $ E.from $ \ (holder `E.InnerJoin` topic) -> do
E.on $ holder E.^. SourceHolderProjectId E.==. topic E.^. SourceTopicProjectHolder
E.where_ $
holder E.^. SourceHolderProjectProject E.==. E.val projectID E.&&.
topic E.^. SourceTopicProjectChild E.==. E.val childID
return
( holder E.^. SourceHolderProjectSource
, topic E.^. SourceTopicProjectTopic
)
getExistingProjectSources projectID (Right childID) =
fmap (map $ bimap E.unValue (Right . E.unValue)) $
E.select $ E.from $ \ (holder `E.InnerJoin` topic) -> do
E.on $ holder E.^. SourceHolderProjectSource E.==. topic E.^. SourceTopicRemoteSource
E.where_ $
holder E.^. SourceHolderProjectProject E.==. E.val projectID E.&&.
topic E.^. SourceTopicRemoteTopic E.==. E.val childID
return
( holder E.^. SourceHolderProjectSource
, topic E.^. SourceTopicRemoteId
)
getExistingGroupSources groupID (Left (Entity parentID _)) =
fmap (map $ bimap E.unValue (Left . E.unValue)) $
E.select $ E.from $ \ (holder `E.InnerJoin` topic) -> do
E.on $ holder E.^. SourceHolderGroupId E.==. topic E.^. SourceTopicGroupHolder
E.where_ $
holder E.^. SourceHolderGroupGroup E.==. E.val groupID E.&&.
topic E.^. SourceTopicGroupParent E.==. E.val parentID
return
( holder E.^. SourceHolderGroupSource
, topic E.^. SourceTopicGroupTopic
)
getExistingGroupSources groupID (Right parentID) =
fmap (map $ bimap E.unValue (Right . E.unValue)) $
E.select $ E.from $ \ (holder `E.InnerJoin` topic) -> do
E.on $ holder E.^. SourceHolderGroupSource E.==. topic E.^. SourceTopicRemoteSource
E.where_ $
holder E.^. SourceHolderGroupGroup E.==. E.val groupID E.&&.
topic E.^. SourceTopicRemoteTopic E.==. E.val parentID
return
( holder E.^. SourceHolderGroupSource
, topic E.^. SourceTopicRemoteId
)
verifySourcesNotEnabled sourceIDs = do
byEnabled <-
lift $ for sourceIDs $ \ (sourceID, _) ->
isJust <$> runMaybeT (trySourceEnabled sourceID)
case length $ filter id byEnabled of
0 -> return ()
1 -> throwE "I already have a SourceUsSendDelegator for this source"
_ -> error "Multiple SourceUsSendDelegator for a source"
where
trySourceEnabled sourceID =
const () <$> MaybeT (getBy $ UniqueSourceUsSendDelegator sourceID)
verifySourcesNotStarted sourceIDs = do
anyStarted <-
lift $ runMaybeT $ asum $
map (\ (sourceID, topic) ->
trySourceUs sourceID <|>
trySourceThem sourceID topic
)
sourceIDs
unless (isNothing anyStarted) $
throwE "One of the Source records is already in Add-Accept state"
where
trySourceUs sourceID = do
usID <- MaybeT $ getKeyBy $ UniqueSourceOriginUs sourceID
const () <$> MaybeT (getBy $ UniqueSourceUsAccept usID)
trySourceThem sourceID topic = do
_ <- MaybeT $ getBy $ UniqueSourceOriginThem sourceID
case topic of
Left localID ->
const () <$>
MaybeT (getBy $ UniqueSourceThemAcceptLocal localID)
Right remoteID ->
const () <$>
MaybeT (getBy $ UniqueSourceThemAcceptRemote remoteID)
verifyNoStartedProjectChildren
:: ProjectId -> Either (Entity Project) RemoteActorId -> ActDBE ()
verifyNoStartedProjectChildren projectID sourceDB = do
-- Find existing Source records I have for this source
sourceIDs <- lift $ getExistingProjectSources projectID sourceDB
-- 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)
verifySourcesNotEnabled sourceIDs
-- Verify none of the Source records are already in
-- Our-Add+Accept-waiting-for-them or Their-Add+Accept-waiting-for-us state
verifySourcesNotStarted sourceIDs
verifyNoStartedGroupParents
:: GroupId -> Either (Entity Group) RemoteActorId -> ActDBE ()
verifyNoStartedGroupParents groupID sourceDB = do
-- Find existing Source records I have for this source
sourceIDs <- lift $ getExistingGroupSources groupID sourceDB
-- 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)
verifySourcesNotEnabled sourceIDs
-- Verify none of the Source records are already in
-- Our-Add+Accept-waiting-for-them or Their-Add+Accept-waiting-for-us state
verifySourcesNotStarted sourceIDs
verifyNoEnabledProjectChildren
:: ProjectId -> Either (Entity Project) RemoteActorId -> ActDBE ()
verifyNoEnabledProjectChildren projectID sourceDB = do
-- Find existing Source records I have for this source
sourceIDs <- lift $ getExistingProjectSources projectID sourceDB
-- 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)
verifySourcesNotEnabled sourceIDs
verifyNoEnabledGroupParents
:: GroupId -> Either (Entity Group) RemoteActorId -> ActDBE ()
verifyNoEnabledGroupParents groupID sourceDB = do
-- Find existing Source records I have for this source
sourceIDs <- lift $ getExistingGroupSources groupID sourceDB
-- 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)
verifySourcesNotEnabled sourceIDs
getExistingProjectDests projectID (Left (Entity parentID _)) =
fmap (map $ bimap E.unValue (Left . E.unValue)) $
E.select $ E.from $ \ (holder `E.InnerJoin` topic) -> do
E.on $ holder E.^. DestHolderProjectId E.==. topic E.^. DestTopicProjectHolder
E.where_ $
holder E.^. DestHolderProjectProject E.==. E.val projectID E.&&.
topic E.^. DestTopicProjectParent E.==. E.val parentID
return
( holder E.^. DestHolderProjectDest
, topic E.^. DestTopicProjectTopic
)
getExistingProjectDests projectID (Right parentID) =
fmap (map $ bimap E.unValue (Right . E.unValue)) $
E.select $ E.from $ \ (holder `E.InnerJoin` topic) -> do
E.on $ holder E.^. DestHolderProjectDest E.==. topic E.^. DestTopicRemoteDest
E.where_ $
holder E.^. DestHolderProjectProject E.==. E.val projectID E.&&.
topic E.^. DestTopicRemoteTopic E.==. E.val parentID
return
( holder E.^. DestHolderProjectDest
, topic E.^. DestTopicRemoteId
)
getExistingGroupDests groupID (Left (Entity childID _)) =
fmap (map $ bimap E.unValue (Left . E.unValue)) $
E.select $ E.from $ \ (holder `E.InnerJoin` topic) -> do
E.on $ holder E.^. DestHolderGroupId E.==. topic E.^. DestTopicGroupHolder
E.where_ $
holder E.^. DestHolderGroupGroup E.==. E.val groupID E.&&.
topic E.^. DestTopicGroupChild E.==. E.val childID
return
( holder E.^. DestHolderGroupDest
, topic E.^. DestTopicGroupTopic
)
getExistingGroupDests groupID (Right childID) =
fmap (map $ bimap E.unValue (Right . E.unValue)) $
E.select $ E.from $ \ (holder `E.InnerJoin` topic) -> do
E.on $ holder E.^. DestHolderGroupDest E.==. topic E.^. DestTopicRemoteDest
E.where_ $
holder E.^. DestHolderGroupGroup E.==. E.val groupID E.&&.
topic E.^. DestTopicRemoteTopic E.==. E.val childID
return
( holder E.^. DestHolderGroupDest
, topic E.^. DestTopicRemoteId
)
verifyDestsNotEnabled destIDs = do
byEnabled <-
lift $ for destIDs $ \ (_, dest) ->
isJust <$> runMaybeT (tryDestEnabled dest)
case length $ filter id byEnabled of
0 -> return ()
1 -> throwE "I already have a DestThemSendDelegator* for this dest"
_ -> error "Multiple DestThemSendDelegator* for a dest"
where
tryDestEnabled (Left localID) =
const () <$>
MaybeT (getBy $ UniqueDestThemSendDelegatorLocalTopic localID)
tryDestEnabled (Right remoteID) =
const () <$>
MaybeT (getBy $ UniqueDestThemSendDelegatorRemoteTopic remoteID)
verifyDestsNotStarted destIDs = do
anyStarted <-
lift $ runMaybeT $ asum $
map (\ (destID, topic) ->
tryDestUs destID <|>
tryDestThem destID topic
)
destIDs
unless (isNothing anyStarted) $
throwE "One of the Dest records is already in Add-Accept state"
where
tryDestUs destID = do
_ <- MaybeT $ getBy $ UniqueDestOriginUs destID
const () <$> MaybeT (getBy $ UniqueDestUsAccept destID)
tryDestThem destID topic = do
_ <- MaybeT $ getBy $ UniqueDestOriginThem destID
case topic of
Left localID ->
const () <$>
MaybeT (getBy $ UniqueDestThemAcceptLocalTopic localID)
Right remoteID ->
const () <$>
MaybeT (getBy $ UniqueDestThemAcceptRemoteTopic remoteID)
verifyNoStartedProjectParents
:: ProjectId -> Either (Entity Project) RemoteActorId -> ActDBE ()
verifyNoStartedProjectParents projectID destDB = do
-- Find existing Dest records I have for this dest
destIDs <- lift $ getExistingProjectDests projectID destDB
-- 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)
verifyDestsNotEnabled destIDs
-- Verify none of the Dest records are already in
-- Our-Add+Accept-waiting-for-them or Their-Add+Accept-waiting-for-us state
verifyDestsNotStarted destIDs
verifyNoStartedGroupChildren
:: GroupId -> Either (Entity Group) RemoteActorId -> ActDBE ()
verifyNoStartedGroupChildren groupID destDB = do
-- Find existing Dest records I have for this dest
destIDs <- lift $ getExistingGroupDests groupID destDB
-- 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)
verifyDestsNotEnabled destIDs
-- Verify none of the Dest records are already in
-- Our-Add+Accept-waiting-for-them or Their-Add+Accept-waiting-for-us state
verifyDestsNotStarted destIDs
verifyNoEnabledProjectParents
:: ProjectId -> Either (Entity Project) RemoteActorId -> ActDBE ()
verifyNoEnabledProjectParents projectID destDB = do
-- Find existing Dest records I have for this dest
destIDs <- lift $ getExistingProjectDests projectID destDB
-- 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)
verifyDestsNotEnabled destIDs
verifyNoEnabledGroupChildren
:: GroupId -> Either (Entity Group) RemoteActorId -> ActDBE ()
verifyNoEnabledGroupChildren groupID destDB = do
-- Find existing Dest records I have for this dest
destIDs <- lift $ getExistingGroupDests groupID destDB
-- 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)
verifyDestsNotEnabled destIDs

11
src/Web/ActivityPub.hs
View file

@ -1,6 +1,6 @@
{- This file is part of Vervis.
-
- Written in 2019, 2020, 2021, 2022, 2023
- Written in 2019, 2020, 2021, 2022, 2023, 2024
- by fr33domlover <fr33domlover@riseup.net>.
-
- ♡ Copying is an act of love. Please copy, reuse and share.
@ -126,6 +126,7 @@ module Web.ActivityPub
, fetchAP
, fetchAP_T
, fetchAPID
, fetchAPID_T
, fetchAPID'
, fetchTip
, fetchRecipient
@ -1767,6 +1768,7 @@ data Add u = Add
{ addObject :: Either (ObjURI u) (AddObject u)
, addTarget :: ObjURI u
, addInstrument :: Role
, addContext :: Maybe (ObjURI u)
}
parseAdd :: UriMode u => Object -> Authority u -> Parser (Add u)
@ -1776,14 +1778,16 @@ parseAdd o h = Add
)
<*> o .: "target"
<*> o .: "instrument"
<*> o .:? "context"
encodeAdd :: UriMode u => Authority u -> Add u -> Series
encodeAdd h (Add obj target ins)
encodeAdd h (Add obj target ins context)
= case obj of
Left u -> "object" .= u
Right o -> "object" `pair` pairs (toSeries h o)
<> "target" .= target
<> "instrument" .= ins
<> "context" .=? context
data Apply u = Apply
{ applyObject :: ObjURI u
@ -2692,6 +2696,9 @@ fetchAPID m getId h lu = first showError <$> fetchAPID' m getId h lu
showError Nothing = "Object @id doesn't match the URI we fetched"
showError (Just e) = displayException e
fetchAPID_T :: (MonadIO m, UriMode u, ActivityPub a) => Manager -> (a u -> LocalURI) -> Authority u -> LocalURI -> ExceptT Text m (a u)
fetchAPID_T m getId h lu = ExceptT $ first T.pack <$> fetchAPID m getId h lu
data FetchAPError
= FetchAPErrorGet APGetError
-- Object @id doesn't match the URI we fetched