Actor system: Add support for C2S actor methods

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

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

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

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

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

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!"

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

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] []

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

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