S2S: Project: Accept: Separate child and parent modes' code

src/Vervis/Actor/Project.hs

@@ -725,14 +725,12 @@ projectAccept now projectID (Verse authorIdMsig body) accept = do
                         remoteRecipsGrant fwdHostsGrant grantID actionGrant
                 doneDB inboxItemID "[Component mode] Forwarded the Accept and maybe published a Grant"
 
-    addChildParent cp = do
+    -- Add-a-child mode
+    addChildParent (Left (sourceID, topic, mode)) = do
 
-        idsForAccept <-
+        mode' <-
             bitraverse
 
-                -- Adding-a-new-child mode
-                (\ (sourceID, topic, mode) -> (sourceID,topic,) <$> bitraverse
-
                 -- Child-active mode
                 -- Verify we haven't yet seen child's Accept
                 (\ () -> do
@@ -777,55 +775,6 @@ projectAccept now projectID (Verse authorIdMsig body) accept = do
                 )
 
                 mode
-                )
-
-                -- Adding-a-new-parent mode
-                (\ (destID, topic, mode) -> case mode of
-
-                    -- Parent-active mode
-                    -- Respond with error, we aren't supposed to get any Accept
-                    Left () -> throwE "Parent-active (DestOriginUs) mode, I'm not expecting any Accept"
-
-                    -- Parent-passive mode
-                    -- Option 1: I haven't yet seen parent's Accept
-                    --   * Verify sender is the parent
-                    -- Option 2: I saw it, but not my collaborator's Accept
-                    --   * Verify the accept is authorized
-                    -- Otherwise respond with error, no Accept is needed
-                    Right themID -> (destID,themID,topic,) <$> do
-                        (maybeParentAccept, maybeUsGesture) <-
-                            lift $ withDB $ liftA2 (,)
-                                (case bimap fst fst topic of
-                                    Left localID -> (() <$) <$> getBy (UniqueDestThemAcceptLocalTopic localID)
-                                    Right remoteID -> (() <$) <$> getBy (UniqueDestThemAcceptRemoteTopic remoteID)
-                                )
-                                (do l <- getBy $ UniqueDestUsGestureLocal destID
-                                    r <- getBy $ UniqueDestUsGestureRemote destID
-                                    case (isJust l, isJust r) of
-                                        (False, False) -> pure Nothing
-                                        (False, True) -> pure $ Just ()
-                                        (True, False) -> pure $ Just ()
-                                        (True, True) -> error "Both DestUsGestureLocal and DestUsGestureRemote"
-                                )
-                        case (isJust maybeParentAccept, isJust maybeUsGesture) of
-                            (False, True) -> error "Impossible/bug, didn't see parent's Accept but recorded my collaborator's Accept"
-                            (False, False) -> do
-                                unless (theyIsAuthor topic) $
-                                    throwE "The Accept I'm waiting for is from my new parent"
-                                return $ Left ()
-                            (True, False) -> do
-                                let muCap = AP.activityCapability $ actbActivity body
-                                uCap <- fromMaybeE muCap "No capability provided"
-                                verifyCapability''
-                                    uCap
-                                    authorIdMsig
-                                    (LocalResourceProject projectID)
-                                    AP.RoleAdmin
-                                return $ Right ()
-                            (True, True) -> throwE "Just waiting for Grant from parent, or already have it, anyway not needing any further Accept"
-                )
-
-                cp
 
         maybeNew <- withDBExcept $ do
 
@@ -839,11 +788,9 @@ projectAccept now projectID (Verse authorIdMsig body) accept = do
             for maybeAcceptDB $ \ (inboxItemID, acceptDB) -> do
 
                 idsForGrant <-
+                    lift $
                     bitraverse
 
-                        -- Child mode
-                        (\ (sourceID, topic, mode) -> lift $ bitraverse
-
                         -- Child-active mode
                         -- If sender is child, record the Accept into the
                         -- Source record & prepare to send degelator-Grant
@@ -859,7 +806,7 @@ projectAccept now projectID (Verse authorIdMsig body) accept = do
                                         _ -> error "projectAccept impossible iv"
                                     grantID <- insertEmptyOutboxItem' (actorOutbox recipActor) now
                                     insert_ $ SourceUsSendDelegator sourceID grantID
-                                        return (topic, grantID)
+                                    return grantID
                                 else pure Nothing
                         )
 
@@ -891,14 +838,107 @@ projectAccept now projectID (Verse authorIdMsig body) accept = do
                                 -}
                                 grantID <- insertEmptyOutboxItem' (actorOutbox recipActor) now
                                 insert_ $ SourceUsSendDelegator sourceID grantID
-                                    return (topic, grantID)
+                                return grantID
                         )
 
-                            mode
+                        mode'
-                        )
+
+
+                -- Prepare forwarding of Accept to my followers
+                let recipByID = LocalActorProject projectID
+                recipByHash <- hashLocalActor recipByID
+                let sieve = makeRecipientSet [] [localActorFollowers recipByHash]
+
+                maybeAct <-
+                    case idsForGrant of
+                        Left mg -> for mg $ \ grantID -> lift $ do
+                            grant@(actionGrant, _, _, _) <-
+                                prepareSourceDelegGrant (bimap snd snd topic) False
+                            let recipByKey = LocalActorProject projectID
+                            _luGrant <- updateOutboxItem' recipByKey grantID actionGrant
+                            return (grantID, grant)
+
+                        Right mg -> for mg $ \ grantID -> lift $ do
+                            grant@(actionGrant, _, _, _) <-
+                                prepareSourceDelegGrant (bimap snd snd topic) True
+                            let recipByKey = LocalActorProject projectID
+                            _luGrant <- updateOutboxItem' recipByKey grantID actionGrant
+                            return (grantID, grant)
+
+                return (recipActorID, sieve, maybeAct, inboxItemID)
+
+        case maybeNew of
+            Nothing -> done "I already have this activity in my inbox"
+            Just (recipActorID, sieve, maybeGrant, inboxItemID) -> do
+                let recipByID = LocalActorProject projectID
+                forwardActivity authorIdMsig body recipByID recipActorID sieve
+                lift $ for_ maybeGrant $ \ (grantID, (actionGrant, localRecipsGrant, remoteRecipsGrant, fwdHostsGrant)) ->
+                    sendActivity
+                        recipByID recipActorID localRecipsGrant
+                        remoteRecipsGrant fwdHostsGrant grantID actionGrant
+                doneDB inboxItemID "[Child mode] Forwarded the Accept and maybe published a Grant/Accept"
+
+    -- Add-a-parent mode
+    addChildParent (Right (destID, topic, mode)) = do
+
+        (themID, mode') <-
+            case mode of
+
+                -- Parent-active mode
+                -- Respond with error, we aren't supposed to get any Accept
+                Left () -> throwE "Parent-active (DestOriginUs) mode, I'm not expecting any Accept"
 
                 -- Parent-passive mode
-                        (\ (destID, themID, topic, mode) -> lift $ case mode of
+                -- Option 1: I haven't yet seen parent's Accept
+                --   * Verify sender is the parent
+                -- Option 2: I saw it, but not my collaborator's Accept
+                --   * Verify the accept is authorized
+                -- Otherwise respond with error, no Accept is needed
+                Right themID -> (themID,) <$> do
+                    (maybeParentAccept, maybeUsGesture) <-
+                        lift $ withDB $ liftA2 (,)
+                            (case bimap fst fst topic of
+                                Left localID -> (() <$) <$> getBy (UniqueDestThemAcceptLocalTopic localID)
+                                Right remoteID -> (() <$) <$> getBy (UniqueDestThemAcceptRemoteTopic remoteID)
+                            )
+                            (do l <- getBy $ UniqueDestUsGestureLocal destID
+                                r <- getBy $ UniqueDestUsGestureRemote destID
+                                case (isJust l, isJust r) of
+                                    (False, False) -> pure Nothing
+                                    (False, True) -> pure $ Just ()
+                                    (True, False) -> pure $ Just ()
+                                    (True, True) -> error "Both DestUsGestureLocal and DestUsGestureRemote"
+                            )
+                    case (isJust maybeParentAccept, isJust maybeUsGesture) of
+                        (False, True) -> error "Impossible/bug, didn't see parent's Accept but recorded my collaborator's Accept"
+                        (False, False) -> do
+                            unless (theyIsAuthor topic) $
+                                throwE "The Accept I'm waiting for is from my new parent"
+                            return $ Left ()
+                        (True, False) -> do
+                            let muCap = AP.activityCapability $ actbActivity body
+                            uCap <- fromMaybeE muCap "No capability provided"
+                            verifyCapability''
+                                uCap
+                                authorIdMsig
+                                (LocalResourceProject projectID)
+                                AP.RoleAdmin
+                            return $ Right ()
+                        (True, True) -> throwE "Just waiting for Grant from parent, or already have it, anyway not needing any further Accept"
+
+        maybeNew <- withDBExcept $ do
+
+            -- Grab me from DB
+            (recipActorID, recipActor) <- lift $ do
+                recip <- getJust projectID
+                let actorID = projectActor recip
+                (actorID,) <$> getJust actorID
+
+            maybeAcceptDB <- lift $ insertToInbox now authorIdMsig body (actorInbox recipActor) False
+            for maybeAcceptDB $ \ (inboxItemID, acceptDB) -> do
+
+                idsForGrant <-
+                    lift $ case mode' of
 
                         -- Getting an Accept from the parent
                         -- Record parent's Accept in the Dest record
@@ -922,11 +962,7 @@ projectAccept now projectID (Verse authorIdMsig body) accept = do
                                     insert_ $ DestUsGestureRemote destID (remoteAuthorId author) acceptID
                             acceptID <- insertEmptyOutboxItem' (actorOutbox recipActor) now
                             insert_ $ DestUsAccept destID acceptID
-                                return (topic, acceptID)
+                            return acceptID
-                        )
-
-                        idsForAccept
-
 
                 -- Prepare forwarding of Accept to my followers
                 let recipByID = LocalActorProject projectID
@@ -934,22 +970,7 @@ projectAccept now projectID (Verse authorIdMsig body) accept = do
                 let sieve = makeRecipientSet [] [localActorFollowers recipByHash]
 
                 maybeAct <-
-                    case idsForGrant of
+                    for idsForGrant $ \ acceptID -> lift $ do
-                        Left (Left mg) -> for mg $ \ (topic, grantID) -> lift $ do
-                            grant@(actionGrant, _, _, _) <-
-                                prepareSourceDelegGrant (bimap snd snd topic) False
-                            let recipByKey = LocalActorProject projectID
-                            _luGrant <- updateOutboxItem' recipByKey grantID actionGrant
-                            return (grantID, grant)
-
-                        Left (Right mg) -> for mg $ \ (topic, grantID) -> lift $ do
-                            grant@(actionGrant, _, _, _) <-
-                                prepareSourceDelegGrant (bimap snd snd topic) True
-                            let recipByKey = LocalActorProject projectID
-                            _luGrant <- updateOutboxItem' recipByKey grantID actionGrant
-                            return (grantID, grant)
-
-                        Right ma -> for ma $ \ (topic, acceptID) -> lift $ do
                         accept@(actionAccept, _, _, _) <-
                             prepareDestAccept (bimap snd snd topic)
                         let recipByKey = LocalActorProject projectID
@@ -967,7 +988,7 @@ projectAccept now projectID (Verse authorIdMsig body) accept = do
                     sendActivity
                         recipByID recipActorID localRecipsGrant
                         remoteRecipsGrant fwdHostsGrant grantID actionGrant
-                doneDB inboxItemID "[Child/Parent mode] Forwarded the Accept and maybe published a Grant/Accept"
+                doneDB inboxItemID "[Parent mode] Forwarded the Accept and maybe published a Grant/Accept"
 
     prepareCollabGrant isInvite sender role = do
         encodeRouteHome <- getEncodeRouteHome