Upgrade actor system, now using HList, to allow per-actor method type

src/Control/Concurrent/Actor.hs

@@ -1,6 +1,6 @@
 {- This file is part of Vervis.
  -
- - Written in 2019, 2020, 2023, 2024 by fr33domlover <fr33domlover@riseup.net>.
+ - Written in 2019, 2020, 2024 by fr33domlover <fr33domlover@riseup.net>.
  -
  - ♡ Copying is an act of love. Please copy, reuse and share.
  -
@@ -13,14 +13,31 @@
  - <http://creativecommons.org/publicdomain/zero/1.0/>.
  -}
 
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE PackageImports #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE PolyKinds #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE TypeFamilyDependencies #-}
+
+{-# LANGUAGE IncoherentInstances #-}
+
 module Control.Concurrent.Actor
-    ( Stage (..)
+    ( Next ()
+    , Actor (..)
+    , ActorLaunch (..)
+    , Stage (..)
+    , ActorRef ()
     , TheaterFor ()
     , ActFor ()
     , runActor
     , MonadActor (..)
     , asksEnv
-    , Next ()
     , Message (..)
     , startTheater
     , callIO
@@ -37,6 +54,13 @@ module Control.Concurrent.Actor
     )
 where
 
+import Data.HList (HList)
+import Data.Kind
+import Fcf
+import "first-class-families" Fcf.Data.Symbol
+
+import qualified Data.HList as H
+
 import Control.Concurrent
 import Control.Concurrent.STM.TVar
 import Control.Monad
@@ -52,6 +76,7 @@ import Data.Foldable
 import Data.Hashable
 import Data.HashMap.Strict (HashMap)
 import Data.HashSet (HashSet)
+import Data.Proxy
 import Data.Text (Text)
 import Data.Traversable
 import UnliftIO.Exception
@@ -64,8 +89,6 @@ import qualified Data.Text as T
 
 import Control.Concurrent.Return
 
-type LogFunc = Loc -> LogSource -> LogLevel -> LogStr -> IO ()
-
 -- PROBLEM: I'm stuck with how App can hold the (TheaterFor Env) while Env
 -- needs to somehow hold the route rendering function (Route App -> Text) so
 -- there's a cyclic reference
@@ -79,15 +102,34 @@ type LogFunc = Loc -> LogSource -> LogLevel -> LogStr -> IO ()
 --
 -- And that change into abstract type can also help with the cyclic reference?
 
-class Stage a where
+type LogFunc = Loc -> LogSource -> LogLevel -> LogStr -> IO ()
-    type StageKey a
-    type StageMessage a
-    type StageReturn a
 
-newtype Actor m r = Actor (Chan (m, Either SomeException r -> IO ()))
+data Next = Stop | Proceed
 
-callIO' :: Actor m r -> m -> IO r
+class Actor (a :: Type) where
-callIO' (Actor chan) msg = do
+    type ActorStage a :: Type
+    type ActorKey a = (k :: Type) | k -> a
+    data ActorMessage a :: Type
+    type ActorReturn a :: Type
+
+class Actor a => ActorLaunch a where
+    actorBehavior
+        :: ActorKey a
+        -> ActorMessage a
+        -> ActFor
+            (ActorStage a)
+            (ActorReturn a, ActFor (ActorStage a) (), Next)
+
+class Stage (a :: Type) where
+    data StageEnv a :: Type
+    type StageActors a :: [Type]
+
+newtype ActorRef' m r = ActorRef' (Chan (m, Either SomeException r -> IO ()))
+
+newtype ActorRef a = ActorRef (ActorRef' (ActorMessage a) (ActorReturn a))
+
+callIO'' :: ActorRef' m r -> m -> IO r
+callIO'' (ActorRef' chan) msg = do
     (returx, wait) <- newReturn
     writeChan chan (msg, returx)
     result <- wait
@@ -95,19 +137,31 @@ callIO' (Actor chan) msg = do
         Left e -> AE.checkpointCallStack $ throwIO e
         Right r -> return r
 
-sendIO' :: Actor m r -> m -> IO ()
+callIO' :: Actor a => ActorRef a -> ActorMessage a -> IO (ActorReturn a)
-sendIO' (Actor chan) msg = writeChan chan (msg, const $ pure ())
+callIO' (ActorRef ref) = callIO'' ref
+
+sendIO'' :: ActorRef' m r -> m -> IO ()
+sendIO'' (ActorRef' chan) msg = writeChan chan (msg, const $ pure ())
+
+sendIO' :: Actor a => ActorRef a -> ActorMessage a -> IO ()
+sendIO' (ActorRef ref) = sendIO'' ref
+
+type ActorRefMap a = HashMap (ActorKey a) (ActorRef a)
+
+data Item_ :: Type -> Exp Type
+type instance Eval (Item_ a) = TVar (ActorRefMap a)
 
 -- | A set of live actors responding to messages
 data TheaterFor s = TheaterFor
-    { theaterMap :: TVar (HashMap (StageKey s) (Actor (StageMessage s) (StageReturn s)))
+    { theaterMap :: HList (Eval (Map Item_ (StageActors s)))
     , theaterLog :: LogFunc
     }
+-- theaterMap :: TVar (HashMap (StageKey s) (ActorRef (StageMessage s) (StageReturn 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 (s, TheaterFor s) IO) a
+    { unActFor :: LoggingT (ReaderT (StageEnv s, TheaterFor s) IO) a
     }
     deriving
         ( Functor, Applicative, Monad, MonadFail, MonadIO, MonadLogger
@@ -118,60 +172,63 @@ instance MonadUnliftIO (ActFor s) where
     withRunInIO inner =
         ActFor $ withRunInIO $ \ run -> inner (run . unActFor)
 
-runActor :: TheaterFor s -> s -> ActFor s a -> IO a
+runActor :: TheaterFor s -> StageEnv s -> ActFor s a -> IO a
 runActor theater env (ActFor action) =
     runReaderT (runLoggingT action $ theaterLog theater) (env, theater)
 
-class Monad m => MonadActor m where
+class (Monad m, Stage (MonadActorStage m)) => MonadActor m where
-    type ActorEnv m
+    type MonadActorStage m
-    askEnv :: m (ActorEnv m)
+    askEnv :: m (StageEnv (MonadActorStage m))
-    liftActor :: ActFor (ActorEnv m) a -> m a
+    liftActor :: ActFor (MonadActorStage m) a -> m a
 
-instance MonadActor (ActFor s) where
+instance Stage (s :: Type) => MonadActor (ActFor s) where
-    type ActorEnv (ActFor s) = s
+    type MonadActorStage (ActFor s) = s
     askEnv = ActFor $ lift $ asks fst
     liftActor = id
 
 instance MonadActor m => MonadActor (ReaderT r m) where
-    type ActorEnv (ReaderT r m) = ActorEnv m
+    type MonadActorStage (ReaderT r m) = MonadActorStage m
-    askEnv                      = lift askEnv
+    askEnv                             = lift askEnv
-    liftActor                   = lift . liftActor
+    liftActor                          = lift . liftActor
 
 instance MonadActor m => MonadActor (MaybeT m) where
-    type ActorEnv (MaybeT m) = ActorEnv m
+    type MonadActorStage (MaybeT m) = MonadActorStage m
-    askEnv                   = lift askEnv
+    askEnv                          = lift askEnv
-    liftActor                = lift . liftActor
+    liftActor                       = lift . liftActor
 
 instance MonadActor m => MonadActor (ExceptT e m) where
-    type ActorEnv (ExceptT e m) = ActorEnv m
+    type MonadActorStage (ExceptT e m) = MonadActorStage m
-    askEnv                      = lift askEnv
+    askEnv                             = lift askEnv
-    liftActor                   = lift . liftActor
+    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
+    type MonadActorStage (RWSL.RWST r w s m) = MonadActorStage m
-    askEnv                            = lift askEnv
+    askEnv                                   = lift askEnv
-    liftActor                         = lift . liftActor
+    liftActor                                = lift . liftActor
 
-asksEnv :: MonadActor m => (ActorEnv m -> a) -> m a
+asksEnv :: MonadActor m => (StageEnv (MonadActorStage 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
+    :: forall (a::Type) (k::Type) (m::Type) (r::Type) (s::Type).
-       , Hashable k, Eq k, Show k, Message m, Show r
+       ( ActorLaunch a
+       , ActorStage a ~ s
+       , ActorKey a ~  k, ActorMessage a ~ m, ActorReturn a ~ r
+       , H.HOccurs
+            (TVar (ActorRefMap a))
+            (HList (Eval (Map Item_ (StageActors s))))
+       , Eq k, Hashable k, Show k, Message m, Show r
        )
     => Chan (m, Either SomeException r -> IO ())
     -> TheaterFor s
     -> k
-    -> s
+    -> StageEnv s
-    -> (m -> ActFor s (r, ActFor s (), Next))
     -> IO ()
-launchActorThread chan theater actor env behavior =
+launchActorThread chan theater actor env =
     void $ forkIO $ runActor theater env $ do
         logInfo $ prefix <> "starting"
         loop
@@ -181,7 +238,7 @@ launchActorThread chan theater actor env behavior =
     loop = do
         (message, respond) <- liftIO $ readChan chan
         logInfo $ T.concat [prefix, "received: ", summarize message]
-        result <- try $ behavior message
+        result <- try $ behavior (actorProxy actor) actor message
         proceed <-
             case result of
                 Left e -> do
@@ -195,50 +252,182 @@ launchActorThread chan theater actor env behavior =
                     case next of
                         Stop -> do
                             logInfo $ T.concat [prefix, "on ", refer message, " stopping"]
-                            let tvar = theaterMap theater
+
+                            let tvar = H.hOccurs (theaterMap theater) :: TVar (ActorRefMap a)
                             liftIO $ atomically $ modifyTVar' tvar $ HM.delete actor
+
                             return False
                         Proceed -> do
                             logInfo $ T.concat [prefix, "on ", refer message, " done"]
                             return True
         when proceed loop
+    actorProxy :: forall a. ActorKey a -> Proxy a
+    actorProxy _ = Proxy
+    behavior
+        :: Proxy a
+        -> ActorKey a
+        -> ActorMessage a
+        -> ActFor
+            (ActorStage a)
+            (ActorReturn a, ActFor (ActorStage a) (), Next)
+    behavior _ = actorBehavior
+
+--data HFind :: Type -> [Type] -> Maybe Type
+--type instance Eval (HFind a as) = Eval (Find (TyEq a) as) :: Exp (Maybe a)
+
+prepareActorType
+    :: ( ActorLaunch a
+       , Eq (ActorKey a), Hashable (ActorKey a), Show (ActorKey a)
+       , Message (ActorMessage a)
+       , Show (ActorReturn a)
+       , ActorStage a ~ s
+       , Stage s
+       , H.HOccurs
+            (TVar (ActorRefMap a))
+            (HList (Eval (Map Item_ (StageActors s))))
+       )
+    => [(ActorKey a, StageEnv s)]
+    -> IO
+        ( TVar (ActorRefMap a)
+        , TheaterFor s -> IO ()
+        )
+prepareActorType actors = do
+    actorsWithChans <- for actors $ \ (key, env) -> do
+        chan <- newChan
+        return (key, env, chan)
+    tvar <-
+        newTVarIO $ HM.fromList $
+            map
+                (\ (key, _, chan) -> (key, ActorRef $ ActorRef' chan))
+                actorsWithChans
+    return
+        ( tvar
+        , \ theater -> for_ actorsWithChans $ \ (key, env, chan) ->
+            launchActorThread chan theater key env
+        )
+
+data HPrepareActorType = HPrepareActorType
+instance
+    ( ActorLaunch a
+    , Eq (ActorKey a), Hashable (ActorKey a), Show (ActorKey a)
+    , Message (ActorMessage a)
+    , Show (ActorReturn a)
+    , ActorStage a ~ s
+    , Stage s
+    , H.HOccurs
+        (TVar (ActorRefMap a))
+        (HList (Eval (Map Item_ (StageActors s))))
+    , i ~ [(ActorKey a, StageEnv s)]
+    , o ~ IO (TVar (ActorRefMap a), TheaterFor (ActorStage a) -> IO ())
+    ) =>
+    H.ApplyAB HPrepareActorType i o where
+        applyAB _ a = prepareActorType a
+
+--Why can't the compiler prove the HOccurence? Because it can't detect the l'?
+
+data A_ :: Type -> Exp Constraint
+type instance Eval (A_ a) =
+    ( ActorLaunch a
+    , Eq (ActorKey a), Hashable (ActorKey a), Show (ActorKey a)
+    , Message (ActorMessage a)
+    , Show (ActorReturn a)
+    )
+
+data Starter :: Type -> Exp Type
+type instance Eval (Starter a) = [(ActorKey a, StageEnv (ActorStage a))]
+
+data Prepare_ :: Type -> Type -> Exp Type
+type instance Eval (Prepare_ s a) = IO (TVar (ActorRefMap a), TheaterFor s -> IO ())
+
+data Pair_ :: Type -> Type -> Exp Type
+type instance Eval (Pair_ s a) = (TVar (ActorRefMap a), TheaterFor s -> IO ())
+
+data Launch_ :: Type -> Type -> Exp Type
+type instance Eval (Launch_ s _) = TheaterFor s -> IO ()
 
 -- | Launch the actor system
 startTheater
-    :: ( StageKey s ~ k, StageMessage s ~ m, StageReturn s ~ r
+    :: forall (s :: Type) (as :: [Type]) .
-       , Hashable k, Eq k, Show k, Message m, Show r
+       ( Stage s
+       , StageActors s ~ as
+       , Eval (Constraints (Eval (Map A_ as)))
+
+       , H.HMapAux
+                          HList
+                          HPrepareActorType
+                          (Eval (Map Starter as))
+                          (Eval (Map (Prepare_ s) as))
+       , H.SameLength'
+                          (Eval (Map Starter as))
+                          (Eval (Map (Prepare_ s) as))
+       , H.SameLength'
+                          (Eval (Map (Prepare_ s) as))
+                          (Eval (Map Starter as))
+
+       , H.HSequence
+                          IO
+                          (Eval (Map (Prepare_ s) as))
+                          (Eval (Map (Pair_ s) as))
+
+       , H.SameLength'
+                          (Eval (Map Item_ as))
+                          (Eval (Map (Launch_ s) as))
+       , H.SameLength'
+                          (Eval (Map (Launch_ s) as))
+                          (Eval (Map Item_ as))
+
+       , H.SameLength'
+                          (Eval (Map (Launch_ s) as))
+                          (Eval (Map (Pair_ s) as))
+       , H.SameLength'
+                          (Eval (Map (Pair_ s) as))
+                          (Eval (Map (Launch_ s) as))
+
+       , H.HZipList
+                          (Eval (Map Item_ as))
+                          (Eval (Map (Launch_ s) as))
+                          (Eval (Map (Pair_ s) as))
+
+       , H.HList2List
+                          (Eval (Map (Launch_ s) as))
+                          (TheaterFor s -> IO ())
        )
     => LogFunc
-    -> [(k, s, m -> ActFor s (r, ActFor s (), Next))]
+    -> HList (Eval (Map Starter as))
     -> IO (TheaterFor s)
 startTheater logFunc actors = do
-    actorsWithChans <- for actors $ \ (key, env, behavior) -> do
+    let actions = H.hMapL HPrepareActorType actors :: HList (Eval (Map (Prepare_ s) as))
-        chan <- newChan
+    mapsAndLaunches <- H.hSequence actions :: IO (HList (Eval (Map (Pair_ s) as)))
-        return ((key, Actor chan), (env, behavior))
+    let (maps :: HList (Eval (Map Item_ as)), launches :: HList (Eval (Map (Launch_ s) as))) = H.hUnzip mapsAndLaunches
-    tvar <- newTVarIO $ HM.fromList $ map fst actorsWithChans
+        theater = TheaterFor maps logFunc
-    let theater = TheaterFor tvar logFunc
+    for_ (H.hList2List launches) $ \ launch -> launch theater
-    for_ actorsWithChans $ \ ((key, Actor chan), (env, behavior)) ->
-        launchActorThread chan theater key env behavior
     return theater
 
 askTheater :: ActFor s (TheaterFor s)
 askTheater = ActFor $ lift $ asks snd
 
 lookupActor
-    :: ( StageKey s ~ k, StageMessage s ~ m, StageReturn s ~ r
+    :: ( Eq (ActorKey a), Hashable (ActorKey a)
-       , Eq k, Hashable k
+       , H.HOccurs
+                         (TVar (ActorRefMap a))
+                         (HList (Eval (Map Item_ (StageActors s))))
        )
     => TheaterFor s
-    -> k
+    -> ActorKey a
-    -> IO (Maybe (Actor m r))
+    -> IO (Maybe (ActorRef a))
-lookupActor (TheaterFor tvar _) actor = HM.lookup actor <$> readTVarIO tvar
+lookupActor (TheaterFor hlist _) key =
+    HM.lookup key <$> readTVarIO (H.hOccurs hlist)
+
 
 -- | Same as 'call', except it takes the theater as a parameter.
 callIO
-    :: ( StageKey s ~ k, StageMessage s ~ m, StageReturn s ~ r
+    :: ( Actor a
-       , Eq k, Hashable k
+       , Eq (ActorKey a), Hashable (ActorKey a)
+       , H.HOccurs
+                         (TVar (ActorRefMap a))
+                         (HList (Eval (Map Item_ (StageActors s))))
        )
-    => TheaterFor s -> k -> m -> IO (Maybe r)
+    => TheaterFor s -> ActorKey a -> ActorMessage a -> IO (Maybe (ActorReturn a))
 callIO theater key msg = do
     maybeActor <- lookupActor theater key
     for maybeActor $ \ actor -> callIO' actor msg
@@ -249,19 +438,27 @@ callIO theater key msg = do
 -- If the called method throws an exception, it is rethrown, wrapped with an
 -- annotation, in the current thread.
 call
-    :: ( MonadActor n, ActorEnv n ~ s
+    :: ( MonadActor m, MonadActorStage m ~ ActorStage a
-       , StageKey s ~ k, StageMessage s ~ m, StageReturn s ~ r
+       , Actor a
-       , Eq k, Hashable k
+       , Eq (ActorKey a), Hashable (ActorKey a)
+       , H.HOccurs
+                         (TVar (ActorRefMap a))
+                         (HList (Eval (Map Item_ (StageActors (ActorStage a)))))
        )
-    => k -> m -> n (Maybe r)
+    => ActorKey a -> ActorMessage a -> m (Maybe (ActorReturn a))
 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)
+    :: ( Actor a
-    => TheaterFor s -> k -> m -> IO Bool
+       , Eq (ActorKey a), Hashable (ActorKey a)
+       , H.HOccurs
+                         (TVar (ActorRefMap a))
+                         (HList (Eval (Map Item_ (StageActors s))))
+       )
+    => TheaterFor s -> ActorKey a -> ActorMessage a -> IO Bool
 sendIO theater key msg = do
     maybeActor <- lookupActor theater key
     case maybeActor of
@@ -273,56 +470,173 @@ sendIO theater key msg = do
 -- | 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
+    :: ( MonadActor m, MonadActorStage m ~ ActorStage a
-       , StageKey s ~ k, StageMessage s ~ m
+       , Actor a
-       , Eq k, Hashable k
+       , Eq (ActorKey a), Hashable (ActorKey a)
+       , H.HOccurs
+                         (TVar (ActorRefMap a))
+                         (HList (Eval (Map Item_ (StageActors (ActorStage a)))))
        )
-    => k -> m -> n Bool
+    => ActorKey a -> ActorMessage a -> m Bool
 send key msg = liftActor $ do
     theater <- askTheater
     liftIO $ sendIO theater key msg
 
--- | Like 'sendMany', except it takes the theater as a parameter.
+hSendTo
-sendManyIO
+    :: ( Actor a
-    :: (StageKey s ~ k, StageMessage s ~ m, Eq k, Hashable k)
+       , Eq (ActorKey a), Hashable (ActorKey a)
-    => TheaterFor s -> HashSet k -> m -> IO ()
+       )
-sendManyIO (TheaterFor tvar _) recips msg = do
+    => (TVar (ActorRefMap a), (HashSet (ActorKey a), ActorMessage a))
+    -> IO ()
+hSendTo (tvar, (recips, msg)) = do
     allActors <- readTVarIO tvar
     for_ (HM.intersection allActors (HS.toMap recips)) $
         \ actor -> sendIO' actor msg
 
+data HSendTo = HSendTo
+instance
+    ( Actor a
+    , Eq (ActorKey a), Hashable (ActorKey a)
+    , i ~ (TVar (ActorRefMap a), (HashSet (ActorKey a), ActorMessage a))
+    ) =>
+    H.ApplyAB HSendTo i (IO ()) where
+        applyAB _ a = hSendTo a
+
+data B_ :: Type -> Exp Constraint
+type instance Eval (B_ a) =
+    ( Actor a
+    , Eq (ActorKey a), Hashable (ActorKey a)
+    )
+
+data Set_ :: Type -> Exp Type
+type instance Eval (Set_ a) = (HashSet (ActorKey a), ActorMessage a)
+
+data Pair__ :: Type -> Exp Type
+type instance Eval (Pair__ a) = (Eval (Item_ a), Eval (Set_ a))
+
+-- | Like 'sendMany', except it takes the theater as a parameter.
+sendManyIO
+    :: forall s.
+       ( Stage s
+       , Eval (Constraints (Eval (Map B_ (StageActors s))))
+
+       , H.HZipList
+                          (Eval (Map Item_ (StageActors s)))
+                          (Eval (Map Set_ (StageActors s)))
+                          (Eval (Map Pair__ (StageActors s)))
+       , H.SameLength'
+                          (Eval (Map Item_ (StageActors s)))
+                          (Eval (Map Set_ (StageActors s)))
+       , H.SameLength'
+                          (Eval (Map Set_ (StageActors s)))
+                          (Eval (Map Item_ (StageActors s)))
+       , H.SameLength'
+                          (Eval (Map Set_ (StageActors s)))
+                          (Eval (Map Pair__ (StageActors s)))
+       , H.SameLength'
+                          (Eval (Map Pair__ (StageActors s)))
+                          (Eval (Map Set_ (StageActors s)))
+       , H.HMapAux
+                          HList
+                          HSendTo
+                          (Eval (Map Pair__ (StageActors s)))
+                          (Eval (Map (ConstFn (IO ())) (StageActors s)))
+       , H.SameLength'
+                          (Eval (Map Pair__ (StageActors s)))
+                          (Eval (Map (ConstFn (IO ())) (StageActors s)))
+       , H.SameLength'
+                          (Eval (Map (ConstFn (IO ())) (StageActors s)))
+                          (Eval (Map Pair__ (StageActors s)))
+       , H.HSequence
+                          IO
+                          (Eval (Map (ConstFn (IO ())) (StageActors s)))
+                          (Eval (Map (ConstFn ()) (StageActors s)))
+       )
+    => TheaterFor s
+    -> HList (Eval (Map Set_ (StageActors s)))
+    -> IO ()
+sendManyIO (TheaterFor hlist _) recips =
+    let zipped = H.hZip hlist recips
+            :: HList (Eval (Map Pair__ (StageActors s)))
+        actions = H.hMapL HSendTo zipped
+            :: HList (Eval (Map (ConstFn (IO ())) (StageActors s)))
+        action = H.hSequence actions
+            :: IO (HList (Eval (Map (ConstFn ()) (StageActors s))))
+    in  void action
+
 -- | Send a message to each actor in the set that exists in the system,
 -- without waiting for results.
 sendMany
-    :: ( MonadActor n, ActorEnv n ~ s
+    :: forall m s.
-       , StageKey s ~ k, StageMessage s ~ m
+       ( MonadActor m, MonadActorStage m ~ s
-       , Eq k, Hashable k
+       , Stage s
+       , Eval (Constraints (Eval (Map B_ (StageActors s))))
+
+       , H.HZipList
+                          (Eval (Map Item_ (StageActors s)))
+                          (Eval (Map Set_ (StageActors s)))
+                          (Eval (Map Pair__ (StageActors s)))
+       , H.SameLength'
+                          (Eval (Map Item_ (StageActors s)))
+                          (Eval (Map Set_ (StageActors s)))
+       , H.SameLength'
+                          (Eval (Map Set_ (StageActors s)))
+                          (Eval (Map Item_ (StageActors s)))
+       , H.SameLength'
+                          (Eval (Map Set_ (StageActors s)))
+                          (Eval (Map Pair__ (StageActors s)))
+       , H.SameLength'
+                          (Eval (Map Pair__ (StageActors s)))
+                          (Eval (Map Set_ (StageActors s)))
+       , H.HMapAux
+                          HList
+                          HSendTo
+                          (Eval (Map Pair__ (StageActors s)))
+                          (Eval (Map (ConstFn (IO ())) (StageActors s)))
+       , H.SameLength'
+                          (Eval (Map Pair__ (StageActors s)))
+                          (Eval (Map (ConstFn (IO ())) (StageActors s)))
+       , H.SameLength'
+                          (Eval (Map (ConstFn (IO ())) (StageActors s)))
+                          (Eval (Map Pair__ (StageActors s)))
+       , H.HSequence
+                          IO
+                          (Eval (Map (ConstFn (IO ())) (StageActors s)))
+                          (Eval (Map (ConstFn ()) (StageActors s)))
        )
-    => HashSet k -> m -> n ()
+    => HList (Eval (Map Set_ (StageActors s)))
-sendMany keys msg = liftActor $ do
+    -> m ()
+sendMany keys = liftActor $ do
     theater <- askTheater
-    liftIO $ sendManyIO theater keys msg
+    liftIO $ sendManyIO theater keys
 
 -- | Same as 'spawn', except it takes the theater as a parameter.
 spawnIO
-    :: ( StageKey s ~ k, StageMessage s ~ m, StageReturn s ~ r
+    :: forall a s.
-       , Eq k, Hashable k, Show k, Message m, Show r
+       ( ActorLaunch a, ActorStage a ~ s
+       , Eq (ActorKey a), Hashable (ActorKey a), Show (ActorKey a)
+       , Message (ActorMessage a)
+       , Show (ActorReturn a)
+
+       , H.HOccurs
+                          (TVar (HashMap (ActorKey a) (ActorRef a)))
+                          (HList (Eval (Map Item_ (StageActors s))))
        )
     => TheaterFor s
-    -> k
+    -> ActorKey a
-    -> IO s
+    -> IO (StageEnv s)
-    -> (m -> ActFor s (r, ActFor s (), Next))
     -> IO Bool
-spawnIO theater@(TheaterFor tvar _) key mkEnv behavior = do
+spawnIO theater@(TheaterFor hlist _) key mkEnv = do
+    let tvar = H.hOccurs hlist :: TVar (ActorRefMap a)
     chan <- newChan
     added <- atomically $ stateTVar tvar $ \ hm ->
-        let hm' = HM.alter (create $ Actor chan) key hm
+        let hm' = HM.alter (create $ ActorRef $ ActorRef' chan) key hm
         in  ( not (HM.member key hm) && HM.member key hm'
             , hm'
             )
     when added $ do
         env <- mkEnv
-        launchActorThread chan theater key env behavior
+        launchActorThread chan theater key env
     return added
     where
     create actor Nothing    = Just actor
@@ -332,23 +646,29 @@ spawnIO theater@(TheaterFor tvar _) key mkEnv behavior = do
 -- 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
+    :: forall m a s.
-       , StageKey s ~ k, StageMessage s ~ m, StageReturn s ~ r
+       ( MonadActor m, MonadActorStage m ~ s
-       , Eq k, Hashable k, Show k, Message m, Show r
+       , ActorLaunch a, ActorStage a ~ s
-       )
+       , Eq (ActorKey a), Hashable (ActorKey a), Show (ActorKey a)
-    => k
+       , Message (ActorMessage a)
-    -> IO s
+       , Show (ActorReturn a)
-    -> (m -> ActFor s (r, ActFor s (), Next))
-    -> n Bool
-spawn key mkEnv behavior = liftActor $ do
-    theater <- askTheater
-    liftIO $ spawnIO theater key mkEnv behavior
 
-done :: Monad n => a -> n (a, ActFor s (), Next)
+       , H.HOccurs
+                          (TVar (HashMap (ActorKey a) (ActorRef a)))
+                          (HList (Eval (Map Item_ (StageActors s))))
+       )
+    => ActorKey a
+    -> IO (StageEnv s)
+    -> m Bool
+spawn key mkEnv = liftActor $ do
+    theater <- askTheater
+    liftIO $ spawnIO theater key mkEnv
+
+done :: Monad m => a -> m (a, ActFor s (), Next)
 done msg = return (msg, return (), Proceed)
 
-doneAnd :: Monad n => a -> ActFor s () -> n (a, ActFor s (), Next)
+doneAnd :: Monad m => a -> ActFor s () -> m (a, ActFor s (), Next)
 doneAnd msg act = return (msg, act, Proceed)
 
-stop :: Monad n => a -> n (a, ActFor s (), Next)
+stop :: Monad m => a -> m (a, ActFor s (), Next)
 stop msg = return (msg, return (), Stop)

src/Vervis/API.hs

@@ -72,7 +72,7 @@ import qualified Data.Text as T
 import qualified Data.Text.Encoding as TE
 import qualified Data.Text.Lazy as TL
 
-import Control.Concurrent.Actor
+import Control.Concurrent.Actor hiding (Actor)
 import Database.Persist.JSON
 import Development.PatchMediaType
 import Network.FedURI
@@ -126,7 +126,6 @@ import Vervis.Recipient
 import Vervis.RemoteActorStore
 import Vervis.Settings
 import Vervis.Ticket
-import Vervis.Web.Delivery
 import Vervis.Web.Repo
 
 import qualified Vervis.Actor2 as VA2
@@ -148,7 +147,7 @@ handleViaActor personID maybeCap localRecips remoteRecips fwdHosts action = do
     let maybeCap' = first (\ (byKey, _, i) -> (byKey, i)) <$> maybeCap
         msg = ClientMsg maybeCap' localRecips remoteRecips fwdHosts action
     maybeResult <-
-        liftIO $ callIO theater (LocalActorPerson personID) (Right msg)
+        liftIO $ callIO theater personID (MsgP $ Right msg)
     itemText <-
         case maybeResult of
             Nothing -> error "Person not found in theater"
@@ -290,9 +289,12 @@ acceptC (Entity senderPersonID senderPerson) senderActor maybeCap localRecips re
                         ]
                 return $ makeRecipientSet sieveActors sieveStages
             let localRecipsFinal = localRecipSieve sieve False localRecips
+            {-
             deliverActivityDB
                 (LocalActorPerson senderHash) (personActor senderPerson)
                 localRecipsFinal remoteRecips fwdHosts acceptID action
+            -}
+            pure $ pure ()
 
         -- If resource is local, approve the Collab and deliver a Grant
         deliverHttpGrant <- for maybeCollabMore $ \ (collabID, _, _, resource, sender) -> do
@@ -324,9 +326,12 @@ acceptC (Entity senderPersonID senderPerson) senderActor maybeCap localRecips re
             -- for unavailable remote recipients
             resourceHash <-
                 grantResourceLocalActor <$> hashGrantResource resource
+            {-
             deliverActivityDB
                 resourceHash resourceActorID localRecipsGrant remoteRecipsGrant
                 fwdHostsGrant grantID actionGrant
+            -}
+            pure $ pure ()
 
         -- Return instructions for HTTP delivery to remote recipients
         return
@@ -677,9 +682,12 @@ applyC (Entity senderPersonID senderPerson) senderActor maybeCap localRecips rem
                         ]
                 return $ makeRecipientSet sieveActors sieveStages
             let localRecipsFinal = localRecipSieve sieve False localRecips
+            {-
             deliverActivityDB
                 (LocalActorPerson senderHash) (personActor senderPerson)
                 localRecipsFinal remoteRecips fwdHosts applyID action
+            -}
+            pure $ pure ()
 
         -- Verify that the loom has received the Apply, resolve the Ticket in
         -- DB, and publish Accept
@@ -711,9 +719,12 @@ applyC (Entity senderPersonID senderPerson) senderActor maybeCap localRecips rem
             -- delivery for unavailable remote recipients
             let localRecipsAccept =
                     makeRecipientSet acceptRecipActors acceptRecipStages
+            {-
             deliverActivityDB
                 (LocalActorLoom loomHash) loomActorID localRecipsAccept [] []
                 acceptID actionAccept
+            -}
+            pure $ pure ()
 
         -- Return instructions for HTTP delivery or Apply and Accept to remote
         -- recipients
@@ -862,9 +873,12 @@ createNoteC (Entity senderPersonID senderPerson) senderActor maybeCap localRecip
                 return $ makeRecipientSet actors stages
             let localRecipsFinal =
                     localRecipSieve' sieve True False localRecips
+            {-
             deliverActivityDB
                 (LocalActorPerson senderHash) (personActor senderPerson)
                 localRecipsFinal remoteRecips fwdHosts createID actionCreate
+            -}
+            pure $ pure ()
 
         -- Return instructions for HTTP delivery to remote recipients
         return (createID, deliverHttpCreate)
@@ -1049,9 +1063,12 @@ createPatchTrackerC (Entity pidUser personUser) senderActor maybeCap localRecips
                         , LocalStageRepoFollowers repoHash
                         ]
                 localRecipsFinal = localRecipSieve sieve False localRecips
+            {-
             deliverActivityDB
                 (LocalActorPerson senderHash) (personActor personUser)
                 localRecipsFinal remoteRecips fwdHosts obiidCreate actionCreate
+            -}
+            pure $ pure ()
 
         -- Insert collaboration access for loom's creator
         let loomOutboxID = actorOutbox loomActor
@@ -1070,9 +1087,12 @@ createPatchTrackerC (Entity pidUser personUser) senderActor maybeCap localRecips
         deliverHttpGrant <- do
             let localRecipsGrant =
                     makeRecipientSet grantRecipActors grantRecipStages
+            {-
             deliverActivityDB
                 (LocalActorLoom loomHash) loomActorID localRecipsGrant [] []
                 obiidGrant actionGrant
+            -}
+            pure $ pure ()
 
         -- Insert follow record
         obiidFollow <- lift $ insertEmptyOutboxItem (actorOutbox senderActor) now
@@ -1104,7 +1124,7 @@ createPatchTrackerC (Entity pidUser personUser) senderActor maybeCap localRecips
     success <- do
         theater <- asksSite appTheater
         env <- asksSite appEnv
-        liftIO $ launchActorIO theater env LocalActorLoom loomID
+        liftIO $ launchActorIO theater env loomID
     unless success $
         error "Failed to spawn new Loom, somehow ID already in Theater"
 
@@ -1295,9 +1315,12 @@ createRepositoryC (Entity pidUser personUser) senderActor maybeCap localRecips r
             let sieve =
                     makeRecipientSet [] [LocalStagePersonFollowers senderHash]
                 localRecipsFinal = localRecipSieve sieve False localRecips
+            {-
             deliverActivityDB
                 (LocalActorPerson senderHash) (personActor personUser)
                 localRecipsFinal remoteRecips fwdHosts obiidCreate actionCreate
+            -}
+            pure $ pure ()
 
         -- Insert collaboration access for repo's creator
         let repoOutboxID = actorOutbox repoActor
@@ -1315,9 +1338,12 @@ createRepositoryC (Entity pidUser personUser) senderActor maybeCap localRecips r
         deliverHttpGrant <- do
             let localRecipsGrant =
                     makeRecipientSet grantRecipActors grantRecipStages
+            {-
             deliverActivityDB
                 (LocalActorRepo repoHash) repoActorID localRecipsGrant [] []
                 grantID actionGrant
+            -}
+            pure $ pure ()
 
         -- Insert follow record
         obiidFollow <- lift $ insertEmptyOutboxItem (actorOutbox senderActor) now
@@ -1352,7 +1378,7 @@ createRepositoryC (Entity pidUser personUser) senderActor maybeCap localRecips r
     success <- do
         theater <- asksSite appTheater
         env <- asksSite appEnv
-        liftIO $ launchActorIO theater env LocalActorRepo repoID
+        liftIO $ launchActorIO theater env repoID
     unless success $
         error "Failed to spawn new Repo, somehow ID already in Theater"
 
@@ -1572,9 +1598,12 @@ followC (Entity senderPersonID senderPerson) senderActor maybeCap localRecips re
                 let stages' = LocalStagePersonFollowers senderHash : stages
                 return $ makeRecipientSet actors stages'
             let localRecipsFinal = localRecipSieve sieve False localRecips
+            {-
             deliverActivityDB
                 (LocalActorPerson senderHash) (personActor senderPerson)
                 localRecipsFinal remoteRecips fwdHosts followID action
+            -}
+            pure $ pure ()
 
         maybeDeliverHttpAccept <-
             case followeeDB of
@@ -1614,9 +1643,12 @@ followC (Entity senderPersonID senderPerson) senderActor maybeCap localRecips re
                     -- schedule delivery for unavailable remote recipients
                     let localRecipsAccept = makeRecipientSet acceptActors acceptStages
                     actorByHash <- hashLocalActor actorByKey
+                    {-
                     deliverActivityDB
                         actorByHash actorID localRecipsAccept [] []
                         acceptID actionAccept
+                    -}
+                    pure $ pure ()
 
         -- Return instructions for HTTP delivery to remote recipients
         return (followID, deliverHttpFollow, maybeDeliverHttpAccept)

src/Vervis/Actor.hs

@@ -79,7 +79,8 @@ module Vervis.Actor
 
       -- * Behavior utility types
     , VerseExt
-    , Env (..)
+    , StageEnv (..)
+    , Staje
     , Act
     , ActE
     , ActDB
@@ -91,6 +92,8 @@ module Vervis.Actor
     , withDBExcept
     , behave
     , VervisActor (..)
+    , VervisActorLaunch (..)
+    , ActorMessage (..)
     , launchActorIO
     , launchActor
 
@@ -116,6 +119,8 @@ import Data.ByteString (ByteString)
 import Data.Foldable
 import Data.Function
 import Data.Hashable
+import Data.HashMap.Strict (HashMap)
+import Data.HashSet (HashSet)
 import Data.List.NonEmpty (NonEmpty)
 import Data.Maybe
 import Data.Text (Text)
@@ -133,13 +138,13 @@ import qualified Control.Monad.Fail as F
 import qualified Data.Aeson as A
 import qualified Data.ByteString.Lazy as BL
 import qualified Data.HashSet as HS
+import qualified Data.HList as H
 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 Network.FedURI
 import Web.Actor
 import Web.Actor.Deliver
@@ -147,6 +152,7 @@ import Web.Actor.Persist
 import Yesod.Hashids
 import Yesod.MonadSite
 
+import qualified Crypto.ActorKey as AK
 import qualified Web.ActivityPub as AP
 
 import Data.List.NonEmpty.Local
@@ -231,14 +237,14 @@ hashLocalActorPure ctx = f
     f (LocalActorProject j) = LocalActorProject $ encodeKeyHashidPure ctx j
 
 getHashLocalActor
-    :: (MonadActor m, StageHashids (ActorEnv m))
+    :: (MonadActor m, StageHashids (MonadActorStage m))
     => m (LocalActorBy Key -> LocalActorBy KeyHashid)
 getHashLocalActor = do
     ctx <- asksEnv stageHashidsContext
     return $ hashLocalActorPure ctx
 
 hashLocalActor
-    :: (MonadActor m, StageHashids (ActorEnv m))
+    :: (MonadActor m, StageHashids (MonadActorStage m))
     => LocalActorBy Key -> m (LocalActorBy KeyHashid)
 hashLocalActor actor = do
     hash <- getHashLocalActor
@@ -256,24 +262,24 @@ unhashLocalActorPure ctx = f
     f (LocalActorProject j) = LocalActorProject <$> decodeKeyHashidPure ctx j
 
 unhashLocalActor
-    :: (MonadActor m, StageHashids (ActorEnv m))
+    :: (MonadActor m, StageHashids (MonadActorStage m))
     => LocalActorBy KeyHashid -> m (Maybe (LocalActorBy Key))
 unhashLocalActor actor = do
     ctx <- asksEnv stageHashidsContext
     return $ unhashLocalActorPure ctx actor
 
 unhashLocalActorF
-    :: (F.MonadFail m, MonadActor m, StageHashids (ActorEnv m))
+    :: (F.MonadFail m, MonadActor m, StageHashids (MonadActorStage m))
     => LocalActorBy KeyHashid -> String -> m (LocalActorBy Key)
 unhashLocalActorF actor e = maybe (F.fail e) return =<< unhashLocalActor actor
 
 unhashLocalActorM
-    :: (MonadActor m, StageHashids (ActorEnv m))
+    :: (MonadActor m, StageHashids (MonadActorStage m))
     => LocalActorBy KeyHashid -> MaybeT m (LocalActorBy Key)
 unhashLocalActorM = MaybeT . unhashLocalActor
 
 unhashLocalActorE
-    :: (MonadActor m, StageHashids (ActorEnv m))
+    :: (MonadActor m, StageHashids (MonadActorStage m))
     => LocalActorBy KeyHashid -> e -> ExceptT e m (LocalActorBy Key)
 unhashLocalActorE actor e =
     ExceptT $ maybe (Left e) Right <$> unhashLocalActor actor
@@ -303,14 +309,14 @@ hashLocalResourcePure ctx = f
     f (LocalResourceProject j) = LocalResourceProject $ encodeKeyHashidPure ctx j
 
 getHashLocalResource
-    :: (MonadActor m, StageHashids (ActorEnv m))
+    :: (MonadActor m, StageHashids (MonadActorStage m))
     => m (LocalResourceBy Key -> LocalResourceBy KeyHashid)
 getHashLocalResource = do
     ctx <- asksEnv stageHashidsContext
     return $ hashLocalResourcePure ctx
 
 hashLocalResource
-    :: (MonadActor m, StageHashids (ActorEnv m))
+    :: (MonadActor m, StageHashids (MonadActorStage m))
     => LocalResourceBy Key -> m (LocalResourceBy KeyHashid)
 hashLocalResource actor = do
     hash <- getHashLocalResource
@@ -327,24 +333,24 @@ unhashLocalResourcePure ctx = f
     f (LocalResourceProject j) = LocalResourceProject <$> decodeKeyHashidPure ctx j
 
 unhashLocalResource
-    :: (MonadActor m, StageHashids (ActorEnv m))
+    :: (MonadActor m, StageHashids (MonadActorStage m))
     => LocalResourceBy KeyHashid -> m (Maybe (LocalResourceBy Key))
 unhashLocalResource actor = do
     ctx <- asksEnv stageHashidsContext
     return $ unhashLocalResourcePure ctx actor
 
 unhashLocalResourceF
-    :: (F.MonadFail m, MonadActor m, StageHashids (ActorEnv m))
+    :: (F.MonadFail m, MonadActor m, StageHashids (MonadActorStage m))
     => LocalResourceBy KeyHashid -> String -> m (LocalResourceBy Key)
 unhashLocalResourceF actor e = maybe (F.fail e) return =<< unhashLocalResource actor
 
 unhashLocalResourceM
-    :: (MonadActor m, StageHashids (ActorEnv m))
+    :: (MonadActor m, StageHashids (MonadActorStage m))
     => LocalResourceBy KeyHashid -> MaybeT m (LocalResourceBy Key)
 unhashLocalResourceM = MaybeT . unhashLocalResource
 
 unhashLocalResourceE
-    :: (MonadActor m, StageHashids (ActorEnv m))
+    :: (MonadActor m, StageHashids (MonadActorStage m))
     => LocalResourceBy KeyHashid -> e -> ExceptT e m (LocalResourceBy Key)
 unhashLocalResourceE actor e =
     ExceptT $ maybe (Left e) Right <$> unhashLocalResource actor
@@ -459,74 +465,145 @@ data ClientMsg = ClientMsg
     , cmAction       :: AP.Action URIMode
     }
 
+summarizeVerse (Verse (Left (actor, _, itemID)) body) =
+    let typ = AP.activityType $ AP.activitySpecific $ actbActivity body
+    in  T.concat [typ, " ", T.pack $ show actor, " ", T.pack $ show itemID]
+summarizeVerse (Verse (Right (author, luAct, _)) body) =
+    let ObjURI h _ = remoteAuthorURI author
+        typ = AP.activityType $ AP.activitySpecific $ actbActivity body
+    in  T.concat [typ, " ", renderObjURI $ ObjURI h luAct]
+
+referVerse (Verse (Left (actor, _, itemID)) _body) =
+    T.concat [T.pack $ show actor, " ", T.pack $ show itemID]
+referVerse (Verse (Right (author, luAct, _)) _body) =
+    let ObjURI h _ = remoteAuthorURI author
+    in  renderObjURI $ ObjURI h luAct
+
 type VerseExt = Either Verse ClientMsg
 
-instance Message VerseExt where
+data Staje
-    summarize (Left (Verse (Left (actor, _, itemID)) body)) =
+
-        let typ = AP.activityType $ AP.activitySpecific $ actbActivity body
+instance Actor Person where
-        in  T.concat [typ, " ", T.pack $ show actor, " ", T.pack $ show itemID]
+    type ActorStage   Person = Staje
-    summarize (Left (Verse (Right (author, luAct, _)) body)) =
+    type ActorKey     Person = PersonId
-        let ObjURI h _ = remoteAuthorURI author
+    type ActorReturn  Person = Either Text Text
-            typ = AP.activityType $ AP.activitySpecific $ actbActivity body
+    data ActorMessage Person = MsgP (Either Verse ClientMsg)
-        in  T.concat [typ, " ", renderObjURI $ ObjURI h luAct]
+instance Actor Deck where
-    summarize (Right _) = "ClientMsg"
+    type ActorStage   Deck = Staje
-    refer (Left (Verse (Left (actor, _, itemID)) _body)) =
+    type ActorKey     Deck = DeckId
-        T.concat [T.pack $ show actor, " ", T.pack $ show itemID]
+    type ActorReturn  Deck = Either Text Text
-    refer (Left (Verse (Right (author, luAct, _)) _body)) =
+    data ActorMessage Deck = MsgD Verse
-        let ObjURI h _ = remoteAuthorURI author
+instance Actor Loom where
-        in  renderObjURI $ ObjURI h luAct
+    type ActorStage   Loom = Staje
-    refer (Right _) = "ClientMsg"
+    type ActorKey     Loom = LoomId
+    type ActorReturn  Loom = Either Text Text
+    data ActorMessage Loom = MsgL Verse
+instance Actor Repo where
+    type ActorStage   Repo = Staje
+    type ActorKey     Repo = RepoId
+    type ActorReturn  Repo = Either Text Text
+    data ActorMessage Repo = MsgR Verse
+instance Actor Project where
+    type ActorStage   Project = Staje
+    type ActorKey     Project = ProjectId
+    type ActorReturn  Project = Either Text Text
+    data ActorMessage Project = MsgJ Verse
+instance Actor Group where
+    type ActorStage   Group = Staje
+    type ActorKey     Group = GroupId
+    type ActorReturn  Group = Either Text Text
+    data ActorMessage Group = MsgG Verse
+
+instance VervisActor Person where
+    actorVerse = MsgP . Left
+    toVerse (MsgP e) =
+        case e of
+            Left v -> Just v
+            Right _ -> Nothing
+instance VervisActor Project where
+    actorVerse = MsgJ
+    toVerse (MsgJ v) = Just v
+instance VervisActor Group where
+    actorVerse = MsgG
+    toVerse (MsgG v) = Just v
+instance VervisActor Deck where
+    actorVerse = MsgD
+    toVerse (MsgD v) = Just v
+instance VervisActor Loom where
+    actorVerse = MsgL
+    toVerse (MsgL v) = Just v
+instance VervisActor Repo where
+    actorVerse = MsgR
+    toVerse (MsgR v) = Just v
+
+instance Stage Staje where
+    data StageEnv Staje = forall y. (Typeable y, Yesod y) => Env
+        -- | 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.
+        --
+        -- The purpose of Env is to hold the system stuff: DB connection pool,
+        -- settings, HTTP manager, etc. etc. while the data stuff (actual info of the
+        -- actor) is meant to be passed as parameters of the behavior function.
+        --
+        -- Maybe in the future there won't be data shared by all actors, and then this
+        -- type can be removed.
+        { envSettings        :: AppSettings
+        , envDbPool          :: ConnectionPool
+        , envHashidsContext  :: HashidsContext
+        , envActorKeys       :: Maybe (TVar (AK.ActorKey, AK.ActorKey, Bool))
+        , envDeliveryTheater :: DeliveryTheater URIMode
+        , envYesodRender     :: YesodRender y
+        , envHttpManager     :: Manager
+        , envFetch           :: ActorFetchShare
+        }
+        deriving Typeable
+    type StageActors Staje = [Person, Project, Group, Deck, Loom, Repo]
+
+instance Message (ActorMessage Person) where
+    summarize (MsgP (Left verse)) = summarizeVerse verse
+    summarize (MsgP (Right _)) = "ClientMsg"
+    refer (MsgP (Left verse)) = referVerse verse
+    refer (MsgP (Right _)) = "ClientMsg"
+instance Message (ActorMessage Deck) where
+    summarize (MsgD verse) = summarizeVerse verse
+    refer (MsgD verse) = referVerse verse
+instance Message (ActorMessage Loom) where
+    summarize (MsgL verse) = summarizeVerse verse
+    refer (MsgL verse) = referVerse verse
+instance Message (ActorMessage Repo) where
+    summarize (MsgR verse) = summarizeVerse verse
+    refer (MsgR verse) = referVerse verse
+instance Message (ActorMessage Project) where
+    summarize (MsgJ verse) = summarizeVerse verse
+    refer (MsgJ verse) = referVerse verse
+instance Message (ActorMessage Group) where
+    summarize (MsgG verse) = summarizeVerse verse
+    refer (MsgG verse) = referVerse verse
 
 type YesodRender y = Route y -> [(Text, Text)] -> Text
 
--- | Data to which every actor has access. Since such data can be passed to the
+instance StageWeb Staje where
--- behavior function when launching the actor, having a dedicated datatype is
+    type StageURIMode Staje = URIMode
--- just convenience. The main reason is to allow 'runDB' not to take a
+    --type StageRoute Staje = Route Site
--- connection pool parameter, instead grabbing it from the ReaderT. Another
--- reason is to avoid the clutter of passing the same arguments manually
--- everywhere.
---
--- The purpose of Env is to hold the system stuff: DB connection pool,
--- settings, HTTP manager, etc. etc. while the data stuff (actual info of the
--- actor) is meant to be passed as parameters of the behavior function.
---
--- Maybe in the future there won't be data shared by all actors, and then this
--- type can be removed.
-data Env = forall y. (Typeable y, Yesod y) => Env
-    { envSettings        :: AppSettings
-    , envDbPool          :: ConnectionPool
-    , envHashidsContext  :: HashidsContext
-    , envActorKeys       :: Maybe (TVar (ActorKey, ActorKey, Bool))
-    , envDeliveryTheater :: DeliveryTheater URIMode
-    , envYesodRender     :: YesodRender y
-    , envHttpManager     :: Manager
-    , envFetch           :: ActorFetchShare
-    }
-    deriving Typeable
-
-instance Stage Env where
-    type StageKey Env     = LocalActorBy Key
-    type StageMessage Env = VerseExt
-    type StageReturn Env  = Either Text Text
-
-instance StageWeb Env where
-    type StageURIMode Env = URIMode
-    --type StageRoute Env = Route Site
     stageInstanceHost = appInstanceHost . envSettings
     stageDeliveryTheater = envDeliveryTheater
 
-instance StageHashids Env where
+instance StageHashids Staje where
     stageHashidsContext = envHashidsContext
 
-type Act = ActFor Env
+type Act = ActFor Staje
 
-type ActE = ActForE Env
+type ActE = ActForE Staje
 
 type ActDB = SqlPersistT Act
 
 type ActDBE = ExceptT Text ActDB
 
-type Theater = TheaterFor Env
+type Theater = TheaterFor Staje
 
 -- | Run a database transaction. If an exception is thrown, the whole
 -- transaction is aborted.
@@ -552,8 +629,8 @@ withDBExcept action = do
     abort = throwIO . FedError
 
 behave
-    :: (UTCTime -> Key a -> VerseExt -> ExceptT Text Act (Text, Act (), Next))
+    :: (UTCTime -> ActorKey a -> ActorMessage a -> ExceptT Text Act (Text, Act (), Next))
-    -> (Key a -> VerseExt -> Act (Either Text Text, Act (), Next))
+    -> (ActorKey a -> ActorMessage a -> Act (Either Text Text, Act (), Next))
 behave handler key msg = do
     now <- liftIO getCurrentTime
     result <- runExceptT $ handler now key msg
@@ -562,16 +639,84 @@ behave handler key msg = do
         Right (t, after, next) -> return (Right t, after, next)
 
 class VervisActor a where
-    actorBehavior :: UTCTime -> Key a -> VerseExt -> ActE (Text, Act (), Next)
+    actorVerse :: Verse -> ActorMessage a
+    toVerse    :: ActorMessage a -> Maybe Verse
 
-launchActorIO :: VervisActor a => Theater -> Env -> (Key a -> LocalActorBy Key) -> Key a -> IO Bool
+class VervisActor a => VervisActorLaunch a where
-launchActorIO theater env mk key =
+    actorBehavior' :: UTCTime -> ActorKey a -> ActorMessage a -> ActE (Text, Act (), Next)
-    spawnIO theater (mk key) (pure env) $ behave actorBehavior key
 
-launchActor :: forall a. VervisActor a => (Key a -> LocalActorBy Key) -> Key a -> Act Bool
+instance (Actor a, VervisActorLaunch a, ActorReturn a ~ Either Text Text, ActorStage a ~ Staje) => ActorLaunch a where
-launchActor mk key = do
+    actorBehavior = behave actorBehavior'
+
+launchActorIO
+    :: ( ActorLaunch a, ActorStage a ~ Staje
+       , Eq (ActorKey a), Hashable (ActorKey a), Show (ActorKey a)
+       , Message (ActorMessage a)
+       , Show (ActorReturn a)
+       , H.HEq
+                                  (TVar (HashMap (ActorKey a) (ActorRef a)))
+                                  (TVar (HashMap PersonId (ActorRef Person)))
+                                  b1
+       , H.HOccurrence'
+                          b1
+                          (TVar (HashMap (ActorKey a) (ActorRef a)))
+                          '[TVar (HashMap PersonId (ActorRef Person)),
+                            TVar (HashMap ProjectId (ActorRef Project)),
+                            TVar (HashMap GroupId (ActorRef Group)),
+                            TVar (HashMap DeckId (ActorRef Deck)),
+                            TVar (HashMap LoomId (ActorRef Loom)),
+                            TVar (HashMap RepoId (ActorRef Repo))]
+                          l'1
+       , H.HOccurs'
+                          (TVar (HashMap (ActorKey a) (ActorRef a)))
+                          l'1
+                          '[TVar (HashMap PersonId (ActorRef Person)),
+                            TVar (HashMap ProjectId (ActorRef Project)),
+                            TVar (HashMap GroupId (ActorRef Group)),
+                            TVar (HashMap DeckId (ActorRef Deck)),
+                            TVar (HashMap LoomId (ActorRef Loom)),
+                            TVar (HashMap RepoId (ActorRef Repo))]
+       )
+    => Theater
+    -> StageEnv Staje
+    -> ActorKey a
+    -> IO Bool
+launchActorIO theater env key = spawnIO theater key (pure env)
+
+launchActor
+    :: ( ActorLaunch a, ActorStage a ~ Staje
+       , Eq (ActorKey a), Hashable (ActorKey a), Show (ActorKey a)
+       , Message (ActorMessage a)
+       , Show (ActorReturn a)
+       , H.HEq
+                                  (TVar (HashMap (ActorKey a) (ActorRef a)))
+                                  (TVar (HashMap PersonId (ActorRef Person)))
+                                  b0
+       , H.HOccurrence'
+                          b0
+                          (TVar (HashMap (ActorKey a) (ActorRef a)))
+                          '[TVar (HashMap PersonId (ActorRef Person)),
+                            TVar (HashMap ProjectId (ActorRef Project)),
+                            TVar (HashMap GroupId (ActorRef Group)),
+                            TVar (HashMap DeckId (ActorRef Deck)),
+                            TVar (HashMap LoomId (ActorRef Loom)),
+                            TVar (HashMap RepoId (ActorRef Repo))]
+                          l'0
+       , H.HOccurs'
+                          (TVar (HashMap (ActorKey a) (ActorRef a)))
+                          l'0
+                          '[TVar (HashMap PersonId (ActorRef Person)),
+                            TVar (HashMap ProjectId (ActorRef Project)),
+                            TVar (HashMap GroupId (ActorRef Group)),
+                            TVar (HashMap DeckId (ActorRef Deck)),
+                            TVar (HashMap LoomId (ActorRef Loom)),
+                            TVar (HashMap RepoId (ActorRef Repo))]
+       )
+    => ActorKey a
+    -> Act Bool
+launchActor key = do
     e <- askEnv
-    spawn (mk key) (pure e) $ behave actorBehavior key
+    spawn key (pure e)
 
 data RemoteRecipient = RemoteRecipient
     { remoteRecipientActor      :: RemoteActorId
@@ -739,7 +884,16 @@ sendToLocalActors authorAndId body requireOwner mauthor maidAuthor recips = do
                     Just a -> HS.delete a s
         authorAndId' =
             second (\ (author, luAct) -> (author, luAct, Nothing)) authorAndId
-    sendMany liveRecips $ Left $ Verse authorAndId' body
+        (liveRecipsP, liveRecipsJ, liveRecipsG, liveRecipsD, liveRecipsL, liveRecipsR) =
+            partitionByActor liveRecips
+        verse = Verse authorAndId' body
+    sendMany $
+        (liveRecipsP, actorVerse verse) `H.HCons`
+        (liveRecipsJ, actorVerse verse) `H.HCons`
+        (liveRecipsG, actorVerse verse) `H.HCons`
+        (liveRecipsD, actorVerse verse) `H.HCons`
+        (liveRecipsL, actorVerse verse) `H.HCons`
+        (liveRecipsR, actorVerse verse) `H.HCons` H.HNil
 
     -- Return remote followers, to whom we need to deliver via HTTP
     return remoteFollowers
@@ -831,6 +985,30 @@ sendToLocalActors authorAndId body requireOwner mauthor maidAuthor recips = do
             E.where_ $ f E.^. FollowTarget `E.in_` E.valList followerSetIDs
             return $ p E.^. persistIdField
 
+    partitionByActor
+        :: HashSet (LocalActorBy Key)
+        -> ( HashSet PersonId
+           , HashSet ProjectId
+           , HashSet GroupId
+           , HashSet DeckId
+           , HashSet LoomId
+           , HashSet RepoId
+           )
+    partitionByActor = foldl' f (HS.empty, HS.empty, HS.empty, HS.empty, HS.empty, HS.empty)
+        where
+        f (p, j, g, d, l, r) (LocalActorPerson k) =
+            (HS.insert k p, j, g, d, l, r)
+        f (p, j, g, d, l, r) (LocalActorProject k) =
+            (p, HS.insert k j, g, d, l, r)
+        f (p, j, g, d, l, r) (LocalActorGroup k) =
+            (p, j, HS.insert k g, d, l, r)
+        f (p, j, g, d, l, r) (LocalActorDeck k) =
+            (p, j, g, HS.insert k d, l, r)
+        f (p, j, g, d, l, r) (LocalActorLoom k) =
+            (p, j, g, d, HS.insert k l, r)
+        f (p, j, g, d, l, r) (LocalActorRepo k) =
+            (p, j, g, d, l, HS.insert k r)
+
 actorIsAddressed :: RecipientRoutes -> LocalActor -> Bool
 actorIsAddressed recips = isJust . verify
     where

src/Vervis/Actor/Common.hs

@@ -60,7 +60,7 @@ import Yesod.Persist.Core
 import qualified Data.Text as T
 import qualified Database.Esqueleto as E
 
-import Control.Concurrent.Actor
+import Control.Concurrent.Actor hiding (Actor)
 import Network.FedURI
 import Web.Actor
 import Web.Actor.Persist

src/Vervis/Actor/Deck.hs

@@ -821,8 +821,8 @@ deckUndo now recipDeckID (Verse authorIdMsig body) (AP.Undo uObject) = do
 -- Main behavior function
 ------------------------------------------------------------------------------
 
-deckBehavior :: UTCTime -> DeckId -> VerseExt -> ActE (Text, Act (), Next)
+deckBehavior :: UTCTime -> DeckId -> ActorMessage Deck -> ActE (Text, Act (), Next)
-deckBehavior now deckID (Left verse@(Verse _authorIdMsig body)) =
+deckBehavior now deckID (MsgD verse@(Verse _authorIdMsig body)) =
     case AP.activitySpecific $ actbActivity body of
         AP.AcceptActivity accept -> deckAccept now deckID verse accept
         AP.AddActivity add       -> deckAdd now deckID verse add
@@ -838,10 +838,9 @@ deckBehavior now deckID (Left verse@(Verse _authorIdMsig body)) =
         AP.RevokeActivity revoke -> deckRevoke now deckID verse revoke
         AP.UndoActivity undo     -> deckUndo now deckID verse undo
         _ -> throwE "Unsupported activity type for Deck"
-deckBehavior _ _ (Right _) = throwE "ClientMsgs aren't supported for Deck"
 
-instance VervisActor Deck where
+instance VervisActorLaunch Deck where
-    actorBehavior now deckID ve = do
+    actorBehavior' now deckID ve = do
         errboxID <- lift $ withDB $ do
             resourceID <- deckResource <$> getJust deckID
             Resource actorID <- getJust resourceID

src/Vervis/Actor/Group.hs

@@ -5926,8 +5926,8 @@ groupUndo now recipGroupID (Verse authorIdMsig body) (AP.Undo uObject) = do
 
         return (action, recipientSet, remoteActors, fwdHosts)
 
-groupBehavior :: UTCTime -> GroupId -> VerseExt -> ActE (Text, Act (), Next)
+groupBehavior :: UTCTime -> GroupId -> ActorMessage Group -> ActE (Text, Act (), Next)
-groupBehavior now groupID (Left verse@(Verse _authorIdMsig body)) =
+groupBehavior now groupID (MsgG verse@(Verse _authorIdMsig body)) =
     case AP.activitySpecific $ actbActivity body of
         AP.AcceptActivity accept -> groupAccept now groupID verse accept
         AP.AddActivity add       -> groupAdd now groupID verse add
@@ -5941,10 +5941,9 @@ groupBehavior now groupID (Left verse@(Verse _authorIdMsig body)) =
         AP.RevokeActivity revoke -> groupRevoke now groupID verse revoke
         AP.UndoActivity undo     -> groupUndo now groupID verse undo
         _ -> throwE "Unsupported activity type for Group"
-groupBehavior _ _ (Right _) = throwE "ClientMsgs aren't supported for Group"
 
-instance VervisActor Group where
+instance VervisActorLaunch Group where
-    actorBehavior now groupID ve = do
+    actorBehavior' now groupID ve = do
         errboxID <- lift $ withDB $ do
             resourceID <- groupResource <$> getJust groupID
             Resource actorID <- getJust resourceID

src/Vervis/Actor/Loom.hs

@@ -570,16 +570,15 @@ loomResolve now loomID (Verse authorIdMsig body) (AP.Resolve uObject) = do
 
         return (action, recipientSet, remoteActors, fwdHosts)
 
-loomBehavior :: UTCTime -> LoomId -> VerseExt -> ActE (Text, Act (), Next)
+loomBehavior :: UTCTime -> LoomId -> ActorMessage Loom -> ActE (Text, Act (), Next)
-loomBehavior now loomID (Left verse@(Verse _authorIdMsig body)) =
+loomBehavior now loomID (MsgL verse@(Verse _authorIdMsig body)) =
     case AP.activitySpecific $ actbActivity body of
         AP.OfferActivity offer     -> loomOffer now loomID verse offer
         AP.ResolveActivity resolve -> loomResolve now loomID verse resolve
         _ -> throwE "Unsupported activity type for Loom"
-loomBehavior _ _ (Right _) = throwE "ClientMsgs aren't supported for Loom"
 
-instance VervisActor Loom where
+instance VervisActorLaunch Loom where
-    actorBehavior now loomID ve = do
+    actorBehavior' now loomID ve = do
         errboxID <- lift $ withDB $ do
             resourceID <- loomResource <$> getJust loomID
             Resource actorID <- getJust resourceID

src/Vervis/Actor/Person.hs

@@ -1316,8 +1316,8 @@ personRevoke now recipPersonID (Verse authorIdMsig body) (AP.Revoke lus) = do
 -- Main behavior function
 ------------------------------------------------------------------------------
 
-personBehavior :: UTCTime -> PersonId -> VerseExt -> ActE (Text, Act (), Next)
+personBehavior :: UTCTime -> PersonId -> ActorMessage Person -> ActE (Text, Act (), Next)
-personBehavior now personID (Left verse@(Verse _authorIdMsig body)) =
+personBehavior now personID (MsgP (Left verse@(Verse _authorIdMsig body))) =
     case AP.activitySpecific $ actbActivity body of
         AP.AcceptActivity accept -> personAccept now personID verse accept
         AP.AddActivity add -> personAdd now personID verse add
@@ -1337,10 +1337,10 @@ personBehavior now personID (Left verse@(Verse _authorIdMsig body)) =
         AP.RevokeActivity revoke -> personRevoke now personID verse revoke
         AP.UndoActivity undo     -> personUndo now personID verse undo
         _ -> throwE "Unsupported activity type for Person"
-personBehavior now personID (Right msg) = clientBehavior now personID msg
+personBehavior now personID (MsgP (Right msg)) = clientBehavior now personID msg
 
-instance VervisActor Person where
+instance VervisActorLaunch Person where
-    actorBehavior now personID ve = do
+    actorBehavior' now personID ve = do
         errboxID <- lift $ withDB $ do
             actorID <- personActor <$> getJust personID
             actorErrbox <$> getJust actorID

src/Vervis/Actor/Person/Client.hs

@@ -429,7 +429,7 @@ clientCreateDeck now personMeID (ClientMsg maybeCap localRecips remoteRecips fwd
             )
 
     -- Spawn new Deck actor
-    success <- lift $ launchActor LocalActorDeck deckID
+    success <- lift $ launchActor deckID
     unless success $
         error "Failed to spawn new Deck, somehow ID already in Theater"
 
@@ -593,7 +593,7 @@ clientCreateProject now personMeID (ClientMsg maybeCap localRecips remoteRecips
             )
 
     -- Spawn new Project actor
-    success <- lift $ launchActor LocalActorProject projectID
+    success <- lift $ launchActor projectID
     unless success $
         error "Failed to spawn new Project, somehow ID already in Theater"
 
@@ -748,7 +748,7 @@ clientCreateTeam now personMeID (ClientMsg maybeCap localRecips remoteRecips fwd
             )
 
     -- Spawn new Group actor
-    success <- lift $ launchActor LocalActorGroup groupID
+    success <- lift $ launchActor groupID
     unless success $
         error "Failed to spawn new Group, somehow ID already in Theater"
 

src/Vervis/Actor/Project.hs

@@ -7613,8 +7613,8 @@ projectUndo now recipProjectID (Verse authorIdMsig body) (AP.Undo uObject) = do
 
         return (action, recipientSet, remoteActors, fwdHosts)
 
-projectBehavior :: UTCTime -> ProjectId -> VerseExt -> ActE (Text, Act (), Next)
+projectBehavior :: UTCTime -> ProjectId -> ActorMessage Project -> ActE (Text, Act (), Next)
-projectBehavior now projectID (Left verse@(Verse _authorIdMsig body)) =
+projectBehavior now projectID (MsgJ verse@(Verse _authorIdMsig body)) =
     case AP.activitySpecific $ actbActivity body of
         AP.AcceptActivity accept -> projectAccept now projectID verse accept
         AP.AddActivity add       -> projectAdd now projectID verse add
@@ -7628,10 +7628,9 @@ projectBehavior now projectID (Left verse@(Verse _authorIdMsig body)) =
         AP.RevokeActivity revoke -> projectRevoke now projectID verse revoke
         AP.UndoActivity undo     -> projectUndo now projectID verse undo
         _ -> throwE "Unsupported activity type for Project"
-projectBehavior _ _ (Right _) = throwE "ClientMsgs aren't supported for Project"
 
-instance VervisActor Project where
+instance VervisActorLaunch Project where
-    actorBehavior now projectID ve = do
+    actorBehavior' now projectID ve = do
         errboxID <- lift $ withDB $ do
             resourceID <- projectResource <$> getJust projectID
             Resource actorID <- getJust resourceID

src/Vervis/Actor/Repo.hs

@@ -53,14 +53,13 @@ import Vervis.Persist.Actor
 import Vervis.Persist.Discussion
 import Vervis.Ticket
 
-repoBehavior :: UTCTime -> RepoId -> VerseExt -> ActE (Text, Act (), Next)
+repoBehavior :: UTCTime -> RepoId -> ActorMessage Repo -> ActE (Text, Act (), Next)
-repoBehavior now repoID (Left _verse@(Verse _authorIdMsig body)) =
+repoBehavior now repoID (MsgR _verse@(Verse _authorIdMsig body)) =
     case AP.activitySpecific $ actbActivity body of
         _ -> throwE "Unsupported activity type for Repo"
-repoBehavior _ _ (Right _) = throwE "ClientMsgs aren't supported for Repo"
 
-instance VervisActor Repo where
+instance VervisActorLaunch Repo where
-    actorBehavior now repoID ve = do
+    actorBehavior' now repoID ve = do
         errboxID <- lift $ withDB $ do
             resourceID <- repoResource <$> getJust repoID
             Resource actorID <- getJust resourceID

src/Vervis/Actor2.hs

@@ -66,12 +66,12 @@ import qualified Data.List.NonEmpty as NE
 import qualified Data.Text as T
 
 import Control.Concurrent.Actor
-import Crypto.ActorKey
 import Network.FedURI
 import Web.Actor
 import Web.Actor.Deliver
 import Web.Actor.Persist
 
+import qualified Crypto.ActorKey as AK
 import qualified Web.ActivityPub as AP
 import qualified Yesod.MonadSite as YM
 
@@ -88,7 +88,7 @@ import Vervis.Recipient (renderLocalActor, localRecipSieve', localActorFollowers
 import Vervis.RemoteActorStore
 import Vervis.Settings
 
-askLatestInstanceKey :: Act (Maybe (Route App, ActorKey))
+askLatestInstanceKey :: Act (Maybe (Route App, AK.ActorKey))
 askLatestInstanceKey = do
     maybeTVar <- asksEnv envActorKeys
     for maybeTVar $ \ tvar -> do
@@ -99,14 +99,14 @@ askLatestInstanceKey = do
                 else (ActorKey2R, akey2)
 
 prepareSendIK
-    :: (Route App, ActorKey)
+    :: (Route App, AK.ActorKey)
     -> LocalActorBy KeyHashid
     -> OutboxItemId
     -> AP.Action URIMode
     -> Act (AP.Envelope URIMode)
 prepareSendIK (keyR, akey) actorByHash itemID action = do
     itemHash <- encodeKeyHashid itemID
-    let sign = actorKeySign akey
+    let sign = AK.actorKeySign akey
         actorR = renderLocalActor actorByHash
         idR = activityRoute actorByHash itemHash
     prepareToSend keyR sign True actorR idR action
@@ -126,7 +126,7 @@ prepareSendAK actorID actorByHash itemID action = do
     itemHash <- encodeKeyHashid itemID
     keyHash <- encodeKeyHashid keyID
     let keyR = stampRoute actorByHash keyHash
-        sign = actorKeySign $ sigKeyMaterial key
+        sign = AK.actorKeySign $ sigKeyMaterial key
         actorR = renderLocalActor actorByHash
         idR = activityRoute actorByHash itemHash
     prepareToSend keyR sign False actorR idR action
@@ -232,13 +232,13 @@ sendActivity senderByKey senderActorID localRecips remoteRecips fwdHosts itemID
             sendHttp dt (MethodDeliverLocal envelope False) noFwd
 
 prepareForwardIK
-    :: (Route App, ActorKey)
+    :: (Route App, AK.ActorKey)
     -> LocalActorBy KeyHashid
     -> BL.ByteString
     -> Maybe ByteString
     -> Act (AP.Errand URIMode)
 prepareForwardIK (keyR, akey) fwderByHash body mproof = do
-    let sign = actorKeySign akey
+    let sign = AK.actorKeySign akey
         fwderR = renderLocalActor fwderByHash
     prepareToForward keyR sign True fwderR body mproof
 
@@ -256,7 +256,7 @@ prepareForwardAK actorID fwderByHash body mproof = do
             Just k -> return k
     keyHash <- encodeKeyHashid keyID
     let keyR = stampRoute fwderByHash keyHash
-        sign = actorKeySign $ sigKeyMaterial key
+        sign = AK.actorKeySign $ sigKeyMaterial key
         fwderR = renderLocalActor fwderByHash
     prepareToForward keyR sign False fwderR body mproof
 

src/Vervis/Application.hs

@@ -80,6 +80,7 @@ import Yesod.Static
 
 import qualified Data.CaseInsensitive as CI
 import qualified Data.HashMap.Strict as HM
+import qualified Data.HList as H
 import qualified Data.Text as T
 import qualified Database.Esqueleto as E
 
@@ -144,7 +145,6 @@ import Vervis.Path
 import Vervis.Persist.Actor
 import Vervis.Settings
 import Vervis.Ssh (runSsh)
-import Vervis.Web.Delivery
 
 -- Only for fillPermitRecords, so remove soon
 import qualified Web.ActivityPub as AP
@@ -338,33 +338,28 @@ makeFoundation appSettings = do
                     , T.pack $ show from, " ==> ", T.pack $ show to
                     ]
 
-    loadTheater :: Env -> WorkerDB [(LocalActorBy Key, Env, VerseExt -> Act (Either Text Text, Act (), Next))]
+    loadTheater
-    loadTheater env = concat <$> sequenceA
+        :: StageEnv Staje
-        [ selectAllWhere LocalActorPerson (PersonVerified ==. True)
+        -> WorkerDB
-        , selectAll LocalActorGroup
+            (H.HList
-        , selectAll LocalActorRepo
+                [ [(PersonId , StageEnv Staje)]
-        , selectAll LocalActorDeck
+                , [(ProjectId, StageEnv Staje)]
-        , selectAll LocalActorLoom
+                , [(GroupId  , StageEnv Staje)]
-        , selectAll LocalActorProject
+                , [(DeckId   , StageEnv Staje)]
-        ]
+                , [(LoomId   , StageEnv Staje)]
-        where
+                , [(RepoId   , StageEnv Staje)]
-        selectAll
+                ]
-            :: (PersistRecordBackend a SqlBackend, VervisActor a)
+            )
-            => (Key a -> LocalActorBy Key)
+    loadTheater env =
-            -> WorkerDB [(LocalActorBy Key, Env, VerseExt -> Act (Either Text Text, Act (), Next))]
+        (\ p j g d l r -> p `H.HCons`j `H.HCons` g `H.HCons` d `H.HCons` l `H.HCons` r `H.HCons` H.HNil)
-        selectAll makeLocalActor =
+        <$> (map (,env) <$> selectKeysList [PersonVerified ==. True] [])
-            map (\ xid -> (makeLocalActor xid, env, behave actorBehavior xid)) <$>
+        <*> (map (,env) <$> selectKeysList [] [])
-                selectKeysList [] []
+        <*> (map (,env) <$> selectKeysList [] [])
-        selectAllWhere
+        <*> (map (,env) <$> selectKeysList [] [])
-            :: (PersistRecordBackend a SqlBackend, VervisActor a)
+        <*> (map (,env) <$> selectKeysList [] [])
-            => (Key a -> LocalActorBy Key)
+        <*> (map (,env) <$> selectKeysList [] [])
-            -> Filter a
-            -> WorkerDB [(LocalActorBy Key, Env, VerseExt -> Act (Either Text Text, Act (), Next))]
-        selectAllWhere makeLocalActor filt =
-            map (\ xid -> (makeLocalActor xid, env, behave actorBehavior xid)) <$>
-                selectKeysList [filt] []
 
-    startPersonLauncher :: Theater -> Env -> IO (MVar (PersonId, MVar Bool))
+    startPersonLauncher :: Theater -> StageEnv Staje -> IO (MVar (PersonId, MVar Bool))
     startPersonLauncher theater env = do
         mvar <- newEmptyMVar
         _ <- forkIO $ forever $ handle mvar
@@ -372,7 +367,7 @@ makeFoundation appSettings = do
         where
         handle mvar = do
             (personID, sendResult) <- takeMVar mvar
-            success <- launchActorIO theater env LocalActorPerson personID
+            success <- launchActorIO theater env personID
             putMVar sendResult success
 
 -- | Convert our foundation to a WAI Application by calling @toWaiAppPlain@ and

src/Vervis/Data/Collab.hs

@@ -122,7 +122,7 @@ unhashGrantRecipE resource e =
 verifyRole = pure
 
 parseTopic
-    :: StageRoute Env ~ Route App
+    :: StageRoute Staje ~ Route App
     => FedURI -> ActE (Either (LocalResourceBy Key) FedURI)
 parseTopic u = do
     t <- parseTopic' u
@@ -135,7 +135,7 @@ parseTopic u = do
         t
 
 parseTopic'
-    :: StageRoute Env ~ Route App
+    :: StageRoute Staje ~ Route App
     => FedURI
     -> ActE (Either (Either (LocalResourceBy Key) ProjectId) FedURI)
 parseTopic' u = do
@@ -216,7 +216,7 @@ parseRecipient' sender u = do
         routeOrRemote
 
 parseInvite
-    :: StageRoute Env ~ Route App
+    :: StageRoute Staje ~ Route App
     => Either (LocalActorBy Key) FedURI
     -> AP.Invite URIMode
     -> ActE
@@ -231,7 +231,7 @@ parseInvite sender (AP.Invite instrument object target) =
         <*> nameExceptT "Invite object" (parseRecipient' sender object)
 
 parseJoin
-    :: StageRoute Env ~ Route App
+    :: StageRoute Staje ~ Route App
     => AP.Join URIMode
     -> ActE (AP.Role, Either (LocalResourceBy Key) FedURI)
 parseJoin (AP.Join instrument object) =
@@ -405,7 +405,7 @@ parseCollabs route = do
         "Contains invalid hashid"
 
 parseRemove
-    :: StageRoute Env ~ Route App
+    :: StageRoute Staje ~ Route App
     => Either (LocalActorBy Key) FedURI
     -> AP.Remove URIMode
     -> ActE
@@ -487,7 +487,7 @@ addTargetResourceTeams = \case
     _ -> Nothing
 
 parseAdd
-    :: StageRoute Env ~ Route App
+    :: StageRoute Staje ~ Route App
     => Either (LocalActorBy Key) FedURI
     -> AP.Add URIMode
     -> ActE

src/Vervis/Data/Discussion.hs

@@ -1,6 +1,6 @@
 {- This file is part of Vervis.
  -
- - Written in 2016, 2019, 2020, 2022, 2023
+ - Written in 2016, 2019, 2020, 2022, 2023, 2024
  - by fr33domlover <fr33domlover@riseup.net>.
  -
  - ♡ Copying is an act of love. Please copy, reuse and share.
@@ -125,7 +125,7 @@ parseCommentTopicOld (ClothR lkhid ltkhid) =
 parseCommentTopicOld _ = throwE "Not a ticket/cloth route"
 
 parseCommentTopic
-    :: (MonadActor m, StageHashids (ActorEnv m))
+    :: (MonadActor m, StageHashids (MonadActorStage m))
     => Route App
     -> ExceptT Text m CommentTopic
 parseCommentTopic (TicketR dkhid ltkhid) =

src/Vervis/Data/Ticket.hs

@@ -1,6 +1,6 @@
 {- This file is part of Vervis.
  -
- - Written in 2022, 2023 by fr33domlover <fr33domlover@riseup.net>.
+ - Written in 2022, 2023, 2024 by fr33domlover <fr33domlover@riseup.net>.
  -
  - ♡ Copying is an act of love. Please copy, reuse and share.
  -
@@ -287,14 +287,14 @@ hashWorkItemPure ctx = f
         WorkItemCloth (encodeKeyHashidPure ctx l) (encodeKeyHashidPure ctx c)
 
 getHashWorkItem
-    :: (MonadActor m, StageHashids (ActorEnv m))
+    :: (MonadActor m, StageHashids (MonadActorStage m))
     => m (WorkItemBy Key -> WorkItemBy KeyHashid)
 getHashWorkItem = do
     ctx <- asksEnv stageHashidsContext
     return $ hashWorkItemPure ctx
 
 hashWorkItem
-    :: (MonadActor m, StageHashids (ActorEnv m))
+    :: (MonadActor m, StageHashids (MonadActorStage m))
     => WorkItemBy Key -> m (WorkItemBy KeyHashid)
 hashWorkItem actor = do
     hash <- getHashWorkItem
@@ -314,24 +314,24 @@ unhashWorkItemPure ctx = f
             <*> decodeKeyHashidPure ctx c
 
 unhashWorkItem
-    :: (MonadActor m, StageHashids (ActorEnv m))
+    :: (MonadActor m, StageHashids (MonadActorStage m))
     => WorkItemBy KeyHashid -> m (Maybe (WorkItemBy Key))
 unhashWorkItem actor = do
     ctx <- asksEnv stageHashidsContext
     return $ unhashWorkItemPure ctx actor
 
 unhashWorkItemF
-    :: (F.MonadFail m, MonadActor m, StageHashids (ActorEnv m))
+    :: (F.MonadFail m, MonadActor m, StageHashids (MonadActorStage m))
     => WorkItemBy KeyHashid -> String -> m (WorkItemBy Key)
 unhashWorkItemF actor e = maybe (F.fail e) return =<< unhashWorkItem actor
 
 unhashWorkItemM
-    :: (MonadActor m, StageHashids (ActorEnv m))
+    :: (MonadActor m, StageHashids (MonadActorStage m))
     => WorkItemBy KeyHashid -> MaybeT m (WorkItemBy Key)
 unhashWorkItemM = MaybeT . unhashWorkItem
 
 unhashWorkItemE
-    :: (MonadActor m, StageHashids (ActorEnv m))
+    :: (MonadActor m, StageHashids (MonadActorStage m))
     => WorkItemBy KeyHashid -> e -> ExceptT e m (WorkItemBy Key)
 unhashWorkItemE actor e =
     ExceptT $ maybe (Left e) Right <$> unhashWorkItem actor

src/Vervis/Federation/Discussion.hs

@@ -80,7 +80,6 @@ import Vervis.Persist.Discussion
 import Vervis.Recipient
 import Vervis.Settings
 import Vervis.Ticket
-import Vervis.Web.Delivery
 
 -- | Insert the new remote comment into the discussion tree. If we didn't have
 -- this comment before, return the database ID of the newly created cached

src/Vervis/Federation/Offer.hs

@@ -94,7 +94,6 @@ import Vervis.Model.Ticket
 import Vervis.Persist.Actor
 import Vervis.Recipient
 import Vervis.Ticket
-import Vervis.Web.Delivery
 
 {-
 sharerAcceptF

src/Vervis/Federation/Ticket.hs

@@ -96,7 +96,6 @@ import Vervis.Data.Actor
 import Vervis.Data.Collab
 import Vervis.Data.Ticket
 import Vervis.Darcs
-import Vervis.Web.Delivery
 import Vervis.Federation.Auth
 
 import Vervis.FedURI

src/Vervis/Fetch.hs

@@ -90,7 +90,6 @@ import Vervis.Cloth
 import Vervis.Data.Actor
 import Vervis.Data.Collab
 import Vervis.Data.Ticket
-import Vervis.Web.Delivery
 import Vervis.FedURI
 import Vervis.Foundation
 import Vervis.Model

src/Vervis/Foundation.hs

@@ -75,7 +75,6 @@ import qualified Network.HTTP.Signature as S (Algorithm (..))
 import qualified Yesod.Hashids as YH
 
 import Control.Concurrent.Actor hiding (Message)
-import Crypto.ActorKey
 --import Crypto.PublicVerifKey
 import Network.FedURI
 import Web.ActivityAccess
@@ -85,6 +84,7 @@ import Yesod.Actor
 import Yesod.FedURI
 import Yesod.MonadSite
 
+import qualified Crypto.ActorKey as AK
 import qualified Web.ActivityPub as AP
 import qualified Yesod.Hashids as YH
 
@@ -127,14 +127,14 @@ data App = App
     , appLogger       :: Logger
     , appMailQueue    :: Maybe (Chan (MailRecipe App))
     --, appSvgFont      :: PreparedFont Double
-    , appActorKeys    :: Maybe (TVar (ActorKey, ActorKey, Bool))
+    , appActorKeys    :: Maybe (TVar (AK.ActorKey, AK.ActorKey, Bool))
     , appInstanceMutex :: InstanceMutex
     , appCapSignKey   :: AccessTokenSecretKey
     , appHashidsContext :: HashidsContext
     , appHookSecret      :: HookSecret
     , appActorFetchShare :: ActorFetchShare
     , appTheater :: Theater
-    , appEnv     :: Env
+    , appEnv     :: StageEnv Staje
     , appPersonLauncher :: MVar (PersonId, MVar Bool)
     }
 

src/Vervis/Handler/Deck.hs

@@ -205,7 +205,7 @@ getDeckErrboxR = getInbox' actorErrbox DeckErrboxR deckActor
 postDeckInboxR :: KeyHashid Deck -> Handler ()
 postDeckInboxR deckHash = do
     deckID <- decodeKeyHashid404 deckHash
-    postInbox $ LocalActorDeck deckID
+    postInbox LocalActorDeck deckID
 
 {-
             AP.AcceptActivity accept ->

src/Vervis/Handler/Group.hs

@@ -115,6 +115,7 @@ import Yesod.Form.Local
 import Yesod.Persist.Local
 
 import Vervis.Access
+import Vervis.Actor.Group
 import Vervis.API
 import Vervis.Data.Actor
 import Vervis.Data.Collab
@@ -235,7 +236,7 @@ getGroupErrboxR = getInbox' actorErrbox GroupErrboxR groupActor
 postGroupInboxR :: KeyHashid Group -> Handler ()
 postGroupInboxR groupHash = do
     groupID <- decodeKeyHashid404 groupHash
-    postInbox $ LocalActorGroup groupID
+    postInbox LocalActorGroup groupID
 
 getGroupOutboxR :: KeyHashid Group -> Handler TypedContent
 getGroupOutboxR = getOutbox GroupOutboxR GroupOutboxItemR groupActor

src/Vervis/Handler/Loom.hs

@@ -175,7 +175,7 @@ getLoomErrboxR = getInbox' actorErrbox LoomErrboxR loomActor
 postLoomInboxR :: KeyHashid Loom -> Handler ()
 postLoomInboxR loomHash = do
     loomID <- decodeKeyHashid404 loomHash
-    postInbox $ LocalActorLoom loomID
+    postInbox LocalActorLoom loomID
 
 {-
             AP.AcceptActivity accept ->

src/Vervis/Handler/Person.hs

@@ -68,6 +68,7 @@ import Data.Either.Local
 import Database.Persist.Local
 
 import Vervis.ActivityPub
+import Vervis.Actor.Person
 import Vervis.API
 import Vervis.Data.Actor
 import Vervis.Federation.Auth
@@ -138,7 +139,7 @@ getPersonErrboxR = getInbox' actorErrbox PersonErrboxR personActor
 postPersonInboxR :: KeyHashid Person -> Handler ()
 postPersonInboxR personHash = do
     personID <- decodeKeyHashid404 personHash
-    postInbox $ LocalActorPerson personID
+    postInbox LocalActorPerson personID
 
 getPersonOutboxR :: KeyHashid Person -> Handler TypedContent
 getPersonOutboxR = getOutbox PersonOutboxR PersonOutboxItemR personActor

src/Vervis/Handler/Project.hs

@@ -113,6 +113,7 @@ import Yesod.Persist.Local
 
 import Vervis.Access
 import Vervis.Actor (resourceToActor)
+import Vervis.Actor.Project
 import Vervis.API
 import Vervis.Data.Actor
 import Vervis.Data.Collab
@@ -207,7 +208,7 @@ getProjectErrboxR = getInbox' actorErrbox ProjectErrboxR projectActor
 postProjectInboxR :: KeyHashid Project -> Handler ()
 postProjectInboxR projectHash = do
     projectID <- decodeKeyHashid404 projectHash
-    postInbox $ LocalActorProject projectID
+    postInbox LocalActorProject projectID
 
 getProjectOutboxR :: KeyHashid Project -> Handler TypedContent
 getProjectOutboxR = getOutbox ProjectOutboxR ProjectOutboxItemR projectActor

src/Vervis/Handler/Repo.hs

@@ -191,7 +191,6 @@ import Vervis.Time
 import Vervis.Web.Actor
 import Vervis.Web.Collab
 import Vervis.Web.Darcs
-import Vervis.Web.Delivery
 import Vervis.Web.Git
 import Vervis.Widget
 import Vervis.Widget.Repo
@@ -264,7 +263,7 @@ getRepoErrboxR = getInbox' actorErrbox RepoErrboxR repoActor
 postRepoInboxR :: KeyHashid Repo -> Handler ()
 postRepoInboxR repoHash = do
     repoID <- decodeKeyHashid404 repoHash
-    postInbox $ LocalActorRepo repoID
+    postInbox LocalActorRepo repoID
 
 {-
             AP.AcceptActivity accept ->
@@ -587,9 +586,12 @@ postPostReceiveR = do
             pushID <- lift $ insertEmptyOutboxItem (actorOutbox actor) now
             luPush <- lift $ updateOutboxItem (LocalActorRepo repoID) pushID action
             deliverHttpPush <-
+                {-
                 deliverActivityDB
                     (LocalActorRepo repoHash) actorID localRecips remoteRecips
                     fwdHosts pushID action
+                -}
+                pure $ pure ()
             return (luPush, deliverHttpPush)
 
     -- HTTP delivery to remote recipients

src/Vervis/Persist/Actor.hs

@@ -72,8 +72,7 @@ import Yesod.Core.Handler
 import qualified Data.Text as T
 import qualified Database.Esqueleto as E
 
-import Control.Concurrent.Actor
+import Control.Concurrent.Actor hiding (Actor)
-import Crypto.ActorKey
 import Database.Persist.JSON
 import Network.FedURI
 import Yesod.ActivityPub
@@ -81,6 +80,7 @@ import Yesod.FedURI
 import Yesod.Hashids
 import Yesod.MonadSite
 
+import qualified Crypto.ActorKey as AK
 import qualified Web.ActivityPub as AP
 import qualified Web.Actor as WA
 import qualified Web.Actor.Persist as WAP
@@ -297,7 +297,7 @@ updateOutboxItem actorByKey itemID action = do
     return luId
 
 updateOutboxItem'
-    :: WA.StageRoute VA.Env ~ Route App
+    :: WA.StageRoute VA.Staje ~ Route App
     => LocalActorBy Key
     -> OutboxItemId
     -> AP.Action URIMode
@@ -322,7 +322,7 @@ fillPerActorKeys = do
             E.where_ $ E.isNothing $ sigkey E.?. SigKeyId
             return $ actor E.^. ActorId
         keys <- for actorIDs $ \ (E.Value actorID) -> do
-            key <- liftIO generateActorKey
+            key <- liftIO AK.generateActorKey
             return $ SigKey actorID key
         runSiteDB $ insertMany_ keys
         logInfo $
@@ -420,21 +420,24 @@ insertToInbox now (Right (author, luAct, _)) body inboxID unread = do
         Just _ -> return $ Just (ibiid, Right (author, luAct, ractid))
 
 adaptErrbox
-    :: InboxId
+    :: VA.VervisActor a
+    => InboxId
     -> Bool
-    -> (UTCTime -> Key a -> VA.VerseExt -> VA.ActE (Text, VA.Act (), Next))
+    -> (UTCTime -> ActorKey a -> ActorMessage a -> VA.ActE (Text, VA.Act (), Next))
-    -> UTCTime -> Key a -> VA.VerseExt -> VA.ActE (Text, VA.Act (), Next)
+    -> UTCTime -> ActorKey a -> ActorMessage a -> VA.ActE (Text, VA.Act (), Next)
-adaptErrbox _ _ behavior now key ve@(Right _) = behavior now key ve
+adaptErrbox inboxID unread behavior now key msg =
-adaptErrbox inboxID unread behavior now key ve@(Left (VA.Verse authorIdMsig body)) = do
+    case VA.toVerse msg of
-    result <- lift $ runExceptT $ behavior now key ve
+        Nothing -> behavior now key msg
-    case result of
+        Just (VA.Verse authorIdMsig body) -> do
-        Right success -> return success
+            result <- lift $ runExceptT $ behavior now key msg
-        Left err -> do
+            case result of
-            _ <- lift $ VA.withDB $ runMaybeT $ do
+                Right success -> return success
-                _ <- MaybeT $ get inboxID
+                Left err -> do
-                (itemID, _) <- MaybeT $ insertToInbox now authorIdMsig body inboxID unread
+                    _ <- lift $ VA.withDB $ runMaybeT $ do
-                lift $ update itemID [InboxItemResult =. err]
+                        _ <- MaybeT $ get inboxID
-            throwE err
+                        (itemID, _) <- MaybeT $ insertToInbox now authorIdMsig body inboxID unread
+                        lift $ update itemID [InboxItemResult =. err]
+                    throwE err
 
 getActivityIdent
     :: MonadIO m

src/Vervis/Recipient.hs

@@ -169,8 +169,8 @@ import Vervis.FedURI
 import Vervis.Foundation
 import Vervis.Model
 
-instance WA.StageWebRoute Env where
+instance WA.StageWebRoute Staje where
-    type StageRoute Env = Route App
+    type StageRoute Staje = Route App
     askUrlRenderParams = do
         Env _ _ _ _ _ render _ _ <- askEnv
         case cast render of
@@ -898,7 +898,7 @@ parseRecipients recips = do
                 Just recip -> Right recip
 
 parseRecipients'
-    :: WA.StageRoute Env ~ Route App
+    :: WA.StageRoute Staje ~ Route App
     => NonEmpty FedURI -> ActE (RecipientRoutes, [FedURI])
 parseRecipients' recips = do
     hLocal <- asksEnv WA.stageInstanceHost
@@ -966,7 +966,7 @@ parseAudience audience = do
     groupByHost = groupAllExtract objUriAuthority objUriLocal
 
 parseAudience'
-    :: WA.StageRoute Env ~ Route App
+    :: WA.StageRoute Staje ~ Route App
     => AP.Audience URIMode -> ActE (Maybe (ParsedAudience URIMode))
 parseAudience' audience = do
     let recips = concatRecipients audience

src/Vervis/Web/Actor.hs

@@ -30,7 +30,7 @@ module Vervis.Web.Actor
 where
 
 import Control.Applicative ((<|>))
-import Control.Concurrent.STM.TVar (readTVarIO, modifyTVar')
+import Control.Concurrent.STM.TVar (readTVarIO, modifyTVar', TVar)
 import Control.Exception hiding (Handler)
 import Control.Monad
 import Control.Monad.IO.Class (liftIO)
@@ -44,6 +44,7 @@ import Data.Bifunctor
 import Data.Bitraversable
 import Data.ByteString (ByteString)
 import Data.Foldable (for_)
+import Data.Hashable
 import Data.List
 import Data.Maybe
 import Data.Text (Text)
@@ -70,13 +71,13 @@ import Yesod.Persist.Core
 import qualified Data.ByteString.Char8 as BC (unpack)
 import qualified Data.ByteString.Lazy as BL
 import qualified Data.HashMap.Strict as M
+import qualified Data.HList as H
 import qualified Data.Text as T
 import qualified Data.Text.Lazy as TL
 import qualified Data.Vector as V
 import qualified Database.Esqueleto as E
 
-import Control.Concurrent.Actor
+import Control.Concurrent.Actor hiding (Actor)
-import Crypto.ActorKey
 import Database.Persist.JSON
 import Network.FedURI
 import Web.ActivityPub hiding (Project (..), ActorLocal (..))
@@ -87,6 +88,9 @@ import Yesod.Hashids
 import Yesod.MonadSite
 import Yesod.RenderSource
 
+import qualified Control.Concurrent.Actor as CCA
+import qualified Crypto.ActorKey as AK
+
 import Control.Monad.Trans.Except.Local
 import Data.Aeson.Local
 import Data.Either.Local
@@ -99,7 +103,7 @@ import Yesod.Persist.Local
 import qualified Data.Aeson.Encode.Pretty.ToEncoding as P
 import qualified Web.ActivityPub as AP
 
-import Vervis.Actor (RemoteAuthor (..), ActivityBody (..), Verse (..))
+import Vervis.Actor (RemoteAuthor (..), ActivityBody (..), Verse (..), VervisActor (..), VervisActorLaunch)
 import Vervis.Actor2
 import Vervis.ActivityPub
 import Vervis.API
@@ -238,8 +242,41 @@ getInbox' grabInbox here actor hash = do
         where
         ibiidString = "InboxItem #" ++ show (fromSqlKey ibid)
 
-postInbox :: LocalActorBy Key -> Handler ()
+postInbox
-postInbox recipByKey = do
+    :: ( CCA.Actor a
+       , ActorLaunch a
+       , VervisActor a
+       , ActorKey a ~ Key a
+       , ActorReturn a ~ Either Text Text
+       , Eq (Key a)
+       , Hashable (Key a)
+       , H.HEq
+                                  (TVar (M.HashMap (Key a) (ActorRef a)))
+                                  (TVar (M.HashMap PersonId (ActorRef Person)))
+                                  b0
+       , H.HOccurrence'
+                          b0
+                          (TVar (M.HashMap (Key a) (ActorRef a)))
+                          '[TVar (M.HashMap PersonId (ActorRef Person)),
+                            TVar (M.HashMap ProjectId (ActorRef Project)),
+                            TVar (M.HashMap GroupId (ActorRef Group)),
+                            TVar (M.HashMap DeckId (ActorRef Deck)),
+                            TVar (M.HashMap LoomId (ActorRef Loom)),
+                            TVar (M.HashMap RepoId (ActorRef Vervis.Model.Repo))]
+                          l'0
+       , H.HOccurs'
+                          (TVar (M.HashMap (Key a) (ActorRef a)))
+                          l'0
+                          '[TVar (M.HashMap PersonId (ActorRef Person)),
+                            TVar (M.HashMap ProjectId (ActorRef Project)),
+                            TVar (M.HashMap GroupId (ActorRef Group)),
+                            TVar (M.HashMap DeckId (ActorRef Deck)),
+                            TVar (M.HashMap LoomId (ActorRef Loom)),
+                            TVar (M.HashMap RepoId (ActorRef Vervis.Model.Repo))]
+       )
+    => (Key a -> LocalActorBy Key) -> Key a -> Handler ()
+postInbox toLA recipID = do
+    let recipByKey = toLA recipID
     federation <- getsYesod $ appFederation . appSettings
     unless federation badMethod
     contentTypes <- lookupHeaders "Content-Type"
@@ -266,7 +303,7 @@ postInbox recipByKey = do
                     msig <- checkForwarding recipByHash
                     return (author, luActivity, msig)
         theater <- getsYesod appTheater
-        r <- liftIO $ callIO theater recipByKey $ Left $ Verse authorIdMsig body
+        r <- liftIO $ callIO theater recipID $ actorVerse $ Verse authorIdMsig body
         case r of
             Nothing -> notFound
             Just (Left e) -> throwE e
@@ -519,7 +556,7 @@ actorKeyAP
     :: ( MonadSite m, SiteEnv m ~ site
        , SiteFedURI site, SiteFedURIMode site ~ u
        )
-    => Maybe (Route site) -> Route site -> ActorKey -> m (AP.PublicKey u)
+    => Maybe (Route site) -> Route site -> AK.ActorKey -> m (AP.PublicKey u)
 actorKeyAP maybeHolderR keyR akey = do
     encodeRouteLocal <- getEncodeRouteLocal
     return AP.PublicKey
@@ -529,11 +566,11 @@ actorKeyAP maybeHolderR keyR akey = do
             case maybeHolderR of
                 Nothing -> AP.OwnerInstance
                 Just holderR -> AP.OwnerActor $ encodeRouteLocal holderR
-        , AP.publicKeyMaterial = actorKeyPublicBin akey
+        , AP.publicKeyMaterial = AK.actorKeyPublicBin akey
         }
 
 serveInstanceKey
-    :: ((ActorKey, ActorKey) -> ActorKey)
+    :: ((AK.ActorKey, AK.ActorKey) -> AK.ActorKey)
     -> Route App
     -> Handler TypedContent
 serveInstanceKey choose keyR = do
@@ -550,7 +587,7 @@ serveInstanceKey choose keyR = do
 servePerActorKey'
     :: LocalActorBy KeyHashid
     -> KeyHashid SigKey
-    -> ActorKey
+    -> AK.ActorKey
     -> Handler TypedContent
 servePerActorKey' holderByHash keyHash akey = do
     let holderR = renderLocalActor holderByHash

src/Web/Actor.hs

@@ -1,6 +1,6 @@
 {- This file is part of Vervis.
  -
- - Written in 2019, 2022, 2023 by fr33domlover <fr33domlover@riseup.net>.
+ - Written in 2019, 2022, 2023, 2024 by fr33domlover <fr33domlover@riseup.net>.
  -
  - ♡ Copying is an act of love. Please copy, reuse and share.
  -
@@ -76,8 +76,8 @@ type ActForE s = ExceptT Text (ActFor s)
 
 class (Stage s, UriMode (StageURIMode s)) => StageWeb s where
     type StageURIMode s
-    stageInstanceHost :: s -> Authority (StageURIMode s)
+    stageInstanceHost :: StageEnv s -> Authority (StageURIMode s)
-    stageDeliveryTheater :: s -> DeliveryTheater (StageURIMode s)
+    stageDeliveryTheater :: StageEnv s -> DeliveryTheater (StageURIMode s)
 
 class DecodeRouteLocal r where
     decodeRouteLocal :: LocalURI -> Maybe r
@@ -85,21 +85,21 @@ class DecodeRouteLocal r where
 class (DecodeRouteLocal (StageRoute s), StageWeb s) => StageWebRoute s where
     type StageRoute s
     askUrlRenderParams
-        :: (MonadActor m, ActorEnv m ~ s)
+        :: (MonadActor m, MonadActorStage m ~ s)
         => m (StageRoute s -> [(Text, Text)] -> Text)
     -- | Name of parameter to use in generated URIs' query part to indicate the
     -- page number in a paginated collection
     pageParamName :: Proxy s -> Text
 
 askUrlRender
-    :: (MonadActor m, ActorEnv m ~ s, StageWebRoute s)
+    :: (MonadActor m, MonadActorStage m ~ s, StageWebRoute s)
     => m (StageRoute s -> Text)
 askUrlRender = do
     render <- askUrlRenderParams
     return $ \ route -> render route []
 
 hostIsLocal
-    :: (MonadActor m, ActorEnv m ~ s, StageWeb s)
+    :: (MonadActor m, MonadActorStage m ~ s, StageWeb s)
     => Authority (StageURIMode s) -> m Bool
 hostIsLocal h = asksEnv $ (== h) . stageInstanceHost
 
@@ -117,7 +117,7 @@ parseFedURI u@(ObjURI h lu) = do
         else pure $ Right u
 
 getEncodeRouteHome
-    :: (MonadActor m, ActorEnv m ~ s, StageWebRoute s)
+    :: (MonadActor m, MonadActorStage m ~ s, StageWebRoute s)
     => m (StageRoute s -> ObjURI (StageURIMode s))
 getEncodeRouteHome = toFed <$> askUrlRender
     where
@@ -127,13 +127,13 @@ getEncodeRouteHome = toFed <$> askUrlRender
             Right u -> u
 
 getEncodeRouteLocal
-    :: (MonadActor m, ActorEnv m ~ s, StageWebRoute s)
+    :: (MonadActor m, MonadActorStage m ~ s, StageWebRoute s)
     => m (StageRoute s -> LocalURI)
 getEncodeRouteLocal = (objUriLocal .) <$> getEncodeRouteHome
 
 getEncodeRouteFed
     :: ( MonadActor m
-       , ActorEnv m ~ s
+       , MonadActorStage m ~ s
        , StageWebRoute s
        , StageURIMode s ~ u
        )
@@ -141,13 +141,13 @@ getEncodeRouteFed
 getEncodeRouteFed = (\ f a -> ObjURI a . f) <$> getEncodeRouteLocal
 
 getEncodeRoutePageLocal
-    :: (MonadActor m, ActorEnv m ~ s, StageWebRoute s)
+    :: (MonadActor m, MonadActorStage m ~ s, StageWebRoute s)
     => m (StageRoute s -> Int -> LocalPageURI)
 getEncodeRoutePageLocal =
     (\ f r n -> pageUriLocal $ f r n) <$> getEncodeRoutePageHome
 
 getEncodeRoutePageHome
-    :: forall m s. (MonadActor m, ActorEnv m ~ s, StageWebRoute s)
+    :: forall m s. (MonadActor m, MonadActorStage m ~ s, StageWebRoute s)
     => m (StageRoute s -> Int -> PageURI (StageURIMode s))
 getEncodeRoutePageHome = do
     encodeRouteHome <- getEncodeRouteHome
@@ -158,7 +158,7 @@ getEncodeRoutePageHome = do
 
 getEncodeRoutePageFed
     :: ( MonadActor m
-       , ActorEnv m ~ s
+       , MonadActorStage m ~ s
        , StageWebRoute s
        , StageURIMode s ~ u
        )
@@ -167,7 +167,7 @@ getEncodeRoutePageFed =
     (\ f a r n -> PageURI a $ f r n) <$> getEncodeRoutePageLocal
 
 prepareToSend
-    :: (MonadActor m, ActorEnv m ~ s, StageWebRoute s, StageURIMode s ~ u)
+    :: (MonadActor m, MonadActorStage m ~ s, StageWebRoute s, StageURIMode s ~ u)
     => StageRoute s
     -> (ByteString -> S.Signature)
     -> Bool
@@ -187,7 +187,7 @@ prepareToSend keyR sign holder actorR idR action = do
     return $ AP.sending lruKey sign (Just (config, signB)) holder uActor luId action
 
 prepareToForward
-    :: (MonadActor m, ActorEnv m ~ s, StageWebRoute s, StageURIMode s ~ u)
+    :: (MonadActor m, MonadActorStage m ~ s, StageWebRoute s, StageURIMode s ~ u)
     => StageRoute s
     -> (ByteString -> S.Signature)
     -> Bool

src/Web/Actor/Deliver.hs

@@ -22,8 +22,10 @@
 -- System of local utility-actors that do the actual HTTP POSTing of
 -- activities to remote actors.
 module Web.Actor.Deliver
-    ( Method (..)
+    ( DeliveryActor
+    , DeliveryStage
     , DeliveryTheater ()
+    , ActorMessage (..)
     , startDeliveryTheater
     , sendHttp
     )
@@ -56,6 +58,7 @@ import Web.Hashids
 import qualified Data.Aeson as A
 import qualified Data.ByteString.Lazy as BL
 import qualified Data.HashSet as HS
+import qualified Data.HList as H
 import qualified Data.Text as T
 import qualified Data.Text.Encoding as TE
 
@@ -67,14 +70,6 @@ import qualified Web.ActivityPub as AP
 
 import Vervis.Settings
 
-data Method u
-    = MethodDeliverLocal (AP.Envelope u) Bool
-    | MethodForwardRemote (AP.Errand u)
-
-instance Message (Method u) where
-    summarize _ = "Method"
-    refer _     = "Method"
-
 data RemoteActor = RemoteActor
     { raInbox      :: Maybe LocalURI
     , _raErrorSince :: Maybe UTCTime
@@ -84,6 +79,33 @@ data RemoteActor = RemoteActor
 instance BoxableVia RemoteActor where
     type BV RemoteActor = BoxableShow
 
+data DeliveryActor u
+data DeliveryStage u
+
+instance UriMode u => Actor (DeliveryActor u) where
+    type ActorStage  (DeliveryActor u) = DeliveryStage u
+    type ActorKey    (DeliveryActor u) = ObjURI u
+    type ActorReturn (DeliveryActor _) = ()
+    data ActorMessage (DeliveryActor u)
+        = MethodDeliverLocal (AP.Envelope u) Bool
+        | MethodForwardRemote (AP.Errand u)
+
+instance UriMode u => ActorLaunch (DeliveryActor u) where
+    actorBehavior uri msg = do
+        Env _ (manager, headers, micros) <- askEnv
+        behavior manager headers micros uri msg
+
+instance UriMode u => Stage (DeliveryStage u) where
+    data StageEnv (DeliveryStage u) = Env
+        { envBox :: Box RemoteActor
+        , envInit :: (Manager, NonEmpty HeaderName, Int)
+        }
+    type StageActors (DeliveryStage u) = '[DeliveryActor u]
+
+instance Message (ActorMessage (DeliveryActor u)) where
+    summarize _ = "Method"
+    refer _     = "Method"
+
 {-
 migrations :: [Migration SqlBackend IO]
 migrations =
@@ -96,26 +118,17 @@ migrations =
     ]
 -}
 
-data Env u = Env
+instance UriMode u => MonadBox (ActFor (DeliveryStage u)) where
-    { envBox :: Box RemoteActor
+    type BoxType (ActFor (DeliveryStage u)) = RemoteActor
-    }
-
-instance MonadBox (ActFor (Env u)) where
-    type BoxType (ActFor (Env u)) = RemoteActor
     askBox = asksEnv envBox
 
-instance Stage (Env u) where
-    type StageKey (Env u)     = ObjURI u
-    type StageMessage (Env u) = Method u
-    type StageReturn (Env u)  = ()
-
 data DeliveryTheater u = DeliveryTheater
     { _dtManager :: Manager
     , _dtHeaders :: NonEmpty HeaderName
     , _dtDelay   :: Int
     , _dtLog     :: LogFunc
     , _dtDir     :: OsPath
-    , _dtTheater :: TheaterFor (Env u)
+    , _dtTheater :: TheaterFor (DeliveryStage u)
     }
 
 data IdMismatch = IdMismatch deriving Show
@@ -128,8 +141,8 @@ behavior
     -> NonEmpty HeaderName
     -> Int
     -> ObjURI u
-    -> Method u
+    -> ActorMessage (DeliveryActor u)
-    -> ActFor (Env u) ((), ActFor (Env u) (), Next)
+    -> ActFor (DeliveryStage u) ((), ActFor (DeliveryStage u) (), Next)
 behavior manager postSignedHeaders micros (ObjURI h lu) = \case
     MethodDeliverLocal envelope fwd -> do
         ra@(RemoteActor mluInbox _mError) <- runBox obtain
@@ -182,10 +195,14 @@ behavior manager postSignedHeaders micros (ObjURI h lu) = \case
                     return luInb
         return $ ObjURI h luInbox
 
-mkEnv :: LogFunc -> OsPath -> IO (Env u)
+mkEnv
-mkEnv logFunc path = flip runLoggingT logFunc $ do
+    :: (Manager, NonEmpty HeaderName, Int)
+    -> LogFunc
+    -> OsPath
+    -> IO (StageEnv (DeliveryStage u))
+mkEnv env logFunc path = flip runLoggingT logFunc $ do
     box <- loadBox {-migrations-} path (RemoteActor Nothing Nothing)
-    return $ Env box
+    return $ Env box env
 
 type OsPath = FilePath
 encodeUtf = pure
@@ -210,14 +227,13 @@ startDeliveryTheater headers micros manager logFunc dbRootDir = do
                     error $
                         "Failed to parse URI-named SQLite db filename: " ++ e
                 Right uri -> return uri
-        env <- mkEnv logFunc $ dbRootDir </> path
+        env <- mkEnv (manager, headers, micros) logFunc (dbRootDir </> path)
-        return (u, env, behavior manager headers micros u)
+        return (u, env)
-    DeliveryTheater manager headers micros logFunc dbRootDir <$> startTheater logFunc actors
+    DeliveryTheater manager headers micros logFunc dbRootDir <$> startTheater logFunc (actors `H.HCons` H.HNil)
 
-sendHttp :: UriMode u => DeliveryTheater u -> Method u -> [ObjURI u] -> IO ()
+sendHttp :: UriMode u => DeliveryTheater u -> ActorMessage (DeliveryActor u) -> [ObjURI u] -> IO ()
 sendHttp (DeliveryTheater manager headers micros logFunc root theater) method recips = do
     for_ recips $ \ u ->
-        let makeEnv = either throwIO pure (TE.decodeUtf8' $ urlEncode False $ TE.encodeUtf8 $ renderObjURI u) >>= encodeUtf . (root </>) . T.unpack >>= mkEnv logFunc
+        let makeEnv = either throwIO pure (TE.decodeUtf8' $ urlEncode False $ TE.encodeUtf8 $ renderObjURI u) >>= encodeUtf . (root </>) . T.unpack >>= mkEnv (manager, headers, micros) logFunc
-            behave = behavior manager headers micros u
+        in  void $ spawnIO theater u makeEnv
-        in  void $ spawnIO theater u makeEnv behave
+    sendManyIO theater $ (HS.fromList recips, method) `H.HCons` H.HNil
-    sendManyIO theater (HS.fromList recips) method

src/Web/Actor/Persist.hs

@@ -1,6 +1,7 @@
 {- This file is part of Vervis.
  -
- - Written in 2019, 2020, 2022, 2023 by fr33domlover <fr33domlover@riseup.net>.
+ - Written in 2019, 2020, 2022, 2023, 2024
+ - by fr33domlover <fr33domlover@riseup.net>.
  -
  - ♡ Copying is an act of love. Please copy, reuse and share.
  -
@@ -49,7 +50,7 @@ import Web.Actor
 import Web.Hashids.Local
 
 class StageWeb s => StageHashids s where
-    stageHashidsContext :: s -> HashidsContext
+    stageHashidsContext :: StageEnv s -> HashidsContext
 
 newtype KeyHashid record = KeyHashid
     { keyHashidText :: Text
@@ -67,7 +68,7 @@ encodeKeyHashidPure ctx = KeyHashid . decodeUtf8 . encodeInt64 ctx . fromSqlKey
 
 getEncodeKeyHashid
     :: ( MonadActor m
-       , StageHashids (ActorEnv m)
+       , StageHashids (MonadActorStage m)
        , ToBackendKey SqlBackend record
        )
     => m (Key record -> KeyHashid record)
@@ -77,7 +78,7 @@ getEncodeKeyHashid = do
 
 encodeKeyHashid
     :: ( MonadActor m
-       , StageHashids (ActorEnv m)
+       , StageHashids (MonadActorStage m)
        , ToBackendKey SqlBackend record
        )
     => Key record
@@ -96,7 +97,7 @@ decodeKeyHashidPure ctx (KeyHashid t) =
 
 decodeKeyHashid
     :: ( MonadActor m
-       , StageHashids (ActorEnv m)
+       , StageHashids (MonadActorStage m)
        , ToBackendKey SqlBackend record
        )
     => KeyHashid record
@@ -108,7 +109,7 @@ decodeKeyHashid khid = do
 decodeKeyHashidF
     :: ( MonadFail m
        , MonadActor m
-       , StageHashids (ActorEnv m)
+       , StageHashids (MonadActorStage m)
        , ToBackendKey SqlBackend record
        )
     => KeyHashid record
@@ -118,7 +119,7 @@ decodeKeyHashidF khid e = maybe (fail e) return =<< decodeKeyHashid khid
 
 decodeKeyHashidM
     :: ( MonadActor m
-       , StageHashids (ActorEnv m)
+       , StageHashids (MonadActorStage m)
        , ToBackendKey SqlBackend record
        )
     => KeyHashid record
@@ -127,7 +128,7 @@ decodeKeyHashidM = MaybeT . decodeKeyHashid
 
 decodeKeyHashidE
     :: ( MonadActor m
-       , StageHashids (ActorEnv m)
+       , StageHashids (MonadActorStage m)
        , ToBackendKey SqlBackend record
        )
     => KeyHashid record

vervis.cabal

@@ -52,8 +52,8 @@ library
                        Data.Binary.Put.Local
 
                        Control.Applicative.Local
+                       --Control.Concurrent.ActorOld
                        Control.Concurrent.Actor
-                       --Control.Concurrent.ActorNew2
                        Control.Concurrent.Local
                        Control.Concurrent.ResultShare
                        Control.Concurrent.Return
@@ -277,7 +277,7 @@ library
                        Vervis.Web.Actor
                        Vervis.Web.Collab
                        Vervis.Web.Darcs
-                       Vervis.Web.Delivery
+                       --Vervis.Web.Delivery
                        Vervis.Web.Discussion
                        Vervis.Web.Git
                        Vervis.Web.Repo