Actor system: Add support for C2S actor methods

2023-06-15 20:23:50 +03:00 · 2023-06-15 20:23:50 +03:00 · a683185918
commit a683185918
parent d33f272ede
10 changed files with 106 additions and 107 deletions
--- 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
--- 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
--- 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
--- 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
--- 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
--- a/src/Vervis/Actor/Person/Client.hs
+++ b/src/Vervis/Actor/Person/Client.hs
@ -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!"
--- 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
--- 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] []
--- 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
--- 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