From bce8079cb5f3b8a328561a19bf4e470c999c7bef Mon Sep 17 00:00:00 2001 From: Pere Lev Date: Thu, 1 Feb 2024 16:51:52 +0200 Subject: [PATCH] S2S: Project: Add: Handle adding a child/parent; also update C2S Add --- src/Vervis/Actor/Deck.hs | 10 +- src/Vervis/Actor/Person/Client.hs | 62 ++- src/Vervis/Actor/Project.hs | 718 +++++++++++++++++++++++++----- src/Vervis/Data/Collab.hs | 72 ++- src/Vervis/Persist/Collab.hs | 294 +++++++++++- src/Web/ActivityPub.hs | 11 +- 6 files changed, 1000 insertions(+), 167 deletions(-) diff --git a/src/Vervis/Actor/Deck.hs b/src/Vervis/Actor/Deck.hs index cd90ee9..8b8a9d5 100644 --- a/src/Vervis/Actor/Deck.hs +++ b/src/Vervis/Actor/Deck.hs @@ -1,6 +1,7 @@ {- This file is part of Vervis. - - - Written in 2019, 2020, 2022, 2023 by fr33domlover . + - Written in 2019, 2020, 2022, 2023, 2024 + - by fr33domlover . - - ♡ 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 diff --git a/src/Vervis/Actor/Person/Client.hs b/src/Vervis/Actor/Person/Client.hs index 8db73f2..144488c 100644 --- a/src/Vervis/Actor/Person/Client.hs +++ b/src/Vervis/Actor/Person/Client.hs @@ -1,6 +1,6 @@ {- This file is part of Vervis. - - - Written in 2023 by fr33domlover . + - Written in 2023, 2024 by fr33domlover . - - ♡ 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 diff --git a/src/Vervis/Actor/Project.hs b/src/Vervis/Actor/Project.hs index 65ea074..ec1205d 100644 --- a/src/Vervis/Actor/Project.hs +++ b/src/Vervis/Actor/Project.hs @@ -1,6 +1,6 @@ {- This file is part of Vervis. - - - Written in 2023 by fr33domlover . + - Written in 2023, 2024 by fr33domlover . - - ♡ 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,16 +696,66 @@ checkExistingComponents projectID componentDB = do -- Meaning: An actor is adding some object to some target -- Behavior: --- * Verify my components list is the target --- * 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 +-- * 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 +-- +-- * 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,104 +764,559 @@ 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" - unless (role == AP.RoleAdmin) $ - throwE "Add role isn't admin" - return component - - -- If component is local, find it in our DB - -- If component is remote, HTTP GET it, verify it's an actor of a component - -- 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. - componentDB <- - bitraverse - (withDBExcept . flip getComponentE "Component 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 "Target @id mismatch" - Left (Just err) -> throwE $ T.pack $ displayException err - Right Nothing -> throwE "Target isn't an actor" - Right (Just actor) -> do - case remoteActorType $ entityVal actor of - AP.ActorTypeRepo -> pure () - AP.ActorTypeTicketTracker -> pure () - AP.ActorTypePatchTracker -> pure () - _ -> throwE "Remote component type isn't repo/tt/pt" - return $ entityKey actor - ) - component - - maybeNew <- withDBExcept $ do - - -- Grab me from DB - (project, actorRecip) <- lift $ do - p <- getJust projectID - (p,) <$> getJust (projectActor p) - - -- Find existing Component records I have for this component - -- Make sure none are enabled / in Add-Accept mode / in Invite-Accept - -- mode - checkExistingComponents projectID componentDB - - -- Insert the Add to my inbox - mractid <- lift $ insertToInbox now authorIdMsig body (actorInbox actorRecip) False - lift $ for mractid $ \ addDB -> do - - -- Create a Component record in DB - insertComponent componentDB addDB - - return $ projectActor project - - case maybeNew of - Nothing -> done "I already have this activity in my inbox" - Just actorID -> do - projectHash <- encodeKeyHashid projectID - let sieve = - makeRecipientSet - [] - [LocalStageProjectFollowers projectHash] - forwardActivity - authorIdMsig body (LocalActorProject projectID) actorID sieve - done - "Recorded a Component record; Inserted the Add to inbox; \ - \Forwarded to followers if addressed" + let author = bimap (view _1) (remoteAuthorURI . view _1) authorIdMsig + (object, target, role) <- parseAdd author add + unless (role == AP.RoleAdmin) $ + throwE "Add role isn't admin" + 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 - insertComponent componentDB addDB = do - componentID <- insert $ Component projectID AP.RoleAdmin - originID <- insert $ ComponentOriginAdd componentID - case addDB of - Left (_, _, addID) -> - insert_ $ ComponentGestureLocal originID addID - Right (author, _, addID) -> - insert_ $ ComponentGestureRemote originID (remoteAuthorId author) addID - case componentDB of - Left l -> do - identID <- insert $ ComponentLocal componentID - case l of - ComponentRepo (Entity repoID _) -> - insert_ $ ComponentLocalRepo identID repoID - ComponentDeck (Entity deckID _) -> - insert_ $ ComponentLocalDeck identID deckID - ComponentLoom (Entity loomID _) -> - insert_ $ ComponentLocalLoom identID loomID - Right remoteActorID -> - insert_ $ ComponentRemote componentID remoteActorID + 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 + -- 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. + componentDB <- + bitraverse + (withDBExcept . flip getComponentE "Component 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 "Target @id mismatch" + Left (Just err) -> throwE $ T.pack $ displayException err + Right Nothing -> throwE "Target isn't an actor" + Right (Just actor) -> do + case remoteActorType $ entityVal actor of + AP.ActorTypeRepo -> pure () + AP.ActorTypeTicketTracker -> pure () + AP.ActorTypePatchTracker -> pure () + _ -> throwE "Remote component type isn't repo/tt/pt" + return $ entityKey actor + ) + component + + maybeNew <- withDBExcept $ do + + -- Grab me from DB + (project, actorRecip) <- lift $ do + p <- getJust projectID + (p,) <$> getJust (projectActor p) + + -- Find existing Component records I have for this component + -- Make sure none are enabled / in Add-Accept mode / in Invite-Accept + -- mode + checkExistingComponents projectID componentDB + + -- Insert the Add to my inbox + mractid <- lift $ insertToInbox now authorIdMsig body (actorInbox actorRecip) False + lift $ for mractid $ \ addDB -> do + + -- Create a Component record in DB + insertComponent componentDB addDB + + return $ projectActor project + + case maybeNew of + Nothing -> done "I already have this activity in my inbox" + Just actorID -> do + projectHash <- encodeKeyHashid projectID + let sieve = + makeRecipientSet + [] + [LocalStageProjectFollowers projectHash] + forwardActivity + authorIdMsig body (LocalActorProject projectID) actorID sieve + done + "Recorded a Component record; Inserted the Add to inbox; \ + \Forwarded to followers if addressed" + + where + + insertComponent componentDB addDB = do + componentID <- insert $ Component projectID AP.RoleAdmin + originID <- insert $ ComponentOriginAdd componentID + case addDB of + Left (_, _, addID) -> + insert_ $ ComponentGestureLocal originID addID + Right (author, _, addID) -> + insert_ $ ComponentGestureRemote originID (remoteAuthorId author) addID + case componentDB of + Left l -> do + identID <- insert $ ComponentLocal componentID + case l of + ComponentRepo (Entity repoID _) -> + insert_ $ ComponentLocalRepo identID repoID + ComponentDeck (Entity deckID _) -> + insert_ $ ComponentLocalDeck identID deckID + ComponentLoom (Entity loomID _) -> + insert_ $ ComponentLocalLoom identID loomID + 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: diff --git a/src/Vervis/Data/Collab.hs b/src/Vervis/Data/Collab.hs index 4d094d9..2898aec 100644 --- a/src/Vervis/Data/Collab.hs +++ b/src/Vervis/Data/Collab.hs @@ -1,6 +1,6 @@ {- This file is part of Vervis. - - - Written in 2022, 2023 by fr33domlover . + - Written in 2022, 2023, 2024 by fr33domlover . - - ♡ 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 diff --git a/src/Vervis/Persist/Collab.hs b/src/Vervis/Persist/Collab.hs index aeb816b..9668566 100644 --- a/src/Vervis/Persist/Collab.hs +++ b/src/Vervis/Persist/Collab.hs @@ -1,6 +1,6 @@ {- This file is part of Vervis. - - - Written in 2022, 2023 by fr33domlover . + - Written in 2022, 2023, 2024 by fr33domlover . - - ♡ 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 diff --git a/src/Web/ActivityPub.hs b/src/Web/ActivityPub.hs index 104bcd8..099ebde 100644 --- a/src/Web/ActivityPub.hs +++ b/src/Web/ActivityPub.hs @@ -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 . - - ♡ 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