Deck: Port Join handler

2023-06-09 09:40:10 +03:00 · 2023-06-09 09:40:10 +03:00 · 59e99f405a
commit 59e99f405a
parent 85f77fcac4
5 changed files with 125 additions and 84 deletions
--- a/src/Vervis/Actor.hs
+++ b/src/Vervis/Actor.hs
@ -335,6 +335,9 @@ data Event
    -- ^ An authorized remote actor sent an Invite-to-a-local-topic, and the
    --   local topic is forwarding the Invite to me because I'm following the
    --   topic
+    | EventRemoteJoinLocalTopicFwdToFollower RemoteActivityId
+    -- ^ A remote actor asked to Join a local topic, and the local topic is
+    --   forwarding the Join to me because I'm following the topic
    | EventUnknown
    deriving Show

--- a/src/Vervis/Actor/Common.hs
+++ b/src/Vervis/Actor/Common.hs
@ -20,6 +20,7 @@ module Vervis.Actor.Common
    , topicAccept
    , topicReject
    , topicInvite
+    , topicJoin
    )
 where

@ -821,3 +822,85 @@ topicInvite grabActor topicResource topicField topicCollabField collabTopicCtor
                insert_ $ CollabRecipLocal collabID personID
            Right remoteActorID ->
                insert_ $ CollabRecipRemote collabID remoteActorID
+
+topicJoin
+    :: ( PersistRecordBackend topic SqlBackend, ToBackendKey SqlBackend topic
+       , PersistRecordBackend ct SqlBackend
+       )
+    => (topic -> ActorId)
+    -> (forall f. f topic -> GrantResourceBy f)
+    -> EntityField ct (Key topic)
+    -> EntityField ct CollabId
+    -> (CollabId -> Key topic -> ct)
+    -> UTCTime
+    -> Key topic
+    -> RemoteAuthor
+    -> ActivityBody
+    -> Maybe (RecipientRoutes, ByteString)
+    -> LocalURI
+    -> AP.Join URIMode
+    -> ActE (Text, Act (), Next)
+topicJoin grabActor topicResource topicField topicCollabField collabTopicCtor now topicKey author body mfwd luJoin join = do
+
+    -- Check input
+    resource <- parseJoin join
+    unless (resource == Left (topicResource topicKey)) $
+        throwE "Join's object isn't me, don't need this Join"
+
+    maybeNew <- withDBExcept $ do
+
+        -- Grab topic from DB
+        (topicActorID, topicActor) <- lift $ do
+            recip <- getJust topicKey
+            let actorID = grabActor recip
+            (actorID,) <$> getJust actorID
+
+        -- Verify that target doesn't already have a Collab for me
+        existingCollabIDs <- lift $ do
+            let targetID = remoteAuthorId author
+            E.select $ E.from $ \ (topic `E.InnerJoin` recipr) -> do
+                E.on $
+                    topic E.^. topicCollabField E.==.
+                    recipr E.^. CollabRecipRemoteCollab
+                E.where_ $
+                    topic E.^. topicField E.==. E.val topicKey E.&&.
+                    recipr E.^. CollabRecipRemoteActor E.==. E.val targetID
+                return $ recipr E.^. CollabRecipRemoteCollab
+        case existingCollabIDs of
+            [] -> pure ()
+            [_] -> throwE "I already have a Collab for the target"
+            _ -> error "Multiple collabs found for target"
+
+        mractid <- lift $ insertToInbox now author body (actorInbox topicActor) luJoin False
+        lift $ for mractid $ \ joinID -> do
+
+            -- Insert Collab record to DB
+            insertCollab joinID
+
+            -- Prepare forwarding Join to my followers
+            sieve <- do
+                topicHash <- encodeKeyHashid topicKey
+                let topicByHash =
+                        grantResourceLocalActor $ topicResource topicHash
+                return $ makeRecipientSet [] [localActorFollowers topicByHash]
+            return (topicActorID, joinID, sieve)
+
+    case maybeNew of
+        Nothing -> done "I already have this activity in my inbox"
+        Just (topicActorID, joinID, sieve) -> do
+            let topicByID = grantResourceLocalActor $ topicResource topicKey
+            lift $ for_ mfwd $ \ (localRecips, sig) -> do
+                forwardActivity
+                    (actbBL body) localRecips sig topicActorID topicByID sieve
+                    (EventRemoteJoinLocalTopicFwdToFollower joinID)
+            done "Recorded and forwarded the Join"
+
+    where
+
+    insertCollab joinID = do
+        collabID <- insert Collab
+        fulfillsID <- insert $ CollabFulfillsJoin collabID
+        insert_ $ collabTopicCtor collabID topicKey
+        let authorID = remoteAuthorId author
+        recipID <- insert $ CollabRecipRemote collabID authorID
+        insert_ $ CollabRecipRemoteJoin recipID fulfillsID joinID
--- a/src/Vervis/Actor/Deck.hs
+++ b/src/Vervis/Actor/Deck.hs
@ -171,7 +171,6 @@ deckReject
    -> ActE (Text, Act (), Next)
 deckReject = topicReject deckActor GrantResourceDeck

-
 -- Meaning: A remote actor A invited someone B to a resource
 -- Behavior:
 --      * Verify the resource is me
@ -194,6 +193,26 @@ deckInvite =
        deckActor GrantResourceDeck
        CollabTopicDeckDeck CollabTopicDeckCollab CollabTopicDeck

+-- Meaning: A remote actor A asked to join a resource
+-- Behavior:
+--      * Verify the resource is me
+--      * Verify A doesn't already have an invite/join/grant for me
+--      * Remember the join in DB
+--      * Forward the Join to my followers
+deckJoin
+    :: UTCTime
+    -> DeckId
+    -> RemoteAuthor
+    -> ActivityBody
+    -> Maybe (RecipientRoutes, ByteString)
+    -> LocalURI
+    -> AP.Join URIMode
+    -> ActE (Text, Act (), Next)
+deckJoin =
+    topicJoin
+        deckActor GrantResourceDeck
+        CollabTopicDeckDeck CollabTopicDeckCollab CollabTopicDeck
+
 ------------------------------------------------------------------------------
 -- Ambiguous: Following/Resolving
 ------------------------------------------------------------------------------
@ -417,6 +436,8 @@ deckBehavior now deckID (Right (VerseRemote author body mfwd luActivity)) =
            deckFollow now deckID author body mfwd luActivity follow
        AP.InviteActivity invite ->
            deckInvite now deckID author body mfwd luActivity invite
+        AP.JoinActivity join ->
+            deckJoin now deckID author body mfwd luActivity join
        AP.RejectActivity reject ->
            deckReject now deckID author body mfwd luActivity reject
        AP.UndoActivity undo ->
--- a/src/Vervis/Actor/Person.hs
+++ b/src/Vervis/Actor/Person.hs
@ -710,6 +710,19 @@ personBehavior now personID (Left event) =
                itemID <- insert $ InboxItem True now
                insert_ $ InboxItemRemote inboxID inviteID itemID
            done "Inserted Invite to inbox"
+        -- Meaning: A remote actor sent a Join on a local resource, I'm being
+        -- forwarded as a follower of the resource
+        --
+        -- Behavior: Insert the Join to my inbox
+        EventRemoteJoinLocalTopicFwdToFollower joinID -> do
+            lift $ withDB $ do
+                (_personRecip, actorRecip) <- do
+                    p <- getJust personID
+                    (p,) <$> getJust (personActor p)
+                let inboxID = actorInbox actorRecip
+                itemID <- insert $ InboxItem True now
+                insert_ $ InboxItemRemote inboxID joinID itemID
+            done "Inserted Invite to inbox"
        _ -> throwE $ "Unsupported event for Person: " <> T.pack (show event)
 personBehavior now personID (Right (VerseRemote author body mfwd luActivity)) =
    case AP.activitySpecific $ actbActivity body of
--- a/src/Vervis/Federation/Collab.hs
+++ b/src/Vervis/Federation/Collab.hs
@ -19,9 +19,9 @@ module Vervis.Federation.Collab
    ( --personInviteF
      --topicInviteF

-      repoJoinF
-    , deckJoinF
-    , loomJoinF
+     -- repoJoinF
+    --, deckJoinF
+    --, loomJoinF

    --, repoAcceptF
    --, deckAcceptF
@ -90,87 +90,7 @@ import Vervis.Persist.Collab
 import Vervis.Recipient
 import Vervis.RemoteActorStore

-topicJoinF
-    :: (PersistRecordBackend topic SqlBackend, ToBackendKey SqlBackend topic)
-    => (topic -> ActorId)
-    -> (forall f. f topic -> GrantResourceBy f)
-    -> UTCTime
-    -> KeyHashid topic
-    -> RemoteAuthor
-    -> ActivityBody
-    -> Maybe (RecipientRoutes, ByteString)
-    -> LocalURI
-    -> AP.Join URIMode
-    -> ExceptT Text Handler (Text, Maybe (ExceptT Text Worker Text))
-topicJoinF topicActor topicResource now recipHash author body mfwd luJoin join = (,Nothing) <$> do
-    error "Temporarily disabled due to switch to new actor system"
 {-
-    -- Check input
-    recipKey <- decodeKeyHashid404 recipHash
-    verifyNothingE
-        (AP.activityCapability $ actbActivity body)
-        "Capability not needed"
-    resource <- parseJoin join
-    unless (resource == Left (topicResource recipKey)) $
-        throwE "Join's object isn't me, don't need this Join"
-
-    maybeHttp <- lift $ runDB $ do
-
-        -- Find recipient topic in DB, returning 404 if doesn't exist because
-        -- we're in the topic's inbox post handler
-        (recipActorID, recipActor) <- do
-            topic <- get404 recipKey
-            let actorID = topicActor topic
-            (actorID,) <$> getJust actorID
-
-        -- Insert the Join to topic's inbox
-        mractid <- insertToInbox now author body (actorInbox recipActor) luJoin False
-        for mractid $ \ joinID -> do
-
-            -- Insert Collab record to DB
-            insertCollab (topicResource recipKey) joinID
-
-            -- Forward the Join activity to relevant local stages,
-            -- and schedule delivery for unavailable remote members of
-            -- them
-            for mfwd $ \ (localRecips, sig) -> do
-                let recipByHash =
-                        grantResourceLocalActor $ topicResource recipHash
-                    sieve =
-                        makeRecipientSet
-                            []
-                            [localActorFollowers recipByHash]
-                forwardActivityDB
-                    (actbBL body) localRecips sig recipActorID recipByHash
-                    sieve joinID
-
-    -- Launch asynchronous HTTP forwarding of the Join activity
-    case maybeHttp of
-        Nothing -> return "I already have this activity in my inbox, doing nothing"
-        Just maybeForward -> do
-            traverse_ (forkWorker "topicJoinF inbox-forwarding") maybeForward
-            return $
-                case maybeForward of
-                    Nothing -> "Inserted Collab to DB, no inbox-forwarding to do"
-                    Just _ -> "Inserted Collab to DB and ran inbox-forwarding of the Join"
-
-    where
-
-    insertCollab topic joinID = do
-        collabID <- insert Collab
-        fulfillsID <- insert $ CollabFulfillsJoin collabID
-        case topic of
-            GrantResourceRepo repoID ->
-                insert_ $ CollabTopicRepo collabID repoID
-            GrantResourceDeck deckID ->
-                insert_ $ CollabTopicDeck collabID deckID
-            GrantResourceLoom loomID ->
-                insert_ $ CollabTopicLoom collabID loomID
-        let authorID = remoteAuthorId author
-        recipID <- insert $ CollabRecipRemote collabID authorID
-        insert_ $ CollabRecipRemoteJoin recipID fulfillsID joinID
-}
-
 repoJoinF
    :: UTCTime
    -> KeyHashid Repo
@ -203,6 +123,7 @@ loomJoinF
    -> AP.Join URIMode
    -> ExceptT Text Handler (Text, Maybe (ExceptT Text Worker Text))
 loomJoinF = topicJoinF loomActor GrantResourceLoom
+-}

 {-
 repoAcceptF