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

src/Vervis/Actor/Deck.hs

@@ -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

src/Vervis/Actor/Person/Client.hs

@@ -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 C is local, verify it exists in DB
---          * If project 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
+    -- If target objects 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
+    -- 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
+                AP.ResourceWithCollections _ _ _ _ <- ExceptT $ liftIO $ first (T.pack . show) <$> AP.fetchRWC manager h lu
-                unless (mluComps == Just luComps) $
-                    throwE "Add target isn't a components list"
 
                 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
+            targetHash <- bitraverse (hashLocalActor . addTargetActor) pure target
-            componentHash <- bitraverse hashComponent pure component
+            objectHash <- bitraverse hashLocalActor pure object
             senderHash <- encodeKeyHashid personMeID
             let sieveActors = catMaybes
-                    [ case projectHash of
+                    [ case targetHash of
-                        Left j -> Just $ LocalActorProject j
+                        Left a -> Just a
                         Right _ -> Nothing
-                    , case componentHash of
+                    , case objectHash of
-                        Left c -> Just $ componentActor c
+                        Left c -> Just c
                         Right _ -> Nothing
                     ]
                 sieveStages = catMaybes
                     [ Just $ LocalStagePersonFollowers senderHash
-                    , case projectHash of
+                    , case targetHash of
-                        Left j -> Just $ LocalStageProjectFollowers j
+                        Left a -> Just $ localActorFollowers a
                         Right _ -> Nothing
-                    , case componentHash of
+                    , case objectHash of
-                        Left c -> Just $ localActorFollowers $ componentActor c
+                        Left c -> Just $ localActorFollowers c
                         Right _ -> Nothing
                     ]
             return $ makeRecipientSet sieveActors sieveStages

src/Vervis/Actor/Project.hs

@@ -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,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
+--      * If the target is my components list:
---     * Verify the object is a component, find in DB/HTTP
+--        * Verify the object is a component, find in DB/HTTP
---     * Verify it's not already an active component of mine
+--        * Verify it's not already an active component of mine
---     * Verify it's not already in a Add-Accept process waiting for project
+--        * Verify it's not already in a Add-Accept process waiting for project
---       collab to accept too
+--          collab to accept too
---     * Verify it's not already in an Invite-Accept process waiting for
+--        * Verify it's not already in an Invite-Accept process waiting for
---       component (or its collaborator) to accept too
+--          component (or its collaborator) to accept too
---     * Insert the Add to my inbox
+--        * Insert the Add to my inbox
---     * Create a Component record in DB
+--        * Create a Component record in DB
---     * Forward the Add to my followers
+--        * 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
+    let author = bimap (view _1) (remoteAuthorURI . view _1) authorIdMsig
-    component <- do
+    (object, target, role) <- parseAdd author add
-        let author = bimap (view _1) (remoteAuthorURI . view _1) authorIdMsig
+    unless (role == AP.RoleAdmin) $
-        (component, projectComps, role) <- parseAdd author add
+        throwE "Add role isn't admin"
-        unless (projectComps == Left projectID) $
+    case (target, object) of
-            throwE "Add target isn't my components collection"
+        (Left (ATProjectComponents j), _)| j == projectID -> do
-        unless (role == AP.RoleAdmin) $
+            comp <-
-            throwE "Add role isn't admin"
+                bitraverse
-        return component
+                    (\ la -> fromMaybeE (actorToComponent la) "Not a component")
-
+                    pure
-    -- If component is local, find it in our DB
+                    object
-    -- If component is remote, HTTP GET it, verify it's an actor of a component
+            addComponent comp
-    -- type, and store in our DB (if it's already there, no need for HTTP)
+        (Left (ATProjectChildren j), _) | j == projectID ->
-    --
+            addChildActive object
-    -- NOTE: This is a blocking HTTP GET done right here in the handler,
+        (Left (ATProjectParents j), _) | j == projectID ->
-    -- which is NOT a good idea. Ideally, it would be done async, and the
+            addParentActive object
-    -- handler result would be sent later in a separate (e.g. Accept) activity.
+        (_, Left (LocalActorProject j)) | j == projectID ->
-    -- But for the PoC level, the current situation will hopefully do.
+            case target of
-    componentDB <-
+                Left (ATProjectParents j) | j /= projectID ->
-        bitraverse
+                    addChildPassive $ Left j
-            (withDBExcept . flip getComponentE "Component not found in DB")
+                Left (ATProjectChildren j) | j /= projectID ->
-            (\ u@(ObjURI h lu) -> do
+                    addParentPassive $ Left j
-                instanceID <-
+                Right (ObjURI h luColl) -> do
-                    lift $ withDB $ either entityKey id <$> insertBy' (Instance h)
+                    -- NOTE this is HTTP GET done synchronously in the activity
-                result <-
+                    -- handler
-                    ExceptT $ first (T.pack . displayException) <$>
+                    manager <- asksEnv envHttpManager
-                        fetchRemoteActor' instanceID h lu
+                    c <- AP.fetchAPID_T manager (AP.collectionId :: AP.Collection FedURI URIMode -> LocalURI) h luColl
-                case result of
+                    lu <- fromMaybeE (AP.collectionContext c) "No context"
-                    Left Nothing -> throwE "Target @id mismatch"
+                    j <- AP.fetchAPID_T manager (AP.actorId . AP.actorLocal . AP.projectActor) h lu
-                    Left (Just err) -> throwE $ T.pack $ displayException err
+                    case (luColl == AP.projectChildren j, luColl == AP.projectParents j) of
-                    Right Nothing -> throwE "Target isn't an actor"
+                        (True, False) ->
-                    Right (Just actor) -> do
+                            addParentPassive $ Right $ ObjURI h lu
-                        case remoteActorType $ entityVal actor of
+                        (False, True) ->
-                            AP.ActorTypeRepo -> pure ()
+                            addChildPassive $ Right $ ObjURI h lu
-                            AP.ActorTypeTicketTracker -> pure ()
+                        _ -> throwE "Weird collection situation"
-                            AP.ActorTypePatchTracker -> pure ()
+                _ -> throwE "I'm being added somewhere irrelevant"
-                            _ -> throwE "Remote component type isn't repo/tt/pt"
+        _ -> throwE "This Add isn't for me"
-                        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
+    addComponent component = do
-        componentID <- insert $ Component projectID AP.RoleAdmin
+
-        originID <- insert $ ComponentOriginAdd componentID
+        -- If component is local, find it in our DB
-        case addDB of
+        -- If component is remote, HTTP GET it, verify it's an actor of a component
-            Left (_, _, addID) ->
+        -- type, and store in our DB (if it's already there, no need for HTTP)
-                insert_ $ ComponentGestureLocal originID addID
+        --
-            Right (author, _, addID) ->
+        -- NOTE: This is a blocking HTTP GET done right here in the handler,
-                insert_ $ ComponentGestureRemote originID (remoteAuthorId author) addID
+        -- which is NOT a good idea. Ideally, it would be done async, and the
-        case componentDB of
+        -- handler result would be sent later in a separate (e.g. Accept) activity.
-            Left l -> do
+        -- But for the PoC level, the current situation will hopefully do.
-                identID <- insert $ ComponentLocal componentID
+        componentDB <-
-                case l of
+            bitraverse
-                    ComponentRepo (Entity repoID _) ->
+                (withDBExcept . flip getComponentE "Component not found in DB")
-                        insert_ $ ComponentLocalRepo identID repoID
+                (\ u@(ObjURI h lu) -> do
-                    ComponentDeck (Entity deckID _) ->
+                    instanceID <-
-                        insert_ $ ComponentLocalDeck identID deckID
+                        lift $ withDB $ either entityKey id <$> insertBy' (Instance h)
-                    ComponentLoom (Entity loomID _) ->
+                    result <-
-                        insert_ $ ComponentLocalLoom identID loomID
+                        ExceptT $ first (T.pack . displayException) <$>
-            Right remoteActorID ->
+                            fetchRemoteActor' instanceID h lu
-                insert_ $ ComponentRemote componentID remoteActorID
+                    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:

src/Vervis/Data/Collab.hs

@@ -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 (LocalActorBy Key) FedURI
-        , Either ProjectId 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) ->
+        Left t | sender == Left (targetActor t) ->
-            throwE "Sender and project are the same"
+            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
+        bitraverse parseLocalActorE' pure routeOrRemote
-            (\ route -> do
+    parseCollection u = do
-                componentHash <-
-                    fromMaybeE
-                        (parseComponent route)
-                        "Not a component route"
-                unhashComponentE
-                    componentHash
-                    "Contains invalid hashid"
-            )
-            pure
-            routeOrRemote
-    parseProjectComps u = do
         routeOrRemote <- parseFedURI u
         bitraverse
             (\case
-                ProjectComponentsR j -> WAP.decodeKeyHashidE j "Inavlid hashid"
+                ProjectComponentsR j ->
-                _ -> throwE "Not a project components collection route"
+                    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

src/Vervis/Persist/Collab.hs

@@ -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

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 <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