Port deckAdd to be a reusable componentAdd

src/Vervis/Actor/Common.hs

@@ -26,6 +26,7 @@ module Vervis.Actor.Common
     , topicJoin
     , topicCreateMe
     , componentGrant
+    , componentAdd
     )
 where
 
@@ -1887,3 +1888,217 @@ componentGrant grabResource topicComponent now recipKey (Verse authorIdMsig body
                 }
 
         return (action, recipientSet, remoteActors, fwdHosts)
+
+-- Meaning: An actor is adding some object to some target
+-- Behavior:
+--  * If the object is me:
+--      * Verify that the object is me
+--      * Verify the target is some project's components collection URI
+--      * Verify the Add is authorized
+--      * For all the Stem records I have for this project:
+--          * Verify I'm not yet a member of the project
+--          * Verify I haven't already Accepted an our-Add to this project
+--          * Verify I haven't already seen an them-Invite-and-Project-accept for
+--            this project
+--      * Insert the Add to my inbox
+--      * Create a Stem record in DB
+--      * Forward the Add activity to my followers
+--      * Send an Accept on the Add:
+--          * To:
+--              * The author of the Add
+--              * The project
+--          * CC:
+--              * Author's followers
+--              * Project's followers
+--              * My followers
+componentAdd
+    :: (PersistRecordBackend topic SqlBackend, ToBackendKey SqlBackend topic)
+    => (topic -> KomponentId)
+    -> (forall f. f topic -> ComponentBy f)
+    -> UTCTime
+    -> Key topic
+    -> Verse
+    -> AP.Add URIMode
+    -> ActE (Text, Act (), Next)
+componentAdd grabKomponent toComponent now meID (Verse authorIdMsig body) add = do
+
+    let meComponent = toComponent meID
+        meResource = componentResource meComponent
+        meActor = resourceToActor meResource
+
+    -- Check capability
+    capability <- do
+
+        -- Verify that a capability is provided
+        uCap <- do
+            let muCap = AP.activityCapability $ actbActivity body
+            fromMaybeE muCap "No capability provided"
+
+        -- Verify the capability URI is one of:
+        --   * Outbox item URI of a local actor, i.e. a local activity
+        --   * A remote URI
+        cap <- nameExceptT "Add capability" $ parseActivityURI' uCap
+
+        -- Verify the capability is local
+        case cap of
+            Left (actorByKey, _, outboxItemID) ->
+                return (actorByKey, outboxItemID)
+            _ -> throwE "Capability is remote i.e. definitely not by me"
+
+    -- Check input
+    projectComps <- do
+        let author = bimap (view _1) (remoteAuthorURI . view _1) authorIdMsig
+        (component, projectComps, role) <- parseAdd author add
+        unless (component == Left meActor) $
+            throwE "Add object isn't me"
+        unless (role == AP.RoleAdmin) $
+            throwE "Add role isn't admin"
+        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
+    -- 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.
+    projectDB <-
+        bitraverse
+            (withDBExcept . flip getEntityE "Project not found in DB")
+            (\ u@(ObjURI h luComps) -> do
+                manager <- asksEnv envHttpManager
+                collection <-
+                    ExceptT $ first T.pack <$>
+                        AP.fetchAPID
+                            manager
+                            (AP.collectionId :: AP.Collection FedURI URIMode -> LocalURI)
+                            h
+                            luComps
+                luProject <- fromMaybeE (AP.collectionContext collection) "Collection has no context"
+                project <-
+                    ExceptT $ first T.pack <$>
+                        AP.fetchAPID manager (AP.actorId . AP.actorLocal . AP.projectActor) h luProject
+                unless (AP.projectComponents project == luComps) $
+                    throwE "The collection isn't the project's components collection"
+
+                instanceID <-
+                    lift $ withDB $ either entityKey id <$> insertBy' (Instance h)
+                result <-
+                    ExceptT $ first (T.pack . displayException) <$>
+                        fetchRemoteActor' instanceID h luProject
+                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
+                        unless (remoteActorType (entityVal actor) == AP.ActorTypeProject) $
+                            throwE "Remote project type isn't Project"
+                        return $ entityKey actor
+            )
+            projectComps
+
+    meHash <- encodeKeyHashid meID
+    let meComponentHash = toComponent meHash
+        meResourceHash = componentResource meComponentHash
+        meActorHash = resourceToActor meResourceHash
+
+    maybeNew <- withDBExcept $ do
+
+        -- Grab me from DB
+        komponentID <- lift $ grabKomponent <$> getJust meID
+        Komponent resourceID <- lift $ getJust komponentID
+        Resource meActorID <- lift $ getJust resourceID
+        actor <- lift $ getJust meActorID
+
+        -- Find existing Stem records I have for this project
+        -- Make sure none are enabled / in Add-Accept mode / in Invite-Accept
+        -- mode
+        checkExistingStems komponentID projectDB
+
+        -- Verify the specified capability gives relevant access
+        verifyCapability' capability authorIdMsig meResource AP.RoleAdmin
+
+        -- Insert the Add to my inbox
+        mractid <- lift $ insertToInbox now authorIdMsig body (actorInbox actor) False
+        lift $ for mractid $ \ (inboxItemID, addDB) -> do
+
+            -- Create a Stem record in DB
+            acceptID <- insertEmptyOutboxItem' (actorOutbox actor) now
+            insertStem komponentID projectDB addDB acceptID
+
+            -- Prepare forwarding Add to my followers
+            let sieve = makeRecipientSet [] [localActorFollowers meActorHash]
+
+            -- Prepare an Accept activity and insert to my outbox
+            accept@(actionAccept, _, _, _) <- prepareAccept projectDB
+            _luAccept <- updateOutboxItem' meActor acceptID actionAccept
+
+            return (meActorID, sieve, acceptID, accept, inboxItemID)
+
+    case maybeNew of
+        Nothing -> done "I already have this activity in my inbox"
+        Just (actorID, sieve, acceptID, (actionAccept, localRecipsAccept, remoteRecipsAccept, fwdHostsAccept), inboxItemID) -> do
+            forwardActivity authorIdMsig body meActor actorID sieve
+            lift $ sendActivity
+                meActor actorID localRecipsAccept
+                remoteRecipsAccept fwdHostsAccept acceptID actionAccept
+            doneDB inboxItemID "Recorded and forwarded the Add, sent an Accept"
+
+    where
+
+    insertStem komponentID projectDB addDB acceptID = do
+        stemID <- insert $ Stem AP.RoleAdmin komponentID
+        case projectDB of
+            Left (Entity projectID _) ->
+                insert_ $ StemProjectLocal stemID projectID
+            Right remoteActorID ->
+                insert_ $ StemProjectRemote stemID remoteActorID
+        insert_ $ StemOriginAdd stemID
+        case addDB of
+            Left (_, _, addID) ->
+                insert_ $ StemComponentGestureLocal stemID addID
+            Right (author, _, addID) ->
+                insert_ $ StemComponentGestureRemote stemID (remoteAuthorId author) addID
+        insert_ $ StemComponentAccept stemID acceptID
+
+    prepareAccept projectDB = do
+        encodeRouteHome <- getEncodeRouteHome
+
+        audAdder <- makeAudSenderWithFollowers authorIdMsig
+        audProject <-
+            case projectDB of
+                Left (Entity j _) -> do
+                    jh <- encodeKeyHashid j
+                    return $
+                        AudLocal
+                            [LocalActorProject jh]
+                            [LocalStageProjectFollowers jh]
+                Right remoteActorID -> do
+                    ra <- getJust remoteActorID
+                    ObjURI h lu <- getRemoteActorURI ra
+                    return $ AudRemote h [lu] (maybeToList $ remoteActorFollowers ra)
+        audComponent <-
+            AudLocal [] . pure . localActorFollowers <$>
+                hashLocalActor (resourceToActor $ componentResource $ toComponent meID)
+        uAdd <- lift $ getActivityURI authorIdMsig
+
+        let (recipientSet, remoteActors, fwdHosts, audLocal, audRemote) =
+                collectAudience [audAdder, audProject, audComponent]
+
+            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)

src/Vervis/Actor/Deck.hs

@@ -105,182 +105,7 @@ deckAdd
     -> Verse
     -> AP.Add URIMode
     -> ActE (Text, Act (), Next)
-deckAdd now deckID (Verse authorIdMsig body) add = do
+deckAdd = componentAdd deckKomponent ComponentDeck
-
-    -- Check capability
-    capability <- do
-
-        -- Verify that a capability is provided
-        uCap <- do
-            let muCap = AP.activityCapability $ actbActivity body
-            fromMaybeE muCap "No capability provided"
-
-        -- Verify the capability URI is one of:
-        --   * Outbox item URI of a local actor, i.e. a local activity
-        --   * A remote URI
-        cap <- nameExceptT "Invite capability" $ parseActivityURI' uCap
-
-        -- Verify the capability is local
-        case cap of
-            Left (actorByKey, _, outboxItemID) ->
-                return (actorByKey, outboxItemID)
-            _ -> throwE "Capability is remote i.e. definitely not by me"
-
-    -- Check input
-    projectComps <- do
-        let author = bimap (view _1) (remoteAuthorURI . view _1) authorIdMsig
-        (component, projectComps, role) <- parseAdd author add
-        unless (component == Left (LocalActorDeck deckID)) $
-            throwE "Add object isn't me"
-        unless (role == AP.RoleAdmin) $
-            throwE "Add role isn't admin"
-        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
-    -- 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.
-    projectDB <-
-        bitraverse
-            (withDBExcept . flip getEntityE "Project not found in DB")
-            (\ u@(ObjURI h luComps) -> do
-                manager <- asksEnv envHttpManager
-                collection <-
-                    ExceptT $ first T.pack <$>
-                        AP.fetchAPID
-                            manager
-                            (AP.collectionId :: AP.Collection FedURI URIMode -> LocalURI)
-                            h
-                            luComps
-                luProject <- fromMaybeE (AP.collectionContext collection) "Collection has no context"
-                project <-
-                    ExceptT $ first T.pack <$>
-                        AP.fetchAPID manager (AP.actorId . AP.actorLocal . AP.projectActor) h luProject
-                unless (AP.projectComponents project == luComps) $
-                    throwE "The collection isn't the project's components collection"
-
-                instanceID <-
-                    lift $ withDB $ either entityKey id <$> insertBy' (Instance h)
-                result <-
-                    ExceptT $ first (T.pack . displayException) <$>
-                        fetchRemoteActor' instanceID h luProject
-                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
-                        unless (remoteActorType (entityVal actor) == AP.ActorTypeProject) $
-                            throwE "Remote project type isn't Project"
-                        return $ entityKey actor
-            )
-            projectComps
-
-    maybeNew <- withDBExcept $ do
-
-        -- Grab me from DB
-        (deck, actor) <- lift $ do
-            d <- getJust deckID
-            (d,) <$> getJust (deckActor d)
-
-        -- Find existing Stem records I have for this project
-        -- Make sure none are enabled / in Add-Accept mode / in Invite-Accept
-        -- mode
-        checkExistingStems (deckKomponent deck) projectDB
-
-        -- Verify the specified capability gives relevant access
-        verifyCapability'
-            capability authorIdMsig (LocalResourceDeck deckID) AP.RoleAdmin
-
-        -- Insert the Add to my inbox
-        mractid <- lift $ insertToInbox now authorIdMsig body (actorInbox actor) False
-        lift $ for mractid $ \ (inboxItemID, addDB) -> do
-
-            -- Create a Stem record in DB
-            acceptID <- insertEmptyOutboxItem' (actorOutbox actor) now
-            insertStem (deckKomponent deck) projectDB addDB acceptID
-
-            -- Prepare forwarding Add to my followers
-            sieve <- do
-                deckHash <- encodeKeyHashid deckID
-                return $ makeRecipientSet [] [LocalStageDeckFollowers deckHash]
-
-            -- Prepare an Accept activity and insert to my outbox
-            accept@(actionAccept, _, _, _) <- prepareAccept projectDB
-            _luAccept <- updateOutboxItem' (LocalActorDeck deckID) acceptID actionAccept
-
-            return (deckActor deck, sieve, acceptID, accept, inboxItemID)
-
-    case maybeNew of
-        Nothing -> done "I already have this activity in my inbox"
-        Just (actorID, sieve, acceptID, (actionAccept, localRecipsAccept, remoteRecipsAccept, fwdHostsAccept), inboxItemID) -> do
-            forwardActivity
-                authorIdMsig body (LocalActorDeck deckID) actorID sieve
-            lift $ sendActivity
-                (LocalActorDeck deckID) actorID localRecipsAccept
-                remoteRecipsAccept fwdHostsAccept acceptID actionAccept
-            doneDB inboxItemID "Recorded and forwarded the Add, sent an Accept"
-
-    where
-
-    insertStem komponentID projectDB addDB acceptID = do
-        stemID <- insert $ Stem AP.RoleAdmin komponentID
-        case projectDB of
-            Left (Entity projectID _) ->
-                insert_ $ StemProjectLocal stemID projectID
-            Right remoteActorID ->
-                insert_ $ StemProjectRemote stemID remoteActorID
-        insert_ $ StemOriginAdd stemID
-        case addDB of
-            Left (_, _, addID) ->
-                insert_ $ StemComponentGestureLocal stemID addID
-            Right (author, _, addID) ->
-                insert_ $ StemComponentGestureRemote stemID (remoteAuthorId author) addID
-        insert_ $ StemComponentAccept stemID acceptID
-
-    prepareAccept projectDB = do
-        encodeRouteHome <- getEncodeRouteHome
-
-        audAdder <- makeAudSenderWithFollowers authorIdMsig
-        audProject <-
-            case projectDB of
-                Left (Entity j _) -> do
-                    jh <- encodeKeyHashid j
-                    return $
-                        AudLocal
-                            [LocalActorProject jh]
-                            [LocalStageProjectFollowers jh]
-                Right remoteActorID -> do
-                    ra <- getJust remoteActorID
-                    ObjURI h lu <- getRemoteActorURI ra
-                    return $ AudRemote h [lu] (maybeToList $ remoteActorFollowers ra)
-        audComponent <-
-            AudLocal [] . pure . LocalStageDeckFollowers <$>
-                encodeKeyHashid deckID
-        uAdd <- lift $ getActivityURI authorIdMsig
-
-        let (recipientSet, remoteActors, fwdHosts, audLocal, audRemote) =
-                collectAudience [audAdder, audProject, audComponent]
-
-            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)
 
 -- Meaning: Someone has created a ticket tracker with my ID URI
 -- Behavior: