diff --git a/src/Vervis/API.hs b/src/Vervis/API.hs index 7e01b1e..538eddf 100644 --- a/src/Vervis/API.hs +++ b/src/Vervis/API.hs @@ -1851,7 +1851,8 @@ inviteC -> AP.Invite URIMode -> ExceptT Text Handler OutboxItemId inviteC (Entity senderPersonID senderPerson) senderActor maybeCap localRecips remoteRecips fwdHosts action invite = do - + error "Temporarily disabled due to switch to new actor system" +{- -- Check input (resource, recipient) <- parseInvite (Left senderPersonID) invite capID <- fromMaybeE maybeCap "No capability provided" @@ -2054,6 +2055,7 @@ inviteC (Entity senderPersonID senderPerson) senderActor maybeCap localRecips re hashGrantRecip (GrantRecipPerson k) = GrantRecipPerson <$> encodeKeyHashid k +-} offerTicketC :: Entity Person diff --git a/src/Vervis/ActivityPub.hs b/src/Vervis/ActivityPub.hs index 62c6f56..76ef19c 100644 --- a/src/Vervis/ActivityPub.hs +++ b/src/Vervis/ActivityPub.hs @@ -1,6 +1,7 @@ {- This file is part of Vervis. - - - Written in 2019, 2020, 2021, 2022 by fr33domlover . + - Written in 2019, 2020, 2021, 2022, 2023 + - by fr33domlover . - - ♡ Copying is an act of love. Please copy, reuse and share. - @@ -26,6 +27,7 @@ module Vervis.ActivityPub , provideEmptyCollection , insertEmptyOutboxItem + , insertEmptyOutboxItem' , verifyContentTypeAP , verifyContentTypeAP_E , getActivity @@ -82,9 +84,11 @@ import qualified Database.Esqueleto as E import Yesod.HttpSignature +import Control.Concurrent.Actor import Database.Persist.JSON import Network.FedURI import Network.HTTP.Digest +import Web.Actor (stageInstanceHost) import Yesod.ActivityPub import Yesod.MonadSite import Yesod.FedURI @@ -235,6 +239,15 @@ insertEmptyOutboxItem obid now = do , outboxItemPublished = now } +insertEmptyOutboxItem' obid now = do + h <- asksEnv stageInstanceHost + insert OutboxItem + { outboxItemOutbox = obid + , outboxItemActivity = + persistJSONObjectFromDoc $ AP.Doc h AP.emptyActivity + , outboxItemPublished = now + } + verifyContentTypeAP :: MonadHandler m => m () verifyContentTypeAP = do result <- runExceptT verifyContentTypeAP_E diff --git a/src/Vervis/Actor.hs b/src/Vervis/Actor.hs index ad7a1ec..edc69da 100644 --- a/src/Vervis/Actor.hs +++ b/src/Vervis/Actor.hs @@ -293,13 +293,19 @@ data VerseRemote = VerseRemote } data Event - = EventRemoteGrantLocalRecipFwdToFollower RemoteActivityId - -- ^ A local actor has received a Grant (they're being granted some access) + = EventRemoteInviteLocalRecipFwdToFollower RemoteActivityId + -- ^ A local actor has received an Invite (they're being offered some access) + -- and forwarding it to me because I'm following this local actor + | EventRemoteFollowLocalRecipFwdToFollower RemoteActivityId + -- ^ A local actor has received an Follow where they're the target, -- and forwarding it to me because I'm following this local actor | EventRemoteFwdLocalActivity (LocalActorBy Key) OutboxItemId -- EventLocalFwdRemoteActivity (LocalActorBy Key) RemoteActivityId -- ^ A local actor is forwarding me a remote activity to add to my inbox. -- The data is (1) who's forwarding to me (2) the remote activity + | EventAcceptRemoteFollow + -- ^ A local actor (that I'm following) has accepted a Follow from some + -- remote actor | EventUnknown deriving Show diff --git a/src/Vervis/Actor/Person.hs b/src/Vervis/Actor/Person.hs index 336e29e..0b122aa 100644 --- a/src/Vervis/Actor/Person.hs +++ b/src/Vervis/Actor/Person.hs @@ -14,6 +14,9 @@ - . -} +-- for actorFollow +{-# LANGUAGE RankNTypes #-} + module Vervis.Actor.Person ( personBehavior ) @@ -29,6 +32,7 @@ import Control.Monad.Trans.Reader import Data.Bitraversable import Data.ByteString (ByteString) import Data.Foldable +import Data.Maybe import Data.Text (Text) import Data.Time.Clock import Data.Traversable @@ -40,6 +44,7 @@ import qualified Data.Text as T import Control.Concurrent.Actor import Network.FedURI +import Web.Actor import Web.Actor.Persist import Yesod.MonadSite @@ -48,21 +53,170 @@ import qualified Web.ActivityPub as AP import Control.Monad.Trans.Except.Local import Database.Persist.Local +import Vervis.Access +import Vervis.ActivityPub import Vervis.Actor import Vervis.Actor2 import Vervis.Cloth +import Vervis.Data.Actor import Vervis.Data.Collab import Vervis.Data.Discussion import Vervis.FedURI import Vervis.Federation.Util import Vervis.Foundation import Vervis.Model -import Vervis.Recipient (makeRecipientSet, LocalStageBy (..)) +import Vervis.Recipient (makeRecipientSet, LocalStageBy (..), Aud (..), collectAudience) import Vervis.Persist.Actor import Vervis.Persist.Collab import Vervis.Persist.Discussion import Vervis.Ticket +------------------------------------------------------------------------------ +-- Following +------------------------------------------------------------------------------ + +actorFollow + :: (PersistRecordBackend r SqlBackend, ToBackendKey SqlBackend r) + => (Route App -> ActE a) + -> (r -> ActorId) + -> Bool + -> (Key r -> Actor -> a -> ActDBE FollowerSetId) + -> (a -> ActDB RecipientRoutes) + -> (forall f. f r -> LocalActorBy f) + -> (a -> Act [Aud URIMode]) + -> UTCTime + -> Key r + -> RemoteAuthor + -> ActivityBody + -> Maybe (RecipientRoutes, ByteString) + -> LocalURI + -> AP.Follow URIMode + -> ActE (Text, Act (), Next) +actorFollow parseFollowee grabActor unread getFollowee getSieve makeLocalActor makeAudience now recipID author body mfwd luFollow (AP.Follow uObject _ hide) = do + + -- Check input + followee <- nameExceptT "Follow object" $ do + route <- do + routeOrRemote <- parseFedURI uObject + case routeOrRemote of + Left route -> pure route + Right _ -> throwE "Remote, so definitely not me/mine" + parseFollowee route + verifyNothingE + (AP.activityCapability $ actbActivity body) + "Capability not needed" + + maybeFollow <- withDBExcept $ do + + -- Find recipient actor in DB + recip <- lift $ getJust recipID + let recipActorID = grabActor recip + recipActor <- lift $ getJust recipActorID + + -- Insert the Follow to actor's inbox + mractid <- lift $ insertToInbox now author body (actorInbox recipActor) luFollow unread + for mractid $ \ followID -> do + + -- Find followee in DB + followerSetID <- getFollowee recipID recipActor followee + + -- Verify not already following us + let followerID = remoteAuthorId author + maybeFollow <- + lift $ getBy $ UniqueRemoteFollow followerID followerSetID + verifyNothingE maybeFollow "You're already following this object" + + -- Record the new follow in DB + acceptID <- + lift $ insertEmptyOutboxItem' (actorOutbox recipActor) now + lift $ insert_ $ RemoteFollow followerID followerSetID (not hide) followID acceptID + + -- Prepare an Accept activity and insert to actor's outbox + accept@(actionAccept, localRecipsAccept, remoteRecipsAccept, fwdHostsAccept) <- + lift $ prepareAccept followee + _luAccept <- lift $ updateOutboxItem' (makeLocalActor recipID) acceptID actionAccept + + sieve <- lift $ getSieve followee + return (recipActorID, followID, acceptID, sieve, accept) + + case maybeFollow of + Nothing -> done "I already have this activity in my inbox" + Just (actorID, followID, acceptID, sieve, (actionAccept, localRecipsAccept, remoteRecipsAccept, fwdHostsAccept)) -> do + lift $ for_ mfwd $ \ (localRecips, sig) -> + forwardActivity + (actbBL body) localRecips sig actorID + (makeLocalActor recipID) sieve + (EventRemoteFollowLocalRecipFwdToFollower followID) + lift $ sendActivity + (makeLocalActor recipID) actorID localRecipsAccept + remoteRecipsAccept fwdHostsAccept acceptID + EventAcceptRemoteFollow actionAccept + done "Recorded Follow and published Accept" + + where + + prepareAccept followee = do + encodeRouteHome <- getEncodeRouteHome + + ra <- getJust $ remoteAuthorId author + + let ObjURI hAuthor luAuthor = remoteAuthorURI author + + audSender = + AudRemote hAuthor + [luAuthor] + (maybeToList $ remoteActorFollowers ra) + + audsRecip <- lift $ makeAudience followee + + let (recipientSet, remoteActors, fwdHosts, audLocal, audRemote) = + collectAudience $ audSender : audsRecip + + recips = map encodeRouteHome audLocal ++ audRemote + action = AP.Action + { AP.actionCapability = Nothing + , AP.actionSummary = Nothing + , AP.actionAudience = AP.Audience recips [] [] [] [] [] + , AP.actionFulfills = [] + , AP.actionSpecific = AP.AcceptActivity AP.Accept + { AP.acceptObject = ObjURI hAuthor luFollow + , AP.acceptResult = Nothing + } + } + + return (action, recipientSet, remoteActors, fwdHosts) + +-- Meaning: Someone is following someone +-- Behavior: +-- * Verify I'm the target +-- * Record the follow in DB +-- * Publish and send an Accept to the sender and its followers +personFollow + :: UTCTime + -> PersonId + -> RemoteAuthor + -> ActivityBody + -> Maybe (RecipientRoutes, ByteString) + -> LocalURI + -> AP.Follow URIMode + -> ActE (Text, Act (), Next) +personFollow now recipPersonID author body mfwd luFollow follow = do + recipPersonHash <- encodeKeyHashid recipPersonID + actorFollow + (\case + PersonR p | p == recipPersonHash -> pure () + _ -> throwE "Asking to follow someone else" + ) + personActor + True + (\ _recipPersonID recipPersonActor () -> + pure $ actorFollowers recipPersonActor + ) + (\ () -> pure $ makeRecipientSet [] []) + LocalActorPerson + (\ () -> pure []) + now recipPersonID author body mfwd luFollow follow + ------------------------------------------------------------------------------ -- Commenting ------------------------------------------------------------------------------ @@ -147,10 +301,70 @@ personCreateNote now recipPersonID author body mfwd luCreate note = do -- Access ------------------------------------------------------------------------------ +-- Meaning: Someone invited someone to a resource +-- Behavior: +-- * Insert to my inbox +-- * If I'm the target, forward the Invite to my followers +personInvite + :: UTCTime + -> PersonId + -> RemoteAuthor + -> ActivityBody + -> Maybe (RecipientRoutes, ByteString) + -> LocalURI + -> AP.Invite URIMode + -> ActE (Text, Act (), Next) +personInvite now recipPersonID author body mfwd luInvite invite = do + + -- Check input + recipient <- do + (_resource, target) <- + parseInvite (Right $ remoteAuthorURI author) invite + return target + + maybeInvite <- withDBExcept $ do + + -- Grab recipient person from DB + (personRecip, actorRecip) <- lift $ do + p <- getJust recipPersonID + (p,) <$> getJust (personActor p) + + mractid <- lift $ insertToInbox now author body (actorInbox actorRecip) luInvite True + for mractid $ \ inviteID -> + return (personActor personRecip, inviteID) + + case maybeInvite of + Nothing -> done "I already have this activity in my inbox" + Just (actorID, inviteID) -> do + let targetIsRecip = + case recipient of + Left (GrantRecipPerson p) -> p == recipPersonID + _ -> False + if not targetIsRecip + then done "I'm not the target; Inserted to inbox" + else case mfwd of + Nothing -> + done + "I'm the target; Inserted to inbox; \ + \Forwarding not approved" + Just (localRecips, sig) -> do + recipHash <- encodeKeyHashid recipPersonID + let sieve = + makeRecipientSet + [] + [LocalStagePersonFollowers recipHash] + lift $ forwardActivity + (actbBL body) localRecips sig + actorID + (LocalActorPerson recipPersonID) sieve + (EventRemoteInviteLocalRecipFwdToFollower inviteID) + done + "I'm the target; Inserted to inbox; \ + \Forwarded to followers if addressed" + -- Meaning: A remote actor published a Grant -- Behavior: -- * Insert to my inbox --- * If I'm the target, forward the Grant to my followers personGrant :: UTCTime -> PersonId @@ -182,45 +396,19 @@ personGrant now recipPersonID author body mfwd luGrant grant = do (p,) <$> getJust (personActor p) mractid <- lift $ insertToInbox now author body (actorInbox actorRecip) luGrant True - for mractid $ \ grantID -> do - - -- If recipient is local, find it in our DB - _recipientDB <- - bitraverse - (flip getGrantRecip "Grant local target not found in DB") - pure - recipient - + for mractid $ \ grantID -> return (personActor personRecip, grantID) case maybeGrant of Nothing -> done "I already have this activity in my inbox" - Just (actorID, grantID) -> do + Just (_actorID, _grantID) -> do let targetIsRecip = case recipient of Left (GrantRecipPerson p) -> p == recipPersonID _ -> False if not targetIsRecip then done "I'm not the target; Inserted to inbox" - else case mfwd of - Nothing -> - done - "I'm the target; Inserted to inbox; \ - \Forwarding not approved" - Just (localRecips, sig) -> do - recipHash <- encodeKeyHashid recipPersonID - let sieve = - makeRecipientSet - [] - [LocalStagePersonFollowers recipHash] - lift $ forwardActivity - (actbBL body) localRecips sig - actorID - (LocalActorPerson recipPersonID) sieve - (EventRemoteGrantLocalRecipFwdToFollower grantID) - done - "I'm the target; Inserted to inbox; \ - \Forwarded to followers if addressed" + else done "I'm the target; Inserted to inbox" ------------------------------------------------------------------------------ -- Main behavior function @@ -242,18 +430,18 @@ insertActivityToInbox now recipActorID outboxItemID = do personBehavior :: UTCTime -> PersonId -> Verse -> ActE (Text, Act (), Next) personBehavior now personID (Left event) = case event of - -- Meaning: Someone X received a Grant and forwarded it to me because + -- Meaning: Someone X received an Invite and forwarded it to me because -- I'm a follower of X -- Behavior: Insert to my inbox - EventRemoteGrantLocalRecipFwdToFollower grantID -> do + EventRemoteInviteLocalRecipFwdToFollower 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 grantID itemID - done "Inserted Grant to inbox" + insert_ $ InboxItemRemote inboxID inviteID itemID + done "Inserted Invite to inbox" -- Meaning: A remote actor has forwarded to me a remote activity -- Behavior: Insert it to my inbox EventRemoteFwdLocalActivity authorByKey outboxItemID -> withDBExcept $ do @@ -275,15 +463,13 @@ personBehavior now personID (Right (VerseRemote author body mfwd luActivity)) = AP.CreateNote _ note -> personCreateNote now personID author body mfwd luActivity note _ -> throwE "Unsupported create object type for people" - {- AP.FollowActivity follow -> - personFollowA now personID author body mfwd luActivity follow - -} + personFollow now personID author body mfwd luActivity follow AP.GrantActivity grant -> personGrant now personID author body mfwd luActivity grant - {- AP.InviteActivity invite -> - personInviteA now personID author body mfwd luActivity invite + personInvite now personID author body mfwd luActivity invite + {- AP.UndoActivity undo -> (,Nothing) <$> personUndoA now personID author body mfwd luActivity undo -} diff --git a/src/Vervis/Data/Collab.hs b/src/Vervis/Data/Collab.hs index 859f221..3fc157a 100644 --- a/src/Vervis/Data/Collab.hs +++ b/src/Vervis/Data/Collab.hs @@ -57,6 +57,7 @@ import Control.Monad.Trans.Except.Local import Vervis.Access import Vervis.Actor +import Vervis.Actor2 import Vervis.Data.Actor import Vervis.FedURI import Vervis.Foundation @@ -98,15 +99,18 @@ verifyRole (Left AP.RoleAdmin) = pure () verifyRole (Right _) = throwE "ForgeFed Admin is the only role allowed currently" +parseTopic + :: StageRoute Env ~ Route App + => FedURI -> ActE (Either (GrantResourceBy Key) FedURI) parseTopic u = do - routeOrRemote <- parseFedURIOld u + routeOrRemote <- parseFedURI u bitraverse (\ route -> do resourceHash <- fromMaybeE (parseGrantResource route) "Not a shared resource route" - unhashGrantResourceE + unhashGrantResourceE' resourceHash "Contains invalid hashid" ) @@ -114,9 +118,10 @@ parseTopic u = do routeOrRemote parseInvite - :: Either PersonId FedURI + :: StageRoute Env ~ Route App + => Either PersonId FedURI -> AP.Invite URIMode - -> ExceptT Text Handler + -> ActE ( Either (GrantResourceBy Key) FedURI , Either (GrantRecipBy Key) FedURI ) @@ -126,7 +131,7 @@ parseInvite sender (AP.Invite instrument object target) = do <*> nameExceptT "Invite object" (parseRecipient object) where parseRecipient u = do - routeOrRemote <- parseFedURIOld u + routeOrRemote <- parseFedURI u bitraverse (\ route -> do recipHash <- @@ -134,7 +139,7 @@ parseInvite sender (AP.Invite instrument object target) = do (parseGrantRecip route) "Not a grant recipient route" recipKey <- - unhashGrantRecipEOld + unhashGrantRecipE recipHash "Contains invalid hashid" case recipKey of @@ -150,8 +155,8 @@ parseInvite sender (AP.Invite instrument object target) = do routeOrRemote parseJoin - :: AP.Join URIMode - -> ExceptT Text Handler (Either (GrantResourceBy Key) FedURI) + :: StageRoute Env ~ Route App + => AP.Join URIMode -> ActE (Either (GrantResourceBy Key) FedURI) parseJoin (AP.Join instrument object) = do verifyRole instrument nameExceptT "Join object" (parseTopic object) diff --git a/src/Vervis/Federation/Collab.hs b/src/Vervis/Federation/Collab.hs index a5f9170..b5057a0 100644 --- a/src/Vervis/Federation/Collab.hs +++ b/src/Vervis/Federation/Collab.hs @@ -100,7 +100,8 @@ topicInviteF -> 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 @@ -227,6 +228,7 @@ topicInviteF now recipByHash author body mfwd luInvite invite = do insert_ $ CollabRecipLocal collabID personID Right remoteActorID -> insert_ $ CollabRecipRemote collabID remoteActorID +-} topicJoinF :: (PersistRecordBackend topic SqlBackend, ToBackendKey SqlBackend topic) @@ -241,7 +243,8 @@ topicJoinF -> 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 @@ -306,6 +309,7 @@ topicJoinF topicActor topicResource now recipHash author body mfwd luJoin join = let authorID = remoteAuthorId author recipID <- insert $ CollabRecipRemote collabID authorID insert_ $ CollabRecipRemoteJoin recipID fulfillsID joinID +-} repoJoinF :: UTCTime diff --git a/src/Vervis/Federation/Offer.hs b/src/Vervis/Federation/Offer.hs index 0adc841..1b158b6 100644 --- a/src/Vervis/Federation/Offer.hs +++ b/src/Vervis/Federation/Offer.hs @@ -20,12 +20,12 @@ module Vervis.Federation.Offer --, sharerRejectF - personFollowF - , deckFollowF - , loomFollowF - , repoFollowF + --personFollowF + --, deckFollowF + --, loomFollowF + --, repoFollowF - , personUndoF + personUndoF , deckUndoF , loomUndoF , repoUndoF @@ -301,137 +301,6 @@ sharerRejectF recipHash now author body mfwd luReject (Reject (ObjURI hOffer luO lift $ delete frrid -} -followF - :: (PersistRecordBackend r SqlBackend, ToBackendKey SqlBackend r) - => (Route App -> ExceptT Text Handler a) - -> (r -> ActorId) - -> Bool - -> (Key r -> Actor -> a -> ExceptT Text AppDB FollowerSetId) - -> (a -> AppDB RecipientRoutes) - -> (forall f. f r -> LocalActorBy f) - -> (a -> Handler [Aud URIMode]) - -> UTCTime - -> KeyHashid r - -> RemoteAuthor - -> ActivityBody - -> Maybe (RecipientRoutes, ByteString) - -> LocalURI - -> AP.Follow URIMode - -> ExceptT Text Handler (Text, Maybe (ExceptT Text Worker Text)) -followF parseFollowee grabActor unread getFollowee getSieve makeLocalActor makeAudience now recipHash author body mfwd luFollow (AP.Follow uObject _ hide) = (,Nothing) <$> do - - -- Check input - recipID <- decodeKeyHashid404 recipHash - followee <- nameExceptT "Follow object" $ do - route <- do - routeOrRemote <- parseFedURIOld uObject - case routeOrRemote of - Left route -> pure route - Right _ -> throwE "Remote, so definitely not me/mine" - parseFollowee route - verifyNothingE - (AP.activityCapability $ actbActivity body) - "Capability not needed" - - maybeHttp <- runDBExcept $ do - - -- Find recipient actor in DB, returning 404 if doesn't exist because - -- we're in the actor's inbox post handler - recip <- lift $ get404 recipID - let recipActorID = grabActor recip - recipActor <- lift $ getJust recipActorID - - -- Insert the Follow to actor's inbox - mractid <- lift $ insertToInbox now author body (actorInbox recipActor) luFollow unread - for mractid $ \ followID -> do - - -- Find followee in DB - followerSetID <- getFollowee recipID recipActor followee - - -- Verify not already following us - let followerID = remoteAuthorId author - maybeFollow <- - lift $ getBy $ UniqueRemoteFollow followerID followerSetID - verifyNothingE maybeFollow "You're already following this object" - - -- Forward the Follow activity to relevant local stages, and - -- schedule delivery for unavailable remote members of them - maybeHttpFwdFollow <- lift $ for mfwd $ \ (localRecips, sig) -> do - sieve <- getSieve followee - forwardActivityDB - (actbBL body) localRecips sig recipActorID - (makeLocalActor recipHash) sieve followID - - -- Record the new follow in DB - acceptID <- - lift $ insertEmptyOutboxItem (actorOutbox recipActor) now - lift $ insert_ $ RemoteFollow followerID followerSetID (not hide) followID acceptID - - -- Prepare an Accept activity and insert to actor's outbox - (actionAccept, localRecipsAccept, remoteRecipsAccept, fwdHostsAccept) <- - lift $ prepareAccept followee - _luAccept <- lift $ updateOutboxItem (makeLocalActor recipID) acceptID actionAccept - - -- Deliver the Accept to local recipients, and schedule delivery - -- for unavailable remote recipients - deliverHttpAccept <- - deliverActivityDB - (makeLocalActor recipHash) recipActorID - localRecipsAccept remoteRecipsAccept fwdHostsAccept - acceptID actionAccept - - -- Return instructions for HTTP inbox-forwarding of the Follow - -- activity, and for HTTP delivery of the Accept activity to - -- remote recipients - return (maybeHttpFwdFollow, deliverHttpAccept) - - -- Launch asynchronous HTTP forwarding of the Follow activity and HTTP - -- delivery of the Accept activity - case maybeHttp of - Nothing -> - return "I already have this activity in my inbox, doing nothing" - Just (maybeHttpFwdFollow, deliverHttpAccept) -> do - for_ maybeHttpFwdFollow $ forkWorker "followF inbox-forwarding" - forkWorker "followF Accept HTTP delivery" deliverHttpAccept - return $ - case maybeHttpFwdFollow of - Nothing -> "Recorded follow, no inbox-forwarding to do" - Just _ -> - "Recorded follow and ran inbox-forwarding of the Follow" - - where - - prepareAccept followee = do - encodeRouteHome <- getEncodeRouteHome - - ra <- getJust $ remoteAuthorId author - - let ObjURI hAuthor luAuthor = remoteAuthorURI author - - audSender = - AudRemote hAuthor - [luAuthor] - (maybeToList $ remoteActorFollowers ra) - - audsRecip <- lift $ makeAudience followee - - let (recipientSet, remoteActors, fwdHosts, audLocal, audRemote) = - collectAudience $ audSender : audsRecip - - recips = map encodeRouteHome audLocal ++ audRemote - action = AP.Action - { AP.actionCapability = Nothing - , AP.actionSummary = Nothing - , AP.actionAudience = AP.Audience recips [] [] [] [] [] - , AP.actionFulfills = [] - , AP.actionSpecific = AP.AcceptActivity AP.Accept - { AP.acceptObject = ObjURI hAuthor luFollow - , AP.acceptResult = Nothing - } - } - - return (action, recipientSet, remoteActors, fwdHosts) - {- followF :: (Route App -> Maybe a) @@ -559,6 +428,7 @@ followF return (obiid, doc) -} +{- personFollowF :: UTCTime -> KeyHashid Person @@ -678,6 +548,7 @@ repoFollowF now recipRepoHash = (\ () -> pure []) now recipRepoHash +-} personUndoF :: UTCTime diff --git a/src/Vervis/Persist/Actor.hs b/src/Vervis/Persist/Actor.hs index 4bfb01b..e278ed9 100644 --- a/src/Vervis/Persist/Actor.hs +++ b/src/Vervis/Persist/Actor.hs @@ -1,6 +1,6 @@ {- This file is part of Vervis. - - - Written in 2022 by fr33domlover . + - Written in 2022, 2023 by fr33domlover . - - ♡ Copying is an act of love. Please copy, reuse and share. - @@ -21,6 +21,7 @@ module Vervis.Persist.Actor , getRemoteActorURI , insertActor , updateOutboxItem + , updateOutboxItem' , fillPerActorKeys , getPersonWidgetInfo ) @@ -42,6 +43,7 @@ import Database.Persist.Sql import qualified Data.Text as T import qualified Database.Esqueleto as E +import Control.Concurrent.Actor import Crypto.ActorKey import Database.Persist.JSON import Network.FedURI @@ -51,10 +53,13 @@ import Yesod.Hashids import Yesod.MonadSite import qualified Web.ActivityPub as AP +import qualified Web.Actor as WA +import qualified Web.Actor.Persist as WAP import Control.Monad.Trans.Except.Local import Database.Persist.Local +import Vervis.Actor2 () import Vervis.Data.Actor import Vervis.FedURI import Vervis.Foundation @@ -62,6 +67,8 @@ import Vervis.Model import Vervis.Recipient import Vervis.Settings +import qualified Vervis.Actor as VA + getLocalActor :: MonadIO m => ActorId -> ReaderT SqlBackend m (LocalActorBy Key) getLocalActor = fmap (bmap entityKey) . getLocalActorEnt @@ -154,6 +161,23 @@ updateOutboxItem actorByKey itemID action = do update itemID [OutboxItemActivity =. persistJSONObjectFromDoc doc] return luId +updateOutboxItem' + :: WA.StageRoute VA.Env ~ Route App + => LocalActorBy Key + -> OutboxItemId + -> AP.Action URIMode + -> VA.ActDB LocalURI +updateOutboxItem' actorByKey itemID action = do + encodeRouteLocal <- WA.getEncodeRouteLocal + hLocal <- asksEnv WA.stageInstanceHost + actorByHash <- VA.hashLocalActor actorByKey + itemHash <- WAP.encodeKeyHashid itemID + let luId = encodeRouteLocal $ activityRoute actorByHash itemHash + luActor = encodeRouteLocal $ renderLocalActor actorByHash + doc = AP.Doc hLocal $ AP.makeActivity luId luActor action + update itemID [OutboxItemActivity =. persistJSONObjectFromDoc doc] + return luId + fillPerActorKeys :: Worker () fillPerActorKeys = do perActor <- asksSite $ appPerActorKeys . appSettings