From 85f77fcac47b1fbedfabe7f87d9383c92a5deef5 Mon Sep 17 00:00:00 2001 From: Pere Lev Date: Thu, 8 Jun 2023 15:38:09 +0300 Subject: [PATCH] Deck: Port Invite handler --- src/Vervis/Actor.hs | 8 ++ src/Vervis/Actor/Common.hs | 156 ++++++++++++++++++++++++++- src/Vervis/Actor/Deck.hs | 25 +++++ src/Vervis/Actor/Person.hs | 13 +++ src/Vervis/Actor2.hs | 2 +- src/Vervis/Application.hs | 2 +- src/Vervis/Federation/Collab.hs | 144 +------------------------ src/Vervis/Foundation.hs | 2 +- src/Vervis/RemoteActorStore.hs | 82 ++++++++------ src/Vervis/RemoteActorStore/Types.hs | 59 ++++++++++ vervis.cabal | 1 + 11 files changed, 315 insertions(+), 179 deletions(-) create mode 100644 src/Vervis/RemoteActorStore/Types.hs diff --git a/src/Vervis/Actor.hs b/src/Vervis/Actor.hs index 0867141..75b37bd 100644 --- a/src/Vervis/Actor.hs +++ b/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 diff --git a/src/Vervis/Actor/Common.hs b/src/Vervis/Actor/Common.hs index eb8477e..b846dc5 100644 --- a/src/Vervis/Actor/Common.hs +++ b/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 diff --git a/src/Vervis/Actor/Deck.hs b/src/Vervis/Actor/Deck.hs index 9b187a4..376509c 100644 --- a/src/Vervis/Actor/Deck.hs +++ b/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 -> diff --git a/src/Vervis/Actor/Person.hs b/src/Vervis/Actor/Person.hs index b1b3d8b..82bbcd9 100644 --- a/src/Vervis/Actor/Person.hs +++ b/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 diff --git a/src/Vervis/Actor2.hs b/src/Vervis/Actor2.hs index d7922e9..488c1c9 100644 --- a/src/Vervis/Actor2.hs +++ b/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 diff --git a/src/Vervis/Application.hs b/src/Vervis/Application.hs index d87f5f0..dd6cb49 100644 --- a/src/Vervis/Application.hs +++ b/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 diff --git a/src/Vervis/Federation/Collab.hs b/src/Vervis/Federation/Collab.hs index b54d460..d61295f 100644 --- a/src/Vervis/Federation/Collab.hs +++ b/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) diff --git a/src/Vervis/Foundation.hs b/src/Vervis/Foundation.hs index 1d3fe69..c210e3d 100644 --- a/src/Vervis/Foundation.hs +++ b/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)) diff --git a/src/Vervis/RemoteActorStore.hs b/src/Vervis/RemoteActorStore.hs index 59505f4..495d6a5 100644 --- a/src/Vervis/RemoteActorStore.hs +++ b/src/Vervis/RemoteActorStore.hs @@ -1,6 +1,6 @@ {- This file is part of Vervis. - - - Written in 2019, 2020, 2022 by fr33domlover . + - Written in 2019, 2020, 2022, 2023 by fr33domlover . - - ♡ 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 - , YesodPersist site - , PersistUniqueWrite (YesodPersistBackend site) - , BaseBackend (YesodPersistBackend site) ~ SqlBackend - , HasHttpManager site - , Site site - , PersistConfigPool (SitePersistConfig site) ~ ConnectionPool - , PersistConfigBackend (SitePersistConfig site) ~ SqlPersistT - ) - => FedURI - -> (site, InstanceId) + :: FedURI + -> (ConnectionPool, Manager, InstanceId) -> IO (Either (Maybe APGetError) (Maybe (Entity RemoteActor))) -actorFetchShareAction u (site, iid) = flip runWorkerT site $ do - let ObjURI h lu = u - mrecip <- runSiteDB $ runMaybeT $ - MaybeT (getKeyBy $ UniqueRemoteObject iid lu) >>= \ roid -> - Left <$> MaybeT (getBy $ UniqueRemoteActor roid) - <|> Right <$> MaybeT (getBy $ UniqueRemoteCollection roid) +actorFetchShareAction u@(ObjURI h lu) (pool, manager, iid) = do + mrecip <- rundb $ runMaybeT $ do + roid <- MaybeT $ getKeyBy $ UniqueRemoteObject iid lu + Left <$> MaybeT (getBy $ UniqueRemoteActor 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 -> - case recip of - RecipientActor (Actor local detail) -> runSiteDB $ do + for erecip $ + \case + 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 - , PersistUniqueRead (YesodPersistBackend site) - , BaseBackend (YesodPersistBackend site) ~ SqlBackend - , YesodRemoteActorStore site + :: ( YesodRemoteActorStore site + , HasHttpManager 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 diff --git a/src/Vervis/RemoteActorStore/Types.hs b/src/Vervis/RemoteActorStore/Types.hs new file mode 100644 index 0000000..7dc0c2f --- /dev/null +++ b/src/Vervis/RemoteActorStore/Types.hs @@ -0,0 +1,59 @@ +{- This file is part of Vervis. + - + - Written in 2019, 2020, 2022, 2023 by fr33domlover . + - + - ♡ 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 + - . + -} + +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) diff --git a/vervis.cabal b/vervis.cabal index 5f5748c..ca410cf 100644 --- a/vervis.cabal +++ b/vervis.cabal @@ -240,6 +240,7 @@ library Vervis.Readme Vervis.Recipient Vervis.RemoteActorStore + Vervis.RemoteActorStore.Types --Vervis.Repo --Vervis.Role Vervis.Secure