Actor system: Add support for C2S actor methods
This commit is contained in:
parent
d33f272ede
commit
a683185918
10 changed files with 106 additions and 107 deletions
|
@ -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)
|
||||
{ verseSource
|
||||
:: Either
|
||||
(LocalActorBy Key, ActorId, OutboxItemId)
|
||||
(RemoteAuthor, LocalURI, Maybe ByteString)
|
||||
, verseBody :: ActivityBody
|
||||
--, verseLocalRecips :: RecipientRoutes
|
||||
}
|
||||
|
||||
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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
56
src/Vervis/Actor/Person/Client.hs
Normal file
56
src/Vervis/Actor/Person/Client.hs
Normal file
|
@ -0,0 +1,56 @@
|
|||
{- This file is part of Vervis.
|
||||
-
|
||||
- Written in 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.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!"
|
|
@ -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
|
||||
|
|
|
@ -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] []
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
Loading…
Reference in a new issue