Deck: Port Invite handler

This commit is contained in:
Pere Lev 2023-06-08 15:38:09 +03:00
parent 9955a3c0ad
commit 85f77fcac4
No known key found for this signature in database
GPG key ID: 5252C5C863E5E57D
11 changed files with 315 additions and 179 deletions

View file

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

View file

@ -19,10 +19,12 @@ module Vervis.Actor.Common
( actorFollow ( actorFollow
, topicAccept , topicAccept
, topicReject , topicReject
, topicInvite
) )
where where
import Control.Applicative import Control.Applicative
import Control.Exception.Base
import Control.Monad import Control.Monad
import Control.Monad.IO.Class import Control.Monad.IO.Class
import Control.Monad.Logger.CallStack import Control.Monad.Logger.CallStack
@ -45,6 +47,7 @@ import Optics.Core
import Yesod.Persist.Core import Yesod.Persist.Core
import qualified Data.Text as T import qualified Data.Text as T
import qualified Database.Esqueleto as E
import Control.Concurrent.Actor import Control.Concurrent.Actor
import Network.FedURI import Network.FedURI
@ -70,10 +73,11 @@ import Vervis.FedURI
import Vervis.Federation.Util import Vervis.Federation.Util
import Vervis.Foundation import Vervis.Foundation
import Vervis.Model import Vervis.Model
import Vervis.Recipient (makeRecipientSet, LocalStageBy (..), Aud (..), collectAudience, localActorFollowers, renderLocalActor)
import Vervis.Persist.Actor import Vervis.Persist.Actor
import Vervis.Persist.Collab import Vervis.Persist.Collab
import Vervis.Persist.Discussion import Vervis.Persist.Discussion
import Vervis.Recipient (makeRecipientSet, LocalStageBy (..), Aud (..), collectAudience, localActorFollowers, renderLocalActor)
import Vervis.RemoteActorStore
import Vervis.Ticket import Vervis.Ticket
actorFollow actorFollow
@ -667,3 +671,153 @@ topicReject topicActor topicResource now recipKey author body mfwd luReject reje
} }
return (action, recipientSet, remoteActors, fwdHosts) 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

View file

@ -171,6 +171,29 @@ deckReject
-> ActE (Text, Act (), Next) -> ActE (Text, Act (), Next)
deckReject = topicReject deckActor GrantResourceDeck 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 -- Ambiguous: Following/Resolving
------------------------------------------------------------------------------ ------------------------------------------------------------------------------
@ -392,6 +415,8 @@ deckBehavior now deckID (Right (VerseRemote author body mfwd luActivity)) =
deckAccept now deckID author body mfwd luActivity accept deckAccept now deckID author body mfwd luActivity accept
AP.FollowActivity follow -> AP.FollowActivity follow ->
deckFollow now deckID author body mfwd luActivity follow deckFollow now deckID author body mfwd luActivity follow
AP.InviteActivity invite ->
deckInvite now deckID author body mfwd luActivity invite
AP.RejectActivity reject -> AP.RejectActivity reject ->
deckReject now deckID author body mfwd luActivity reject deckReject now deckID author body mfwd luActivity reject
AP.UndoActivity undo -> AP.UndoActivity undo ->

View file

@ -697,6 +697,19 @@ personBehavior now personID (Left event) =
(p,) <$> getJust (personActor p) (p,) <$> getJust (personActor p)
insertActivityToInbox now (personActor personRecip) rejectID insertActivityToInbox now (personActor personRecip) rejectID
done "Inserted Reject to my inbox" 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) _ -> throwE $ "Unsupported event for Person: " <> T.pack (show event)
personBehavior now personID (Right (VerseRemote author body mfwd luActivity)) = personBehavior now personID (Right (VerseRemote author body mfwd luActivity)) =
case AP.activitySpecific $ actbActivity body of case AP.activitySpecific $ actbActivity body of

View file

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

View file

@ -256,7 +256,7 @@ makeFoundation appSettings = do
let root = renderObjURI $ flip ObjURI topLocalURI $ appInstanceHost appSettings let root = renderObjURI $ flip ObjURI topLocalURI $ appInstanceHost appSettings
--render :: Yesod y => y -> Route y -> [(Text, Text)] -> Text --render :: Yesod y => y -> Route y -> [(Text, Text)] -> Text
render = yesodRender app root 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 actors <- flip runWorker app $ runSiteDB $ loadTheater env
theater <- startTheater logFunc actors theater <- startTheater logFunc actors

View file

@ -17,9 +17,9 @@
module Vervis.Federation.Collab module Vervis.Federation.Collab
( --personInviteF ( --personInviteF
topicInviteF --topicInviteF
, repoJoinF repoJoinF
, deckJoinF , deckJoinF
, loomJoinF , loomJoinF
@ -90,146 +90,6 @@ import Vervis.Persist.Collab
import Vervis.Recipient import Vervis.Recipient
import Vervis.RemoteActorStore 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 topicJoinF
:: (PersistRecordBackend topic SqlBackend, ToBackendKey SqlBackend topic) :: (PersistRecordBackend topic SqlBackend, ToBackendKey SqlBackend topic)
=> (topic -> ActorId) => (topic -> ActorId)

View file

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

View file

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

View file

@ -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)

View file

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