Implement actor-model system and start moving Person actor to it

This patch makes Vervis temporarily unusable, because all actors' inbox POST
handlers use the new system, but the actual federation handler code hasn't been
ported. The next patches will port all the S2S activities supported so far, as
well as C2S.

INSTALL.md

@@ -32,10 +32,12 @@ On Debian based distros, installation can be done like this:
 
     $ sudo apt install libpq-dev zlib1g-dev libssl-dev libpcre3-dev
 
-# (2) The Stack build tool
+# (2) Haskell development tools
 
-Install stack. To install stack, go to its [website](https://haskellstack.org)
+Go to the [GHCup website](https://www.haskell.org/ghcup) and follow the
-and follow the instructions.
+instructions.
+
+    $ curl --proto '=https' --tlsv1.2 -sSf https://get-ghcup.haskell.org | sh
 
 # (3) Version control systems Darcs and Git
 

src/Control/Concurrent/Actor.hs

@@ -0,0 +1,332 @@
+{- This file is part of Vervis.
+ -
+ - Written in 2019, 2020, 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 Control.Concurrent.Actor
+    ( Stage (..)
+    , TheaterFor ()
+    , ActFor ()
+    , MonadActor (..)
+    , asksEnv
+    , Next ()
+    , Message (..)
+    , startTheater
+    , callIO
+    , call
+    --, sendIO
+    , send
+    , sendManyIO
+    , sendMany
+    --, spawnIO
+    , spawn
+    , done
+    , doneAnd
+    , stop
+    )
+where
+
+import Control.Concurrent
+import Control.Concurrent.STM.TVar
+import Control.Monad
+import Control.Monad.Fail
+import Control.Monad.IO.Unlift
+import Control.Monad.Logger.CallStack
+import Control.Monad.STM
+import Control.Monad.Trans.Class
+import Control.Monad.Trans.Except
+import Control.Monad.Trans.Maybe
+import Control.Monad.Trans.Reader
+import Data.Foldable
+import Data.Hashable
+import Data.HashMap.Strict (HashMap)
+import Data.HashSet (HashSet)
+import Data.Text (Text)
+import Data.Traversable
+import UnliftIO.Exception
+
+import qualified Control.Exception.Annotated as AE
+import qualified Control.Monad.Trans.RWS.Lazy as RWSL
+import qualified Data.HashMap.Strict as HM
+import qualified Data.HashSet as HS
+import qualified Data.Text as T
+
+import Control.Concurrent.Return
+
+type LogFunc = Loc -> LogSource -> LogLevel -> LogStr -> IO ()
+
+class Stage a where
+    type StageKey a
+    type StageMessage a
+    type StageReturn a
+
+-- | A set of live actors responding to messages
+data TheaterFor s = TheaterFor
+    { theaterMap :: TVar (HashMap (StageKey s) (Chan (StageMessage s, Either SomeException (StageReturn s) -> IO ())))
+    , theaterLog :: LogFunc
+    , theaterEnv :: s
+    }
+
+-- | Actor monad in which message reponse actions are executed. Supports
+-- logging, a read-only environment, and IO.
+newtype ActFor s a = ActFor
+    { unActFor :: LoggingT (ReaderT (TheaterFor s) IO) a
+    }
+    deriving
+        ( Functor, Applicative, Monad, MonadFail, MonadIO, MonadLogger
+        , MonadLoggerIO
+        )
+
+instance MonadUnliftIO (ActFor s) where
+    askUnliftIO =
+        ActFor $ withUnliftIO $ \ u ->
+            return $ UnliftIO $ unliftIO u . unActFor
+    withRunInIO inner =
+        ActFor $ withRunInIO $ \ run -> inner (run . unActFor)
+
+runActor :: TheaterFor s -> ActFor s a -> IO a
+runActor theater (ActFor action) =
+    runReaderT (runLoggingT action $ theaterLog theater) theater
+
+class Monad m => MonadActor m where
+    type ActorEnv m
+    askEnv :: m (ActorEnv m)
+    liftActor :: ActFor (ActorEnv m) a -> m a
+
+instance MonadActor (ActFor s) where
+    type ActorEnv (ActFor s) = s
+    askEnv = theaterEnv <$> askTheater
+    liftActor = id
+
+instance MonadActor m => MonadActor (ReaderT r m) where
+    type ActorEnv (ReaderT r m) = ActorEnv m
+    askEnv                      = lift askEnv
+    liftActor                   = lift . liftActor
+
+instance MonadActor m => MonadActor (MaybeT m) where
+    type ActorEnv (MaybeT m) = ActorEnv m
+    askEnv                   = lift askEnv
+    liftActor                = lift . liftActor
+
+instance MonadActor m => MonadActor (ExceptT e m) where
+    type ActorEnv (ExceptT e m) = ActorEnv m
+    askEnv                      = lift askEnv
+    liftActor                   = lift . liftActor
+
+instance (Monoid w, MonadActor m) => MonadActor (RWSL.RWST r w s m) where
+    type ActorEnv (RWSL.RWST r w s m) = ActorEnv m
+    askEnv                            = lift askEnv
+    liftActor                         = lift . liftActor
+
+asksEnv :: MonadActor m => (ActorEnv m -> a) -> m a
+asksEnv f = f <$> askEnv
+
+data Next = Stop | Proceed
+
+class Message a where
+    summarize :: a -> Text
+    refer :: a -> Text
+
+launchActorThread
+    :: ( StageKey s ~ k, StageMessage s ~ m, StageReturn s ~ r
+       , Hashable k, Eq k, Show k, Message m, Show r
+       )
+    => Chan (m, Either SomeException r -> IO ())
+    -> TheaterFor s
+    -> k
+    -> (m -> ActFor s (r, ActFor s (), Next))
+    -> IO ()
+launchActorThread chan theater actor behavior =
+    void $ forkIO $ runActor theater $ do
+        logInfo $ prefix <> "starting"
+        loop
+        logInfo $ prefix <> "bye"
+    where
+    prefix = T.concat ["[Actor '", T.pack $ show actor, "'] "]
+    loop = do
+        (message, respond) <- liftIO $ readChan chan
+        logInfo $ T.concat [prefix, "received: ", summarize message]
+        result <- try $ behavior message
+        proceed <-
+            case result of
+                Left e -> do
+                    logError $ T.concat [prefix, "on ", refer message, " exception: ", T.pack $ displayException (e :: SomeException)]
+                    liftIO $ respond $ Left e
+                    return True
+                Right (value, after, next) -> do
+                    logInfo $ T.concat [prefix, "on ", refer message, " result: ", T.pack $ show value]
+                    liftIO $ respond $ Right value
+                    after
+                    case next of
+                        Stop -> do
+                            logInfo $ T.concat [prefix, "on ", refer message, " stopping"]
+                            let tvar = theaterMap theater
+                            liftIO $ atomically $ modifyTVar' tvar $ HM.delete actor
+                            return False
+                        Proceed -> do
+                            logInfo $ T.concat [prefix, "on ", refer message, " done"]
+                            return True
+        when proceed loop
+
+-- | Launch the actor system
+startTheater
+    :: ( StageKey s ~ k, StageMessage s ~ m, StageReturn s ~ r
+       , Hashable k, Eq k, Show k, Message m, Show r
+       )
+    => LogFunc
+    -> s
+    -> [(k, m -> ActFor s (r, ActFor s (), Next))]
+    -> IO (TheaterFor s)
+startTheater logFunc env actors = do
+    actorsWithChans <- for actors $ \ (key, behavior) -> do
+        chan <- newChan
+        return ((key, chan), behavior)
+    tvar <- newTVarIO $ HM.fromList $ map fst actorsWithChans
+    let theater = TheaterFor tvar logFunc env
+    for_ actorsWithChans $ \ ((key, chan), behavior) ->
+        launchActorThread chan theater key behavior
+    return theater
+
+askTheater :: ActFor s (TheaterFor s)
+askTheater = ActFor $ lift ask
+
+lookupActor
+    :: ( StageKey s ~ k, StageMessage s ~ m, StageReturn s ~ r
+       , Eq k, Hashable k
+       )
+    => TheaterFor s
+    -> k
+    -> IO (Maybe (Chan (m, Either SomeException r -> IO ())))
+lookupActor (TheaterFor tvar _ _) actor = HM.lookup actor <$> readTVarIO tvar
+
+-- | Same as 'call', except it takes the theater as a parameter.
+callIO
+    :: ( StageKey s ~ k, StageMessage s ~ m, StageReturn s ~ r
+       , Eq k, Hashable k
+       )
+    => TheaterFor s -> k -> m -> IO (Maybe r)
+callIO theater actor msg = do
+    maybeChan <- lookupActor theater actor
+    for maybeChan $ \ chan -> do
+        (returx, wait) <- newReturn
+        writeChan chan (msg, returx)
+        result <- wait
+        case result of
+            Left e -> AE.checkpointCallStack $ throwIO e
+            Right r -> return r
+
+-- | Send a message to an actor, and wait for the result to arrive. Return
+-- 'Nothing' if actor doesn't exist, otherwise 'Just' the result.
+--
+-- If the called method throws an exception, it is rethrown, wrapped with an
+-- annotation, in the current thread.
+call
+    :: ( MonadActor n, ActorEnv n ~ s
+       , StageKey s ~ k, StageMessage s ~ m, StageReturn s ~ r
+       , Eq k, Hashable k
+       )
+    => k -> m -> n (Maybe r)
+call key msg = liftActor $ do
+    theater <- askTheater
+    liftIO $ callIO theater key msg
+
+-- | Like 'send', except it takes the theater as a parameter.
+sendIO
+    :: (StageKey s ~ k, StageMessage s ~ m, Eq k, Hashable k)
+    => TheaterFor s -> k -> m -> IO Bool
+sendIO theater actor msg = do
+    maybeChan <- lookupActor theater actor
+    case maybeChan of
+        Nothing -> return False
+        Just chan -> do
+            writeChan chan (msg, const $ pure ())
+            return True
+
+-- | Send a message to an actor, without waiting for a result. Return 'True' if
+-- the given actor exists, 'False' otherwise.
+send
+    :: ( MonadActor n, ActorEnv n ~ s
+       , StageKey s ~ k, StageMessage s ~ m
+       , Eq k, Hashable k
+       )
+    => k -> m -> n Bool
+send key msg = liftActor $ do
+    theater <- askTheater
+    liftIO $ sendIO theater key msg
+
+-- | Like 'sendMany', except it takes the theater as a parameter.
+sendManyIO
+    :: (StageKey s ~ k, StageMessage s ~ m, Eq k, Hashable k)
+    => TheaterFor s -> HashSet k -> m -> IO ()
+sendManyIO (TheaterFor tvar _ _) recips msg = do
+    allActors <- readTVarIO tvar
+    for_ (HM.intersection allActors (HS.toMap recips)) $
+        \ chan -> writeChan chan (msg, const $ pure ())
+
+-- | Send a message to each actor in the set that exists in the system,
+-- without waiting for results.
+sendMany
+    :: ( MonadActor n, ActorEnv n ~ s
+       , StageKey s ~ k, StageMessage s ~ m
+       , Eq k, Hashable k
+       )
+    => HashSet k -> m -> n ()
+sendMany keys msg = liftActor $ do
+    theater <- askTheater
+    liftIO $ sendManyIO theater keys msg
+
+-- | Same as 'spawn', except it takes the theater as a parameter.
+spawnIO
+    :: ( StageKey s ~ k, StageMessage s ~ m, StageReturn s ~ r
+       , Eq k, Hashable k, Show k, Message m, Show r
+       )
+    => TheaterFor s
+    -> k
+    -> (m -> ActFor s (r, ActFor s (), Next))
+    -> IO Bool
+spawnIO theater@(TheaterFor tvar _ _) actor behavior = do
+    chan <- newChan
+    added <- atomically $ stateTVar tvar $ \ hm ->
+        let hm' = HM.alter (create chan) actor hm
+        in  ( not (HM.member actor hm) && HM.member actor hm'
+            , hm'
+            )
+    when added $ launchActorThread chan theater actor behavior
+    return added
+    where
+    create chan Nothing    = Just chan
+    create _    j@(Just _) = j
+
+-- | Launch a new actor with the given ID and behavior. Return 'True' if the ID
+-- was unused and the actor has been launched. Return 'False' if the ID is
+-- already in use, thus a new actor hasn't been launched.
+spawn
+    :: ( MonadActor n, ActorEnv n ~ s
+       , StageKey s ~ k, StageMessage s ~ m, StageReturn s ~ r
+       , Eq k, Hashable k, Show k, Message m, Show r
+       )
+    => k
+    -> (m -> ActFor s (r, ActFor s (), Next))
+    -> n Bool
+spawn key behavior = liftActor $ do
+    theater <- askTheater
+    liftIO $ spawnIO theater key behavior
+
+done :: Monad n => a -> n (a, ActFor s (), Next)
+done msg = return (msg, return (), Proceed)
+
+doneAnd :: Monad n => a -> ActFor s () -> n (a, ActFor s (), Next)
+doneAnd msg act = return (msg, act, Proceed)
+
+stop :: Monad n => a -> n (a, ActFor s (), Next)
+stop msg = return (msg, return (), Stop)

src/Control/Concurrent/Return.hs

@@ -0,0 +1,37 @@
+{- 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/>.
+ -}
+
+-- | Give another thread a way to send a value back to us.
+module Control.Concurrent.Return
+    ( newReturn
+    )
+where
+
+import Control.Concurrent.MVar
+import Control.Monad
+
+-- | Produce a pair of IO actions:
+--
+-- 1. Setter to give another thread, where it would be called at most once to
+--    send us a value
+-- 2. Action that waits until the value arrives
+newReturn :: IO (a -> IO (), IO a)
+newReturn = do
+    mvar <- newEmptyMVar
+    return (putReturn mvar, readMVar mvar)
+    where
+    putReturn mvar val = do
+        success <- tryPutMVar mvar val
+        unless success $ error "newReturn: putReturn: MVar is full"

src/Vervis/API.hs

@@ -1,6 +1,6 @@
 {- This file is part of Vervis.
  -
- - Written in 2019, 2020, 2022 by fr33domlover <fr33domlover@riseup.net>.
+ - Written in 2019, 2020, 2022, 2023 by fr33domlover <fr33domlover@riseup.net>.
  -
  - ♡ Copying is an act of love. Please copy, reuse and share.
  -
@@ -80,6 +80,7 @@ import Network.FedURI
 import Web.ActivityPub hiding (Patch (..), Ticket, Follow, Repo (..), ActorLocal (..), ActorDetail (..), Actor (..))
 import Web.Text
 import Yesod.ActivityPub
+import Yesod.Actor
 import Yesod.FedURI
 import Yesod.Hashids
 import Yesod.MonadSite
@@ -781,7 +782,7 @@ createNoteC (Entity senderPersonID senderPerson) senderActor maybeCap localRecip
     -- Check input
     verifyNothingE maybeCap "Capability not needed"
     Comment maybeParent topic source content <- do
-        (authorPersonID, comment) <- parseNewLocalComment note
+        (authorPersonID, comment) <- parseNewLocalCommentOld note
         unless (authorPersonID == senderPersonID) $
             throwE "Note attributed to someone else"
         return comment
@@ -1079,7 +1080,7 @@ createPatchTrackerC (Entity pidUser personUser) senderActor maybeCap localRecips
 
     parseRepo (ObjURI h lu :| us) = do
         unless (null us) $ throwE "More than one repo is specified"
-        hl <- hostIsLocal h
+        hl <- hostIsLocalOld h
         unless hl $ throwE "A remote repo is specified"
         route <- fromMaybeE (decodeRouteLocal lu) "Not a valid route"
         case route of
@@ -2712,7 +2713,7 @@ resolveC (Entity senderPersonID senderPerson) senderActor maybeCap localRecips r
     -- Check input
     maybeLocalWorkItem <-
         nameExceptT "Resolve object" $ either Just (const Nothing) <$> do
-            routeOrRemote <- parseFedURI uObject
+            routeOrRemote <- parseFedURIOld uObject
             bitraverse
                 (\ r -> do
                     wiByHash <-

src/Vervis/Actor.hs

@@ -0,0 +1,271 @@
+{- This file is part of Vervis.
+ -
+ - Written in 2019, 2020, 2022, 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/>.
+ -}
+
+-- These are for the Barbie-based generated instances
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE UndecidableInstances #-}
+
+module Vervis.Actor
+    ( -- * Local actors
+      LocalActorBy (..)
+    , LocalActor
+
+      -- * Local recipient set
+    , TicketRoutes (..)
+    , ClothRoutes (..)
+    , PersonRoutes (..)
+    , GroupRoutes (..)
+    , RepoRoutes (..)
+    , DeckRoutes (..)
+    , LoomRoutes (..)
+    , DeckFamilyRoutes (..)
+    , LoomFamilyRoutes (..)
+    , RecipientRoutes (..)
+
+      -- * AP system base types
+    , RemoteAuthor (..)
+    , ActivityBody (..)
+    , VerseRemote (..)
+
+      -- * Behavior utility types
+    , Verse
+    , Event (..)
+    , Env (..)
+    , Act
+    , ActE
+    , ActDB
+    , ActDBE
+    , Theater
+
+      -- * Behavior utilities
+    , withDB
+    , withDBExcept
+    , behave
+    )
+where
+
+import Control.Monad.IO.Class
+import Control.Monad.Trans.Class
+import Control.Monad.Trans.Except
+import Data.Barbie
+import Data.ByteString (ByteString)
+import Data.Hashable
+import Data.Text (Text)
+import Data.Time.Clock
+import Database.Persist.Sql
+import GHC.Generics
+import UnliftIO.Exception
+import Web.Hashids
+
+import qualified Data.Aeson as A
+import qualified Data.ByteString.Lazy as BL
+import qualified Data.Text as T
+
+import Control.Concurrent.Actor
+import Network.FedURI
+import Web.Actor
+import Web.Actor.Persist
+
+import qualified Web.ActivityPub as AP
+
+import Vervis.FedURI
+import Vervis.Model hiding (Actor, Message)
+import Vervis.Settings
+
+data LocalActorBy f
+    = LocalActorPerson (f Person)
+    | LocalActorGroup  (f Group)
+    | LocalActorRepo   (f Repo)
+    | LocalActorDeck   (f Deck)
+    | LocalActorLoom   (f Loom)
+    deriving (Generic, FunctorB, ConstraintsB)
+
+deriving instance AllBF Eq f LocalActorBy => Eq (LocalActorBy f)
+deriving instance AllBF Ord f LocalActorBy => Ord (LocalActorBy f)
+deriving instance AllBF Hashable f LocalActorBy => Hashable (LocalActorBy f)
+deriving instance AllBF Show f LocalActorBy => Show (LocalActorBy f)
+
+type LocalActor = LocalActorBy KeyHashid
+
+data TicketRoutes = TicketRoutes
+    { routeTicketFollowers :: Bool
+    }
+    deriving Eq
+
+data ClothRoutes = ClothRoutes
+    { routeClothFollowers :: Bool
+    }
+    deriving Eq
+
+data PersonRoutes = PersonRoutes
+    { routePerson          :: Bool
+    , routePersonFollowers :: Bool
+    }
+    deriving Eq
+
+data GroupRoutes = GroupRoutes
+    { routeGroup          :: Bool
+    , routeGroupFollowers :: Bool
+    }
+    deriving Eq
+
+data RepoRoutes = RepoRoutes
+    { routeRepo          :: Bool
+    , routeRepoFollowers :: Bool
+    }
+    deriving Eq
+
+data DeckRoutes = DeckRoutes
+    { routeDeck          :: Bool
+    , routeDeckFollowers :: Bool
+    }
+    deriving Eq
+
+data LoomRoutes = LoomRoutes
+    { routeLoom          :: Bool
+    , routeLoomFollowers :: Bool
+    }
+    deriving Eq
+
+data DeckFamilyRoutes = DeckFamilyRoutes
+    { familyDeck    :: DeckRoutes
+    , familyTickets :: [(KeyHashid TicketDeck, TicketRoutes)]
+    }
+    deriving Eq
+
+data LoomFamilyRoutes = LoomFamilyRoutes
+    { familyLoom   :: LoomRoutes
+    , familyCloths :: [(KeyHashid TicketLoom, ClothRoutes)]
+    }
+    deriving Eq
+
+data RecipientRoutes = RecipientRoutes
+    { recipPeople :: [(KeyHashid Person, PersonRoutes)]
+    , recipGroups :: [(KeyHashid Group , GroupRoutes)]
+    , recipRepos  :: [(KeyHashid Repo  , RepoRoutes)]
+    , recipDecks  :: [(KeyHashid Deck  , DeckFamilyRoutes)]
+    , recipLooms  :: [(KeyHashid Loom  , LoomFamilyRoutes)]
+    }
+    deriving Eq
+
+data RemoteAuthor = RemoteAuthor
+    { remoteAuthorURI      :: FedURI
+    , remoteAuthorInstance :: InstanceId
+    , remoteAuthorId       :: RemoteActorId
+    }
+
+data ActivityBody = ActivityBody
+    { actbBL         :: BL.ByteString
+    , actbObject     :: A.Object
+    , actbActivity   :: AP.Activity URIMode
+    }
+
+data VerseRemote = VerseRemote
+    { verseAuthor   :: RemoteAuthor
+    , verseBody     :: ActivityBody
+    , verseForward  :: Maybe (RecipientRoutes, ByteString)
+    , verseActivity :: LocalURI
+    }
+
+data Event
+    = EventFwdRemoteGrantToSomeoneElse RemoteActivityId
+    | EventRemoteFwdLocalActivity (LocalActorBy Key) OutboxItemId
+    | 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
+
+-- | Data to which every actor has access. Since such data can be passed to the
+-- behavior function when launching the actor, having a dedicated datatype is
+-- just convenience. The main reason is to allow 'runDB' not to take a
+-- connection pool parameter, instead grabbing it from the ReaderT. Another
+-- reason is to avoid the clutter of passing the same arguments manually
+-- everywhere.
+--
+-- Maybe in the future there won't be data shared by all actors, and then this
+-- type can be removed.
+data Env = Env
+    { envSettings       :: AppSettings
+    , envDbPool         :: ConnectionPool
+    , envHashidsContext :: HashidsContext
+    }
+
+instance Stage Env where
+    type StageKey Env     = LocalActorBy Key
+    type StageMessage Env = Verse
+    type StageReturn Env  = Either Text Text
+
+instance StageWeb Env where
+    type StageURIMode Env = URIMode
+    stageInstanceHost = appInstanceHost . envSettings
+
+instance StageHashids Env where
+    stageHashidsContext = envHashidsContext
+
+type Act = ActFor Env
+
+type ActE = ActForE Env
+
+type ActDB = SqlPersistT Act
+
+type ActDBE = ExceptT Text ActDB
+
+type Theater = TheaterFor Env
+
+-- | Run a database transaction. If an exception is thrown, the whole
+-- transaction is aborted.
+withDB :: ActDB a -> Act a
+withDB action = do
+    env <- askEnv
+    runPool (appDatabaseConf $ envSettings env) action (envDbPool env)
+
+newtype FedError = FedError Text deriving Show
+
+instance Exception FedError
+
+-- | Like 'withDB', but supports errors via 'ExceptT. If an exception is
+-- thrown, either via the 'ExceptT' or via regular throwing, the whole
+-- transaction is aborted.
+withDBExcept :: ExceptT Text (SqlPersistT Act) a -> ExceptT Text Act a
+withDBExcept action = do
+    result <- lift $ try $ withDB $ either abort return =<< runExceptT action
+    case result of
+        Left (FedError t) -> throwE t
+        Right r -> return r
+    where
+    abort = throwIO . FedError
+
+behave
+    :: (UTCTime -> Key a -> Verse -> ExceptT Text Act (Text, Act (), Next))
+    -> (Key a -> Verse -> Act (Either Text Text, Act (), Next))
+behave handler key msg = do
+    now <- liftIO getCurrentTime
+    result <- runExceptT $ handler now key msg
+    case result of
+        Left e -> done $ Left e
+        Right (t, after, next) -> return (Right t, after, next)

src/Vervis/Actor/Deck.hs

@@ -0,0 +1,64 @@
+{- 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.Deck
+    ( deckBehavior
+    )
+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
+
+deckBehavior
+    :: UTCTime -> DeckId -> Verse -> ExceptT Text Act (Text, Act (), Next)
+deckBehavior now deckID (Left event) =
+    case event of
+        EventRemoteFwdLocalActivity _ _ ->
+            throwE "Got a forwarded local activity, I don't need those"
+        _ -> throwE $ "Unsupported event for Deck: " <> T.pack (show event)
+deckBehavior now deckID (Right (VerseRemote author body mfwd luActivity)) =
+    case AP.activitySpecific $ actbActivity body of
+        _ -> throwE "Unsupported activity type for Deck"

src/Vervis/Actor/Group.hs

@@ -0,0 +1,64 @@
+{- 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.Group
+    ( groupBehavior
+    )
+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
+
+groupBehavior
+    :: UTCTime -> GroupId -> Verse -> ExceptT Text Act (Text, Act (), Next)
+groupBehavior now groupID (Left event) =
+    case event of
+        EventRemoteFwdLocalActivity _ _ ->
+            throwE "Got a forwarded local activity, I don't need those"
+        _ -> throwE $ "Unsupported event for Group: " <> T.pack (show event)
+groupBehavior now groupID (Right (VerseRemote author body mfwd luActivity)) =
+    case AP.activitySpecific $ actbActivity body of
+        _ -> throwE "Unsupported activity type for Group"

src/Vervis/Actor/Loom.hs

@@ -0,0 +1,64 @@
+{- 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.Loom
+    ( loomBehavior
+    )
+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
+
+loomBehavior
+    :: UTCTime -> LoomId -> Verse -> ExceptT Text Act (Text, Act (), Next)
+loomBehavior now loomID (Left event) =
+    case event of
+        EventRemoteFwdLocalActivity _ _ ->
+            throwE "Got a forwarded local activity, I don't need those"
+        _ -> throwE $ "Unsupported event for Loom: " <> T.pack (show event)
+loomBehavior now loomID (Right (VerseRemote author body mfwd luActivity)) =
+    case AP.activitySpecific $ actbActivity body of
+        _ -> throwE "Unsupported activity type for Loom"

src/Vervis/Actor/Person.hs

@@ -0,0 +1,189 @@
+{- This file is part of Vervis.
+ -
+ - Written in 2016, 2018, 2019, 2020, 2022, 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
+    ( personBehavior
+    )
+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 Control.Monad.Trans.Reader
+import Data.ByteString (ByteString)
+import Data.Foldable
+import Data.Text (Text)
+import Data.Time.Clock
+import Database.Persist
+import Database.Persist.Sql
+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.Actor
+import Vervis.Persist.Discussion
+import Vervis.Ticket
+
+insertActivityToInbox
+    :: MonadIO m
+    => UTCTime -> ActorId -> OutboxItemId -> ReaderT SqlBackend m Bool
+insertActivityToInbox now recipActorID outboxItemID = do
+    inboxID <- actorInbox <$> getJust recipActorID
+    inboxItemID <- insert $ InboxItem True now
+    maybeItem <- insertUnique $ InboxItemLocal inboxID outboxItemID inboxItemID
+    case maybeItem of
+        Nothing -> do
+            delete inboxItemID
+            return False
+        Just _ -> return True
+
+-- Meaning: Someone commented on an issue/PR
+-- Behavior: Insert to inbox
+personCreateNote
+    :: UTCTime
+    -> PersonId
+    -> RemoteAuthor
+    -> ActivityBody
+    -> Maybe (RecipientRoutes, ByteString)
+    -> LocalURI
+    -> AP.Note URIMode
+    -> ExceptT Text Act (Text, Act (), Next)
+personCreateNote now recipPersonID author body mfwd luCreate note = do
+
+    -- Check input
+    (luNote, published, Comment maybeParent topic source content) <- do
+        (luId, luAuthor, published, comment) <- parseRemoteComment note
+        unless (luAuthor == objUriLocal (remoteAuthorURI author)) $
+            throwE "Create author != note author"
+        return (luId, published, comment)
+
+    mractid <- withDBExcept $ do
+        Entity recipActorID recipActor <- lift $ do
+            person <- getJust recipPersonID
+            let actorID = personActor person
+            Entity actorID <$> getJust actorID
+
+        case topic of
+
+            Right uContext -> do
+                checkContextParent uContext maybeParent
+                lift $ insertToInbox now author body (actorInbox recipActor) luCreate True
+
+            Left (CommentTopicTicket deckID taskID) -> do
+                (_, _, Entity _ ticket, _, _) <- do
+                    mticket <- lift $ getTicket deckID taskID
+                    fromMaybeE mticket "Context: No such deck-ticket"
+                let did = ticketDiscuss ticket
+                _ <- traverse (getMessageParent did) maybeParent
+                lift $ insertToInbox now author body (actorInbox recipActor) luCreate True
+
+            Left (CommentTopicCloth loomID clothID) -> do
+                (_, _, Entity _ ticket, _, _, _) <- do
+                    mticket <- lift $ getCloth loomID clothID
+                    fromMaybeE mticket "Context: No such loom-cloth"
+                let did = ticketDiscuss ticket
+                _ <- traverse (getMessageParent did) maybeParent
+                lift $ insertToInbox now author body (actorInbox recipActor) luCreate True
+
+    done $
+        case mractid of
+            Nothing -> "I already have this activity in my inbox, doing nothing"
+            Just _ -> "Inserted Create{Note} to my inbox"
+    where
+    checkContextParent (ObjURI hContext luContext) mparent = do
+        mdid <- lift $ runMaybeT $ do
+            iid <- MaybeT $ getKeyBy $ UniqueInstance hContext
+            roid <- MaybeT $ getKeyBy $ UniqueRemoteObject iid luContext
+            rd <- MaybeT $ getValBy $ UniqueRemoteDiscussionIdent roid
+            return $ remoteDiscussionDiscuss rd
+        for_ mparent $ \ parent ->
+            case parent of
+                Left msg -> do
+                    did <- fromMaybeE mdid "Local parent inexistent, no RemoteDiscussion"
+                    void $ getLocalParentMessageId did msg
+                Right (ObjURI hParent luParent) -> do
+                    mrm <- lift $ runMaybeT $ do
+                        iid <- MaybeT $ getKeyBy $ UniqueInstance hParent
+                        roid <- MaybeT $ getKeyBy $ UniqueRemoteObject iid luParent
+                        MaybeT $ getValBy $ UniqueRemoteMessageIdent roid
+                    for_ mrm $ \ rm -> do
+                        let mid = remoteMessageRest rm
+                        m <- lift $ getJust mid
+                        did <- fromMaybeE mdid "Remote parent known, but no context RemoteDiscussion"
+                        unless (messageRoot m == did) $
+                            throwE "Remote parent belongs to a different discussion"
+
+personBehavior :: UTCTime -> PersonId -> Verse -> ActE (Text, Act (), Next)
+personBehavior now personID (Left event) =
+    case event of
+        EventFwdRemoteGrantToSomeoneElse grantID -> 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"
+        EventRemoteFwdLocalActivity authorByKey outboxItemID -> withDBExcept $ do
+                recipPerson <- lift $ getJust personID
+                verifyLocalActivityExistsInDB authorByKey outboxItemID
+                if LocalActorPerson personID == authorByKey
+                    then done "Received activity authored by self, ignoring"
+                    else do
+                        inserted <- lift $ insertActivityToInbox now (personActor recipPerson) outboxItemID
+                        done $
+                            if inserted
+                                then "Activity inserted to my inbox"
+                                else "Activity already exists in my inbox, ignoring"
+        _ -> throwE $ "Unsupported event for Person: " <> T.pack (show event)
+personBehavior now personID (Right (VerseRemote author body mfwd luActivity)) =
+    case AP.activitySpecific $ actbActivity body of
+        AP.CreateActivity (AP.Create obj mtarget) ->
+            case obj of
+                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
+        AP.GrantActivity grant ->
+            personGrantA now personID author body mfwd luActivity grant
+        AP.InviteActivity invite ->
+            personInviteA now personID author body mfwd luActivity invite
+        AP.UndoActivity undo ->
+            (,Nothing) <$> personUndoA now personID author body mfwd luActivity undo
+        -}
+        _ -> throwE "Unsupported activity type for Person"

src/Vervis/Actor/Repo.hs

@@ -0,0 +1,64 @@
+{- 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.Repo
+    ( repoBehavior
+    )
+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
+
+repoBehavior
+    :: UTCTime -> RepoId -> Verse -> ExceptT Text Act (Text, Act (), Next)
+repoBehavior now repoID (Left event) =
+    case event of
+        EventRemoteFwdLocalActivity _ _ ->
+            throwE "Got a forwarded local activity, I don't need those"
+        _ -> throwE $ "Unsupported event for Repo: " <> T.pack (show event)
+repoBehavior now repoID (Right (VerseRemote author body mfwd luActivity)) =
+    case AP.activitySpecific $ actbActivity body of
+        _ -> throwE "Unsupported activity type for Repo"

src/Vervis/Application.hs

@@ -1,6 +1,6 @@
 {- This file is part of Vervis.
  -
- - Written in 2016, 2018, 2019, 2020, 2022
+ - Written in 2016, 2018, 2019, 2020, 2022, 2023
  - by fr33domlover <fr33domlover@riseup.net>.
  -
  - ♡ Copying is an act of love. Please copy, reuse and share.
@@ -32,10 +32,12 @@ module Vervis.Application
 where
 
 import Control.Concurrent.Chan
+import Control.Concurrent.STM
 import Control.Concurrent.STM.TVar
 import Control.Exception hiding (Handler)
 import Control.Monad
 import Control.Monad.Logger                 (liftLoc, runLoggingT, logInfo, logError)
+import Control.Monad.Trans.Except
 import Control.Monad.Trans.Reader
 import Data.Bifunctor
 import Data.Default.Class
@@ -47,6 +49,7 @@ import Data.Maybe
 import Data.Proxy
 import Data.String
 import Data.Text (Text)
+import Data.Time.Clock
 import Data.Traversable
 import Database.Persist.Postgresql
 import Graphics.SVGFonts.Fonts (lin2)
@@ -75,6 +78,7 @@ import Yesod.Persist.Core
 import Yesod.Static
 
 import qualified Data.CaseInsensitive as CI
+import qualified Data.HashMap.Strict as HM
 import qualified Data.Text as T
 import qualified Database.Esqueleto as E
 
@@ -82,6 +86,7 @@ import Database.Persist.Schema.PostgreSQL (schemaBackend)
 import Dvara
 import Yesod.Mail.Send (runMailer)
 
+import Control.Concurrent.Actor
 import Control.Concurrent.ResultShare
 import Crypto.ActorKey
 import Data.KeyFile
@@ -94,8 +99,14 @@ import Control.Concurrent.Local
 import Data.List.NonEmpty.Local
 import Web.Hashids.Local
 
+import Vervis.Actor
+import Vervis.Actor.Deck
+import Vervis.Actor.Group
+import Vervis.Actor.Loom
+import Vervis.Actor.Person
+import Vervis.Actor.Repo
 import Vervis.Darcs
-import Vervis.Web.Delivery
+import Vervis.Data.Actor
 import Vervis.Foundation
 import Vervis.Git
 import Vervis.Hook
@@ -127,6 +138,7 @@ import Vervis.Path
 import Vervis.Persist.Actor
 import Vervis.Settings
 import Vervis.Ssh (runSsh)
+import Vervis.Web.Delivery
 
 -- This line actually creates our YesodDispatch instance. It is the second half
 -- of the call to mkYesodData which occurs in Foundation.hs. Please see the
@@ -176,6 +188,9 @@ makeFoundation appSettings = do
 
     appActorFetchShare <- newResultShare actorFetchShareAction
 
+    -- Temporarily blank actor map, we'll replace it in a moment
+    --appTheatre <- startTheater (error "logFunc") (error "env") []
+
     appActivities <-
         case appInboxDebugReportLength appSettings of
             Nothing -> return Nothing
@@ -189,7 +204,8 @@ makeFoundation appSettings = do
     let mkFoundation
             appConnPool
             appCapSignKey
-            appHashidsContext =
+            appHashidsContext
+            appTheater =
                 App {..}
         -- The App {..} syntax is an example of record wild cards. For more
         -- information, see:
@@ -199,6 +215,7 @@ makeFoundation appSettings = do
                 (error "connPool forced in tempFoundation")
                 (error "capSignKey forced in tempFoundation")
                 (error "hashidsContext forced in tempFoundation")
+                (error "theater forced in tempFoundation")
         logFunc = loggingFunction tempFoundation
 
     -- Create the database connection pool
@@ -213,7 +230,7 @@ makeFoundation appSettings = do
     hashidsSalt <- loadKeyFile loadMode $ appHashidsSaltFile appSettings
     let hashidsCtx = hashidsContext hashidsSalt
 
-        app = mkFoundation pool capSignKey hashidsCtx
+        app = mkFoundation pool capSignKey hashidsCtx (error "theater")
 
     -- Perform database migration using our application's logging settings.
     --runLoggingT (runSqlPool (runMigration migrateAll) pool) logFunc
@@ -227,6 +244,11 @@ makeFoundation appSettings = do
         writePostReceiveHooks
         writePostApplyHooks
 
+    -- Launch actor threads and fill the actor map
+    actors <- flip runWorker app $ runSiteDB loadTheatre
+    let env = Env appSettings pool hashidsCtx
+    theater <- startTheater logFunc env actors
+
     let hostString = T.unpack $ renderAuthority hLocal
     writeHookConfig hostString Config
         { configSecret     = hookSecretText appHookSecret
@@ -235,7 +257,7 @@ makeFoundation appSettings = do
         }
 
     -- Return the foundation
-    return app
+    return app { appTheater = theater }
     where
     verifyRepoDir = do
         repos <- lift reposFromDir
@@ -300,6 +322,23 @@ makeFoundation appSettings = do
                     , T.pack $ show from, " ==> ", T.pack $ show to
                     ]
 
+    loadTheatre = concat <$> sequenceA
+        [ selectAll LocalActorPerson personBehavior
+        , selectAll LocalActorGroup  groupBehavior
+        , selectAll LocalActorRepo   repoBehavior
+        , selectAll LocalActorDeck   deckBehavior
+        , selectAll LocalActorLoom   loomBehavior
+        ]
+        where
+        selectAll
+            :: PersistRecordBackend a SqlBackend
+            => (Key a -> LocalActorBy Key)
+            -> (UTCTime -> Key a -> Verse -> ExceptT Text Act (Text, Act (), Next))
+            -> WorkerDB [(LocalActorBy Key, Verse -> Act (Either Text Text, Act (), Next))]
+        selectAll makeLocalActor behavior =
+            map (\ xid -> (makeLocalActor xid, behave behavior xid)) <$>
+                selectKeysList [] []
+
 -- | Convert our foundation to a WAI Application by calling @toWaiAppPlain@ and
 -- applying some additional middlewares.
 makeApplication :: App -> IO Application

src/Vervis/Data/Actor.hs

@@ -1,6 +1,6 @@
 {- This file is part of Vervis.
  -
- - Written in 2022 by fr33domlover <fr33domlover@riseup.net>.
+ - Written in 2022, 2023 by fr33domlover <fr33domlover@riseup.net>.
  -
  - ♡ Copying is an act of love. Please copy, reuse and share.
  -
@@ -21,17 +21,27 @@ module Vervis.Data.Actor
     , parseStampRoute
     , localActorID
     , parseLocalURI
-    , parseFedURI
+    , parseFedURIOld
     , parseLocalActorE
     )
 where
 
+import Control.Concurrent.Chan
+import Control.Concurrent.STM.TVar
+import Control.Monad
+import Control.Monad.IO.Class
+import Control.Monad.Logger.CallStack
 import Control.Monad.Trans.Except
 import Data.Text (Text)
 import Database.Persist.Types
+import UnliftIO.Exception (try, SomeException, displayException)
+
+import qualified Data.HashMap.Strict as HM
+import qualified Data.Text as T
 
 import Network.FedURI
 import Yesod.ActivityPub
+import Yesod.Actor
 import Yesod.FedURI
 import Yesod.Hashids
 import Yesod.MonadSite
@@ -76,7 +86,7 @@ parseActivityURI
             FedURI
         )
 parseActivityURI u@(ObjURI h lu) = do
-    hl <- hostIsLocal h
+    hl <- hostIsLocalOld h
     if hl
         then Left <$> parseLocalActivityURI lu
         else pure $ Right u
@@ -95,6 +105,8 @@ stampRoute (LocalActorRepo r) = RepoStampR r
 stampRoute (LocalActorDeck d) = DeckStampR d
 stampRoute (LocalActorLoom l) = LoomStampR l
 
+parseStampRoute
+    :: Route App -> Maybe (LocalActorBy KeyHashid, KeyHashid SigKey)
 parseStampRoute (PersonStampR p i) = Just (LocalActorPerson p, i)
 parseStampRoute (GroupStampR g i)  = Just (LocalActorGroup g, i)
 parseStampRoute (RepoStampR r i)   = Just (LocalActorRepo r, i)
@@ -102,18 +114,23 @@ parseStampRoute (DeckStampR d i)   = Just (LocalActorDeck d, i)
 parseStampRoute (LoomStampR l i)   = Just (LocalActorLoom l, i)
 parseStampRoute _                       = Nothing
 
+localActorID :: LocalActorBy Entity -> ActorId
 localActorID (LocalActorPerson (Entity _ p)) = personActor p
 localActorID (LocalActorGroup (Entity _ g))  = groupActor g
 localActorID (LocalActorRepo (Entity _ r))   = repoActor r
 localActorID (LocalActorDeck (Entity _ d))   = deckActor d
 localActorID (LocalActorLoom (Entity _ l))   = loomActor l
 
-parseLocalURI :: LocalURI -> ExceptT Text Handler (Route App)
+parseFedURIOld
-parseLocalURI lu = fromMaybeE (decodeRouteLocal lu) "Not a valid route"
+    :: ( MonadSite m
-
+       , SiteEnv m ~ site
-parseFedURI :: FedURI -> ExceptT Text Handler (Either (Route App) FedURI)
+       , YesodActivityPub site
-parseFedURI u@(ObjURI h lu) = do
+       , SiteFedURIMode site ~ URIMode
-    hl <- hostIsLocal h
+       )
+    => FedURI
+    -> ExceptT Text m (Either (Route App) FedURI)
+parseFedURIOld u@(ObjURI h lu) = do
+    hl <- hostIsLocalOld h
     if hl
         then Left <$> parseLocalURI lu
         else pure $ Right u

src/Vervis/Data/Collab.hs

@@ -1,6 +1,6 @@
 {- This file is part of Vervis.
  -
- - Written in 2022 by fr33domlover <fr33domlover@riseup.net>.
+ - Written in 2022, 2023 by fr33domlover <fr33domlover@riseup.net>.
  -
  - ♡ Copying is an act of love. Please copy, reuse and share.
  -
@@ -42,6 +42,7 @@ import GHC.Generics
 
 import Network.FedURI
 import Yesod.ActivityPub
+import Yesod.Actor
 import Yesod.FedURI
 import Yesod.Hashids
 import Yesod.MonadSite
@@ -86,7 +87,7 @@ verifyRole (Right _) =
     throwE "ForgeFed Admin is the only role allowed currently"
 
 parseTopic u = do
-    routeOrRemote <- parseFedURI u
+    routeOrRemote <- parseFedURIOld u
     bitraverse
         (\ route -> do
             resourceHash <-
@@ -113,7 +114,7 @@ parseInvite sender (AP.Invite instrument object target) = do
         <*> nameExceptT "Invite object" (parseRecipient object)
     where
     parseRecipient u = do
-        routeOrRemote <- parseFedURI u
+        routeOrRemote <- parseFedURIOld u
         bitraverse
             (\ route -> do
                 recipHash <-
@@ -158,7 +159,7 @@ parseGrant (AP.Grant object context target) = do
     verifyRole (Right _) =
         throwE "ForgeFed Admin is the only role allowed currently"
     parseContext u@(ObjURI h lu) = do
-        hl <- hostIsLocal h
+        hl <- hostIsLocalOld h
         if hl
             then Left <$> do
                 route <-
@@ -179,7 +180,7 @@ parseGrant (AP.Grant object context target) = do
         parseGrantResource (LoomR l) = Just $ GrantResourceLoom l
         parseGrantResource _         = Nothing
     parseTarget u@(ObjURI h lu) = do
-        hl <- hostIsLocal h
+        hl <- hostIsLocalOld h
         if hl
             then Left <$> do
                 route <-

src/Vervis/Data/Discussion.hs

@@ -1,6 +1,7 @@
 {- This file is part of Vervis.
  -
- - Written in 2016, 2019, 2020, 2022 by fr33domlover <fr33domlover@riseup.net>.
+ - Written in 2016, 2019, 2020, 2022, 2023
+ - by fr33domlover <fr33domlover@riseup.net>.
  -
  - ♡ Copying is an act of love. Please copy, reuse and share.
  -
@@ -18,7 +19,8 @@ module Vervis.Data.Discussion
     , commentTopicAudience
     , commentTopicManagingActor
     , Comment (..)
-    , parseNewLocalComment
+    , parseNewLocalCommentOld
+    , parseRemoteCommentOld
     , parseRemoteComment
     , messageRoute
     )
@@ -29,24 +31,53 @@ import Data.Bitraversable
 import Data.Text (Text)
 import Data.Time.Clock
 
+import Control.Concurrent.Actor
 import Network.FedURI
+import Web.Actor.Persist
 import Web.Text
 import Yesod.ActivityPub
+import Yesod.Actor
 import Yesod.FedURI
-import Yesod.Hashids
+import Yesod.MonadSite
 
 import qualified Web.ActivityPub as AP
+import qualified Yesod.Hashids as YH
 
 import Control.Monad.Trans.Except.Local
 
+import Vervis.Actor
 import Vervis.Data.Actor
 import Vervis.FedURI
 import Vervis.Foundation
 import Vervis.Model
 import Vervis.Recipient
 
-parseCommentId
+parseCommentIdOld
-    :: Route App -> ExceptT Text Handler (LocalActorBy Key, LocalMessageId)
+    :: ( MonadSite m
+       , SiteEnv m ~ site
+       , YH.YesodHashids site
+       , SiteFedURIMode site ~ URIMode
+       )
+    => Route App
+    -> ExceptT Text m (LocalActorBy Key, LocalMessageId)
+parseCommentIdOld (PersonMessageR p m) =
+    (,) <$> (LocalActorPerson <$> YH.decodeKeyHashidE p "Invalid actor keyhashid")
+        <*> YH.decodeKeyHashidE m "Invalid LocalMessage keyhashid"
+parseCommentIdOld (GroupMessageR g m) =
+    (,) <$> (LocalActorGroup <$> YH.decodeKeyHashidE g "Invalid actor keyhashid")
+        <*> YH.decodeKeyHashidE m "Invalid LocalMessage keyhashid"
+parseCommentIdOld (RepoMessageR r m) =
+    (,) <$> (LocalActorRepo <$> YH.decodeKeyHashidE r "Invalid actor keyhashid")
+        <*> YH.decodeKeyHashidE m "Invalid LocalMessage keyhashid"
+parseCommentIdOld (DeckMessageR d m) =
+    (,) <$> (LocalActorDeck <$> YH.decodeKeyHashidE d "Invalid actor keyhashid")
+        <*> YH.decodeKeyHashidE m "Invalid LocalMessage keyhashid"
+parseCommentIdOld (LoomMessageR l m) =
+    (,) <$> (LocalActorLoom <$> YH.decodeKeyHashidE l "Invalid actor keyhashid")
+        <*> YH.decodeKeyHashidE m "Invalid LocalMessage keyhashid"
+parseCommentIdOld _ = throwE "Not a message route"
+
+parseCommentId :: Route App -> ActE (LocalActorBy Key, LocalMessageId)
 parseCommentId (PersonMessageR p m) =
     (,) <$> (LocalActorPerson <$> decodeKeyHashidE p "Invalid actor keyhashid")
         <*> decodeKeyHashidE m "Invalid LocalMessage keyhashid"
@@ -77,7 +108,24 @@ commentTopicAudience (CommentTopicCloth loomID clothID) =
 commentTopicManagingActor :: CommentTopic -> LocalActorBy Key
 commentTopicManagingActor = fst . commentTopicAudience
 
-parseCommentTopic :: Route App -> ExceptT Text Handler CommentTopic
+parseCommentTopicOld
+    :: (MonadSite m, YH.YesodHashids (SiteEnv m))
+    => Route App
+    -> ExceptT Text m CommentTopic
+parseCommentTopicOld (TicketR dkhid ltkhid) =
+    CommentTopicTicket
+        <$> YH.decodeKeyHashidE dkhid "Invalid dkhid"
+        <*> YH.decodeKeyHashidE ltkhid "Invalid ltkhid"
+parseCommentTopicOld (ClothR lkhid ltkhid) =
+    CommentTopicCloth
+        <$> YH.decodeKeyHashidE lkhid "Invalid lkhid"
+        <*> YH.decodeKeyHashidE ltkhid "Invalid ltkhid"
+parseCommentTopicOld _ = throwE "Not a ticket/cloth route"
+
+parseCommentTopic
+    :: (MonadActor m, StageHashids (ActorEnv m))
+    => Route App
+    -> ExceptT Text m CommentTopic
 parseCommentTopic (TicketR dkhid ltkhid) =
     CommentTopicTicket
         <$> decodeKeyHashidE dkhid "Invalid dkhid"
@@ -95,7 +143,28 @@ data Comment = Comment
     , commentContent :: HTML
     }
 
-parseComment :: AP.Note URIMode -> ExceptT Text Handler (Maybe LocalURI, LocalURI, Maybe UTCTime, Comment)
+parseCommentOld
+    :: ( MonadSite m
+       , SiteEnv m ~ site
+       , YH.YesodHashids site
+       , YesodActivityPub site
+       , SiteFedURIMode site ~ URIMode
+       )
+    => AP.Note URIMode
+    -> ExceptT Text m (Maybe LocalURI, LocalURI, Maybe UTCTime, Comment)
+parseCommentOld (AP.Note mluNote luAttrib _aud muParent muContext mpublished source content) = do
+    uContext <- fromMaybeE muContext "Note without context"
+    topic <- bitraverse parseCommentTopicOld pure =<< parseFedURIOld uContext
+    maybeParent <- do
+        uParent <- fromMaybeE muParent "Note doesn't specify inReplyTo"
+        if uParent == uContext
+            then pure Nothing
+            else fmap Just . bitraverse parseCommentIdOld pure =<< parseFedURIOld uParent
+    return (mluNote, luAttrib, mpublished, Comment maybeParent topic source content)
+
+parseComment
+    :: AP.Note URIMode
+    -> ActE (Maybe LocalURI, LocalURI, Maybe UTCTime, Comment)
 parseComment (AP.Note mluNote luAttrib _aud muParent muContext mpublished source content) = do
     uContext <- fromMaybeE muContext "Note without context"
     topic <- bitraverse parseCommentTopic pure =<< parseFedURI uContext
@@ -106,10 +175,10 @@ parseComment (AP.Note mluNote luAttrib _aud muParent muContext mpublished source
             else fmap Just . bitraverse parseCommentId pure =<< parseFedURI uParent
     return (mluNote, luAttrib, mpublished, Comment maybeParent topic source content)
 
-parseNewLocalComment
+parseNewLocalCommentOld
     :: AP.Note URIMode -> ExceptT Text Handler (PersonId, Comment)
-parseNewLocalComment note = do
+parseNewLocalCommentOld note = do
-    (mluId, luAuthor, maybePublished, comment) <- parseComment note
+    (mluId, luAuthor, maybePublished, comment) <- parseCommentOld note
     verifyNothingE mluId "Note specifies an id"
     authorPersonID <- do
         authorByKey <-
@@ -121,9 +190,24 @@ parseNewLocalComment note = do
     verifyNothingE maybePublished "Note specifies published"
     return (authorPersonID, comment)
 
+parseRemoteCommentOld
+    :: ( MonadSite m
+       , SiteEnv m ~ site
+       , YH.YesodHashids site
+       , YesodActivityPub site
+       , SiteFedURIMode site ~ URIMode
+       )
+    => AP.Note URIMode
+    -> ExceptT Text m (LocalURI, LocalURI, UTCTime, Comment)
+parseRemoteCommentOld note = do
+    (mluId, luAuthor, maybePublished, comment) <- parseCommentOld note
+    luId <- fromMaybeE mluId "Note doesn't specify id"
+    published <- fromMaybeE maybePublished "Note doesn't specify published"
+    return (luId, luAuthor, published, comment)
+
 parseRemoteComment
     :: AP.Note URIMode
-    -> ExceptT Text Handler (LocalURI, LocalURI, UTCTime, Comment)
+    -> ExceptT Text Act (LocalURI, LocalURI, UTCTime, Comment)
 parseRemoteComment note = do
     (mluId, luAuthor, maybePublished, comment) <- parseComment note
     luId <- fromMaybeE mluId "Note doesn't specify id"

src/Vervis/Data/Follow.hs

@@ -1,6 +1,6 @@
 {- This file is part of Vervis.
  -
- - Written in 2022 by fr33domlover <fr33domlover@riseup.net>.
+ - Written in 2022, 2023 by fr33domlover <fr33domlover@riseup.net>.
  -
  - ♡ Copying is an act of love. Please copy, reuse and share.
  -
@@ -62,7 +62,7 @@ parseFollow
     -> ExceptT Text Handler
         (Either (FolloweeBy Key) (Host, LocalURI, LocalURI), Bool)
 parseFollow (AP.Follow uObject mluContext hide) = do
-    routeOrRemote <- parseFedURI uObject
+    routeOrRemote <- parseFedURIOld uObject
     (,hide) <$>
         bitraverse
             (parseLocal mluContext)

src/Vervis/Data/Ticket.hs

@@ -1,6 +1,6 @@
 {- This file is part of Vervis.
  -
- - Written in 2022 by fr33domlover <fr33domlover@riseup.net>.
+ - Written in 2022, 2023 by fr33domlover <fr33domlover@riseup.net>.
  -
  - ♡ Copying is an act of love. Please copy, reuse and share.
  -
@@ -66,6 +66,7 @@ import Development.PatchMediaType
 import Network.FedURI
 import Web.Text
 import Yesod.ActivityPub
+import Yesod.Actor
 import Yesod.FedURI
 import Yesod.Hashids
 import Yesod.MonadSite
@@ -113,7 +114,7 @@ data WorkItemOffer = WorkItemOffer
 
 checkAuthor :: FedURI -> ExceptT Text Handler (Either PersonId FedURI)
 checkAuthor u@(ObjURI h lu) = do
-    hl <- hostIsLocal h
+    hl <- hostIsLocalOld h
     if hl
         then do
             route <- fromMaybeE (decodeRouteLocal lu) "Local author not a valid route"
@@ -143,7 +144,7 @@ checkBundle h (AP.BundleOffer mlocal patches) = do
 
 checkTipURI :: FedURI -> ExceptT Text Handler (Either RepoId FedURI)
 checkTipURI u@(ObjURI h lu) = do
-    hl <- hostIsLocal h
+    hl <- hostIsLocalOld h
     if hl
         then Left <$> do
             route <- fromMaybeE (decodeRouteLocal lu) "URI is local but isn't a valid route"
@@ -177,7 +178,7 @@ checkMR h (AP.MergeRequest muOrigin target mbundle) =
 
 checkTracker :: FedURI -> ExceptT Text Handler Tracker
 checkTracker u@(ObjURI h lu) = do
-    hl <- hostIsLocal h
+    hl <- hostIsLocalOld h
     if hl
         then do
             route <- fromMaybeE (decodeRouteLocal lu) "Local tracker not a valid route"
@@ -230,7 +231,7 @@ checkOfferTicket host ticket uTarget = do
     return $ WorkItemOffer author title desc source tam
 
 parseBundleRoute name u@(ObjURI h lu) = do
-    hl <- hostIsLocal h
+    hl <- hostIsLocalOld h
     if hl
         then Left <$> do
             route <-

src/Vervis/Federation/Auth.hs

@@ -1,6 +1,6 @@
 {- This file is part of Vervis.
  -
- - Written in 2019, 2022 by fr33domlover <fr33domlover@riseup.net>.
+ - Written in 2019, 2022, 2023 by fr33domlover <fr33domlover@riseup.net>.
  -
  - ♡ Copying is an act of love. Please copy, reuse and share.
  -
@@ -14,10 +14,10 @@
  -}
 
 module Vervis.Federation.Auth
-    ( RemoteAuthor (..)
+    ( --RemoteAuthor (..)
-    , ActivityAuthentication (..)
+    --, ActivityAuthentication (..)
-    , ActivityBody (..)
+    --, ActivityBody (..)
-    , authenticateActivity
+      authenticateActivity
     , checkForwarding
     )
 where
@@ -79,6 +79,7 @@ import Network.FedURI
 import Network.HTTP.Digest
 import Web.ActivityPub hiding (Follow)
 import Yesod.ActivityPub
+import Yesod.Actor
 import Yesod.Auth.Unverified
 import Yesod.FedURI
 import Yesod.Hashids
@@ -94,6 +95,7 @@ import Data.Tuple.Local
 import Database.Persist.Local
 import Yesod.Persist.Local
 
+import Vervis.Actor
 import Vervis.ActivityPub
 import Vervis.Data.Actor
 import Vervis.FedURI
@@ -104,22 +106,6 @@ import Vervis.Recipient
 import Vervis.RemoteActorStore
 import Vervis.Settings
 
-data RemoteAuthor = RemoteAuthor
-    { remoteAuthorURI      :: FedURI
-    , remoteAuthorInstance :: InstanceId
-    , remoteAuthorId       :: RemoteActorId
-    }
-
-data ActivityAuthentication
-    = ActivityAuthLocal (LocalActorBy Key)
-    | ActivityAuthRemote RemoteAuthor
-
-data ActivityBody = ActivityBody
-    { actbBL         :: BL.ByteString
-    , actbObject     :: Object
-    , actbActivity   :: Activity URIMode
-    }
-
 parseKeyId (KeyId k) =
     case parseRefURI =<< (first displayException . decodeUtf8') k of
         Left e -> throwE $ "keyId isn't a valid FedURI: " ++ e
@@ -365,7 +351,7 @@ verifyForwardedSig hAuthor luAuthor (Verification malgo keyid input signature) =
     RefURI hKey luKey <- parseKeyId keyid
     unless (hAuthor == hKey) $
         throwE "Author and forwarded sig key on different hosts"
-    local <- hostIsLocal hKey
+    local <- hostIsLocalOld hKey
     if local
         then ActivityAuthLocal <$> verifySelfSig luAuthor luKey input signature
         else ActivityAuthRemote <$> verifyActorSig' malgo input signature hKey luKey (Just luAuthor)

src/Vervis/Federation/Collab.hs

@@ -1,6 +1,6 @@
 {- This file is part of Vervis.
  -
- - Written in 2022 by fr33domlover <fr33domlover@riseup.net>.
+ - Written in 2022, 2023 by fr33domlover <fr33domlover@riseup.net>.
  -
  - ♡ Copying is an act of love. Please copy, reuse and share.
  -
@@ -76,6 +76,7 @@ import Yesod.Persist.Local
 
 import Vervis.Access
 import Vervis.ActivityPub
+import Vervis.Actor
 import Vervis.Data.Actor
 import Vervis.Data.Collab
 import Vervis.Web.Delivery

src/Vervis/Federation/Discussion.hs

@@ -1,6 +1,6 @@
 {- This file is part of Vervis.
  -
- - Written in 2019, 2020, 2022 by fr33domlover <fr33domlover@riseup.net>.
+ - Written in 2019, 2020, 2022, 2023 by fr33domlover <fr33domlover@riseup.net>.
  -
  - ♡ Copying is an act of love. Please copy, reuse and share.
  -
@@ -67,6 +67,7 @@ import Database.Persist.Local
 import Yesod.Persist.Local
 
 import Vervis.ActivityPub
+import Vervis.Actor
 import Vervis.Cloth
 import Vervis.Data.Discussion
 import Vervis.FedURI
@@ -179,7 +180,7 @@ personCreateNoteF now recipPersonHash author body mfwd luCreate note = do
     -- Check input
     recipPersonID <- decodeKeyHashid404 recipPersonHash
     (luNote, published, Comment maybeParent topic source content) <- do
-        (luId, luAuthor, published, comment) <- parseRemoteComment note
+        (luId, luAuthor, published, comment) <- parseRemoteCommentOld note
         unless (luAuthor == objUriLocal (remoteAuthorURI author)) $
             throwE "Create author != note author"
         return (luId, published, comment)
@@ -253,7 +254,7 @@ deckCreateNoteF now recipDeckHash author body mfwd luCreate note = do
 
     recipDeckID <- decodeKeyHashid404 recipDeckHash
     (luNote, published, Comment maybeParent topic source content) <- do
-        (luId, luAuthor, published, comment) <- parseRemoteComment note
+        (luId, luAuthor, published, comment) <- parseRemoteCommentOld note
         unless (luAuthor == objUriLocal (remoteAuthorURI author)) $
             throwE "Create author != note author"
         return (luId, published, comment)
@@ -322,7 +323,7 @@ loomCreateNoteF now recipLoomHash author body mfwd luCreate note = do
 
     recipLoomID <- decodeKeyHashid404 recipLoomHash
     (luNote, published, Comment maybeParent topic source content) <- do
-        (luId, luAuthor, published, comment) <- parseRemoteComment note
+        (luId, luAuthor, published, comment) <- parseRemoteCommentOld note
         unless (luAuthor == objUriLocal (remoteAuthorURI author)) $
             throwE "Create author != note author"
         return (luId, published, comment)

src/Vervis/Federation/Offer.hs

@@ -1,6 +1,6 @@
 {- This file is part of Vervis.
  -
- - Written in 2019, 2020, 2022 by fr33domlover <fr33domlover@riseup.net>.
+ - Written in 2019, 2020, 2022, 2023 by fr33domlover <fr33domlover@riseup.net>.
  -
  - ♡ Copying is an act of love. Please copy, reuse and share.
  -
@@ -82,6 +82,7 @@ import Yesod.Persist.Local
 
 import Vervis.Access
 import Vervis.ActivityPub
+import Vervis.Actor
 import Vervis.Cloth
 import Vervis.Data.Actor
 import Vervis.FedURI
@@ -323,7 +324,7 @@ followF parseFollowee grabActor unread getFollowee getSieve makeLocalActor makeA
     recipID <- decodeKeyHashid404 recipHash
     followee <- nameExceptT "Follow object" $ do
         route <- do
-            routeOrRemote <- parseFedURI uObject
+            routeOrRemote <- parseFedURIOld uObject
             case routeOrRemote of
                 Left route -> pure route
                 Right _ -> throwE "Remote, so definitely not me/mine"

src/Vervis/Federation/Ticket.hs

@@ -1,6 +1,7 @@
 {- This file is part of Vervis.
  -
- - Written in 2019, 2020, 2021, 2022 by fr33domlover <fr33domlover@riseup.net>.
+ - Written in 2019, 2020, 2021, 2022, 2023
+ - by fr33domlover <fr33domlover@riseup.net>.
  -
  - ♡ Copying is an act of love. Please copy, reuse and share.
  -
@@ -95,6 +96,7 @@ import Development.PatchMediaType
 
 import Vervis.Access
 import Vervis.ActivityPub
+import Vervis.Actor
 import Vervis.Cloth
 import Vervis.Data.Actor
 import Vervis.Data.Ticket
@@ -1902,7 +1904,7 @@ trackerResolveF maybeWorkItem grabActor getWorkItem makeResource trackerFollower
     recipID <- decodeKeyHashid404 recipHash
     wiID <- nameExceptT "Resolve object" $ do
         route <- do
-            routeOrRemote <- parseFedURI uObject
+            routeOrRemote <- parseFedURIOld uObject
             case routeOrRemote of
                 Left route -> pure route
                 Right _ -> throwE "Remote, so definitely not mine"

src/Vervis/Federation/Util.hs

@@ -1,6 +1,6 @@
 {- This file is part of Vervis.
  -
- - Written in 2019, 2020 by fr33domlover <fr33domlover@riseup.net>.
+ - Written in 2019, 2020, 2023 by fr33domlover <fr33domlover@riseup.net>.
  -
  - ♡ Copying is an act of love. Please copy, reuse and share.
  -
@@ -31,6 +31,7 @@ import Network.FedURI
 
 import Database.Persist.Local
 
+import Vervis.Actor
 import Vervis.Federation.Auth
 import Vervis.Foundation
 import Vervis.Model

src/Vervis/Foundation.hs

@@ -1,6 +1,7 @@
 {- This file is part of Vervis.
  -
- - Written in 2016, 2018, 2019, 2022 by fr33domlover <fr33domlover@riseup.net>.
+ - Written in 2016, 2018, 2019, 2022, 2023
+ - by fr33domlover <fr33domlover@riseup.net>.
  -
  - ♡ Copying is an act of love. Please copy, reuse and share.
  -
@@ -21,6 +22,8 @@ import Control.Concurrent.STM.TVar
 import Control.Monad
 import Control.Monad.Logger.CallStack (logWarn)
 import Control.Monad.Trans.Maybe
+import Data.ByteString (ByteString)
+import Data.HashMap.Strict (HashMap)
 import Data.List.NonEmpty (NonEmpty (..))
 import Data.Text (Text)
 import Data.Text.Encoding
@@ -48,10 +51,11 @@ import Yesod.Core.Types
 import Yesod.Default.Util   (addStaticContentExternal)
 import Yesod.Form.Fields
 import Yesod.Form.Functions
-import Yesod.Form.Types
+import Yesod.Form.Types hiding (Env)
 import Yesod.Persist.Core
 import Yesod.Static
 
+import qualified Data.Aeson as A
 import qualified Data.ByteString.Lazy as BL (ByteString)
 import qualified Data.Time.Units as U
 import qualified Database.Esqueleto as E
@@ -69,21 +73,25 @@ import Yesod.Mail.Send
 
 import qualified Network.HTTP.Signature as S (Algorithm (..))
 
+import Control.Concurrent.Actor hiding (Message)
 import Crypto.ActorKey
 import Crypto.PublicVerifKey
 import Network.FedURI
 import Web.ActivityAccess
+import Web.Actor.Persist
 import Yesod.ActivityPub
+import Yesod.Actor
 import Yesod.FedURI
-import Yesod.Hashids
 import Yesod.MonadSite
 
 import qualified Web.ActivityPub as AP
+import qualified Yesod.Hashids as YH
 
 import Text.Email.Local
 import Text.Jasmine.Local (discardm)
 import Yesod.Paginate.Local
 
+import Vervis.Actor
 import Vervis.FedURI
 import Vervis.Hook
 import Vervis.Model
@@ -95,6 +103,10 @@ import Vervis.Settings
 import Vervis.Style
 import Vervis.Widget (breadcrumbsW, revisionW)
 
+data ActivityAuthentication
+    = ActivityAuthLocal (LocalActorBy Key)
+    | ActivityAuthRemote RemoteAuthor
+
 data ActivityReport = ActivityReport
     { _arTime         :: UTCTime
     , _arMessage      :: Text
@@ -120,6 +132,7 @@ data App = App
     , appHashidsContext :: HashidsContext
     , appHookSecret      :: HookSecret
     , appActorFetchShare :: ActorFetchShare App
+    , appTheater :: Theater
 
     , appActivities  :: Maybe (Int, TVar (Vector ActivityReport))
     }
@@ -142,6 +155,9 @@ type TicketDeckKeyHashid        = KeyHashid TicketDeck
 type TicketLoomKeyHashid        = KeyHashid TicketLoom
 type SigKeyKeyHashid            = KeyHashid SigKey
 
+instance StageYesod Env where
+    type StageSite Env = App
+
 -- This is where we define all of the routes in our application. For a full
 -- explanation of the syntax, please see:
 -- http://www.yesodweb.com/book/routing-and-handlers
@@ -259,7 +275,7 @@ instance Yesod App where
                     case vs :: [E.Value Int] of
                         [E.Value i] -> return i
                         _ -> error $ "countUnread returned " ++ show vs
-                hash <- encodeKeyHashid pid
+                hash <- YH.encodeKeyHashid pid
                 return (p, hash, verified, unread)
         (title, bcs) <- breadcrumbs
 
@@ -448,7 +464,7 @@ instance Yesod App where
 
         person :: KeyHashid Person -> Handler AuthResult
         person hash = personAnd $ \ (Entity pid _) -> do
-            hash' <- encodeKeyHashid pid
+            hash' <- YH.encodeKeyHashid pid
             return $ if hash == hash'
                 then Authorized
                 else Unauthorized "No access to this operation"
@@ -770,7 +786,7 @@ unsafeHandler = Unsafe.fakeHandlerGetLogger appLogger
 -- https://github.com/yesodweb/yesod/wiki/Serve-static-files-from-a-separate-domain
 -- https://github.com/yesodweb/yesod/wiki/i18n-messages-in-the-scaffolding
 
-instance YesodHashids App where
+instance YH.YesodHashids App where
     siteHashidsContext = appHashidsContext
 
 instance YesodRemoteActorStore App where

src/Vervis/Handler/Client.hs

@@ -1,6 +1,6 @@
 {- This file is part of Vervis.
  -
- - Written in 2016, 2018, 2019, 2020, 2022
+ - Written in 2016, 2018, 2019, 2020, 2022, 2023
  - by fr33domlover <fr33domlover@riseup.net>.
  -
  - ♡ Copying is an act of love. Please copy, reuse and share.
@@ -30,6 +30,9 @@ module Vervis.Handler.Client
     , getPublishOfferMergeR
     , postPublishOfferMergeR
 
+    --, getPublishCommentR
+    --, postPublishCommentR
+
     , getPublishMergeR
     , postPublishMergeR
     )
@@ -1025,7 +1028,7 @@ postPublishOfferMergeR = do
     (ep@(Entity pid _), a) <- getSender
     senderHash <- encodeKeyHashid pid
 
-    trackerLocal <- hostIsLocal $ objUriAuthority omgTracker
+    trackerLocal <- hostIsLocalOld $ objUriAuthority omgTracker
     edest <- runExceptT $ do
         (summary, audience, ticket) <-
             offerMerge
@@ -1056,6 +1059,65 @@ postPublishOfferMergeR = do
                 else setMessage "Offer published"
             redirect dest
 
+{-
+data Comment = Comment
+    { commentTopic  :: FedURI
+    , commentParent :: Maybe FedURI
+    , commentText   :: PandocMarkdown
+    }
+
+commentForm :: Form Comment
+commentForm = Comment
+    <$> areq fedUriField "Topic"       Nothing
+    <*> aopt fedUriField "Replying to" Nothing
+    <*> (pandocMarkdownFromText <$>
+            areq textField "Message"   Nothing
+        )
+
+getPublishCommentR :: Handler Html
+getPublishCommentR = do
+    ((_, widget), enctype) <- runFormPost commentForm
+    defaultLayout
+        [whamlet|
+            <h1>Comment on a ticket or a merge request
+            <form method=POST action=@{PublishCommentR} enctype=#{enctype}>
+              ^{widget}
+              <input type=submit>
+        |]
+
+postPublishCommentR :: Handler ()
+postPublishCommentR = do
+    federation <- getsYesod $ appFederation . appSettings
+    unless federation badMethod
+
+    Comment uTopic uParent source <-
+        runFormPostRedirect PublishCommentR commentForm
+
+    (ep@(Entity pid _), a) <- getSender
+    senderHash <- encodeKeyHashid pid
+
+    result <- runExceptT $ do
+
+
+
+
+
+
+
+        (maybeSummary, audience, apply) <- applyPatches senderHash uBundle
+        (localRecips, remoteRecips, fwdHosts, action) <-
+            makeServerInput (Just uCap) maybeSummary audience (AP.ApplyActivity apply)
+        applyC ep a (Just cap) localRecips remoteRecips fwdHosts action apply
+
+    case result of
+        Left err -> do
+            setMessage $ toHtml err
+            redirect PublishMergeR
+        Right _ -> do
+            setMessage "Apply activity sent"
+            redirect HomeR
+-}
+
 mergeForm = renderDivs $ (,)
     <$> areq fedUriField "Patch bundle to apply"                   Nothing
     <*> areq capField    "Grant activity to use for authorization" Nothing

src/Vervis/Handler/Deck.hs

@@ -1,6 +1,6 @@
 {- This file is part of Vervis.
  -
- - Written in 2016, 2019, 2022 by fr33domlover <fr33domlover@riseup.net>.
+ - Written in 2016, 2019, 2022, 2023 by fr33domlover <fr33domlover@riseup.net>.
  -
  - ♡ Copying is an act of love. Please copy, reuse and share.
  -
@@ -177,19 +177,11 @@ getDeckInboxR :: KeyHashid Deck -> Handler TypedContent
 getDeckInboxR = getInbox DeckInboxR deckActor
 
 postDeckInboxR :: KeyHashid Deck -> Handler ()
-postDeckInboxR recipDeckHash =
+postDeckInboxR deckHash = do
-    postInbox $ handleRobotInbox (LocalActorDeck recipDeckHash) handle
+    deckID <- decodeKeyHashid404 deckHash
-    where
+    postInbox $ LocalActorDeck deckID
-    handle
+
-        :: UTCTime
+{-
-        -> RemoteAuthor
-        -> ActivityBody
-        -> Maybe (RecipientRoutes, ByteString)
-        -> LocalURI
-        -> SpecificActivity URIMode
-        -> ExceptT Text Handler (Text, Maybe (ExceptT Text Worker Text))
-    handle now author body mfwd luActivity specific =
-        case specific of
             AP.AcceptActivity accept ->
                 deckAcceptF now recipDeckHash author body mfwd luActivity accept
             AP.CreateActivity (AP.Create obj mtarget) ->
@@ -217,6 +209,7 @@ postDeckInboxR recipDeckHash =
             AP.UndoActivity undo ->
                 (,Nothing) <$> deckUndoF now recipDeckHash author body mfwd luActivity undo
             _ -> return ("Unsupported activity type for decks", Nothing)
+-}
 
 getDeckOutboxR :: KeyHashid Deck -> Handler TypedContent
 getDeckOutboxR = getOutbox DeckOutboxR DeckOutboxItemR deckActor

src/Vervis/Handler/Group.hs

@@ -1,6 +1,6 @@
 {- This file is part of Vervis.
  -
- - Written in 2016, 2019, 2022 by fr33domlover <fr33domlover@riseup.net>.
+ - Written in 2016, 2019, 2022, 2023 by fr33domlover <fr33domlover@riseup.net>.
  -
  - ♡ Copying is an act of love. Please copy, reuse and share.
  -
@@ -115,20 +115,9 @@ getGroupInboxR :: KeyHashid Group -> Handler TypedContent
 getGroupInboxR = getInbox GroupInboxR groupActor
 
 postGroupInboxR :: KeyHashid Group -> Handler ()
-postGroupInboxR recipGroupHash =
+postGroupInboxR groupHash = do
-    postInbox $ handleRobotInbox (LocalActorGroup recipGroupHash) handle
+    groupID <- decodeKeyHashid404 groupHash
-    where
+    postInbox $ LocalActorGroup groupID
-    handle
-        :: UTCTime
-        -> RemoteAuthor
-        -> ActivityBody
-        -> Maybe (RecipientRoutes, ByteString)
-        -> LocalURI
-        -> AP.SpecificActivity URIMode
-        -> ExceptT Text Handler (Text, Maybe (ExceptT Text Worker Text))
-    handle _now _author _body _mfwd _luActivity specific =
-        case specific of
-            _ -> return ("Unsupported activity type for groups", Nothing)
 
 getGroupOutboxR :: KeyHashid Group -> Handler TypedContent
 getGroupOutboxR = getOutbox GroupOutboxR GroupOutboxItemR groupActor

src/Vervis/Handler/Loom.hs

@@ -1,6 +1,6 @@
 {- This file is part of Vervis.
  -
- - Written in 2022 by fr33domlover <fr33domlover@riseup.net>.
+ - Written in 2022, 2023 by fr33domlover <fr33domlover@riseup.net>.
  -
  - ♡ Copying is an act of love. Please copy, reuse and share.
  -
@@ -138,19 +138,11 @@ getLoomInboxR :: KeyHashid Loom -> Handler TypedContent
 getLoomInboxR = getInbox LoomInboxR loomActor
 
 postLoomInboxR :: KeyHashid Loom -> Handler ()
-postLoomInboxR recipLoomHash =
+postLoomInboxR loomHash = do
-    postInbox $ handleRobotInbox (LocalActorLoom recipLoomHash) handle
+    loomID <- decodeKeyHashid404 loomHash
-    where
+    postInbox $ LocalActorLoom loomID
-    handle
+
-        :: UTCTime
+{-
-        -> RemoteAuthor
-        -> ActivityBody
-        -> Maybe (RecipientRoutes, ByteString)
-        -> LocalURI
-        -> AP.SpecificActivity URIMode
-        -> ExceptT Text Handler (Text, Maybe (ExceptT Text Worker Text))
-    handle now author body mfwd luActivity specific =
-        case specific of
             AP.AcceptActivity accept ->
                 loomAcceptF now recipLoomHash author body mfwd luActivity accept
             AP.ApplyActivity apply->
@@ -176,6 +168,7 @@ postLoomInboxR recipLoomHash =
             AP.UndoActivity undo ->
                 (,Nothing) <$> loomUndoF now recipLoomHash author body mfwd luActivity undo
             _ -> return ("Unsupported activity type for looms", Nothing)
+-}
 
 getLoomOutboxR :: KeyHashid Loom -> Handler TypedContent
 getLoomOutboxR = getOutbox LoomOutboxR LoomOutboxItemR loomActor

src/Vervis/Handler/Person.hs

@@ -1,6 +1,7 @@
 {- This file is part of Vervis.
  -
- - Written in 2016, 2018, 2019, 2022 by fr33domlover <fr33domlover@riseup.net>.
+ - Written in 2016, 2018, 2019, 2022, 2023
+ - by fr33domlover <fr33domlover@riseup.net>.
  -
  - ♡ Copying is an act of love. Please copy, reuse and share.
  -
@@ -57,6 +58,7 @@ import Text.Email.Local
 
 import Network.FedURI
 import Yesod.ActivityPub
+import Yesod.Actor
 import Yesod.FedURI
 import Yesod.Hashids
 import Yesod.MonadSite
@@ -138,103 +140,10 @@ getPersonR personHash = do
 getPersonInboxR :: KeyHashid Person -> Handler TypedContent
 getPersonInboxR = getInbox PersonInboxR personActor
 
-parseAuthenticatedLocalActivityURI
-    :: (MonadSite m, YesodHashids (SiteEnv m))
-    => LocalActorBy Key -> Maybe LocalURI -> ExceptT Text m OutboxItemId
-parseAuthenticatedLocalActivityURI author maybeActivityURI = do
-    luAct <- fromMaybeE maybeActivityURI "No 'id'"
-    (actorByKey, _, outboxItemID) <- parseLocalActivityURI luAct
-    unless (actorByKey == author) $
-        throwE "'actor' actor and 'id' actor mismatch"
-    return outboxItemID
-
-insertActivityToInbox
-    :: MonadIO m
-    => UTCTime -> ActorId -> OutboxItemId -> ReaderT SqlBackend m Bool
-insertActivityToInbox now recipActorID outboxItemID = do
-    inboxID <- actorInbox <$> getJust recipActorID
-    inboxItemID <- insert $ InboxItem True now
-    maybeItem <- insertUnique $ InboxItemLocal inboxID outboxItemID inboxItemID
-    case maybeItem of
-        Nothing -> do
-            delete inboxItemID
-            return False
-        Just _ -> return True
-
 postPersonInboxR :: KeyHashid Person -> Handler ()
-postPersonInboxR recipPersonHash = postInbox handle
+postPersonInboxR personHash = do
-    where
+    personID <- decodeKeyHashid404 personHash
-    handle
+    postInbox $ LocalActorPerson personID
-        :: UTCTime
-        -> ActivityAuthentication
-        -> ActivityBody
-        -> ExceptT Text Handler (Text, Maybe (ExceptT Text Worker Text))
-
-    handle now (ActivityAuthLocal authorByKey) body = (,Nothing) <$> do
-        outboxItemID <-
-            parseAuthenticatedLocalActivityURI
-                authorByKey
-                (AP.activityId $ actbActivity body)
-        recipPersonID <- decodeKeyHashid404 recipPersonHash
-        runDBExcept $ do
-            recipPerson <- lift $ get404 recipPersonID
-            verifyLocalActivityExistsInDB authorByKey outboxItemID
-            if LocalActorPerson recipPersonID == authorByKey
-                then return "Received activity authored by self, ignoring"
-                else lift $ do
-                    inserted <- insertActivityToInbox now (personActor recipPerson) outboxItemID
-                    return $
-                        if inserted
-                            then "Activity inserted to recipient's inbox"
-                            else "Activity already exists in recipient's inbox"
-
-    handle now (ActivityAuthRemote author) body = do
-        luActivity <-
-            fromMaybeE (AP.activityId $ actbActivity body) "Activity without 'id'"
-        localRecips <- do
-            mrecips <- parseAudience $ AP.activityAudience $ actbActivity body
-            paudLocalRecips <$> fromMaybeE mrecips "Activity with no recipients"
-        msig <- checkForwarding $ LocalActorPerson recipPersonHash
-        let mfwd = (localRecips,) <$> msig
-        case AP.activitySpecific $ actbActivity body of
-            {-
-            AcceptActivity accept ->
-                (,Nothing) <$> sharerAcceptF shrRecip now author body mfwd luActivity accept
-            AddActivity (AP.Add obj target) ->
-                case obj of
-                    Right (AddBundle patches) ->
-                        sharerAddBundleF now shrRecip author body mfwd luActivity patches target
-                    _ -> return ("Unsupported add object type for sharers", Nothing)
-            -}
-            AP.CreateActivity (AP.Create obj mtarget) ->
-                case obj of
-                    AP.CreateNote _ note ->
-                        (,Nothing) <$> personCreateNoteF now recipPersonHash author body mfwd luActivity note
-                    _ -> return ("Unsupported create object type for people", Nothing)
-            AP.FollowActivity follow ->
-                personFollowF now recipPersonHash author body mfwd luActivity follow
-            AP.GrantActivity grant ->
-                personGrantF now recipPersonHash author body mfwd luActivity grant
-            AP.InviteActivity invite ->
-                personInviteF now recipPersonHash author body mfwd luActivity invite
-            {-
-            OfferActivity (Offer obj target) ->
-                case obj of
-                    OfferTicket ticket ->
-                        (,Nothing) <$> sharerOfferTicketF now shrRecip author body mfwd luActivity ticket target
-                    OfferDep dep ->
-                        sharerOfferDepF now shrRecip author body mfwd luActivity dep target
-                    _ -> return ("Unsupported offer object type for sharers", Nothing)
-            PushActivity push ->
-                (,Nothing) <$> sharerPushF shrRecip now author body mfwd luActivity push
-            RejectActivity reject ->
-                (,Nothing) <$> sharerRejectF shrRecip now author body mfwd luActivity reject
-            ResolveActivity resolve ->
-                (,Nothing) <$> sharerResolveF now shrRecip author body mfwd luActivity resolve
-            -}
-            AP.UndoActivity undo ->
-                (,Nothing) <$> personUndoF now recipPersonHash author body mfwd luActivity undo
-            _ -> return ("Unsupported activity type for Person", Nothing)
 
 getPersonOutboxR :: KeyHashid Person -> Handler TypedContent
 getPersonOutboxR = getOutbox PersonOutboxR PersonOutboxItemR personActor
@@ -253,7 +162,7 @@ postPersonOutboxR personHash = do
     verifyContentTypeAP
 
     AP.Doc h activity <- requireInsecureJsonBody
-    hl <- hostIsLocal h
+    hl <- hostIsLocalOld h
     unless hl $ invalidArgs ["Activity host isn't the instance host"]
 
     result <- runExceptT $ do

src/Vervis/Handler/Repo.hs

@@ -1,6 +1,6 @@
 {- This file is part of Vervis.
  -
- - Written in 2016, 2018, 2019, 2020, 2022
+ - Written in 2016, 2018, 2019, 2020, 2022, 2023
  - by fr33domlover <fr33domlover@riseup.net>.
  -
  - ♡ Copying is an act of love. Please copy, reuse and share.
@@ -242,19 +242,11 @@ getRepoInboxR :: KeyHashid Repo -> Handler TypedContent
 getRepoInboxR = getInbox RepoInboxR repoActor
 
 postRepoInboxR :: KeyHashid Repo -> Handler ()
-postRepoInboxR recipRepoHash =
+postRepoInboxR repoHash = do
-    postInbox $ handleRobotInbox (LocalActorRepo recipRepoHash) handle
+    repoID <- decodeKeyHashid404 repoHash
-    where
+    postInbox $ LocalActorRepo repoID
-    handle
+
-        :: UTCTime
+{-
-        -> RemoteAuthor
-        -> ActivityBody
-        -> Maybe (RecipientRoutes, ByteString)
-        -> LocalURI
-        -> AP.SpecificActivity URIMode
-        -> ExceptT Text Handler (Text, Maybe (ExceptT Text Worker Text))
-    handle now author body mfwd luActivity specific =
-        case specific of
             AP.AcceptActivity accept ->
                 repoAcceptF now recipRepoHash author body mfwd luActivity accept
             {-
@@ -289,6 +281,7 @@ postRepoInboxR recipRepoHash =
             AP.UndoActivity undo->
                 (,Nothing) <$> repoUndoF now recipRepoHash author body mfwd luActivity undo
             _ -> return ("Unsupported activity type for repos", Nothing)
+-}
 
 getRepoOutboxR :: KeyHashid Repo -> Handler TypedContent
 getRepoOutboxR = getOutbox RepoOutboxR RepoOutboxItemR repoActor

src/Vervis/Model.hs

@@ -85,6 +85,26 @@ instance Hashable RoleId where
     hashWithSalt salt = hashWithSalt salt . fromSqlKey
     hash = hash . fromSqlKey
 
+instance Hashable PersonId where
+    hashWithSalt salt = hashWithSalt salt . fromSqlKey
+    hash = hash . fromSqlKey
+
+instance Hashable GroupId where
+    hashWithSalt salt = hashWithSalt salt . fromSqlKey
+    hash = hash . fromSqlKey
+
+instance Hashable RepoId where
+    hashWithSalt salt = hashWithSalt salt . fromSqlKey
+    hash = hash . fromSqlKey
+
+instance Hashable DeckId where
+    hashWithSalt salt = hashWithSalt salt . fromSqlKey
+    hash = hash . fromSqlKey
+
+instance Hashable LoomId where
+    hashWithSalt salt = hashWithSalt salt . fromSqlKey
+    hash = hash . fromSqlKey
+
 {-
 instance PersistEntityGraph Ticket TicketDependency where
     sourceParam = ticketDependencyParent
@@ -106,3 +126,20 @@ instance PersistEntityGraphNumbered Ticket TicketDependency where
     numberField _ = TicketNumber
     uniqueNode _  = UniqueTicket
 -}
+
+{-
+instance VervisActor Person where
+    type VervisActorForwarder Person = ForwarderPerson
+
+instance VervisActor Group where
+    type VervisActorForwarder Group = ForwarderGroup
+
+instance VervisActor Repo where
+    type VervisActorForwarder Repo = ForwarderRepo
+
+instance VervisActor Deck where
+    type VervisActorForwarder Deck = ForwarderDeck
+
+instance VervisActor Loom where
+    type VervisActorForwarder Loom = ForwarderLoom
+-}

src/Vervis/Persist/Discussion.hs

@@ -28,6 +28,7 @@ import Control.Monad
 import Control.Monad.Trans.Class
 import Control.Monad.Trans.Except
 import Control.Monad.Trans.Maybe
+import Control.Monad.Trans.Reader
 import Data.Graph.Inductive.Graph (mkGraph, lab')
 import Data.Graph.Inductive.PatriciaTree (Gr)
 import Data.Graph.Inductive.Query.DFS (dffWith)
@@ -158,9 +159,10 @@ getDiscussionTree getdid =
     sortByTime . discussionTree <$> getAllMessages getdid
 
 getMessageFromRoute
-    :: LocalActorBy Key
+    :: MonadIO m
+    => LocalActorBy Key
     -> LocalMessageId
-    -> ExceptT Text AppDB
+    -> ExceptT Text (ReaderT SqlBackend m)
         ( LocalActorBy Entity
         , Entity Actor
         , Entity LocalMessage
@@ -187,9 +189,10 @@ getMessageFromRoute authorByKey localMsgID = do
         )
 
 getLocalParentMessageId
-    :: DiscussionId
+    :: MonadIO m
+    => DiscussionId
     -> (LocalActorBy Key, LocalMessageId)
-    -> ExceptT Text AppDB MessageId
+    -> ExceptT Text (ReaderT SqlBackend m) MessageId
 getLocalParentMessageId discussionID (authorByKey, localMsgID) = do
     (_, _, _, Entity msgID msg) <- getMessageFromRoute authorByKey localMsgID
     unless (messageRoot msg == discussionID) $
@@ -200,9 +203,10 @@ getLocalParentMessageId discussionID (authorByKey, localMsgID) = do
 -- know and have this parent note in the DB, and whether the child and parent
 -- belong to the same discussion root.
 getMessageParent
-    :: DiscussionId
+    :: MonadIO m
+    => DiscussionId
     -> Either (LocalActorBy Key, LocalMessageId) FedURI
-    -> ExceptT Text AppDB (Either MessageId FedURI)
+    -> ExceptT Text (ReaderT SqlBackend m) (Either MessageId FedURI)
 getMessageParent did (Left msg) = Left <$> getLocalParentMessageId did msg
 getMessageParent did (Right p@(ObjURI hParent luParent)) = do
     mrm <- lift $ runMaybeT $ do

src/Vervis/Recipient.hs

@@ -1,6 +1,6 @@
 {- This file is part of Vervis.
  -
- - Written in 2019, 2020, 2022 by fr33domlover <fr33domlover@riseup.net>.
+ - Written in 2019, 2020, 2022, 2023 by fr33domlover <fr33domlover@riseup.net>.
  -
  - ♡ Copying is an act of love. Please copy, reuse and share.
  -
@@ -121,6 +121,7 @@ import qualified Data.Text as T
 
 import Network.FedURI
 import Yesod.ActivityPub
+import Yesod.Actor
 import Yesod.FedURI
 import Yesod.Hashids
 import Yesod.MonadSite
@@ -130,6 +131,7 @@ import qualified Web.ActivityPub as AP
 import Data.List.Local
 import Data.List.NonEmpty.Local
 
+import Vervis.Actor
 import Vervis.FedURI
 import Vervis.Foundation
 import Vervis.Model
@@ -142,17 +144,6 @@ import Vervis.Model
 -- types, then you can do any further parsing and grouping.
 -------------------------------------------------------------------------------
 
-data LocalActorBy f
-    = LocalActorPerson (f Person)
-    | LocalActorGroup  (f Group)
-    | LocalActorRepo   (f Repo)
-    | LocalActorDeck   (f Deck)
-    | LocalActorLoom   (f Loom)
-    deriving (Generic, FunctorB, ConstraintsB)
-
-deriving instance AllBF Eq f LocalActorBy => Eq (LocalActorBy f)
-deriving instance AllBF Ord f LocalActorBy => Ord (LocalActorBy f)
-
 {-
 instance (Eq (f Person), Eq (f Group), Eq (f Repo), Eq (f Deck), Eq (f Loom)) => Eq (LocalActorBy f) where
     (==) (LocalActorPerson p) (LocalActorPerson p') = p == p'
@@ -175,8 +166,6 @@ instance (Ord (f Person), Ord (f Group), Ord (f Repo), Ord (f Deck), Ord (f Loom
     (<=) (LocalActorGroup _) _                    = True
 -}
 
-type LocalActor = LocalActorBy KeyHashid
-
 parseLocalActor :: Route App -> Maybe LocalActor
 parseLocalActor (PersonR pkhid) = Just $ LocalActorPerson pkhid
 parseLocalActor (GroupR gkhid)  = Just $ LocalActorGroup gkhid
@@ -504,67 +493,6 @@ recipientFromStage (LocalStageClothFollowers lkhid ltkhid) =
 -- logic rather than plain lists of routes.
 -------------------------------------------------------------------------------
 
-data TicketRoutes = TicketRoutes
-    { routeTicketFollowers :: Bool
-    }
-    deriving Eq
-
-data ClothRoutes = ClothRoutes
-    { routeClothFollowers :: Bool
-    }
-    deriving Eq
-
-data PersonRoutes = PersonRoutes
-    { routePerson          :: Bool
-    , routePersonFollowers :: Bool
-    }
-    deriving Eq
-
-data GroupRoutes = GroupRoutes
-    { routeGroup          :: Bool
-    , routeGroupFollowers :: Bool
-    }
-    deriving Eq
-
-data RepoRoutes = RepoRoutes
-    { routeRepo          :: Bool
-    , routeRepoFollowers :: Bool
-    }
-    deriving Eq
-
-data DeckRoutes = DeckRoutes
-    { routeDeck          :: Bool
-    , routeDeckFollowers :: Bool
-    }
-    deriving Eq
-
-data LoomRoutes = LoomRoutes
-    { routeLoom          :: Bool
-    , routeLoomFollowers :: Bool
-    }
-    deriving Eq
-
-data DeckFamilyRoutes = DeckFamilyRoutes
-    { familyDeck    :: DeckRoutes
-    , familyTickets :: [(KeyHashid TicketDeck, TicketRoutes)]
-    }
-    deriving Eq
-
-data LoomFamilyRoutes = LoomFamilyRoutes
-    { familyLoom   :: LoomRoutes
-    , familyCloths :: [(KeyHashid TicketLoom, ClothRoutes)]
-    }
-    deriving Eq
-
-data RecipientRoutes = RecipientRoutes
-    { recipPeople :: [(KeyHashid Person, PersonRoutes)]
-    , recipGroups :: [(KeyHashid Group , GroupRoutes)]
-    , recipRepos  :: [(KeyHashid Repo  , RepoRoutes)]
-    , recipDecks  :: [(KeyHashid Deck  , DeckFamilyRoutes)]
-    , recipLooms  :: [(KeyHashid Loom  , LoomFamilyRoutes)]
-    }
-    deriving Eq
-
 groupLocalRecipients :: [LocalRecipient] -> RecipientRoutes
 groupLocalRecipients = organize . partitionByActor
     where

src/Vervis/RemoteActorStore.hs

@@ -511,6 +511,7 @@ actorFetchShareAction u (site, iid) = flip runWorkerT site $ do
                         for_ mroid $ \ roid ->
                             insertUnique_ $ RemoteCollection roid
                         return Nothing
+                    -- TODO see https://vervis.peers.community/decks/br6Go/tickets/r7dDo
 
 fetchRemoteActor
     :: ( YesodPersist site

src/Vervis/Web/Actor.hs

@@ -1,6 +1,6 @@
 {- This file is part of Vervis.
  -
- - Written in 2019, 2020, 2022 by fr33domlover <fr33domlover@riseup.net>.
+ - Written in 2019, 2020, 2022, 2023 by fr33domlover <fr33domlover@riseup.net>.
  -
  - ♡ Copying is an act of love. Please copy, reuse and share.
  -
@@ -71,6 +71,7 @@ import qualified Data.Text.Lazy as TL
 import qualified Data.Vector as V
 import qualified Database.Esqueleto as E
 
+import Control.Concurrent.Actor
 import Crypto.ActorKey
 import Database.Persist.JSON
 import Network.FedURI
@@ -94,6 +95,7 @@ import Yesod.Persist.Local
 import qualified Data.Aeson.Encode.Pretty.ToEncoding as P
 import qualified Web.ActivityPub as AP
 
+import Vervis.Actor
 import Vervis.ActivityPub
 import Vervis.API
 import Vervis.Data.Actor
@@ -226,47 +228,48 @@ getInbox here actor hash = do
         where
         ibiidString = "InboxItem #" ++ show (fromSqlKey ibid)
 
-postInbox
+postInbox :: LocalActorBy Key -> Handler ()
-    :: (   UTCTime
+postInbox recipByKey = do
-        -> ActivityAuthentication
-        -> ActivityBody
-        -> ExceptT Text Handler
-            ( Text
-            , Maybe (ExceptT Text Worker Text)
-            )
-       )
-    -> Handler ()
-postInbox handler = do
     federation <- getsYesod $ appFederation . appSettings
     unless federation badMethod
     contentTypes <- lookupHeaders "Content-Type"
     now <- liftIO getCurrentTime
     result <- runExceptT $ do
         (auth, body) <- authenticateActivity now
-        (actbObject body,) <$> handler now auth body
+        verse <-
+            case auth of
+                ActivityAuthLocal authorByKey -> Left <$> do
+                    outboxItemID <-
+                        parseAuthenticatedLocalActivityURI
+                            authorByKey
+                            (AP.activityId $ actbActivity body)
+                    return $ EventRemoteFwdLocalActivity authorByKey outboxItemID
+                ActivityAuthRemote author -> Right <$> do
+                    luActivity <-
+                        fromMaybeE (AP.activityId $ actbActivity body) "Activity without 'id'"
+                    localRecips <- do
+                        mrecips <- parseAudience $ AP.activityAudience $ actbActivity body
+                        paudLocalRecips <$> fromMaybeE mrecips "Activity with no recipients"
+                    recipByHash <- hashLocalActor recipByKey
+                    msig <- checkForwarding recipByHash
+                    let mfwd = (localRecips,) <$> msig
+                    return $ VerseRemote author body mfwd luActivity
+        theater <- getsYesod appTheater
+        r <- liftIO $ callIO theater recipByKey verse
+        case r of
+            Nothing -> notFound
+            Just (Left e) -> throwE e
+            Just (Right t) -> return (actbObject body, t)
     recordActivity now result contentTypes
     case result of
         Left err -> do
             logDebug err
             sendResponseStatus badRequest400 err
-        Right (obj, (_, mworker)) ->
+        Right _ -> return ()
-            for_ mworker $ \ worker -> forkWorker "postInbox worker" $ do
-                wait <- asyncWorker $ runExceptT worker
-                result' <- wait
-                let result'' =
-                        case result' of
-                            Left e -> Left $ T.pack $ displayException e
-                            Right (Left e) -> Left e
-                            Right (Right t) -> Right (obj, (t, Nothing))
-                now' <- liftIO getCurrentTime
-                recordActivity now' result'' contentTypes
-                case result'' of
-                    Left err -> logDebug err
-                    Right _ -> return ()
     where
     recordActivity
         :: (MonadSite m, SiteEnv m ~ App)
-        => UTCTime -> Either Text (Object, (Text, w)) -> [ContentType] -> m ()
+        => UTCTime -> Either Text (Object, Text) -> [ContentType] -> m ()
     recordActivity now result contentTypes = do
         macts <- asksSite appActivities
         for_ macts $ \ (size, acts) ->
@@ -274,12 +277,21 @@ postInbox handler = do
                 let (msg, body) =
                         case result of
                             Left t -> (t, "{?}")
-                            Right (o, (t, _)) -> (t, encodePretty o)
+                            Right (o, t) -> (t, encodePretty o)
                     item = ActivityReport now msg contentTypes body
                     vec' = item `V.cons` vec
                 in  if V.length vec' > size
                         then V.init vec'
                         else vec'
+    parseAuthenticatedLocalActivityURI
+        :: (MonadSite m, YesodHashids (SiteEnv m))
+        => LocalActorBy Key -> Maybe LocalURI -> ExceptT Text m OutboxItemId
+    parseAuthenticatedLocalActivityURI author maybeActivityURI = do
+        luAct <- fromMaybeE maybeActivityURI "No 'id'"
+        (actorByKey, _, outboxItemID) <- parseLocalActivityURI luAct
+        unless (actorByKey == author) $
+            throwE "'actor' actor and 'id' actor mismatch"
+        return outboxItemID
 
 getOutbox here itemRoute grabActorID hash = do
     key <- decodeKeyHashid404 hash

src/Vervis/Web/Delivery.hs

@@ -1,6 +1,7 @@
 {- This file is part of Vervis.
  -
- - Written in 2019, 2020, 2021, 2022 by fr33domlover <fr33domlover@riseup.net>.
+ - Written in 2019, 2020, 2021, 2022, 2023
+ - by fr33domlover <fr33domlover@riseup.net>.
  -
  - ♡ Copying is an act of love. Please copy, reuse and share.
  -
@@ -31,12 +32,15 @@ module Vervis.Web.Delivery
       fixRunningDeliveries
     , retryOutboxDelivery
 
+    , deliverActivityDB_Live
     , deliverActivityDB
+    , forwardActivityDB_Live
     , forwardActivityDB
     )
 where
 
 import Control.Applicative
+import Control.Concurrent.Chan
 import Control.Concurrent.STM.TVar
 import Control.Exception hiding (Handler, try)
 import Control.Monad
@@ -63,11 +67,14 @@ import Database.Persist.Sql
 import Yesod.Core hiding (logError, logWarn, logInfo, logDebug)
 
 import qualified Data.ByteString.Lazy as BL
+import qualified Data.HashMap.Strict as HM
+import qualified Data.HashSet as HS
 import qualified Data.List.NonEmpty as NE
 import qualified Data.List.Ordered as LO
 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
@@ -82,6 +89,7 @@ import Data.Maybe.Local
 import Data.Tuple.Local
 import Database.Persist.Local
 
+import Vervis.Actor
 import Vervis.ActivityPub
 import Vervis.Data.Actor
 import Vervis.FedURI
@@ -557,13 +565,23 @@ deliverRemoteHttp hContexts obid envelope (fetched, unfetched, unknown) = do
 -- * Insert activity to inboxes of actors
 -- * If collections are listed, insert activity to the local members and return
 --   the remote members
+--
+-- NOTE: This functions is in a transition process! Instead of adding items to
+-- local inboxes, it will send the items to live actors. At the moment, the
+-- transition status is:
+--
+-- * For person actors, send to live actors
+-- * For all other types, insert to inboxes
 insertActivityToLocalInboxes
     :: ( MonadSite m
        , YesodHashids (SiteEnv m)
+       , SiteEnv m ~ App
        , PersistRecordBackend record SqlBackend
        )
-    => (InboxId -> InboxItemId -> record)
+    => Event
-    -- ^ Database record to insert as an new inbox item to each inbox
+    -- ^ Event to send to local live actors
+    -> (InboxId -> InboxItemId -> record)
+    -- ^ Database record to insert as a new inbox item to each inbox
     -> Bool
     -- ^ Whether to deliver to collection only if owner actor is addressed
     -> Maybe LocalActor
@@ -577,7 +595,7 @@ insertActivityToLocalInboxes
     --   author.
     -> RecipientRoutes
     -> ReaderT SqlBackend m [((InstanceId, Host), NonEmpty RemoteRecipient)]
-insertActivityToLocalInboxes makeInboxItem requireOwner mauthor maidAuthor recips = do
+insertActivityToLocalInboxes event makeInboxItem requireOwner mauthor maidAuthor recips = do
 
     -- Unhash actor and work item hashids
     people <- unhashKeys $ recipPeople recips
@@ -625,7 +643,7 @@ insertActivityToLocalInboxes makeInboxItem requireOwner mauthor maidAuthor recip
         loomIDsForSelf =
             [ key | (key, (routes, _)) <- loomsAndCloths, routeLoom routes ]
 
-    -- Grab actor actors whose followers are going to be delivered to
+    -- Grab local actors whose followers are going to be delivered to
     let personIDsForFollowers =
             [ key | (key, routes) <- peopleForStages, routePersonFollowers routes ]
         groupIDsForFollowers =
@@ -658,9 +676,9 @@ insertActivityToLocalInboxes makeInboxItem requireOwner mauthor maidAuthor recip
                 loomsAndClothsForStages
 
     -- Get addressed Actor IDs from DB
+    -- Except for Person actors, we'll send to them via actor system
     actorIDsForSelf <- orderedUnion <$> sequenceA
-        [ selectActorIDsOrdered personActor PersonActor personIDsForSelf
+        [ selectActorIDsOrdered groupActor GroupActor groupIDsForSelf
-        , selectActorIDsOrdered groupActor GroupActor groupIDsForSelf
         , selectActorIDsOrdered repoActor RepoActor repoIDsForSelf
         , selectActorIDsOrdered deckActor DeckActor deckIDsForSelf
         , selectActorIDsOrdered loomActor LoomActor loomIDsForSelf
@@ -694,15 +712,27 @@ insertActivityToLocalInboxes makeInboxItem requireOwner mauthor maidAuthor recip
                 )
 
     -- Get the local and remote followers of the follower sets from DB
-    localFollowers <-
+    localFollowersDB <-
-        map (followActor . entityVal) <$>
+        fmap (map E.unValue) $
-            selectList [FollowTarget <-. followerSetIDs] [Asc FollowActor]
+        E.select $ E.from $ \ (f `E.LeftOuterJoin` p) -> do
+            E.on $ E.just (f E.^. FollowActor) E.==. p E.?. PersonActor
+            E.where_ $
+                f E.^. FollowTarget `E.in_` E.valList followerSetIDs E.&&.
+                E.isNothing (p E.?. PersonId)
+            E.orderBy [E.asc $ f E.^. FollowActor]
+            return $ f E.^. FollowActor
+    localFollowersLivePersonIDs <-
+        fmap (map E.unValue) $
+        E.select $ E.from $ \ (f `E.InnerJoin` p) -> do
+            E.on $ f E.^. FollowActor E.==. p E.^. PersonActor
+            E.where_ $ f E.^. FollowTarget `E.in_` E.valList followerSetIDs
+            return $ p E.^. PersonId
     remoteFollowers <- getRemoteFollowers followerSetIDs
 
     -- Insert inbox items to all local recipients, i.e. the local actors
     -- directly addressed or listed in a local stage addressed
     let localRecipients =
-            let allLocal = LO.union localFollowers actorIDsForSelf
+            let allLocal = LO.union localFollowersDB actorIDsForSelf
             in  case maidAuthor of
                     Nothing -> allLocal
                     Just actorID -> LO.minus' allLocal [actorID]
@@ -713,6 +743,14 @@ insertActivityToLocalInboxes makeInboxItem requireOwner mauthor maidAuthor recip
     inboxItemIDs <- insertMany $ replicate (length inboxIDs) $ InboxItem True now
     insertMany_ $ zipWith makeInboxItem inboxIDs inboxItemIDs
 
+    -- Insert activity to message queues of live actors
+    let liveRecips =
+            HS.fromList $ map LocalActorPerson $
+                localFollowersLivePersonIDs ++ personIDsForSelf
+    lift $ do
+        theater <- asksSite appTheater
+        liftIO $ sendManyIO theater liveRecips $ Left event
+
     -- Return remote followers, to whom we need to deliver via HTTP
     return remoteFollowers
     where
@@ -814,16 +852,19 @@ insertActivityToLocalInboxes makeInboxItem requireOwner mauthor maidAuthor recip
 -- * Insert activity to inboxes of actors
 -- * If collections are listed, insert activity to the local members and return
 --   the remote members
+--
+-- NOTE transition to live actors
 deliverLocal'
-    :: (MonadSite m, YesodHashids (SiteEnv m))
+    :: (MonadSite m, YesodHashids (SiteEnv m), SiteEnv m ~ App)
     => Bool -- ^ Whether to deliver to collection only if owner actor is addressed
     -> LocalActor
     -> ActorId
     -> OutboxItemId
+    -> Event
     -> RecipientRoutes
     -> ReaderT SqlBackend m [((InstanceId, Host), NonEmpty RemoteRecipient)]
-deliverLocal' requireOwner author aidAuthor obiid =
+deliverLocal' requireOwner author aidAuthor obiid event =
-    insertActivityToLocalInboxes makeItem requireOwner (Just author) (Just aidAuthor)
+    insertActivityToLocalInboxes event makeItem requireOwner (Just author) (Just aidAuthor)
     where
     makeItem ibid ibiid = InboxItemLocal ibid obiid ibiid
 
@@ -834,30 +875,35 @@ deliverLocal' requireOwner author aidAuthor obiid =
 -- * If the author's follower collection is listed, insert activity to the
 --   local members and return the remote members
 -- * Ignore other collections
+--
+-- NOTE transition to live actors
 deliverLocal
     :: KeyHashid Person
     -> ActorId
     -> OutboxItemId
+    -> Event
     -> RecipientRoutes
     -> AppDB
         [ ( (InstanceId, Host)
           , NonEmpty RemoteRecipient
           )
         ]
-deliverLocal authorHash aidAuthor obiid
+deliverLocal authorHash aidAuthor obiid event
-    = deliverLocal' True (LocalActorPerson authorHash) aidAuthor obiid
+    = deliverLocal' True (LocalActorPerson authorHash) aidAuthor obiid event
     . localRecipSieve sieve True
     where
     sieve = RecipientRoutes [(authorHash, PersonRoutes False True)] [] [] [] []
 
+-- NOTE transition to live actors
 insertRemoteActivityToLocalInboxes
-    :: (MonadSite m, YesodHashids (SiteEnv m))
+    :: (MonadSite m, YesodHashids (SiteEnv m), SiteEnv m ~ App)
     => Bool
     -> RemoteActivityId
+    -> Event
     -> RecipientRoutes
     -> ReaderT SqlBackend m [((InstanceId, Host), NonEmpty RemoteRecipient)]
-insertRemoteActivityToLocalInboxes requireOwner ractid =
+insertRemoteActivityToLocalInboxes requireOwner ractid event =
-    insertActivityToLocalInboxes makeItem requireOwner Nothing Nothing
+    insertActivityToLocalInboxes event makeItem requireOwner Nothing Nothing
     where
     makeItem ibid ibiid = InboxItemRemote ibid ractid ibiid
 
@@ -1262,7 +1308,8 @@ retryOutboxDelivery = do
 
     logInfo "Periodic delivery done"
 
-deliverActivityDB
+-- NOTE transition to live actors
+deliverActivityDB_Live
     :: (MonadSite m, SiteEnv m ~ App)
     => LocalActorBy KeyHashid
     -> ActorId
@@ -1270,10 +1317,11 @@ deliverActivityDB
     -> [(Host, NonEmpty LocalURI)]
     -> [Host]
     -> OutboxItemId
+    -> Event
     -> AP.Action URIMode
     -> ExceptT Text (ReaderT SqlBackend m) (Worker ())
-deliverActivityDB senderByHash senderActorID localRecips remoteRecips fwdHosts itemID action = do
+deliverActivityDB_Live senderByHash senderActorID localRecips remoteRecips fwdHosts itemID event action = do
-    moreRemoteRecips <- lift $ deliverLocal' True senderByHash senderActorID itemID localRecips
+    moreRemoteRecips <- lift $ deliverLocal' True senderByHash senderActorID itemID event localRecips
     checkFederation moreRemoteRecips
     remoteRecipsHttp <- lift $ deliverRemoteDB fwdHosts itemID remoteRecips moreRemoteRecips
     envelope <- lift $ prepareSendP senderActorID senderByHash itemID action
@@ -1284,7 +1332,12 @@ deliverActivityDB senderByHash senderActorID localRecips remoteRecips fwdHosts i
         unless (federation || null remoteRecips) $
             throwE "Federation disabled, but remote recipients found"
 
-forwardActivityDB
+-- NOTE transition to live actors
+deliverActivityDB senderByHash senderActorID localRecips remoteRecips fwdHosts itemID =
+    deliverActivityDB_Live senderByHash senderActorID localRecips remoteRecips fwdHosts itemID EventUnknown
+
+-- NOTE transition to live actors
+forwardActivityDB_Live
     :: (MonadSite m, SiteEnv m ~ App)
     => BL.ByteString
     -> RecipientRoutes
@@ -1293,13 +1346,18 @@ forwardActivityDB
     -> LocalActorBy KeyHashid
     -> RecipientRoutes
     -> RemoteActivityId
+    -> Event
     -> ReaderT SqlBackend m (Worker ())
-forwardActivityDB body localRecips sig fwderActorID fwderByHash sieve activityID = do
+forwardActivityDB_Live body localRecips sig fwderActorID fwderByHash sieve activityID event = do
     let localRecipsFinal = localRecipSieve' sieve False False localRecips
     remoteRecips <-
-        insertRemoteActivityToLocalInboxes False activityID localRecipsFinal
+        insertRemoteActivityToLocalInboxes False activityID event localRecipsFinal
     remoteRecipsHttp <-
         forwardRemoteDB body activityID fwderActorID sig remoteRecips
     errand <- prepareForwardP fwderActorID fwderByHash body sig
     now <- liftIO getCurrentTime
     return $ forwardRemoteHttp now errand remoteRecipsHttp
+
+-- NOTE transition to live actors
+forwardActivityDB body localRecips sig fwderActorID fwderByHash sieve activityID =
+    forwardActivityDB_Live body localRecips sig fwderActorID fwderByHash sieve activityID EventUnknown

src/Web/ActivityPub.hs

@@ -1,6 +1,7 @@
 {- This file is part of Vervis.
  -
- - Written in 2019, 2020, 2021, 2022 by fr33domlover <fr33domlover@riseup.net>.
+ - Written in 2019, 2020, 2021, 2022, 2023
+ - by fr33domlover <fr33domlover@riseup.net>.
  -
  - ♡ Copying is an act of love. Please copy, reuse and share.
  -
@@ -79,6 +80,7 @@ module Web.ActivityPub
     , Undo (..)
     , Audience (..)
     , SpecificActivity (..)
+    , activityType
     , Action (..)
     , makeActivity
     , Activity (..)
@@ -174,6 +176,119 @@ import Web.Text
 
 import Data.Aeson.Local
 
+{-
+data Link = Link
+    { linkHref      :: URI
+    , linkRel       ::
+    , linkMediaType ::
+    , linkName      ::
+    , linkHreflang  ::
+    , linkHeight    ::
+    , linkWidth     ::
+    , linkPreview   ::
+    , linkRest      :: Object
+    }
+
+data X = X
+    { xId :: LocalURI
+    , x
+    }
+
+data Object' u = Object'
+    { objectId   :: ObjURI
+    , objectType ::
+
+    , objectSubject      ::
+    , objectRelationship ::
+    , objectActor        ::
+    , objectAttributedTo ::
+    , objectAttachment   ::
+    , objectBcc          ::
+    , objectBto          ::
+    , objectCc           ::
+    , objectContext      ::
+    , objectCurrent      ::
+    , objectFirst        ::
+    , objectGenerator    ::
+    , objectIcon         ::
+    , objectImage        ::
+    , objectInReplyTo    ::
+    , objectItems        ::
+    , objectInstrument   ::
+    , objectOrderedItems ::
+    , objectLast         ::
+    , objectLocation     ::
+    , objectNext         ::
+    , objectObject       ::
+    , objectOneOf        ::
+    , objectAnyOf        ::
+    , objectClosed       ::
+    , objectOrigin       ::
+    , objectAccuracy     ::
+    , objectPrev         ::
+    , objectPreview      ::
+    , objectProvider     ::
+    , objectReplies      ::
+    , objectResult       ::
+    , objectAudience     ::
+    , objectPartOf       ::
+    , objectTag          ::
+    , objectTags         ::
+    , objectTarget       ::
+    , objectTo           ::
+    , objectUrl          ::
+    , objectAltitude     ::
+    , objectContent      ::
+    , objectContentMap   ::
+    , objectName         ::
+    , objectNameMap      ::
+    , objectDuration     ::
+    , objectEndTime      ::
+    , objectHeight       ::
+    , objectHref         ::
+    , objectHreflang     ::
+    , objectLatitude     ::
+    , objectLongitude    ::
+    , objectMediaType    ::
+    , objectPublished    ::
+    , objectRadius       ::
+    , objectRating       ::
+    , objectRel          ::
+    , objectStartIndex   ::
+    , objectStartTime    ::
+    , objectSummary      ::
+    , objectSummaryMap   ::
+    , objectTotalItems   ::
+    , objectUnits        ::
+    , objectUpdated      ::
+    , objectWidth        ::
+    , objectDescribes    ::
+    , objectFormerType   ::
+    , objectDeleted      ::
+
+    , objectEndpoints                  ::
+    , objectFollowing                  ::
+    , objectFollowers                  ::
+    , objectInbox                      ::
+    , objectLiked                      ::
+    , objectShares                     ::
+    , objectLikes                      ::
+    , objectOauthAuthorizationEndpoint ::
+    , objectOauthTokenEndpoint         ::
+    , objectOutbox                     ::
+    , objectPreferredUsername          ::
+    , objectProvideClientKey           ::
+    , objectProxyUrl                   ::
+    , objectSharedInbox                ::
+    , objectSignClientKey              ::
+    , objectSource                     ::
+    , objectStreams                    ::
+    , objectUploadMedia                ::
+
+    , objectRest :: Object
+    }
+-}
+
 proxy :: a u -> Proxy a
 proxy _ = Proxy
 
@@ -1712,6 +1827,21 @@ data SpecificActivity u
     | ResolveActivity (Resolve u)
     | UndoActivity    (Undo u)
 
+activityType :: SpecificActivity u -> Text
+activityType (AcceptActivity _)  = "Accept"
+activityType (AddActivity _)     = "Add"
+activityType (ApplyActivity _)   = "Apply"
+activityType (CreateActivity _)  = "Create"
+activityType (FollowActivity _)  = "Follow"
+activityType (GrantActivity _)   = "Grant"
+activityType (InviteActivity _)  = "Invite"
+activityType (JoinActivity _)    = "Join"
+activityType (OfferActivity _)   = "Offer"
+activityType (PushActivity _)    = "Push"
+activityType (RejectActivity _)  = "Reject"
+activityType (ResolveActivity _) = "Resolve"
+activityType (UndoActivity _)    = "Undo"
+
 data Action u = Action
     { actionCapability :: Maybe (ObjURI u)
     , actionSummary    :: Maybe HTML
@@ -1782,20 +1912,6 @@ instance ActivityPub Activity where
         <> "fulfills"   .=% fulfills
         <> encodeSpecific authority actor specific
         where
-        activityType :: SpecificActivity u -> Text
-        activityType (AcceptActivity _)  = "Accept"
-        activityType (AddActivity _)     = "Add"
-        activityType (ApplyActivity _)   = "Apply"
-        activityType (CreateActivity _)  = "Create"
-        activityType (FollowActivity _)  = "Follow"
-        activityType (GrantActivity _)   = "Grant"
-        activityType (InviteActivity _)  = "Invite"
-        activityType (JoinActivity _)    = "Join"
-        activityType (OfferActivity _)   = "Offer"
-        activityType (PushActivity _)    = "Push"
-        activityType (RejectActivity _)  = "Reject"
-        activityType (ResolveActivity _) = "Resolve"
-        activityType (UndoActivity _)    = "Undo"
         encodeSpecific h _ (AcceptActivity a)  = encodeAccept h a
         encodeSpecific h _ (AddActivity a)     = encodeAdd h a
         encodeSpecific _ _ (ApplyActivity a)   = encodeApply a

src/Web/Actor.hs

@@ -0,0 +1,51 @@
+{- This file is part of Vervis.
+ -
+ - Written in 2019, 2022, 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/>.
+ -}
+
+-- | Reusable library for building decentralized actor-model-based web apps,
+-- with 'Control.Concurrent.Actor' for the local actor system, and ActivityPub
+-- as the network protocol.
+--
+-- At the time of writing (April 2023), this module is collecting the pieces
+-- that aren't tied to a specific web framework. Yesod-specific parts are in
+-- separate modules.
+--
+-- Ideally, the whole application structure would be specified using
+-- framework-independent tools, and framework integration (right now just
+-- Yesod, might also be Servant in the future) would be an automatic or
+-- auto-generated nearly-seamless part. I hope to get there, gradually, in
+-- steps of refactoring.
+module Web.Actor
+    ( StageWeb (..)
+    , ActForE
+    , hostIsLocal
+    )
+where
+
+import Control.Monad.Trans.Except
+import Data.Text (Text)
+
+import Control.Concurrent.Actor
+import Network.FedURI
+
+class (Stage s, UriMode (StageURIMode s)) => StageWeb s where
+    type StageURIMode s
+    stageInstanceHost :: s -> Authority (StageURIMode s)
+
+type ActForE s = ExceptT Text (ActFor s)
+
+hostIsLocal
+    :: (MonadActor m, ActorEnv m ~ s, StageWeb s)
+    => Authority (StageURIMode s) -> m Bool
+hostIsLocal h = asksEnv $ (== h) . stageInstanceHost

src/Web/Actor/Persist.hs

@@ -0,0 +1,137 @@
+{- This file is part of Vervis.
+ -
+ - Written in 2019, 2020, 2022, 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 Web.Actor.Persist
+    ( StageHashids (..)
+    , KeyHashid ()
+    , keyHashidText
+
+    , encodeKeyHashidPure
+    --, getEncodeKeyHashid
+    --, encodeKeyHashid
+
+    , decodeKeyHashidPure
+    --, decodeKeyHashid
+    --, decodeKeyHashidF
+    --, decodeKeyHashidM
+    , decodeKeyHashidE
+    )
+where
+
+import Prelude hiding (fail)
+
+import Control.Monad.Fail
+import Control.Monad.Trans.Except
+import Control.Monad.Trans.Maybe
+import Data.Text (Text)
+import Data.Text.Encoding
+import Database.Persist.Class
+import Database.Persist.Sql
+import Web.Hashids
+import Web.PathPieces
+
+import Control.Concurrent.Actor
+import Web.Actor
+--import Yesod.MonadActor
+
+import Web.Hashids.Local
+
+class StageWeb s => StageHashids s where
+    stageHashidsContext :: s -> HashidsContext
+
+newtype KeyHashid record = KeyHashid
+    { keyHashidText :: Text
+    }
+    deriving (Eq, Ord, Read, Show)
+
+instance PersistEntity record => PathPiece (KeyHashid record) where
+    fromPathPiece t = KeyHashid <$> fromPathPiece t
+    toPathPiece (KeyHashid t) = toPathPiece t
+
+encodeKeyHashidPure
+    :: ToBackendKey SqlBackend record
+    => HashidsContext -> Key record -> KeyHashid record
+encodeKeyHashidPure ctx = KeyHashid . decodeUtf8 . encodeInt64 ctx . fromSqlKey
+
+getEncodeKeyHashid
+    :: ( MonadActor m
+       , StageHashids (ActorEnv m)
+       , ToBackendKey SqlBackend record
+       )
+    => m (Key record -> KeyHashid record)
+getEncodeKeyHashid = do
+    ctx <- asksEnv stageHashidsContext
+    return $ encodeKeyHashidPure ctx
+
+encodeKeyHashid
+    :: ( MonadActor m
+       , StageHashids (ActorEnv m)
+       , ToBackendKey SqlBackend record
+       )
+    => Key record
+    -> m (KeyHashid record)
+encodeKeyHashid k = do
+    enc <- getEncodeKeyHashid
+    return $ enc k
+
+decodeKeyHashidPure
+    :: ToBackendKey SqlBackend record
+    => HashidsContext
+    -> KeyHashid record
+    -> Maybe (Key record)
+decodeKeyHashidPure ctx (KeyHashid t) =
+    fmap toSqlKey $ decodeInt64 ctx $ encodeUtf8 t
+
+decodeKeyHashid
+    :: ( MonadActor m
+       , StageHashids (ActorEnv m)
+       , ToBackendKey SqlBackend record
+       )
+    => KeyHashid record
+    -> m (Maybe (Key record))
+decodeKeyHashid khid = do
+    ctx <- asksEnv stageHashidsContext
+    return $ decodeKeyHashidPure ctx khid
+
+decodeKeyHashidF
+    :: ( MonadFail m
+       , MonadActor m
+       , StageHashids (ActorEnv m)
+       , ToBackendKey SqlBackend record
+       )
+    => KeyHashid record
+    -> String
+    -> m (Key record)
+decodeKeyHashidF khid e = maybe (fail e) return =<< decodeKeyHashid khid
+
+decodeKeyHashidM
+    :: ( MonadActor m
+       , StageHashids (ActorEnv m)
+       , ToBackendKey SqlBackend record
+       )
+    => KeyHashid record
+    -> MaybeT m (Key record)
+decodeKeyHashidM = MaybeT . decodeKeyHashid
+
+decodeKeyHashidE
+    :: ( MonadActor m
+       , StageHashids (ActorEnv m)
+       , ToBackendKey SqlBackend record
+       )
+    => KeyHashid record
+    -> e
+    -> ExceptT e m (Key record)
+decodeKeyHashidE khid e =
+    ExceptT $ maybe (Left e) Right <$> decodeKeyHashid khid

src/Yesod/ActivityPub.hs

@@ -34,7 +34,7 @@ module Yesod.ActivityPub
     , provideHtmlAndAP''
     , provideHtmlFeedAndAP
 
-    , hostIsLocal
+    , hostIsLocalOld
     , verifyHostLocal
     )
 where
@@ -576,14 +576,14 @@ provideHtmlFeedAndAP object feed widget = do
         widget
         (Just feed)
 
-hostIsLocal
+hostIsLocalOld
     :: (MonadSite m, SiteEnv m ~ site, YesodActivityPub site)
     => Authority (SiteFedURIMode site) -> m Bool
-hostIsLocal h = asksSite $ (== h) . siteInstanceHost
+hostIsLocalOld h = asksSite $ (== h) . siteInstanceHost
 
 verifyHostLocal
     :: (MonadSite m, SiteEnv m ~ site, YesodActivityPub site)
     => Authority (SiteFedURIMode site) -> Text -> ExceptT Text m ()
 verifyHostLocal h t = do
-    local <- hostIsLocal h
+    local <- hostIsLocalOld h
     unless local $ throwE t

src/Yesod/Actor.hs

@@ -0,0 +1,56 @@
+{- This file is part of Vervis.
+ -
+ - Written 2019, 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/>.
+ -}
+
+-- | Tools for integrating 'Web.Actor' with the Yesod web framework.
+module Yesod.Actor
+    ( decodeRouteLocal
+    , parseLocalURI
+    , StageYesod (..)
+    , parseFedURI
+    )
+where
+
+import Control.Monad.Trans.Except
+import Data.Text (Text)
+import Data.Text.Encoding
+import Network.HTTP.Types.URI
+import Yesod.Core
+
+import Network.FedURI
+import Web.Actor
+
+import Control.Monad.Trans.Except.Local
+
+decodeRouteLocal :: ParseRoute site => LocalURI -> Maybe (Route site)
+decodeRouteLocal =
+    parseRoute . (,[]) . decodePathSegments . encodeUtf8 . localUriPath
+
+parseLocalURI
+    :: (Monad m, ParseRoute site)
+    => LocalURI -> ExceptT Text m (Route site)
+parseLocalURI lu = fromMaybeE (decodeRouteLocal lu) "Not a valid route"
+
+class (StageWeb s, Yesod (StageSite s)) => StageYesod s where
+    type StageSite s
+
+parseFedURI
+    :: (StageYesod s, ParseRoute (StageSite s))
+    => ObjURI (StageURIMode s)
+    -> ActForE s (Either (Route (StageSite s)) (ObjURI (StageURIMode s)))
+parseFedURI u@(ObjURI h lu) = do
+    hl <- lift $ hostIsLocal h
+    if hl
+        then Left <$> parseLocalURI lu
+        else pure $ Right u

src/Yesod/FedURI.hs

@@ -1,6 +1,6 @@
 {- This file is part of Vervis.
  -
- - Written 2019 by fr33domlover <fr33domlover@riseup.net>.
+ - Written in 2019 by fr33domlover <fr33domlover@riseup.net>.
  -
  - ♡ Copying is an act of love. Please copy, reuse and share.
  -
@@ -18,19 +18,14 @@ module Yesod.FedURI
     , getEncodeRouteLocal
     , getEncodeRouteHome
     , getEncodeRouteFed
-    , decodeRouteLocal
     , getEncodeRoutePageLocal
     , getEncodeRoutePageHome
     , getEncodeRoutePageFed
     )
 where
 
-import Data.Text.Encoding
-import Network.HTTP.Types.URI
 import Yesod.Core
 
-import qualified Data.Text as T
-
 import Network.FedURI
 import Yesod.MonadSite
 
@@ -63,10 +58,6 @@ getEncodeRouteFed
     => m (Authority u -> Route site -> ObjURI u)
 getEncodeRouteFed = (\ f a -> ObjURI a . f) <$> getEncodeRouteLocal
 
-decodeRouteLocal :: ParseRoute site => LocalURI -> Maybe (Route site)
-decodeRouteLocal =
-    parseRoute . (,[]) . decodePathSegments . encodeUtf8 . localUriPath
-
 getEncodeRoutePageLocal
     :: (MonadSite m, SiteEnv m ~ site, SiteFedURI site, YesodPaginate site)
     => m (Route site -> Int -> LocalPageURI)

src/Yesod/Hashids.hs

@@ -1,6 +1,6 @@
 {- This file is part of Vervis.
  -
- - Written in 2019, 2020, 2022 by fr33domlover <fr33domlover@riseup.net>.
+ - Written in 2019, 2020, 2022, 2023 by fr33domlover <fr33domlover@riseup.net>.
  -
  - ♡ Copying is an act of love. Please copy, reuse and share.
  -
@@ -15,7 +15,7 @@
 
 module Yesod.Hashids
     ( YesodHashids (..)
-    , KeyHashid ()
+    , KeyHashid
     , keyHashidText
 
     , encodeKeyHashidPure
@@ -44,6 +44,7 @@ import Web.Hashids
 import Web.PathPieces
 import Yesod.Core
 
+import Web.Actor.Persist (KeyHashid, keyHashidText, encodeKeyHashidPure, decodeKeyHashidPure)
 import Yesod.MonadSite
 
 import Web.Hashids.Local
@@ -51,20 +52,6 @@ import Web.Hashids.Local
 class Yesod site => YesodHashids site where
     siteHashidsContext :: site -> HashidsContext
 
-newtype KeyHashid record = KeyHashid
-    { keyHashidText :: Text
-    }
-    deriving (Eq, Ord, Read, Show)
-
-instance PersistEntity record => PathPiece (KeyHashid record) where
-    fromPathPiece t = KeyHashid <$> fromPathPiece t
-    toPathPiece (KeyHashid t) = toPathPiece t
-
-encodeKeyHashidPure
-    :: ToBackendKey SqlBackend record
-    => HashidsContext -> Key record -> KeyHashid record
-encodeKeyHashidPure ctx = KeyHashid . decodeUtf8 . encodeInt64 ctx . fromSqlKey
-
 getEncodeKeyHashid
     :: ( MonadSite m
        , YesodHashids (SiteEnv m)
@@ -86,14 +73,6 @@ encodeKeyHashid k = do
     enc <- getEncodeKeyHashid
     return $ enc k
 
-decodeKeyHashidPure
-    :: ToBackendKey SqlBackend record
-    => HashidsContext
-    -> KeyHashid record
-    -> Maybe (Key record)
-decodeKeyHashidPure ctx (KeyHashid t) =
-    fmap toSqlKey $ decodeInt64 ctx $ encodeUtf8 t
-
 decodeKeyHashid
     :: ( MonadSite m
        , YesodHashids (SiteEnv m)

stack.yaml

@@ -15,6 +15,12 @@ extra-deps:
   # yesod-auth-account
   - git: https://vervis.peers.community/repos/VE2Kr
     commit: 70024e76cafb95bfa50b456efcf0970d720207bd
+# - git: https://notabug.org/fr33domlover/haskell-persistent
+#   commit: 9cc700b540a680ac1fdc9df94847a631013cb3ca
+#   subdirs:
+#     - persistent
+#     - persistent-postgresql
+
   - ./lib/darcs-lights
   - ./lib/darcs-rev
   - ./lib/dvara
@@ -49,6 +55,7 @@ extra-deps:
   - time-interval-0.1.1
   - time-units-1.0.0
   - url-2.1.3
+  - annotated-exception-0.2.0.4
 
 # Override default flag values for local packages and extra-deps
 flags:

templates/personal-overview.hamlet

@@ -35,6 +35,9 @@ $# <http://creativecommons.org/publicdomain/zero/1.0/>.
   <li>
     <a href=@{PublishOfferMergeR}>
       Open a merge request
+$#   <li>
+$#     <a href=@{PublishCommentR}>
+$#       Comment on a ticket or merge request
   <li>
     <a href=@{PublishMergeR}>
       Merge a merge request

th/models

@@ -23,8 +23,13 @@ Instance
     UniqueInstance host
 
 RemoteObject
-    instance InstanceId
+    instance  InstanceId
-    ident    LocalURI
+    ident     LocalURI
+    -- fetched   UTCTime  Maybe
+
+    -- type      Text     Maybe
+    -- followers LocalURI Maybe
+    -- team      LocalURI Maybe
 
     UniqueRemoteObject instance ident
 

th/routes

@@ -129,6 +129,7 @@
 /ssh-keys                         KeysR      GET POST
 /ssh-keys/#SshKeyKeyHashid/delete KeyDeleteR POST
 
+--/publish/comment     PublishCommentR    GET POST
 /publish/offer-merge PublishOfferMergeR GET POST
 /publish/merge       PublishMergeR      GET POST
 

vervis.cabal

@@ -43,8 +43,10 @@ library
                        Vervis.Hook
   other-modules:
                        Control.Applicative.Local
+                       Control.Concurrent.Actor
                        Control.Concurrent.Local
                        Control.Concurrent.ResultShare
+                       Control.Concurrent.Return
                        Control.Monad.Trans.Except.Local
                        Crypto.ActorKey
                        Crypto.PubKey.Encoding
@@ -109,11 +111,14 @@ library
                        Text.Jasmine.Local
                        Web.ActivityAccess
                        Web.ActivityPub
+                       Web.Actor
+                       Web.Actor.Persist
                        -- Web.Capability
                        Web.Text
                        Web.Hashids.Local
                        Web.PathPieces.Local
                        Yesod.ActivityPub
+                       Yesod.Actor
                        Yesod.Auth.Unverified
                        Yesod.Auth.Unverified.Creds
                        Yesod.Auth.Unverified.Internal
@@ -128,6 +133,12 @@ library
 
                        Vervis.Access
                        Vervis.ActivityPub
+                       Vervis.Actor
+                       Vervis.Actor.Deck
+                       Vervis.Actor.Group
+                       Vervis.Actor.Loom
+                       Vervis.Actor.Person
+                       Vervis.Actor.Repo
                        Vervis.API
                        Vervis.Avatar
                        Vervis.BinaryBody
@@ -270,6 +281,8 @@ library
   build-depends:       aeson
                        -- For activity JSOn display in /inbox test page
                      , aeson-pretty
+                       -- For rethrowing in Control.Concurrent.Actor
+                     , annotated-exception
                        -- for encoding and decoding of crypto public keys
                      , asn1-encoding
                      , asn1-types