Deck: Port Invite handler

src/Vervis/Actor.hs

@@ -96,6 +96,7 @@ import Data.Traversable
 import Data.Typeable
 import Database.Persist.Sql
 import GHC.Generics
+import Network.HTTP.Client
 import UnliftIO.Exception
 import Web.Hashids
 import Yesod.Core
@@ -124,6 +125,7 @@ import Data.List.NonEmpty.Local
 
 import Vervis.FedURI
 import Vervis.Model hiding (Actor, Message)
+import Vervis.RemoteActorStore.Types
 import Vervis.Settings
 
 data LocalActorBy f
@@ -329,6 +331,10 @@ data Event
     -- ^ A local resource published a Reject on an Invite/Join, I'm receiving
     --   it because I'm following the resource/target, or I'm the
     --   inviter/rejecter/target
+    | EventRemoteInviteLocalTopicFwdToFollower RemoteActivityId
+    -- ^ 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
     | EventUnknown
     deriving Show
 
@@ -368,6 +374,8 @@ data Env = forall y. (Typeable y, Yesod y) => Env
     , envDeliveryTheater :: DeliveryTheater URIMode
     --, envYesodSite       :: y
     , envYesodRender     :: YesodRender y
+    , envHttpManager     :: Manager
+    , envFetch           :: ActorFetchShare
     }
     deriving Typeable
 

src/Vervis/Actor/Common.hs

@@ -19,10 +19,12 @@ module Vervis.Actor.Common
     ( actorFollow
     , topicAccept
     , topicReject
+    , topicInvite
     )
 where
 
 import Control.Applicative
+import Control.Exception.Base
 import Control.Monad
 import Control.Monad.IO.Class
 import Control.Monad.Logger.CallStack
@@ -45,6 +47,7 @@ import Optics.Core
 import Yesod.Persist.Core
 
 import qualified Data.Text as T
+import qualified Database.Esqueleto as E
 
 import Control.Concurrent.Actor
 import Network.FedURI
@@ -70,10 +73,11 @@ import Vervis.FedURI
 import Vervis.Federation.Util
 import Vervis.Foundation
 import Vervis.Model
-import Vervis.Recipient (makeRecipientSet, LocalStageBy (..), Aud (..), collectAudience, localActorFollowers, renderLocalActor)
 import Vervis.Persist.Actor
 import Vervis.Persist.Collab
 import Vervis.Persist.Discussion
+import Vervis.Recipient (makeRecipientSet, LocalStageBy (..), Aud (..), collectAudience, localActorFollowers, renderLocalActor)
+import Vervis.RemoteActorStore
 import Vervis.Ticket
 
 actorFollow
@@ -667,3 +671,153 @@ topicReject topicActor topicResource now recipKey author body mfwd luReject reje
                 }
 
         return (action, recipientSet, remoteActors, fwdHosts)
+
+topicInvite
+    :: ( 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.Invite URIMode
+    -> ActE (Text, Act (), Next)
+topicInvite grabActor topicResource topicField topicCollabField collabTopicCtor now topicKey author body mfwd luInvite invite = do
+
+    -- 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 invite
+    targetByKey <- do
+        (resource, recipient) <-
+            parseInvite (Right $ remoteAuthorURI author) invite
+        unless (Left (topicResource topicKey) == resource) $
+            throwE "Invite topic isn't me"
+        return recipient
+
+    -- If target is local, find it in our DB
+    -- If target is remote, HTTP GET it, verify it's an actor, 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 Invite handler,
+    -- which is NOT a good idea. Ideally, it would be done async, and the
+    -- handler result (approve/disapprove the Invite) would be sent later in a
+    -- separate (e.g. Accept) activity. But for the PoC level, the current
+    -- situation will hopefully do.
+    targetDB <-
+        bitraverse
+            (withDBExcept . flip getGrantRecip "Invitee not found in DB")
+            (\ u@(ObjURI h lu) -> do
+                instanceID <-
+                    lift $ withDB $ either entityKey id <$> insertBy' (Instance h)
+                result <-
+                    ExceptT $ first (T.pack . displayException) <$>
+                        fetchRemoteActor' instanceID h lu
+                case result of
+                    Left Nothing -> throwE "Target @id mismatch"
+                    Left (Just err) -> throwE $ T.pack $ displayException err
+                    Right Nothing -> throwE "Target isn't an actor"
+                    Right (Just actor) -> return $ entityKey actor
+            )
+            targetByKey
+
+    maybeNew <- withDBExcept $ do
+
+        -- Grab topic from DB
+        (topicActorID, topicActor) <- lift $ do
+            recip <- getJust topicKey
+            let actorID = grabActor recip
+            (actorID,) <$> getJust actorID
+
+        -- Verify the specified capability gives relevant access
+        verifyCapability
+            capability
+            (Right $ remoteAuthorId author)
+            (topicResource topicKey)
+
+        -- Verify that target doesn't already have a Collab for me
+        existingCollabIDs <-
+            lift $ case targetDB of
+                Left (GrantRecipPerson (Entity personID _)) ->
+                    E.select $ E.from $ \ (topic `E.InnerJoin` recipl) -> do
+                        E.on $
+                            topic E.^. topicCollabField E.==.
+                            recipl E.^. CollabRecipLocalCollab
+                        E.where_ $
+                            topic E.^. topicField E.==. E.val topicKey E.&&.
+                            recipl E.^. CollabRecipLocalPerson E.==. E.val personID
+                        return $ recipl E.^. CollabRecipLocalCollab
+                Right remoteActorID ->
+                    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 remoteActorID
+                        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) luInvite False
+        lift $ for mractid $ \ inviteID -> do
+
+            -- Insert Collab record to DB
+            insertCollab targetDB inviteID
+
+            -- Prepare forwarding Invite to my followers
+            sieve <- do
+                topicHash <- encodeKeyHashid topicKey
+                let topicByHash =
+                        grantResourceLocalActor $ topicResource topicHash
+                return $ makeRecipientSet [] [localActorFollowers topicByHash]
+            return (topicActorID, inviteID, sieve)
+
+    case maybeNew of
+        Nothing -> done "I already have this activity in my inbox"
+        Just (topicActorID, inviteID, sieve) -> do
+            let topicByID = grantResourceLocalActor $ topicResource topicKey
+            lift $ for_ mfwd $ \ (localRecips, sig) -> do
+                forwardActivity
+                    (actbBL body) localRecips sig topicActorID topicByID sieve
+                    (EventRemoteInviteLocalTopicFwdToFollower inviteID)
+            done "Recorded and forwarded the Invite"
+
+    where
+
+    insertCollab recipient inviteID = do
+        collabID <- insert Collab
+        fulfillsID <- insert $ CollabFulfillsInvite collabID
+        insert_ $ collabTopicCtor collabID topicKey
+        let authorID = remoteAuthorId author
+        insert_ $ CollabInviterRemote fulfillsID authorID inviteID
+        case recipient of
+            Left (GrantRecipPerson (Entity personID _)) ->
+                insert_ $ CollabRecipLocal collabID personID
+            Right remoteActorID ->
+                insert_ $ CollabRecipRemote collabID remoteActorID

src/Vervis/Actor/Deck.hs

@@ -171,6 +171,29 @@ 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
+--      * Verify A isn't inviting themselves
+--      * Verify A is authorized by me to invite actors to me
+--      * Verify B doesn't already have an invite/join/grant for me
+--      * Remember the invite in DB
+--      * Forward the Invite to my followers
+deckInvite
+    :: UTCTime
+    -> DeckId
+    -> RemoteAuthor
+    -> ActivityBody
+    -> Maybe (RecipientRoutes, ByteString)
+    -> LocalURI
+    -> AP.Invite URIMode
+    -> ActE (Text, Act (), Next)
+deckInvite =
+    topicInvite
+        deckActor GrantResourceDeck
+        CollabTopicDeckDeck CollabTopicDeckCollab CollabTopicDeck
+
 ------------------------------------------------------------------------------
 -- Ambiguous: Following/Resolving
 ------------------------------------------------------------------------------
@@ -392,6 +415,8 @@ deckBehavior now deckID (Right (VerseRemote author body mfwd luActivity)) =
             deckAccept now deckID author body mfwd luActivity accept
         AP.FollowActivity follow ->
             deckFollow now deckID author body mfwd luActivity follow
+        AP.InviteActivity invite ->
+            deckInvite now deckID author body mfwd luActivity invite
         AP.RejectActivity reject ->
             deckReject now deckID author body mfwd luActivity reject
         AP.UndoActivity undo ->

src/Vervis/Actor/Person.hs

@@ -697,6 +697,19 @@ personBehavior now personID (Left event) =
                     (p,) <$> getJust (personActor p)
                 insertActivityToInbox now (personActor personRecip) rejectID
             done "Inserted Reject to my inbox"
+        -- Meaning: An authorized remote actor sent an Invite on a local
+        -- resource, I'm being forwarded as a follower of the resource
+        --
+        -- Behavior: Insert the Invite to my inbox
+        EventRemoteInviteLocalTopicFwdToFollower inviteID -> 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 inviteID 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

src/Vervis/Actor2.hs

@@ -69,7 +69,7 @@ import Vervis.Settings
 instance StageWebRoute Env where
     type StageRoute Env = Route App
     askUrlRenderParams = do
-        Env _ _ _ _ _ render <- askEnv
+        Env _ _ _ _ _ render _ _ <- askEnv
         case cast render of
             Nothing -> error "Env site isn't App"
             Just r -> pure r

src/Vervis/Application.hs

@@ -256,7 +256,7 @@ makeFoundation appSettings = do
     let root = renderObjURI $ flip ObjURI topLocalURI $ appInstanceHost appSettings
         --render :: Yesod y => y -> Route y -> [(Text, Text)] -> Text
         render = yesodRender app root
-        env = Env appSettings pool hashidsCtx appActorKeys delivery render
+        env = Env appSettings pool hashidsCtx appActorKeys delivery render appHttpManager appActorFetchShare
     actors <- flip runWorker app $ runSiteDB $ loadTheater env
     theater <- startTheater logFunc actors
 

src/Vervis/Federation/Collab.hs

@@ -17,9 +17,9 @@
 
 module Vervis.Federation.Collab
     ( --personInviteF
-      topicInviteF
+      --topicInviteF
 
-    , repoJoinF
+      repoJoinF
     , deckJoinF
     , loomJoinF
 
@@ -90,146 +90,6 @@ import Vervis.Persist.Collab
 import Vervis.Recipient
 import Vervis.RemoteActorStore
 
-topicInviteF
-    :: UTCTime
-    -> GrantResourceBy KeyHashid
-    -> RemoteAuthor
-    -> ActivityBody
-    -> Maybe (RecipientRoutes, ByteString)
-    -> LocalURI
-    -> AP.Invite URIMode
-    -> ExceptT Text Handler (Text, Maybe (ExceptT Text Worker Text))
-topicInviteF now recipByHash author body mfwd luInvite invite = do
-    error "Temporarily disabled due to switch to new actor system"
-{-
-    -- Check input
-    uCap <- do
-        let muCap = AP.activityCapability $ actbActivity body
-        fromMaybeE muCap "No capability provided"
-    (resourceAndCap, recipient) <- do
-
-        -- Check the invite-specific data
-        (resource, recip) <-
-            parseInvite (Right $ remoteAuthorURI author) invite
-
-        -- Verify the capability URI is one of:
-        --   * Outbox item URI of a local actor, i.e. a local activity
-        --   * A remote URI
-        capability <- nameExceptT "Invite capability" $ parseActivityURI uCap
-
-        -- Verify that capability is either a local activity of a local
-        -- resource, or both resource and capability are of the same remote
-        -- instance
-        (,recip) <$> case (resource, capability) of
-            (Left r, Left (actor, _, item)) -> do
-                unless (grantResourceLocalActor r == actor) $
-                    throwE "Local capability belongs to actor that isn't the resource"
-                return $ Left (r, item)
-            (Left _, Right _) ->
-                throwE "Remote capability obviously doesn't belong to local resource"
-            (Right _, Left _) ->
-                throwE "Local capability obviously doesn't belong to remote resource"
-            (Right (ObjURI h r), Right (ObjURI h' c)) -> do
-                unless (h == h') $
-                    throwE "Capability and resource are on different remote instances"
-                return $ Right (ObjURI h r, c)
-
-    -- Find recipient topic in DB, returning 404 if doesn't exist because
-    -- we're in the topic's inbox post handler
-    recipByKey <- unhashGrantResource404 recipByHash
-    (_recipByEntity, recipActorID, recipActor) <- lift $ runDB $ do
-        recipE <- getGrantResource404 recipByKey
-        let actorID = grantResourceActorID $ bmap (Identity . entityVal) recipE
-        (recipE, actorID,) <$> getJust actorID
-
-    -- Verify that Invite's topic is me, otherwise I don't need this Invite
-    capability <-
-        case resourceAndCap of
-            Left (resource, item) | resource == recipByKey -> return item
-            _ -> throwE "I'm not the Invite's topic, don't need this Invite"
-
-    return $ (,) "Ran initial checks, doing the rest asynchronously" $ Just $ do
-        mhttp <- do
-            mractid <- lift $ runSiteDB $ insertToInbox now author body (actorInbox recipActor) luInvite False
-            for mractid $ \ inviteID -> do
-
-                -- Verify the specified capability gives relevant access to the
-                -- resource
-                let recipLocalActorByKey = grantResourceLocalActor recipByKey
-                runSiteDBExcept $
-                    verifyCapability
-                        (recipLocalActorByKey, capability)
-                        (Right $ remoteAuthorId author)
-                        recipByKey
-
-                -- If recipient 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.
-                recipientDB <-
-                    bitraverse
-                        (runSiteDBExcept . flip getGrantRecip "Invitee not found in DB")
-                        (\ u@(ObjURI h lu) -> do
-                            instanceID <-
-                                lift $ runSiteDB $ either entityKey id <$> insertBy' (Instance h)
-                            result <-
-                                ExceptT $ first (T.pack . displayException) <$>
-                                    fetchRemoteActor instanceID h lu
-                            case result of
-                                Left Nothing -> throwE "Recipient @id mismatch"
-                                Left (Just err) -> throwE $ T.pack $ displayException err
-                                Right Nothing -> throwE "Recipient isn't an actor"
-                                Right (Just actor) -> return $ entityKey actor
-                        )
-                        recipient
-
-                lift $ runSiteDB $ do
-
-                    -- Insert Collab record to DB
-                    insertCollab recipByKey recipientDB inviteID
-
-                    -- Forward the Invite activity to relevant local stages,
-                    -- and schedule delivery for unavailable remote members of
-                    -- them
-                    for mfwd $ \ (localRecips, sig) -> do
-                        let recipLocalActor =
-                                grantResourceLocalActor recipByHash
-                            sieve =
-                                makeRecipientSet [] [localActorFollowers recipLocalActor]
-                        forwardActivityDB
-                            (actbBL body) localRecips sig recipActorID
-                            recipLocalActor sieve inviteID
-
-        -- Launch asynchronous HTTP forwarding of the Invite activity
-        case mhttp of
-            Nothing -> return "I already have this activity in my inbox, doing nothing"
-            Just maybeForward -> do
-                traverse_ (forkWorker "topicInviteF 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 Invite"
-
-    where
-
-    insertCollab resource recipient inviteID = do
-        collabID <- insert Collab
-        fulfillsID <- insert $ CollabFulfillsInvite collabID
-        case resource of
-            GrantResourceRepo repoID ->
-                insert_ $ CollabTopicRepo collabID repoID
-            GrantResourceDeck deckID ->
-                insert_ $ CollabTopicDeck collabID deckID
-            GrantResourceLoom loomID ->
-                insert_ $ CollabTopicLoom collabID loomID
-        let authorID = remoteAuthorId author
-        insert_ $ CollabInviterRemote fulfillsID authorID inviteID
-        case recipient of
-            Left (GrantRecipPerson (Entity personID _)) ->
-                insert_ $ CollabRecipLocal collabID personID
-            Right remoteActorID ->
-                insert_ $ CollabRecipRemote collabID remoteActorID
--}
-
 topicJoinF
     :: (PersistRecordBackend topic SqlBackend, ToBackendKey SqlBackend topic)
     => (topic -> ActorId)

src/Vervis/Foundation.hs

@@ -131,7 +131,7 @@ data App = App
     , appCapSignKey   :: AccessTokenSecretKey
     , appHashidsContext :: HashidsContext
     , appHookSecret      :: HookSecret
-    , appActorFetchShare :: ActorFetchShare App
+    , appActorFetchShare :: ActorFetchShare
     , appTheater :: Theater
 
     , appActivities  :: Maybe (Int, TVar (Vector ActivityReport))

src/Vervis/RemoteActorStore.hs

@@ -1,6 +1,6 @@
 {- This file is part of Vervis.
  -
- - Written in 2019, 2020, 2022 by fr33domlover <fr33domlover@riseup.net>.
+ - Written in 2019, 2020, 2022, 2023 by fr33domlover <fr33domlover@riseup.net>.
  -
  - ♡ Copying is an act of love. Please copy, reuse and share.
  -
@@ -26,6 +26,7 @@ module Vervis.RemoteActorStore
     , addVerifKey
     , actorFetchShareAction
     , fetchRemoteActor
+    , fetchRemoteActor'
     , deleteUnusedURAs
     )
 where
@@ -59,14 +60,17 @@ import qualified Data.HashMap.Strict as M
 import qualified Data.Text as T
 import qualified Database.Esqueleto as E
 
+import Control.Concurrent.Actor
 import Crypto.PublicVerifKey
 import Database.Persist.Local
 import Network.FedURI
 import Web.ActivityPub
 import Yesod.MonadSite
 
+import Vervis.Actor
 import Vervis.FedURI
 import Vervis.Model hiding (Actor (..))
+import Vervis.RemoteActorStore.Types
 
 newtype InstanceMutex = InstanceMutex (TVar (HashMap Host (MVar ())))
 
@@ -81,15 +85,13 @@ data RoomMode
     = RoomModeInstant
     | RoomModeCached RoomModeDB
 
-type ActorFetchShare site = ResultShare FedURI (Either (Maybe APGetError) (Maybe (Entity RemoteActor))) (site, InstanceId)
-
 class Yesod site => YesodRemoteActorStore site where
     siteInstanceMutex    :: site -> InstanceMutex
     siteInstanceRoomMode :: site -> Maybe Int
     siteActorRoomMode    :: site -> Maybe Int
     siteRejectOnMaxKeys  :: site -> Bool
 
-    siteActorFetchShare  :: site -> ActorFetchShare site
+    siteActorFetchShare  :: site -> ActorFetchShare
 
 withHostLock
     :: ( MonadHandler m
@@ -466,36 +468,25 @@ addVerifKey h mname uinb vkd =
         return (iid, rsid)
 
 actorFetchShareAction
-    :: ( Yesod site
+    :: FedURI
-       , YesodPersist site
+    -> (ConnectionPool, Manager, InstanceId)
-       , PersistUniqueWrite (YesodPersistBackend site)
-       , BaseBackend (YesodPersistBackend site) ~ SqlBackend
-       , HasHttpManager site
-       , Site site
-       , PersistConfigPool (SitePersistConfig site) ~ ConnectionPool
-       , PersistConfigBackend (SitePersistConfig site) ~ SqlPersistT
-       )
-    => FedURI
-    -> (site, InstanceId)
     -> IO (Either (Maybe APGetError) (Maybe (Entity RemoteActor)))
-actorFetchShareAction u (site, iid) = flip runWorkerT site $ do
+actorFetchShareAction u@(ObjURI h lu) (pool, manager, iid) = do
-    let ObjURI h lu = u
+    mrecip <- rundb $ runMaybeT $ do
-    mrecip <- runSiteDB $ runMaybeT $
+        roid <- MaybeT $ getKeyBy $ UniqueRemoteObject iid lu
-        MaybeT (getKeyBy $ UniqueRemoteObject iid lu) >>= \ roid ->
+        Left <$> MaybeT (getBy $ UniqueRemoteActor roid) <|>
-                Left <$> MaybeT (getBy $ UniqueRemoteActor roid)
+            Right <$> MaybeT (getBy $ UniqueRemoteCollection roid)
-            <|> Right <$> MaybeT (getBy $ UniqueRemoteCollection roid)
     case mrecip of
         Just recip ->
             return $ Right $
                 case recip of
-                    Left ers -> Just ers
+                    Left era -> Just era
                     Right _ -> Nothing
         Nothing -> do
-            manager <- asksSite getHttpManager
             erecip <- fetchRecipient manager h lu
-            for erecip $ \ recip ->
+            for erecip $
-                case recip of
+                \case
-                    RecipientActor (Actor local detail) -> runSiteDB $ do
+                    RecipientActor (Actor local detail) -> rundb $ do
                         roid <- either entityKey id <$> insertBy' (RemoteObject iid lu)
                         let ra = RemoteActor
                                 { remoteActorIdent      = roid
@@ -506,18 +497,19 @@ actorFetchShareAction u (site, iid) = flip runWorkerT site $ do
                                 , remoteActorErrorSince = Nothing
                                 }
                         Just . either id (flip Entity ra) <$> insertBy' ra
-                    RecipientCollection _ -> runSiteDB $ do
+                    RecipientCollection _ -> rundb $ do
                         mroid <- insertUnique $ RemoteObject iid lu
                         for_ mroid $ \ roid ->
                             insertUnique_ $ RemoteCollection roid
-                        return Nothing
+                        return (Nothing :: Maybe (Entity RemoteActor))
                     -- TODO see https://vervis.peers.community/decks/br6Go/tickets/r7dDo
+    where
+    rundb :: ReaderT SqlBackend IO a -> IO a
+    rundb = flip runSqlPool pool
 
 fetchRemoteActor
-    :: ( YesodPersist site
+    :: ( YesodRemoteActorStore site
-       , PersistUniqueRead (YesodPersistBackend site)
+       , HasHttpManager site
-       , BaseBackend (YesodPersistBackend site) ~ SqlBackend
-       , YesodRemoteActorStore site
        , MonadUnliftIO m
        , MonadSite m
        , SiteEnv m ~ site
@@ -545,7 +537,31 @@ fetchRemoteActor iid host luActor = do
                     Right _ -> Nothing
         Nothing -> do
             site <- askSite
-            liftIO $ runShared (siteActorFetchShare site) (ObjURI host luActor) (site, iid)
+            liftIO $ runShared (siteActorFetchShare site) (ObjURI host luActor) (sitePersistPool site, getHttpManager site, iid)
+
+fetchRemoteActor'
+    :: InstanceId
+    -> Host
+    -> LocalURI
+    -> Act
+        (Either
+            SomeException
+            (Either (Maybe APGetError) (Maybe (Entity RemoteActor)))
+        )
+fetchRemoteActor' iid host luActor = do
+    mrecip <- withDB $ runMaybeT $
+        MaybeT (getKeyBy $ UniqueRemoteObject iid luActor) >>= \ roid ->
+                Left <$> MaybeT (getBy $ UniqueRemoteActor roid)
+            <|> Right <$> MaybeT (getBy $ UniqueRemoteCollection roid)
+    case mrecip of
+        Just recip ->
+            return $ Right $ Right $
+                case recip of
+                    Left ers -> Just ers
+                    Right _ -> Nothing
+        Nothing -> do
+            Env _ pool _ _ _ _ manager fetch <- askEnv
+            liftIO $ runShared fetch (ObjURI host luActor) (pool, manager, iid)
 
 deleteUnusedURAs :: (MonadIO m, MonadLogger m) => ReaderT SqlBackend m ()
 deleteUnusedURAs = do

src/Vervis/RemoteActorStore/Types.hs

@@ -0,0 +1,59 @@
+{- This file is part of Vervis.
+ -
+ - Written in 2019, 2020, 2022, 2023 by fr33domlover <fr33domlover@riseup.net>.
+ -
+ - ♡ Copying is an act of love. Please copy, reuse and share.
+ -
+ - The author(s) have dedicated all copyright and related and neighboring
+ - rights to this software to the public domain worldwide. This software is
+ - distributed without any warranty.
+ -
+ - You should have received a copy of the CC0 Public Domain Dedication along
+ - with this software. If not, see
+ - <http://creativecommons.org/publicdomain/zero/1.0/>.
+ -}
+
+module Vervis.RemoteActorStore.Types
+    ( ActorFetchShare
+    )
+where
+
+import Control.Applicative
+import Control.Concurrent (forkIO)
+import Control.Concurrent.MVar (MVar, newMVar)
+import Control.Concurrent.ResultShare
+import Control.Concurrent.STM.TVar
+import Control.Exception
+import Control.Monad
+import Control.Monad.Logger.CallStack
+import Control.Monad.STM
+import Control.Monad.Trans.Except
+import Control.Monad.Trans.Maybe
+import Control.Monad.Trans.Reader
+import Data.Foldable
+import Data.HashMap.Strict (HashMap)
+import Data.Maybe
+import Data.Text (Text)
+import Data.Time.Clock
+import Data.Traversable
+import Database.Persist
+import Database.Persist.Sql
+import Network.HTTP.Client
+import UnliftIO.MVar (withMVar)
+import Yesod.Core hiding (logWarn, logError)
+import Yesod.Persist.Core
+
+import qualified Data.HashMap.Strict as M
+import qualified Data.Text as T
+import qualified Database.Esqueleto as E
+
+import Crypto.PublicVerifKey
+import Database.Persist.Local
+import Network.FedURI
+import Web.ActivityPub
+import Yesod.MonadSite
+
+import Vervis.FedURI
+import Vervis.Model hiding (Actor (..))
+
+type ActorFetchShare = ResultShare FedURI (Either (Maybe APGetError) (Maybe (Entity RemoteActor))) (ConnectionPool, Manager, InstanceId)

vervis.cabal

@@ -240,6 +240,7 @@ library
                        Vervis.Readme
                        Vervis.Recipient
                        Vervis.RemoteActorStore
+                       Vervis.RemoteActorStore.Types
                        --Vervis.Repo
                        --Vervis.Role
                        Vervis.Secure