diff --git a/src/Vervis/Actor.hs b/src/Vervis/Actor.hs index 79c6851..c75ac3c 100644 --- a/src/Vervis/Actor.hs +++ b/src/Vervis/Actor.hs @@ -55,12 +55,11 @@ module Vervis.Actor -- * AP system base types , RemoteAuthor (..) , ActivityBody (..) - --, VerseRemote (..) , Verse (..) + , ClientMsg (..) -- * Behavior utility types - --, Verse - --, Event (..) + , VerseExt , Env (..) , Act , ActE @@ -293,101 +292,38 @@ data ActivityBody = ActivityBody } data Verse = Verse - { verseSource :: Either (LocalActorBy Key, ActorId, OutboxItemId) (RemoteAuthor, LocalURI, Maybe ByteString) - , verseBody :: ActivityBody - --, verseLocalRecips :: RecipientRoutes + { verseSource + :: Either + (LocalActorBy Key, ActorId, OutboxItemId) + (RemoteAuthor, LocalURI, Maybe ByteString) + , verseBody :: ActivityBody } -instance Message Verse where - summarize (Verse (Left (actor, _, itemID)) body) = +data ClientMsg = ClientMsg + { _cmMaybeCap :: Maybe (Either (LocalActorBy Key, OutboxItemId) FedURI) + , _cmLocalRecips :: RecipientRoutes + , _cmRemoteRecips :: [(Host, NonEmpty LocalURI)] + , _cmFwdHosts :: [Host] + , _cmAction :: AP.Action URIMode + } + +type VerseExt = Either Verse ClientMsg + +instance Message VerseExt where + summarize (Left (Verse (Left (actor, _, itemID)) body)) = let typ = AP.activityType $ AP.activitySpecific $ actbActivity body in T.concat [typ, " ", T.pack $ show actor, " ", T.pack $ show itemID] - summarize (Verse (Right (author, luAct, _)) body) = + summarize (Left (Verse (Right (author, luAct, _)) body)) = let ObjURI h _ = remoteAuthorURI author typ = AP.activityType $ AP.activitySpecific $ actbActivity body in T.concat [typ, " ", renderObjURI $ ObjURI h luAct] - refer (Verse (Left (actor, _, itemID)) _body) = + summarize (Right _) = "ClientMsg" + refer (Left (Verse (Left (actor, _, itemID)) _body)) = T.concat [T.pack $ show actor, " ", T.pack $ show itemID] - refer (Verse (Right (author, luAct, _)) _body) = + refer (Left (Verse (Right (author, luAct, _)) _body)) = let ObjURI h _ = remoteAuthorURI author in renderObjURI $ ObjURI h luAct - -{- -data VerseRemote = VerseRemote - { verseAuthor :: RemoteAuthor - , verseBody :: ActivityBody - , verseForward :: Maybe (RecipientRoutes, ByteString) - , verseActivity :: LocalURI - } - -data Event - = 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 - | EventRemoteUnresolveLocalResourceFwdToFollower RemoteActivityId - -- ^ A remote authorized actor unresolved a local ticket, and the local - -- deck/loom is forwarding to me because I'm following the deck/loom - -- and/or the specific ticket - | EventRemoteAcceptInviteLocalResourceFwdToFollower RemoteActivityId - -- ^ A remote actor accepted an Invite, and the local resource is - -- forwarding the Accept to me because I'm following the resource - | EventRemoteApproveJoinLocalResourceFwdToFollower RemoteActivityId - -- ^ An authorized remote actor approved a Join, and the local resource is - -- forwarding the Accept to me because I'm following the resource - | EventGrantAfterRemoteAccept OutboxItemId - -- ^ A local resource published a Grant, I'm receiving it because I'm - -- following the resource/target, or I'm the inviter/approver/target - | EventRemoteRejectInviteLocalResourceFwdToFollower RemoteActivityId - -- ^ A remote actor rejected an Invite, and the local resource is - -- forwarding the Reject to me because I'm following the resource - | EventRemoteForbidJoinLocalResourceFwdToFollower RemoteActivityId - -- ^ An authorized remote actor rejected a Join, and the local resource is - -- forwarding the Reject to me because I'm following the resource - | EventRejectAfterRemoteReject OutboxItemId - -- ^ 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 - | EventRemoteJoinLocalTopicFwdToFollower RemoteActivityId - -- ^ A remote actor asked to Join a local topic, and the local topic is - -- forwarding the Join to me because I'm following the topic - | EventTopicHandleLocalInvite PersonId OutboxItemId BL.ByteString ByteString FedURI (Either (GrantRecipBy Key) FedURI) - -- ^ I'm a resource and a local Person has published an invite-for-me. - -- Params: Sender person, Invite ID, Invite activity body, forwarding - -- signature header, capability URI, invite target. - | EventLocalInviteLocalTopicFwdToFollower OutboxItemId - -- ^ An authorized local 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 - -type Verse = Either Event VerseRemote - -instance Message Verse where - summarize (Left event) = T.pack $ show event - summarize (Right (VerseRemote author body _fwd uri)) = - let ObjURI h _ = remoteAuthorURI author - typ = AP.activityType $ AP.activitySpecific $ actbActivity body - in T.concat [typ, " ", renderObjURI $ ObjURI h uri] - refer (Left event) = T.pack $ show event - refer (Right (VerseRemote author _body _fwd uri)) = - let ObjURI h _ = remoteAuthorURI author - in renderObjURI $ ObjURI h uri --} + refer (Right _) = "ClientMsg" type YesodRender y = Route y -> [(Text, Text)] -> Text @@ -419,7 +355,7 @@ data Env = forall y. (Typeable y, Yesod y) => Env instance Stage Env where type StageKey Env = LocalActorBy Key - type StageMessage Env = Verse + type StageMessage Env = VerseExt type StageReturn Env = Either Text Text instance StageWeb Env where @@ -465,8 +401,8 @@ withDBExcept action = do abort = throwIO . FedError behave - :: (UTCTime -> Key a -> Verse -> ExceptT Text Act (Text, Act (), Next)) - -> (Key a -> Verse -> Act (Either Text Text, Act (), Next)) + :: (UTCTime -> Key a -> VerseExt -> ExceptT Text Act (Text, Act (), Next)) + -> (Key a -> VerseExt -> Act (Either Text Text, Act (), Next)) behave handler key msg = do now <- liftIO getCurrentTime result <- runExceptT $ handler now key msg @@ -475,7 +411,7 @@ behave handler key msg = do Right (t, after, next) -> return (Right t, after, next) class VervisActor a where - actorBehavior :: UTCTime -> Key a -> Verse -> ActE (Text, Act (), Next) + actorBehavior :: UTCTime -> Key a -> VerseExt -> ActE (Text, Act (), Next) launchActorIO :: VervisActor a => Theater -> Env -> (Key a -> LocalActorBy Key) -> Key a -> IO Bool launchActorIO theater env mk key = @@ -644,7 +580,7 @@ sendToLocalActors authorAndId body requireOwner mauthor maidAuthor recips = do Just a -> HS.delete a s authorAndId' = second (\ (author, luAct) -> (author, luAct, Nothing)) authorAndId - sendMany liveRecips $ Verse authorAndId' body + sendMany liveRecips $ Left $ Verse authorAndId' body -- Return remote followers, to whom we need to deliver via HTTP return remoteFollowers diff --git a/src/Vervis/Actor/Deck.hs b/src/Vervis/Actor/Deck.hs index 107e545..398ea10 100644 --- a/src/Vervis/Actor/Deck.hs +++ b/src/Vervis/Actor/Deck.hs @@ -406,8 +406,8 @@ deckUndo now recipDeckID (Verse authorIdMsig body) (AP.Undo uObject) = do -- Main behavior function ------------------------------------------------------------------------------ -deckBehavior :: UTCTime -> DeckId -> Verse -> ActE (Text, Act (), Next) -deckBehavior now deckID verse@(Verse _authorIdMsig body) = +deckBehavior :: UTCTime -> DeckId -> VerseExt -> ActE (Text, Act (), Next) +deckBehavior now deckID (Left verse@(Verse _authorIdMsig body)) = case AP.activitySpecific $ actbActivity body of AP.AcceptActivity accept -> deckAccept now deckID verse accept AP.FollowActivity follow -> deckFollow now deckID verse follow @@ -416,6 +416,7 @@ deckBehavior now deckID verse@(Verse _authorIdMsig body) = AP.RejectActivity reject -> deckReject now deckID verse reject AP.UndoActivity undo -> deckUndo now deckID verse undo _ -> throwE "Unsupported activity type for Deck" +deckBehavior _ _ (Right _) = throwE "ClientMsgs aren't supported for Deck" instance VervisActor Deck where actorBehavior = deckBehavior diff --git a/src/Vervis/Actor/Group.hs b/src/Vervis/Actor/Group.hs index f2c4a14..61e40f2 100644 --- a/src/Vervis/Actor/Group.hs +++ b/src/Vervis/Actor/Group.hs @@ -52,10 +52,11 @@ import Vervis.Model import Vervis.Persist.Discussion import Vervis.Ticket -groupBehavior :: UTCTime -> GroupId -> Verse -> ActE (Text, Act (), Next) -groupBehavior now groupID _verse@(Verse _authorIdMsig body) = +groupBehavior :: UTCTime -> GroupId -> VerseExt -> ActE (Text, Act (), Next) +groupBehavior now groupID (Left _verse@(Verse _authorIdMsig body)) = case AP.activitySpecific $ actbActivity body of _ -> throwE "Unsupported activity type for Group" +groupBehavior _ _ (Right _) = throwE "ClientMsgs aren't supported for Group" instance VervisActor Group where actorBehavior = groupBehavior diff --git a/src/Vervis/Actor/Loom.hs b/src/Vervis/Actor/Loom.hs index 41c7a14..cceb9a3 100644 --- a/src/Vervis/Actor/Loom.hs +++ b/src/Vervis/Actor/Loom.hs @@ -52,10 +52,11 @@ import Vervis.Model import Vervis.Persist.Discussion import Vervis.Ticket -loomBehavior :: UTCTime -> LoomId -> Verse -> ActE (Text, Act (), Next) -loomBehavior now loomID _verse@(Verse _authorIdMsig body) = +loomBehavior :: UTCTime -> LoomId -> VerseExt -> ActE (Text, Act (), Next) +loomBehavior now loomID (Left _verse@(Verse _authorIdMsig body)) = case AP.activitySpecific $ actbActivity body of _ -> throwE "Unsupported activity type for Loom" +loomBehavior _ _ (Right _) = throwE "ClientMsgs aren't supported for Loom" instance VervisActor Loom where actorBehavior = loomBehavior diff --git a/src/Vervis/Actor/Person.hs b/src/Vervis/Actor/Person.hs index 28b1713..c11e86e 100644 --- a/src/Vervis/Actor/Person.hs +++ b/src/Vervis/Actor/Person.hs @@ -56,6 +56,7 @@ import Vervis.Access import Vervis.ActivityPub import Vervis.Actor import Vervis.Actor.Common +import Vervis.Actor.Person.Client import Vervis.Actor2 import Vervis.Cloth import Vervis.Data.Actor @@ -574,8 +575,8 @@ personRevoke now recipPersonID (Verse authorIdMsig body) (AP.Revoke _lus) = do -- Main behavior function ------------------------------------------------------------------------------ -personBehavior :: UTCTime -> PersonId -> Verse -> ActE (Text, Act (), Next) -personBehavior now personID verse@(Verse _authorIdMsig body) = +personBehavior :: UTCTime -> PersonId -> VerseExt -> ActE (Text, Act (), Next) +personBehavior now personID (Left verse@(Verse _authorIdMsig body)) = case AP.activitySpecific $ actbActivity body of AP.AcceptActivity accept -> personAccept now personID verse accept AP.CreateActivity (AP.Create obj mtarget) -> @@ -591,6 +592,7 @@ personBehavior now personID verse@(Verse _authorIdMsig body) = AP.RevokeActivity revoke -> personRevoke now personID verse revoke AP.UndoActivity undo -> personUndo now personID verse undo _ -> throwE "Unsupported activity type for Person" +personBehavior now personID (Right msg) = clientBehavior now personID msg instance VervisActor Person where actorBehavior = personBehavior diff --git a/src/Vervis/Actor/Person/Client.hs b/src/Vervis/Actor/Person/Client.hs new file mode 100644 index 0000000..5a28ca5 --- /dev/null +++ b/src/Vervis/Actor/Person/Client.hs @@ -0,0 +1,56 @@ +{- This file is part of Vervis. + - + - Written in 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.Actor.Person.Client + ( clientBehavior + ) +where + +import Control.Monad +import Control.Monad.IO.Class +import Control.Monad.Logger.CallStack +import Control.Monad.Trans.Class +import Control.Monad.Trans.Except +import Control.Monad.Trans.Maybe +import Data.ByteString (ByteString) +import Data.Foldable +import Data.Text (Text) +import Data.Time.Clock +import Database.Persist +import Yesod.Persist.Core + +import qualified Data.Text as T + +import Control.Concurrent.Actor +import Network.FedURI +import Yesod.MonadSite + +import qualified Web.ActivityPub as AP + +import Control.Monad.Trans.Except.Local +import Database.Persist.Local + +import Vervis.Actor +import Vervis.Cloth +import Vervis.Data.Discussion +import Vervis.FedURI +import Vervis.Federation.Util +import Vervis.Foundation +import Vervis.Model +import Vervis.Persist.Discussion +import Vervis.Ticket + +clientBehavior :: UTCTime -> PersonId -> ClientMsg -> ActE (Text, Act (), Next) +clientBehavior _ _ _ = throwE "ClientMsg handlers coming soon!" diff --git a/src/Vervis/Actor/Repo.hs b/src/Vervis/Actor/Repo.hs index 44c32a0..3dd7eb9 100644 --- a/src/Vervis/Actor/Repo.hs +++ b/src/Vervis/Actor/Repo.hs @@ -52,10 +52,11 @@ import Vervis.Model import Vervis.Persist.Discussion import Vervis.Ticket -repoBehavior :: UTCTime -> RepoId -> Verse -> ActE (Text, Act (), Next) -repoBehavior now repoID _verse@(Verse _authorIdMsig body) = +repoBehavior :: UTCTime -> RepoId -> VerseExt -> ActE (Text, Act (), Next) +repoBehavior now repoID (Left _verse@(Verse _authorIdMsig body)) = case AP.activitySpecific $ actbActivity body of _ -> throwE "Unsupported activity type for Repo" +repoBehavior _ _ (Right _) = throwE "ClientMsgs aren't supported for Repo" instance VervisActor Repo where actorBehavior = repoBehavior diff --git a/src/Vervis/Application.hs b/src/Vervis/Application.hs index 31e0d63..4389150 100644 --- a/src/Vervis/Application.hs +++ b/src/Vervis/Application.hs @@ -342,7 +342,7 @@ makeFoundation appSettings = do , T.pack $ show from, " ==> ", T.pack $ show to ] - loadTheater :: Env -> WorkerDB [(LocalActorBy Key, Env, Verse -> Act (Either Text Text, Act (), Next))] + loadTheater :: Env -> WorkerDB [(LocalActorBy Key, Env, VerseExt -> Act (Either Text Text, Act (), Next))] loadTheater env = concat <$> sequenceA [ selectAllWhere LocalActorPerson (PersonVerified ==. True) , selectAll LocalActorGroup @@ -354,7 +354,7 @@ makeFoundation appSettings = do selectAll :: (PersistRecordBackend a SqlBackend, VervisActor a) => (Key a -> LocalActorBy Key) - -> WorkerDB [(LocalActorBy Key, Env, Verse -> Act (Either Text Text, Act (), Next))] + -> WorkerDB [(LocalActorBy Key, Env, VerseExt -> Act (Either Text Text, Act (), Next))] selectAll makeLocalActor = map (\ xid -> (makeLocalActor xid, env, behave actorBehavior xid)) <$> selectKeysList [] [] @@ -362,7 +362,7 @@ makeFoundation appSettings = do :: (PersistRecordBackend a SqlBackend, VervisActor a) => (Key a -> LocalActorBy Key) -> Filter a - -> WorkerDB [(LocalActorBy Key, Env, Verse -> Act (Either Text Text, Act (), Next))] + -> WorkerDB [(LocalActorBy Key, Env, VerseExt -> Act (Either Text Text, Act (), Next))] selectAllWhere makeLocalActor filt = map (\ xid -> (makeLocalActor xid, env, behave actorBehavior xid)) <$> selectKeysList [filt] [] diff --git a/src/Vervis/Web/Actor.hs b/src/Vervis/Web/Actor.hs index 4de1d6c..54f92c6 100644 --- a/src/Vervis/Web/Actor.hs +++ b/src/Vervis/Web/Actor.hs @@ -257,7 +257,7 @@ postInbox recipByKey = do msig <- checkForwarding recipByHash return (author, luActivity, msig) theater <- getsYesod appTheater - r <- liftIO $ callIO theater recipByKey $ Verse authorIdMsig body + r <- liftIO $ callIO theater recipByKey $ Left $ Verse authorIdMsig body case r of Nothing -> notFound Just (Left e) -> throwE e diff --git a/vervis.cabal b/vervis.cabal index ca410cf..28f1d44 100644 --- a/vervis.cabal +++ b/vervis.cabal @@ -148,6 +148,7 @@ library Vervis.Actor.Group Vervis.Actor.Loom Vervis.Actor.Person + Vervis.Actor.Person.Client Vervis.Actor.Repo Vervis.API Vervis.Avatar