Implement theater-based remote delivery and port personGrant

INSTALL.md

@@ -118,6 +118,12 @@ example, if you're keeping the default name:
 
     $ mkdir repos
 
+Create a directory that will keep remote delivery state. Its name should match
+the `delivery-state-dir` setting in `config/settings.yml`. For example, if
+you're keeping the default name:
+
+    $ mkdir delivery-states
+
 # (8) Development and deployment
 
 To update your local clone of Vervis, run:

config/settings-default.yaml

@@ -58,7 +58,7 @@ per-actor-keys:         false
 # load-font-from-lib-data: false
 
 ###############################################################################
-# SQL database
+# Database
 ###############################################################################
 
 # If you need a numeric value (e.g. 123) to parse as a String, wrap it in
@@ -76,6 +76,8 @@ database:
 max-instance-keys:  2
 max-actor-keys:     2
 
+delivery-state-dir: delivery-states
+
 ###############################################################################
 # Version control repositories
 ###############################################################################
@@ -149,12 +151,16 @@ reject-on-max-keys:     true
 # periodically retry to deliver them activities. After that period of time, we
 # stop trying to deliver and we remove them from follower lists of local
 # actors.
+#
+# TODO this probably isn't working anymore since the switch to DeliveryTheater
 drop-delivery-after:
   amount:               25
   unit:                 weeks
 
-# How often to retry failed deliveries
+# Base of the exponential backoff for inbox POST delivery to remote actors,
-retry-delivery-every:
+# i.e. how much time to wait before the first retry. Afterwards this time
+# interval will be doubled with each retry.
+retry-delivery-base:
   amount:               1
   unit:                 hours
 

src/Control/Concurrent/Actor.hs

@@ -28,7 +28,7 @@ module Control.Concurrent.Actor
     , send
     , sendManyIO
     , sendMany
-    --, spawnIO
+    , spawnIO
     , spawn
     , done
     , doneAnd
@@ -65,22 +65,48 @@ 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
+--
+-- And right now the classes below are weird:
+--
+-- * Stage and Env terms used interchangeably, it's cnfusing, Stage is weird
+-- * The main type everything's keyed on is the Env, which is merely parameters
+--   for the actor, perhaps we can key on an abstact type where Env is just one
+--   of the things keyed on it?
+--
+-- And that change into abstract type can also help with the cyclic reference?
+
 class Stage a where
     type StageKey a
     type StageMessage a
     type StageReturn a
 
+newtype Actor m r = Actor (Chan (m, Either SomeException r -> IO ()))
+
+callIO' :: Actor m r -> m -> IO r
+callIO' (Actor chan) msg = do
+    (returx, wait) <- newReturn
+    writeChan chan (msg, returx)
+    result <- wait
+    case result of
+        Left e -> AE.checkpointCallStack $ throwIO e
+        Right r -> return r
+
+sendIO' :: Actor m r -> m -> IO ()
+sendIO' (Actor chan) msg = writeChan chan (msg, const $ pure ())
+
 -- | A set of live actors responding to messages
 data TheaterFor s = TheaterFor
-    { theaterMap :: TVar (HashMap (StageKey s) (Chan (StageMessage s, Either SomeException (StageReturn s) -> IO ())))
+    { theaterMap :: TVar (HashMap (StageKey s) (Actor (StageMessage s) (StageReturn s)))
     , theaterLog :: LogFunc
-    , theaterEnv :: s
     }
 
 -- | Actor monad in which message reponse actions are executed. Supports
 -- logging, a read-only environment, and IO.
 newtype ActFor s a = ActFor
-    { unActFor :: LoggingT (ReaderT (TheaterFor s) IO) a
+    { unActFor :: LoggingT (ReaderT (s, TheaterFor s) IO) a
     }
     deriving
         ( Functor, Applicative, Monad, MonadFail, MonadIO, MonadLogger
@@ -94,9 +120,9 @@ instance MonadUnliftIO (ActFor s) where
     withRunInIO inner =
         ActFor $ withRunInIO $ \ run -> inner (run . unActFor)
 
-runActor :: TheaterFor s -> ActFor s a -> IO a
+runActor :: TheaterFor s -> s -> ActFor s a -> IO a
-runActor theater (ActFor action) =
+runActor theater env (ActFor action) =
-    runReaderT (runLoggingT action $ theaterLog theater) theater
+    runReaderT (runLoggingT action $ theaterLog theater) (env, theater)
 
 class Monad m => MonadActor m where
     type ActorEnv m
@@ -105,7 +131,7 @@ class Monad m => MonadActor m where
 
 instance MonadActor (ActFor s) where
     type ActorEnv (ActFor s) = s
-    askEnv = theaterEnv <$> askTheater
+    askEnv = ActFor $ lift $ asks fst
     liftActor = id
 
 instance MonadActor m => MonadActor (ReaderT r m) where
@@ -144,10 +170,11 @@ launchActorThread
     => Chan (m, Either SomeException r -> IO ())
     -> TheaterFor s
     -> k
+    -> s
     -> (m -> ActFor s (r, ActFor s (), Next))
     -> IO ()
-launchActorThread chan theater actor behavior =
+launchActorThread chan theater actor env behavior =
-    void $ forkIO $ runActor theater $ do
+    void $ forkIO $ runActor theater env $ do
         logInfo $ prefix <> "starting"
         loop
         logInfo $ prefix <> "bye"
@@ -184,21 +211,20 @@ startTheater
        , Hashable k, Eq k, Show k, Message m, Show r
        )
     => LogFunc
-    -> s
+    -> [(k, s, m -> ActFor s (r, ActFor s (), Next))]
-    -> [(k, m -> ActFor s (r, ActFor s (), Next))]
     -> IO (TheaterFor s)
-startTheater logFunc env actors = do
+startTheater logFunc actors = do
-    actorsWithChans <- for actors $ \ (key, behavior) -> do
+    actorsWithChans <- for actors $ \ (key, env, behavior) -> do
         chan <- newChan
-        return ((key, chan), behavior)
+        return ((key, Actor chan), (env, behavior))
     tvar <- newTVarIO $ HM.fromList $ map fst actorsWithChans
-    let theater = TheaterFor tvar logFunc env
+    let theater = TheaterFor tvar logFunc
-    for_ actorsWithChans $ \ ((key, chan), behavior) ->
+    for_ actorsWithChans $ \ ((key, Actor chan), (env, behavior)) ->
-        launchActorThread chan theater key behavior
+        launchActorThread chan theater key env behavior
     return theater
 
 askTheater :: ActFor s (TheaterFor s)
-askTheater = ActFor $ lift ask
+askTheater = ActFor $ lift $ asks snd
 
 lookupActor
     :: ( StageKey s ~ k, StageMessage s ~ m, StageReturn s ~ r
@@ -206,8 +232,8 @@ lookupActor
        )
     => TheaterFor s
     -> k
-    -> IO (Maybe (Chan (m, Either SomeException r -> IO ())))
+    -> IO (Maybe (Actor m r))
-lookupActor (TheaterFor tvar _ _) actor = HM.lookup actor <$> readTVarIO tvar
+lookupActor (TheaterFor tvar _) actor = HM.lookup actor <$> readTVarIO tvar
 
 -- | Same as 'call', except it takes the theater as a parameter.
 callIO
@@ -215,15 +241,9 @@ callIO
        , Eq k, Hashable k
        )
     => TheaterFor s -> k -> m -> IO (Maybe r)
-callIO theater actor msg = do
+callIO theater key msg = do
-    maybeChan <- lookupActor theater actor
+    maybeActor <- lookupActor theater key
-    for maybeChan $ \ chan -> do
+    for maybeActor $ \ actor -> callIO' actor msg
-        (returx, wait) <- newReturn
-        writeChan chan (msg, returx)
-        result <- wait
-        case result of
-            Left e -> AE.checkpointCallStack $ throwIO e
-            Right r -> return r
 
 -- | Send a message to an actor, and wait for the result to arrive. Return
 -- 'Nothing' if actor doesn't exist, otherwise 'Just' the result.
@@ -244,12 +264,12 @@ call key msg = liftActor $ do
 sendIO
     :: (StageKey s ~ k, StageMessage s ~ m, Eq k, Hashable k)
     => TheaterFor s -> k -> m -> IO Bool
-sendIO theater actor msg = do
+sendIO theater key msg = do
-    maybeChan <- lookupActor theater actor
+    maybeActor <- lookupActor theater key
-    case maybeChan of
+    case maybeActor of
         Nothing -> return False
-        Just chan -> do
+        Just actor -> do
-            writeChan chan (msg, const $ pure ())
+            sendIO' actor msg
             return True
 
 -- | Send a message to an actor, without waiting for a result. Return 'True' if
@@ -268,10 +288,10 @@ send key msg = liftActor $ do
 sendManyIO
     :: (StageKey s ~ k, StageMessage s ~ m, Eq k, Hashable k)
     => TheaterFor s -> HashSet k -> m -> IO ()
-sendManyIO (TheaterFor tvar _ _) recips msg = do
+sendManyIO (TheaterFor tvar _) recips msg = do
     allActors <- readTVarIO tvar
     for_ (HM.intersection allActors (HS.toMap recips)) $
-        \ chan -> writeChan chan (msg, const $ pure ())
+        \ actor -> sendIO' actor msg
 
 -- | Send a message to each actor in the set that exists in the system,
 -- without waiting for results.
@@ -292,20 +312,23 @@ spawnIO
        )
     => TheaterFor s
     -> k
+    -> IO s
     -> (m -> ActFor s (r, ActFor s (), Next))
     -> IO Bool
-spawnIO theater@(TheaterFor tvar _ _) actor behavior = do
+spawnIO theater@(TheaterFor tvar _) key mkEnv behavior = do
     chan <- newChan
     added <- atomically $ stateTVar tvar $ \ hm ->
-        let hm' = HM.alter (create chan) actor hm
+        let hm' = HM.alter (create $ Actor chan) key hm
-        in  ( not (HM.member actor hm) && HM.member actor hm'
+        in  ( not (HM.member key hm) && HM.member key hm'
             , hm'
             )
-    when added $ launchActorThread chan theater actor behavior
+    when added $ do
+        env <- mkEnv
+        launchActorThread chan theater key env behavior
     return added
     where
-    create chan Nothing    = Just chan
+    create actor Nothing    = Just actor
-    create _    j@(Just _) = j
+    create _     j@(Just _) = j
 
 -- | Launch a new actor with the given ID and behavior. Return 'True' if the ID
 -- was unused and the actor has been launched. Return 'False' if the ID is
@@ -316,11 +339,12 @@ spawn
        , Eq k, Hashable k, Show k, Message m, Show r
        )
     => k
+    -> IO s
     -> (m -> ActFor s (r, ActFor s (), Next))
     -> n Bool
-spawn key behavior = liftActor $ do
+spawn key mkEnv behavior = liftActor $ do
     theater <- askTheater
-    liftIO $ spawnIO theater key behavior
+    liftIO $ spawnIO theater key mkEnv behavior
 
 done :: Monad n => a -> n (a, ActFor s (), Next)
 done msg = return (msg, return (), Proceed)

src/Control/Concurrent/Local.hs

@@ -1,6 +1,6 @@
 {- This file is part of Vervis.
  -
- - Written in 2019 by fr33domlover <fr33domlover@riseup.net>.
+ - Written in 2019, 2023 by fr33domlover <fr33domlover@riseup.net>.
  -
  - ♡ Copying is an act of love. Please copy, reuse and share.
  -
@@ -15,11 +15,13 @@
 
 module Control.Concurrent.Local
     ( forkCheck
+    , intervalMicros
     , periodically
     )
 where
 
 import Control.Concurrent
+import Control.Exception.Base
 import Control.Monad
 import Control.Monad.IO.Class
 import Data.Functor (void)
@@ -32,11 +34,18 @@ forkCheck run = do
     tid <- myThreadId
     void $ forkFinally run $ either (throwTo tid) (const $ return ())
 
-periodically :: MonadIO m => TimeInterval -> m () -> m ()
+data MicrosBeyondIntRange = MicrosBeyondIntRange Integer deriving Show
-periodically interval action =
+
+instance Exception MicrosBeyondIntRange
+
+intervalMicros :: TimeInterval -> IO Int
+intervalMicros interval = do
     let micros = microseconds interval
-    in  if 0 < micros && micros <= toInteger (maxBound :: Int)
+    if 0 < micros && micros <= toInteger (maxBound :: Int)
-            then
+        then return $ fromInteger micros
-                let micros' = fromInteger micros
+        else throwIO $ MicrosBeyondIntRange micros
-                in  forever $ liftIO (threadDelay micros') >> action
+
-            else error $ "periodically: interval out of range: " ++ show micros
+periodically :: MonadIO m => TimeInterval -> m () -> m ()
+periodically interval action = do
+    micros <- liftIO $ intervalMicros interval
+    forever $ liftIO (threadDelay micros) >> action

src/Data/Slab.hs

@@ -0,0 +1,51 @@
+{- This file is part of Vervis.
+ -
+ - Written in 2023 by fr33domlover <fr33domlover@riseup.net>.
+ -
+ - ♡ Copying is an act of love. Please copy, reuse and share.
+ -
+ - The author(s) have dedicated all copyright and related and neighboring
+ - rights to this software to the public domain worldwide. This software is
+ - distributed without any warranty.
+ -
+ - You should have received a copy of the CC0 Public Domain Dedication along
+ - with this software. If not, see
+ - <http://creativecommons.org/publicdomain/zero/1.0/>.
+ -}
+
+-- | Save and load the read-only environment of application components.
+--
+-- Meh, that's the best title I can come up with right now. I'm tempted not to
+-- make it actor-specific, hence also no "Actor" in the module name. But here's
+-- an attempt with actors:
+--
+-- Disk-persistent actor read-only identity/environments
+--
+-- Or:
+--
+-- Store and load the read-only environments that identity/define/accompany
+-- your actor/microservice threads throughout their lifetimes.
+--
+-- I'm thinking of 3 basic ways that the slab system can be implemented:
+--
+-- * Using one file per actor, naming the file using either UUID or a hash of
+--   some unique property of the actor if it already has one
+-- * Same but using an SQLite database for each slab, for atomicity
+-- * A single database, say SQLite, for all the slabs
+--
+-- This module provides just the slab system, without a specific backend. I'll
+-- write a file backend in another module, which can live in the same package.
+-- The SQLite ones need their own package(s) because they depend on a DB.
+--
+-- Let's see what comes up.
+module Data.Slab
+    ( Engrave ()
+    , EngraveShow ()
+    , EngraveJSON ()
+    , EngraveSerialize ()
+    , Slab (..)
+    , Workshop (..)
+    )
+where
+
+import Data.Slab.Backend

src/Data/Slab/Backend.hs

@@ -0,0 +1,195 @@
+{- This file is part of Vervis.
+ -
+ - Written in 2023 by fr33domlover <fr33domlover@riseup.net>.
+ -
+ - ♡ Copying is an act of love. Please copy, reuse and share.
+ -
+ - The author(s) have dedicated all copyright and related and neighboring
+ - rights to this software to the public domain worldwide. This software is
+ - distributed without any warranty.
+ -
+ - You should have received a copy of the CC0 Public Domain Dedication along
+ - with this software. If not, see
+ - <http://creativecommons.org/publicdomain/zero/1.0/>.
+ -}
+
+-- For the fundep in FaceType - is that fundep needed? haven't verified yet
+{-# LANGUAGE TypeFamilyDependencies #-}
+
+{-# LANGUAGE DataKinds #-}
+
+-- | This module is only for use when implementing new backends, i.e.
+-- 'Workshop' instances. It exports everything 'Data.Slab' does, in addition to
+-- types needed for implementing a backend.
+module Data.Slab.Backend
+    ( SlabValue (..)
+    , Hard (..)
+    , Face (..)
+    , FaceType ()
+    , Engrave (..)
+    , EngraveShow ()
+    , EngraveJSON ()
+    , EngraveSerialize ()
+    , Slab (..)
+    , Workshop (..)
+    )
+where
+
+import Data.Bifunctor
+import Data.ByteString (ByteString)
+import Data.Kind
+import Data.Proxy
+import Data.Text (Text)
+import Data.Typeable
+import Text.Read (readEither)
+
+import qualified Data.Aeson as A
+import qualified Data.ByteString.Lazy as BL
+import qualified Data.Serialize as S
+import qualified Data.Text as T
+import qualified Data.Text.Encoding as TE
+import qualified Data.Text.Encoding.Error as TEE
+
+data SlabValue = SlabText Text | SlabByteString ByteString deriving Show
+
+{-
+data SlabValue (a :: Type) :: Type where
+    SlabText :: Text -> SlabValue Text
+    SlabByteString :: ByteString -> SlabValue ByteString
+-}
+
+class Hard (f :: Face) where
+    toSlabValue :: FaceType f -> SlabValue
+    fromSlabValue :: SlabValue -> Either Text (FaceType f)
+
+data Face = FaceText | FaceByteString
+
+type family FaceType (a :: Face) {-:: Type-} = t | t -> a where
+    FaceType 'FaceText       = Text
+    FaceType 'FaceByteString = ByteString
+
+instance Hard 'FaceText where
+    toSlabValue = SlabText
+    fromSlabValue (SlabText t) = Right t
+    fromSlabValue s  =
+        Left $ "fromSlabValue FaceText: Got " <> T.pack (show s)
+
+instance Hard 'FaceByteString where
+    toSlabValue = SlabByteString
+    fromSlabValue (SlabByteString b) = Right b
+    fromSlabValue s  =
+        Left $ "fromSlabValue FaceByteString: Got " <> T.pack (show s)
+
+class Hard (EngraveFace a) => Engrave a where
+    type EngraveFace a :: Face
+    engrave :: a -> FaceType (EngraveFace a)
+    see :: FaceType (EngraveFace a) -> Either Text a
+
+{-
+engrave :: Engrave a => a -> SlabValue
+engrave = toSlabValue . engrave
+
+see :: Engrave a => SlabValue -> Either Text a
+see = see <=< fromSlabValue
+-}
+
+instance Engrave Text where
+    type EngraveFace Text = 'FaceText
+    engrave = id
+    see = Right
+
+instance Engrave ByteString where
+    type EngraveFace ByteString = 'FaceByteString
+    engrave = id
+    see = Right
+
+showError :: Typeable a => Either (Proxy a, Text -> Text) a -> Either Text a
+showError = bimap (uncurry errorText) id
+    where
+    errorText :: Typeable b => Proxy b -> (Text -> Text) -> Text
+    errorText p mk = mk $ T.pack $ show $ typeRep p
+
+newtype EngraveShow a = EngraveShow { unEngraveShow :: a }
+
+instance (Typeable a, Show a, Read a) => Engrave (EngraveShow a) where
+    type EngraveFace (EngraveShow a) = EngraveFace Text
+    engrave = engrave . T.pack . show . unEngraveShow
+    see v = do
+        t <- see v
+        showError $
+            case readEither $ T.unpack t of
+                Left e ->
+                    Left $ (Proxy,) $ \ typ ->
+                        T.concat [ "Invalid ", typ,  ": ", T.pack e, ": ", t]
+                Right x -> Right $ EngraveShow x
+
+newtype EngraveJSON a = EngraveJSON { unEngraveJSON :: a }
+
+instance (Typeable a, A.FromJSON a, A.ToJSON a) => Engrave (EngraveJSON a) where
+    type EngraveFace (EngraveJSON a) = EngraveFace ByteString
+    engrave = BL.toStrict . A.encode . unEngraveJSON
+    see v = do
+        bs <- see v
+        let input = TE.decodeUtf8With TEE.lenientDecode bs -- TE.decodeUtf8Lenient bs
+        showError $
+            case A.eitherDecodeStrict' bs of
+                Left e ->
+                    Left $ (Proxy,) $ \ typ ->
+                        T.concat
+                            [ "JSON decoding error for ", typ, ": "
+                            , T.pack e, " on input: ", input
+                            ]
+                Right x -> Right $ EngraveJSON x
+
+newtype EngraveSerialize a = EngraveSerialize { unEngraveSerialize :: a }
+
+instance (Typeable a, S.Serialize a) => Engrave (EngraveSerialize a) where
+    type EngraveFace (EngraveSerialize a) = EngraveFace ByteString
+    engrave = engrave . S.encode . unEngraveSerialize
+    see v = do
+        b <- see v
+        showError $
+            case S.decode b of
+                Left e ->
+                    Left $ (Proxy,) $
+                        \ typ -> T.concat ["Invalid ", typ, ": ", T.pack e]
+                Right x -> Right $ EngraveSerialize x
+
+class Slab (s :: Type -> Type) where
+    -- | Once the slab has been created, it's meant to be used from a single
+    -- thread. As long as this thread hasn't obliterated the slab, it can
+    -- 'retrieve' it as many times as it wants.
+    --
+    -- Most likely you want to retrieve once when the thread starts, and
+    -- retrieve again whenever the thread crashes/restarts and loses access to
+    -- the slab.
+    --
+    -- If you want multiple threads to have access to the slab's value,
+    -- 'retrieve' the slab once and then pass the value to those threads.
+    retrieve :: Engrave a => s a -> IO a
+    -- | Permanently deletes the slab from the workshop. Meant to be used only
+    -- from a single thread. Meant to be used only once. After that one use,
+    -- retrieving or obliterating again will raise an exception.
+    obliterate :: Engrave a => s a -> IO ()
+
+class Slab (WorkshopSlab w) => Workshop w where
+    data WorkshopSlab w :: Type -> Type
+    data WorkshopConfig w :: Type
+    -- | Unless a specific 'Workshop' instance says otherwise, it's safe to
+    -- 'load' a workshop only when nothing else is holding access to it: Not
+    -- your program, not another thread, not another process.
+    --
+    -- You probably want to load your workshop once when your application
+    -- starts, and reload when the component of your program that uses the
+    -- workshop is restarted.
+    load :: Engrave a => WorkshopConfig w -> IO (w a, [WorkshopSlab w a])
+    -- | Create a new slab with the given value. This must be thread-safe, i.e.
+    -- different threads can concurrently create new slabs. However, once the
+    -- slab is obtained, only one thread should use it.
+    --
+    -- If you want multiple threads to have access to the slab's value,
+    -- 'retrieve' the slab once and then pass the value to those threads.
+    conceive :: Engrave a => w a -> a -> IO (WorkshopSlab w a)
+    -- | Clear the workshop. Like 'load', this is safe only if nothing else
+    -- holds access to the workshop.
+    vacate :: Engrave a => w a -> IO ()

src/Data/Slab/Simple.hs

@@ -0,0 +1,127 @@
+{- This file is part of Vervis.
+ -
+ - Written in 2023 by fr33domlover <fr33domlover@riseup.net>.
+ -
+ - ♡ Copying is an act of love. Please copy, reuse and share.
+ -
+ - The author(s) have dedicated all copyright and related and neighboring
+ - rights to this software to the public domain worldwide. This software is
+ - distributed without any warranty.
+ -
+ - You should have received a copy of the CC0 Public Domain Dedication along
+ - with this software. If not, see
+ - <http://creativecommons.org/publicdomain/zero/1.0/>.
+ -}
+
+module Data.Slab.Simple
+    ( SimpleWorkshop ()
+    , makeSimpleWorkshopConfig
+    )
+where
+
+import Control.Concurrent
+import Control.Monad
+import Data.Foldable
+import System.Directory
+--import System.Directory.OsPath
+import System.FilePath
+--import System.OsPath
+
+import qualified Data.ByteString as B
+import qualified Data.Text as T
+import qualified Data.Text.Encoding as TE
+
+import Data.Slab.Backend
+
+data SimpleWorkshop a = SimpleWorkshop
+    { _swPath :: OsPath
+    , _swMVar :: MVar (a, MVar OsPath)
+    }
+
+isSlab :: OsPath -> Bool
+isSlab path = takeExtension path == ".slab" -- [osp|.slab|]
+
+type OsPath = FilePath
+decodeUtf = pure
+encodeUtf = pure
+unpack = id
+toChar = id
+
+instance Workshop SimpleWorkshop where
+    data WorkshopSlab SimpleWorkshop a = SimpleSlab OsPath
+    data WorkshopConfig SimpleWorkshop = SimpleConfig OsPath
+    load (SimpleConfig dir) = do
+        entries <- listDirectory dir
+        let slabPaths = filter isSlab $ map (dir </>) entries
+        mvar <- newEmptyMVar
+        let next = dir </> "next" --[osp|next|]
+        nextExists <- doesPathExist next
+        next' <- decodeUtf next
+        unless nextExists $ writeFile next' $ show (0 :: Integer)
+        _ <- forkIO $ forever $ handleRequests mvar
+        return
+            ( SimpleWorkshop dir mvar
+            , map SimpleSlab slabPaths
+            )
+        where
+        handleRequests mvar = do
+            (val, sendPath) <- takeMVar mvar
+            slabPath <- do
+                next <- decodeUtf $ dir </> "next" -- [osp|next|]
+                n <- read <$> readFile next
+                writeFile next $ show $ succ (n :: Integer)
+                let wrap name = dir </> name <.> "slab" -- [osp|slab|]
+                (new, bs) <-
+                    case toSlabValue $ engrave val of
+                        SlabText t ->
+                            (, TE.encodeUtf8 t) <$>
+                                encodeUtf (wrap $ show n ++ "t")
+                        SlabByteString b ->
+                            (, b) <$> encodeUtf (wrap $ show n ++ "b")
+                new' <- decodeUtf new
+                B.writeFile new' bs
+                return new
+            putMVar sendPath slabPath
+    conceive (SimpleWorkshop _ mvar) val = do
+        sendPath <- newEmptyMVar
+        putMVar mvar (val, sendPath)
+        new <- takeMVar sendPath
+        return $ SimpleSlab new
+    vacate (SimpleWorkshop dir _) = do
+        entries <- listDirectory dir
+        let slabPaths = filter isSlab $ map (dir </>) entries
+            next = dir </> "next" -- [osp|next|]
+        traverse_ removeFile slabPaths
+        removeFile next
+
+instance Slab (WorkshopSlab SimpleWorkshop) where
+    retrieve (SimpleSlab path) = do
+        b <- B.readFile path
+        let sv =
+                case reverse $ unpack $ takeBaseName path of
+                    't':_ -> SlabText $ TE.decodeUtf8 b
+                    'b':_ -> SlabByteString b
+                    _ -> error $ "no b/t suffix in " ++ show path
+        case see =<< fromSlabValue sv of
+            Left e -> error $ "retrieve " ++ show path ++ " : " ++ T.unpack e
+            Right val -> return val
+    obliterate (SimpleSlab path) = removeFile path
+
+
+{-
+        TODO CONTINUE
+        then, the atomic-durable one
+        perhaps that's enough, no need for SQLite-based one?
+        I thought it avoids file overload but if every actor has its own SQLite
+        db anyway for the Box, then no harm
+        Just need to make sure that slab file deletion is atomic
+        finally, move on to creating a module that offers a system with slabs
+        and boxes, it doesn't need to be perfect e.g. no need to support
+        persistence of private sub-actors and no need for pretty types, just a
+        function that wraps startTheater,spawnIO,spawn
+        then use that to launch the DeliveryTheater in Vervis.Application
+        And evolve the DeliveryTheater behavior to cache+retry
+-}
+
+makeSimpleWorkshopConfig :: OsPath -> WorkshopConfig SimpleWorkshop
+makeSimpleWorkshopConfig = SimpleConfig

src/Database/Persist/Box.hs

@@ -0,0 +1,82 @@
+{- This file is part of Vervis.
+ -
+ - Written in 2023 by fr33domlover <fr33domlover@riseup.net>.
+ -
+ - ♡ Copying is an act of love. Please copy, reuse and share.
+ -
+ - The author(s) have dedicated all copyright and related and neighboring
+ - rights to this software to the public domain worldwide. This software is
+ - distributed without any warranty.
+ -
+ - You should have received a copy of the CC0 Public Domain Dedication along
+ - with this software. If not, see
+ - <http://creativecommons.org/publicdomain/zero/1.0/>.
+ -}
+
+-- | Example:
+--
+-- @
+-- import Database.Persist.Box
+-- import System.OsPath
+--
+-- data Person = Person
+--     { personName :: Text
+--     , personAge  :: Int
+--     }
+--     deriving Show
+--     deriving 'Boxable' via ('BoxableShow' Person)
+--
+-- main :: IO ()
+-- main = do
+--     path <- decodeUtf "mydb.box"
+--     alice <- 'loadBox' path $ Person "Alice" 50
+--     'withBox' alice $ do
+--         Person _name age <- 'obtain'
+--         'bestow' $ Person "Alicia" (age + 1)
+-- @
+--
+-- Notes:
+--
+-- * A 'Box' is meant to be used from a single thread! However, you can have
+--   multiple threads with read-only access, see 'createBoxView'
+-- * Instead of passing around the 'Box' and using 'withBox' to access it, you
+--   can implement a 'MonadBox' instance for your monad and use 'runBox' to
+--   access the box
+-- * 'BoxableShow' is just one of several serialization methods
+-- * Migrations not supported yet
+module Database.Persist.Box
+    ( -- * TH
+      model
+    , modelFile
+    , makeBox
+
+      -- * Making types boxable
+    , BoxPersistT ()
+    , Boxable ()
+    , BoxableFormat ()
+    , BoxableVia (..)
+    , BoxableRecord ()
+    , BoxableField ()
+    , BoxableShow ()
+    , BoxableJSON ()
+    , BoxableSerialize ()
+
+      -- * Box access
+    , Box ()
+    --, MigrationRecipes
+    , loadBox
+    , withBox
+    , MonadBox (..)
+    , runBox
+    , bestow
+    , obtain
+
+      -- * Box viewer pool
+    , BoxView ()
+    , createBoxView
+    , viewBox
+    )
+where
+
+import Database.Persist.Box.Internal
+import Database.Persist.Box.Via

src/Database/Persist/Box/Internal.hs

@@ -0,0 +1,424 @@
+{- This file is part of Vervis.
+ -
+ - Written in 2023 by fr33domlover <fr33domlover@riseup.net>.
+ -
+ - ♡ Copying is an act of love. Please copy, reuse and share.
+ -
+ - The author(s) have dedicated all copyright and related and neighboring
+ - rights to this software to the public domain worldwide. This software is
+ - distributed without any warranty.
+ -
+ - You should have received a copy of the CC0 Public Domain Dedication along
+ - with this software. If not, see
+ - <http://creativecommons.org/publicdomain/zero/1.0/>.
+ -}
+
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE TypeApplications #-}
+
+module Database.Persist.Box.Internal
+    ( -- * TH
+      model
+    , modelFile
+    , makeBox
+
+      -- * Making types boxable
+    , BoxPersistT ()
+    , Boxable (..)
+    , BoxableFormat (..)
+    , BoxableVia (..)
+    , BoxableRecord ()
+    , BoxableField ()
+    , BoxableShow ()
+    , BoxableJSON ()
+    , BoxableSerialize ()
+
+-- MIGRATIONS
+--
+-- Use the SQLite user version pragma to track the version
+--
+-- Record: Adapt persistent-migration to single-field case
+-- The rest: Provide 3 types of migrations:
+--      1. Create the table
+--      2. Adapt the value
+--      3. Change the value's type
+--
+-- This should allow migrating *between* serialization types as well. Since
+-- SQLite column types are just a recommendation (AFAIK so far), switching type
+-- simply involves an in-place update, and an update to the schema for the
+-- formality.
+--
+-- This can be automated by either having a typeclass for each switch between
+-- serialization types, or have each serialization type specify its sqlType,
+-- and then whenever a migration switches between serialization types with a
+-- different SqlType, run a SQL command to change the column type.
+--
+-- And switching to/from record to simple field would be done by creating a new
+-- table, migrating the row, and deleting the old table.
+--
+-- Actually, this can be done for the between-simples as well, it means there's
+-- no need to define migration SQL for column type change, just reuse the SQL
+-- for table creation. OTOH does it waste anything? Likely not, serialization
+-- type changes would likely be rare, never something that would generate 1000s
+-- of table create-deletes or anything like that.
+--
+-- Switching between different record types is same idea: Make new table,
+-- migrate the row, delete old table.
+--
+-- NOTE: Old and new table names might clash, especially since all the "simple"
+-- types use the same schema of table "cell" with column "value". Solution
+-- would be to create the new table with some very unlikely name, do the
+-- migration, delete old table, then finally rename new table. It's now the
+-- only table, so, the remaming will just work.
+--
+-- Proposal: Somehow use types to force writing migration numbers in the
+-- migration list, not just as comments? And then verify the numbers at *build*
+-- time, i.e. compile successfully only if they're sequential and starting from
+-- the earliest-supported number specified. And perhaps force having the
+-- migration number at the end of the type name for "simple" ones, and have it
+-- auto-prepended to type name and field accessor names using
+-- persistent-migration's existing mechanism that does that?
+--
+-- Proposal: To have better type safety, rather than a plain list of possibly
+-- inconsistent migrations, make sure that a migration a->b is followed by a
+-- migration b->c etc. etc. and finally the last migration leads to the current
+-- version of the boxable type.
+--
+-- Proposal: The "record" option might be most useful for debugging,
+-- inspecting, accessing via non-haskell, etc. etc. but also migrations are
+-- more involved, having to manually specify each column
+-- change/removal/addition. So, idea: Add a migration that allows to specify
+-- function PersonOld->PersonNew and simply creates a new table, writes the row
+-- and deletes old table. Idk if it exhausts anything, but it allows to write a
+-- migration in terms of Haskell types rather than columns. It's also safer,
+-- more checked, unless I add support for column remove/add that verifies the
+-- removed column actually existed and added one truly exists in the new
+-- version of the type etc.
+
+      -- * Box access
+    , Box ()
+    --, MigrationRecipes
+    , loadBox
+    , withBox
+    , MonadBox (..)
+    , runBox
+    , bestow
+    , obtain
+
+      -- * Box viewer pool
+    , BoxView ()
+    , createBoxView
+    , viewBox
+    )
+where
+
+import Control.Exception.Base
+import Control.Monad.IO.Class
+import Control.Monad.IO.Unlift
+import Control.Monad.Logger.CallStack
+import Control.Monad.Trans.Class
+import Data.ByteString (ByteString)
+import Data.Int
+import Data.Kind
+import Data.Proxy
+import Data.Text (Text)
+import Database.Persist
+import Database.Persist.Sql
+import Database.Persist.Sqlite
+import Language.Haskell.TH.Quote (QuasiQuoter)
+import Language.Haskell.TH.Syntax (Q, Exp, Dec)
+import Text.Read (readEither)
+import Type.Reflection (Typeable, typeRep)
+
+import qualified Data.Aeson as A
+import qualified Data.Serialize as S
+import qualified Data.Text as T
+import qualified Data.Text.Encoding as TE
+import qualified Database.Persist.Types as PT
+
+import qualified Database.Persist.Schema.TH as PS
+
+import Database.Persist.Sqlite.Local
+
+{-
+getVersion :: MonadIO m => SqlPersistT m Int
+getVersion = do
+    r <- rawSql "PRAGMA user_version" []
+    case r of
+        [] -> error "No user_version"
+        [Single n] -> return n
+        _ -> error "Multiple user_version"
+
+setVersion :: MonadIO m => Int -> SqlPersistT m ()
+setVersion n = rawExecute "PRAGMA user_version = ?" [toPersistValue n]
+-}
+
+createEntityIfNeeded
+    :: (Monad proxy, MonadIO m, PersistRecordBackend record SqlBackend)
+    => proxy record -> SqlPersistT m ()
+createEntityIfNeeded p = runMigration $ migrate [] (entityDef p)
+
+createCellIfNeeded
+    :: forall m a. (MonadIO m, PersistFieldSql a)
+    => Proxy a -> SqlPersistT m ()
+createCellIfNeeded p = do
+    r <-
+        rawSql
+            "SELECT name FROM sqlite_schema WHERE type='table' AND name=?"
+            [PersistText "cell"]
+    case r  of
+        [] ->
+            let query = T.concat
+                    ["CREATE TABLE cell(id INTEGER PRIMARY KEY, value "
+                    , showSqlType $ sqlType p
+                    , " NOT NULL)"
+                    ]
+            in  rawExecute query []
+        [Single (_ :: a)] -> pure ()
+        _ -> error "Multiple cell tables in sqlite_schema"
+
+model :: QuasiQuoter
+model = PS.model ""
+
+modelFile :: FilePath -> Q Exp
+modelFile = PS.modelFile ""
+
+-- | Declare datatypes and a 'PeristEntity' instance, from the entity
+-- definition produced by 'model' or 'modelFile'
+makeBox :: [PT.EntityDef] -> Q [Dec]
+makeBox [e] = PS.makeEntities [e]
+makeBox _   = fail "makeBox requires exactly 1 entity"
+
+newtype BoxPersistT r m a = BoxPersistT (SqlPersistT m a)
+    deriving (Functor, Applicative, Monad, MonadIO, MonadTrans)
+
+class Boxable a where
+    --type MonadMigrateBox :: (* -> *) -> Constraint
+    --type MigrationRecipes a :: * -> *
+    --migrateBox :: (MonadIO m, MonadLogger m, MonadMigrateBox m) => MigrationRecipe a m -> SqlPersistT m (Either Text (Int, Int))
+    createBoxStorageIfNeeded :: MonadIO m => Proxy a -> SqlPersistT m ()
+    bestowB :: MonadIO m => a -> SqlPersistT m ()
+    obtainB :: MonadIO m => SqlPersistT m a
+
+class BoxableFormat (f :: Type -> Type) where
+    wrapBF :: a -> f a
+    unwrapBF :: f a -> a
+
+class (BoxableFormat (BV a), Boxable (BV a a)) => BoxableVia a where
+    type BV a :: Type -> Type
+
+bestow' :: (MonadIO m, Boxable a) => a -> BoxPersistT a m ()
+bestow' = BoxPersistT . bestowB
+
+obtain' :: (MonadIO m, Boxable a) => BoxPersistT a m a
+obtain' = BoxPersistT obtainB
+
+bestow :: forall m a. (MonadIO m, BoxableVia a) => a -> BoxPersistT a m ()
+bestow = BoxPersistT . bestowB . wrapBF @(BV a) @a
+
+obtain :: forall m a. (MonadIO m, BoxableVia a) => BoxPersistT a m a
+obtain = BoxPersistT $ unwrapBF @(BV a) @a <$> obtainB
+
+newtype BoxableRecord a = BoxableRecord { unBoxableRecord :: a }
+
+instance BoxableFormat BoxableRecord where
+    wrapBF = BoxableRecord
+    unwrapBF = unBoxableRecord
+
+keyN :: Int64
+keyN = 1
+
+key :: ToBackendKey SqlBackend record => Key record
+key = toSqlKey keyN
+
+instance (PersistRecordBackend a SqlBackend, ToBackendKey SqlBackend a) => Boxable (BoxableRecord a) where
+    --type MigrationRecipe (BoxablePersist a) m = [Migration SqlBackend m]
+    --migrateBox ms = second (,length ms) <$> runMigrations schemaBackend? "" 1 ms
+    createBoxStorageIfNeeded = createEntityIfNeeded . fmap unBoxableRecord
+    bestowB (BoxableRecord r) = repsert key r
+    obtainB = BoxableRecord <$> getJust key
+
+newtype BoxableField a = BoxableField { unBoxableField :: a }
+
+instance BoxableFormat BoxableField where
+    wrapBF = BoxableField
+    unwrapBF = unBoxableField
+
+newtype BoxException = BoxException Text deriving Show
+
+instance Exception BoxException
+
+instance PersistFieldSql a => Boxable (BoxableField a) where
+    --type MigrationRecipe (BoxablePersist a) = ???
+    --migrateBox ms = ???
+    createBoxStorageIfNeeded = createCellIfNeeded . fmap unBoxableField
+    bestowB (BoxableField v) =
+        rawExecute query [toPersistValue keyN, toPersistValue v]
+        where
+        query =
+            "INSERT INTO cell(id,value) VALUES (?,?)\
+            \ ON CONFLICT (id) DO UPDATE SET value=EXCLUDED.value"
+    obtainB = do
+        r <- rawSql query [toPersistValue keyN]
+        case r of
+            [] -> liftIO $ throwIO $ BoxException "obtainB: row not found"
+            [Single v] -> return $ BoxableField v
+            _ -> liftIO $ throwIO $ BoxException "obtainB: multiple rows found"
+        where
+        query = "SELECT value FROM cell WHERE id=?"
+
+{-
+adapt :: BoxPersistT x m a -> BoxPersistT y m a
+adapt (BoxPersistT action) = BoxPersistT action
+-}
+
+newtype WrapShow a = WrapShow { unWrapShow :: a }
+
+instance (Typeable a, Show a, Read a) => PersistField (WrapShow a) where
+    toPersistValue = toPersistValue . show . unWrapShow
+    fromPersistValue v = do
+        s <- fromPersistValue v
+        case readEither s of
+            Left e' ->
+                Left $ T.pack $
+                    "Invalid " ++ show (typeRep @a) ++ ": " ++
+                    e' ++ ": " ++ s
+            Right x -> Right $ WrapShow x
+
+instance PersistField (WrapShow a) => PersistFieldSql (WrapShow a) where
+    sqlType _ = sqlType (Proxy :: Proxy String)
+
+newtype BoxableShow a = BoxableShow { unBoxableShow :: a }
+
+instance BoxableFormat BoxableShow where
+    wrapBF = BoxableShow
+    unwrapBF = unBoxableShow
+
+instance (Typeable a, Show a, Read a) => Boxable (BoxableShow a) where
+    --type MigrationRecipe (BoxablePersist a) = ???
+    --migrateBox ms = ???
+    createBoxStorageIfNeeded =
+        createCellIfNeeded . fmap (WrapShow . unBoxableShow)
+    bestowB = bestowB . BoxableField . WrapShow . unBoxableShow
+    obtainB = BoxableShow . unWrapShow . unBoxableField <$> obtainB
+
+newtype WrapJSON a = WrapJSON { unWrapJSON :: a }
+
+instance (Typeable a, A.FromJSON a, A.ToJSON a) => PersistField (WrapJSON a) where
+    toPersistValue = PersistText . toJsonText . unWrapJSON
+    fromPersistValue v = do
+        text <- fromPersistValue v
+        let bs = TE.encodeUtf8 text
+        case A.eitherDecodeStrict' bs of
+            Left e ->
+                Left $
+                    T.concat
+                        [ "JSON decoding error for "
+                        , T.pack $ show $ typeRep @a
+                        , ": ", T.pack e, " on input: ", text
+                        ]
+            Right x -> Right $ WrapJSON x
+
+instance PersistField (WrapJSON a) => PersistFieldSql (WrapJSON a) where
+    sqlType _ = SqlString
+
+newtype BoxableJSON a = BoxableJSON { unBoxableJSON :: a }
+
+instance BoxableFormat BoxableJSON where
+    wrapBF = BoxableJSON
+    unwrapBF = unBoxableJSON
+
+instance (Typeable a, A.FromJSON a, A.ToJSON a) => Boxable (BoxableJSON a) where
+    --type MigrationRecipe (BoxablePersist a) = ???
+    --migrateBox ms = ???
+    createBoxStorageIfNeeded =
+        createCellIfNeeded . fmap (WrapJSON . unBoxableJSON)
+    bestowB = bestowB . BoxableField . WrapJSON . unBoxableJSON
+    obtainB = BoxableJSON . unWrapJSON . unBoxableField <$> obtainB
+
+newtype WrapSerialize a = WrapSerialize { unWrapSerialize :: a }
+
+instance (Typeable a, S.Serialize a) => PersistField (WrapSerialize a) where
+    toPersistValue = toPersistValue . S.encode . unWrapSerialize
+    fromPersistValue v = do
+        b <- fromPersistValue v
+        case S.decode b of
+            Left e ->
+                Left $ T.pack $ "Invalid " ++ show (typeRep @a) ++ ": " ++ e
+            Right x -> Right $ WrapSerialize x
+
+instance PersistField (WrapSerialize a) => PersistFieldSql (WrapSerialize a) where
+    sqlType _ = sqlType (Proxy :: Proxy ByteString)
+
+newtype BoxableSerialize a = BoxableSerialize { unBoxableSerialize :: a }
+
+instance BoxableFormat BoxableSerialize where
+    wrapBF = BoxableSerialize
+    unwrapBF = unBoxableSerialize
+
+instance (Typeable a, S.Serialize a) => Boxable (BoxableSerialize a) where
+    --type MigrationRecipe (BoxablSerialize a) = ???
+    --migrateBox ms = ???
+    createBoxStorageIfNeeded =
+        createCellIfNeeded . fmap (WrapSerialize . unBoxableSerialize)
+    bestowB = bestowB . BoxableField . WrapSerialize . unBoxableSerialize
+    obtainB = BoxableSerialize . unWrapSerialize . unBoxableField <$> obtainB
+
+data Box a = Box SqliteConnectionInfo ConnectionPool
+
+type OsPath = FilePath
+decodeUtf = pure
+
+loadBox
+    :: (MonadLoggerIO m, MonadUnliftIO m, BoxableVia a)
+    => OsPath -> a -> m (Box a)
+loadBox path val = do
+    path' <- liftIO $ T.pack <$> decodeUtf path
+    let info = mkSqliteConnectionInfo path'
+    pool <- createSqlitePoolFromInfo info 1
+    let box = Box info pool
+    withBox box $ do
+        let proxy :: a -> Proxy (BV a a)
+            proxy _ = Proxy
+        BoxPersistT $ createBoxStorageIfNeeded $ proxy val
+        {-
+        r <- migrateBox migrations
+            Left err -> do
+                let msg = "DB migration failed: " <> path' <> ": " <> err
+                logError msg
+                error $ T.unpack msg
+            Right (from, to) -> do
+                logInfo $ T.concat
+                    [ "DB migration success: ", path', ": "
+                    , T.pack $ show from, " ==> ", T.pack $ show to
+                    ]
+                mval <- get key
+                when (isNothing val) $ insertKey key val
+        -}
+    return box
+
+withBox :: MonadUnliftIO m => Box record -> BoxPersistT record m a -> m a
+withBox (Box info pool) (BoxPersistT action) = runPool conf action pool
+    where
+    conf = SqliteConfInfo info 1
+
+class (Monad m, BoxableVia (BoxType m)) => MonadBox m where
+    type BoxType m
+    askBox :: m (Box (BoxType m))
+
+runBox :: (MonadUnliftIO m, MonadBox m) => BoxPersistT (BoxType m) m a -> m a
+runBox action = do
+    box <- askBox
+    withBox box action
+
+data BoxView a = BoxView SqliteConf ConnectionPool
+
+createBoxView :: (MonadLoggerIO m, MonadUnliftIO m) => Box record -> Int -> m (BoxView record)
+createBoxView (Box info _) size = do
+    pool <- createSqlitePoolFromInfo info size
+    let conf = SqliteConfInfo info size
+    return $ BoxView conf pool
+
+viewBox :: (MonadUnliftIO m, Boxable a) => BoxView a -> m a
+viewBox (BoxView conf pool) = runPool conf obtainB pool

src/Database/Persist/Box/Via.hs

@@ -0,0 +1,34 @@
+{- This file is part of Vervis.
+ -
+ - Written in 2023 by fr33domlover <fr33domlover@riseup.net>.
+ -
+ - ♡ Copying is an act of love. Please copy, reuse and share.
+ -
+ - The author(s) have dedicated all copyright and related and neighboring
+ - rights to this software to the public domain worldwide. This software is
+ - distributed without any warranty.
+ -
+ - You should have received a copy of the CC0 Public Domain Dedication along
+ - with this software. If not, see
+ - <http://creativecommons.org/publicdomain/zero/1.0/>.
+ -}
+
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE UndecidableInstances #-}
+
+module Database.Persist.Box.Via
+    (
+    )
+where
+
+import Data.Kind
+
+import Database.Persist.Box.Internal
+
+{-
+instance BoxableVia a => Boxable a where
+    createBoxStorageIfNeeded = createBoxStorageIfNeeded . fmap (wrapBF @(BV a) @a)
+    bestowB = bestowB . wrapBF @(BV a) @a
+    obtainB = unwrapBF @(BV a) @a <$> obtainB
+-}

src/Database/Persist/Sqlite/Local.hs

@@ -0,0 +1,47 @@
+{-
+Copied from persistent-sqlite 2.13.1.1 which is under MIT license
+
+Copyright (c) 2012 Michael Snoyman, http://www.yesodweb.com/
+
+Permission is hereby granted, free of charge, to any person obtaining
+a copy of this software and associated documentation files (the
+"Software"), to deal in the Software without restriction, including
+without limitation the rights to use, copy, modify, merge, publish,
+distribute, sublicense, and/or sell copies of the Software, and to
+permit persons to whom the Software is furnished to do so, subject to
+the following conditions:
+
+The above copyright notice and this permission notice shall be
+included in all copies or substantial portions of the Software.
+
+THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
+LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
+OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
+WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+-}
+
+module Database.Persist.Sqlite.Local
+    ( showSqlType
+    )
+where
+
+import Data.Text (Text)
+import Database.Persist.Sql
+
+import qualified Data.Text as T
+
+showSqlType :: SqlType -> Text
+showSqlType SqlString = "VARCHAR"
+showSqlType SqlInt32 = "INTEGER"
+showSqlType SqlInt64 = "INTEGER"
+showSqlType SqlReal = "REAL"
+showSqlType (SqlNumeric precision scale) = T.concat [ "NUMERIC(", T.pack (show precision), ",", T.pack (show scale), ")" ]
+showSqlType SqlDay = "DATE"
+showSqlType SqlTime = "TIME"
+showSqlType SqlDayTime = "TIMESTAMP"
+showSqlType SqlBlob = "BLOB"
+showSqlType SqlBool = "BOOLEAN"
+showSqlType (SqlOther t) = t

src/Network/FedURI.hs

@@ -65,7 +65,7 @@ data Authority t = Authority
     { authorityHost :: Text
     , authorityPort :: Maybe Word16
     }
-    deriving (Eq, Ord, Generic)
+    deriving (Eq, Ord, Show, Generic)
 
 instance UriMode t => Hashable (Authority t)
 
@@ -185,7 +185,7 @@ instance PersistFieldSql FullURI where
 data LocalURI = LocalURI
     { localUriPath :: Text
     }
-    deriving (Eq, Ord, Generic)
+    deriving (Eq, Ord, Show, Read, Generic)
 
 instance Hashable LocalURI
 
@@ -459,7 +459,7 @@ data ObjURI t = ObjURI
     { objUriAuthority :: Authority t
     , objUriLocal     :: LocalURI
     }
-    deriving (Eq, Generic)
+    deriving (Eq, Show, Generic)
 
 instance UriMode t => Hashable (ObjURI t)
 

src/Vervis/Access.hs

@@ -1,6 +1,6 @@
 {- This file is part of Vervis.
  -
- - Written in 2019, 2022 by fr33domlover <fr33domlover@riseup.net>.
+ - Written in 2019, 2022, 2023 by fr33domlover <fr33domlover@riseup.net>.
  -
  - ♡ Copying is an act of love. Please copy, reuse and share.
  -
@@ -67,6 +67,8 @@ module Vervis.Access
     , unhashGrantResourcePure
     , unhashGrantResource
     , unhashGrantResourceE
+    , unhashGrantResource'
+    , unhashGrantResourceE'
     , unhashGrantResource404
     , hashGrantResource
     , getGrantResource
@@ -96,6 +98,8 @@ import Yesod.Core.Handler
 
 import qualified Database.Esqueleto as E
 
+import Control.Concurrent.Actor
+import Web.Actor.Persist (stageHashidsContext)
 import Yesod.Hashids
 import Yesod.MonadSite
 
@@ -285,6 +289,13 @@ unhashGrantResource resource = do
 unhashGrantResourceE resource e =
     ExceptT $ maybe (Left e) Right <$> unhashGrantResource resource
 
+unhashGrantResource' resource = do
+    ctx <- asksEnv stageHashidsContext
+    return $ unhashGrantResourcePure ctx resource
+
+unhashGrantResourceE' resource e =
+    ExceptT $ maybe (Left e) Right <$> unhashGrantResource' resource
+
 unhashGrantResource404 = maybe notFound return <=< unhashGrantResource
 
 hashGrantResource (GrantResourceRepo k) =

src/Vervis/ActivityPub.hs

@@ -101,6 +101,7 @@ import Database.Persist.Local
 
 import qualified Data.Patch.Local as P
 
+import Vervis.Actor
 import Vervis.FedURI
 import Vervis.Foundation
 import Vervis.Model
@@ -109,13 +110,6 @@ import Vervis.RemoteActorStore
 import Vervis.Settings
 import Vervis.Time
 
-data RemoteRecipient = RemoteRecipient
-    { remoteRecipientActor      :: RemoteActorId
-    , remoteRecipientId         :: LocalURI
-    , remoteRecipientInbox      :: LocalURI
-    , remoteRecipientErrorSince :: Maybe UTCTime
-    }
-
 {-
 getFollowers :: FollowerSetId -> AppDB ([PersonId], [((InstanceId, Host), NonEmpty RemoteRecipient)])
 getFollowers fsid = do

src/Vervis/Actor.hs

@@ -13,6 +13,8 @@
  - <http://creativecommons.org/publicdomain/zero/1.0/>.
  -}
 
+{-# LANGUAGE RankNTypes #-}
+
 -- These are for the Barbie-based generated instances
 {-# LANGUAGE DeriveAnyClass #-}
 {-# LANGUAGE DeriveGeneric #-}
@@ -24,6 +26,20 @@ module Vervis.Actor
       LocalActorBy (..)
     , LocalActor
 
+      -- * Converting between KeyHashid, Key, Identity and Entity
+      --
+      -- Adapted from 'Vervis.Recipient'
+    , hashLocalActorPure
+    , getHashLocalActor
+    , hashLocalActor
+
+    , unhashLocalActorPure
+    , unhashLocalActor
+    , unhashLocalActorF
+    , unhashLocalActorM
+    , unhashLocalActorE
+    , unhashLocalActor404
+
       -- * Local recipient set
     , TicketRoutes (..)
     , ClothRoutes (..)
@@ -55,33 +71,57 @@ module Vervis.Actor
     , withDB
     , withDBExcept
     , behave
+
+    , RemoteRecipient (..)
+    , sendToLocalActors
     )
 where
 
+import Control.Concurrent.STM.TVar
 import Control.Monad.IO.Class
 import Control.Monad.Trans.Class
+import Control.Monad.Trans.Maybe
 import Control.Monad.Trans.Except
+import Control.Monad.Trans.Reader
 import Data.Barbie
 import Data.ByteString (ByteString)
+import Data.Foldable
+import Data.Function
 import Data.Hashable
+import Data.List.NonEmpty (NonEmpty)
+import Data.Maybe
 import Data.Text (Text)
 import Data.Time.Clock
+import Data.Traversable
+import Data.Typeable
 import Database.Persist.Sql
 import GHC.Generics
 import UnliftIO.Exception
 import Web.Hashids
+import Yesod.Core
 
+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.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
 import Web.Actor.Persist
+import Yesod.Hashids
+import Yesod.MonadSite
 
 import qualified Web.ActivityPub as AP
 
+import Data.List.NonEmpty.Local
+
 import Vervis.FedURI
 import Vervis.Model hiding (Actor, Message)
 import Vervis.Settings
@@ -101,6 +141,77 @@ deriving instance AllBF Show f LocalActorBy => Show (LocalActorBy f)
 
 type LocalActor = LocalActorBy KeyHashid
 
+hashLocalActorPure
+    :: HashidsContext -> LocalActorBy Key -> LocalActorBy KeyHashid
+hashLocalActorPure ctx = f
+    where
+    f (LocalActorPerson p) = LocalActorPerson $ encodeKeyHashidPure ctx p
+    f (LocalActorGroup g)  = LocalActorGroup $ encodeKeyHashidPure ctx g
+    f (LocalActorRepo r)   = LocalActorRepo $ encodeKeyHashidPure ctx r
+    f (LocalActorDeck d)   = LocalActorDeck $ encodeKeyHashidPure ctx d
+    f (LocalActorLoom l)   = LocalActorLoom $ encodeKeyHashidPure ctx l
+
+getHashLocalActor
+    :: (MonadActor m, StageHashids (ActorEnv m))
+    => m (LocalActorBy Key -> LocalActorBy KeyHashid)
+getHashLocalActor = do
+    ctx <- asksEnv stageHashidsContext
+    return $ hashLocalActorPure ctx
+
+hashLocalActor
+    :: (MonadActor m, StageHashids (ActorEnv m))
+    => LocalActorBy Key -> m (LocalActorBy KeyHashid)
+hashLocalActor actor = do
+    hash <- getHashLocalActor
+    return $ hash actor
+
+unhashLocalActorPure
+    :: HashidsContext -> LocalActorBy KeyHashid -> Maybe (LocalActorBy Key)
+unhashLocalActorPure ctx = f
+    where
+    f (LocalActorPerson p) = LocalActorPerson <$> decodeKeyHashidPure ctx p
+    f (LocalActorGroup g)  = LocalActorGroup <$> decodeKeyHashidPure ctx g
+    f (LocalActorRepo r)   = LocalActorRepo <$> decodeKeyHashidPure ctx r
+    f (LocalActorDeck d)   = LocalActorDeck <$> decodeKeyHashidPure ctx d
+    f (LocalActorLoom l)   = LocalActorLoom <$> decodeKeyHashidPure ctx l
+
+unhashLocalActor
+    :: (MonadActor m, StageHashids (ActorEnv 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))
+    => LocalActorBy KeyHashid -> String -> m (LocalActorBy Key)
+unhashLocalActorF actor e = maybe (F.fail e) return =<< unhashLocalActor actor
+
+unhashLocalActorM
+    :: (MonadActor m, StageHashids (ActorEnv m))
+    => LocalActorBy KeyHashid -> MaybeT m (LocalActorBy Key)
+unhashLocalActorM = MaybeT . unhashLocalActor
+
+unhashLocalActorE
+    :: (MonadActor m, StageHashids (ActorEnv m))
+    => LocalActorBy KeyHashid -> e -> ExceptT e m (LocalActorBy Key)
+unhashLocalActorE actor e =
+    ExceptT $ maybe (Left e) Right <$> unhashLocalActor actor
+
+unhashLocalActor404
+    :: ( MonadSite m
+       , MonadHandler m
+       , HandlerSite m ~ SiteEnv m
+       , YesodHashids (HandlerSite m)
+       )
+    => LocalActorBy KeyHashid
+    -> m (LocalActorBy Key)
+unhashLocalActor404 actor = maybe notFound return =<< unhashLocalActor actor
+    where
+    unhashLocalActor byHash = do
+        ctx <- asksSite siteHashidsContext
+        return $ unhashLocalActorPure ctx byHash
+
 data TicketRoutes = TicketRoutes
     { routeTicketFollowers :: Bool
     }
@@ -182,8 +293,13 @@ data VerseRemote = VerseRemote
     }
 
 data Event
-    = EventFwdRemoteGrantToSomeoneElse RemoteActivityId
+    = EventRemoteGrantLocalRecipFwdToFollower RemoteActivityId
+    -- ^ A local actor has received a Grant (they're being granted some access)
+    --   and forwarding it to me because I'm following this local actor
     | EventRemoteFwdLocalActivity (LocalActorBy Key) OutboxItemId
+    -- EventLocalFwdRemoteActivity (LocalActorBy Key) RemoteActivityId
+    -- ^ A local actor is forwarding me a remote activity to add to my inbox.
+    --   The data is (1) who's forwarding to me (2) the remote activity
     | EventUnknown
     deriving Show
 
@@ -200,6 +316,8 @@ instance Message Verse where
         let ObjURI h _ = remoteAuthorURI author
         in  renderObjURI $ ObjURI h uri
 
+type YesodRender y = Route y -> [(Text, Text)] -> Text
+
 -- | 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
@@ -207,13 +325,22 @@ instance Message Verse where
 -- 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 = Env
+data Env = forall y. (Typeable y, Yesod y) => Env
-    { envSettings       :: AppSettings
+    { envSettings        :: AppSettings
-    , envDbPool         :: ConnectionPool
+    , envDbPool          :: ConnectionPool
-    , envHashidsContext :: HashidsContext
+    , envHashidsContext  :: HashidsContext
+    , envActorKeys       :: Maybe (TVar (ActorKey, ActorKey, Bool))
+    , envDeliveryTheater :: DeliveryTheater URIMode
+    --, envYesodSite       :: y
+    , envYesodRender     :: YesodRender y
     }
+    deriving Typeable
 
 instance Stage Env where
     type StageKey Env     = LocalActorBy Key
@@ -222,7 +349,9 @@ instance Stage Env where
 
 instance StageWeb Env where
     type StageURIMode Env = URIMode
+    --type StageRoute Env = Route Site
     stageInstanceHost = appInstanceHost . envSettings
+    stageDeliveryTheater = envDeliveryTheater
 
 instance StageHashids Env where
     stageHashidsContext = envHashidsContext
@@ -269,3 +398,249 @@ behave handler key msg = do
     case result of
         Left e -> done $ Left e
         Right (t, after, next) -> return (Right t, after, next)
+
+data RemoteRecipient = RemoteRecipient
+    { remoteRecipientActor      :: RemoteActorId
+    , remoteRecipientId         :: LocalURI
+    , remoteRecipientInbox      :: LocalURI
+    , remoteRecipientErrorSince :: Maybe UTCTime
+    }
+
+-- Given a list of local recipients, which may include actors and collections,
+--
+-- * Insert activity to message queues of live actors
+-- * If collections are listed, insert activity to message queues of local
+--   members and return the remote members
+--
+-- This function reads the follower sets and remote recipient data from the
+-- PostgreSQL database. Don't use it inside a database transaction.
+sendToLocalActors
+    :: Event
+    -- ^ Event to send to local live actors
+    -> Bool
+    -- ^ Whether to deliver to collection only if owner actor is addressed
+    -> Maybe (LocalActorBy Key)
+    -- ^ An actor whose collections are excluded from requiring an owner, i.e.
+    --   even if owner is required, this actor's collections will be delivered
+    --   to, even if this actor isn't addressed. This is meant to be the
+    --   activity's author.
+    -> Maybe (LocalActorBy Key)
+    -- ^ An actor whose inbox to exclude from delivery, even if this actor is
+    --   listed in the recipient set. This is meant to be the activity's
+    --   author.
+    -> RecipientRoutes
+    -> Act [((InstanceId, Host), NonEmpty RemoteRecipient)]
+sendToLocalActors event requireOwner mauthor maidAuthor recips = do
+
+    -- Unhash actor and work item hashids
+    people <- unhashKeys $ recipPeople recips
+    groups <- unhashKeys $ recipGroups recips
+    repos <- unhashKeys $ recipRepos recips
+    decksAndTickets <- do
+        decks <- unhashKeys $ recipDecks recips
+        for decks $ \ (deckID, (DeckFamilyRoutes deck tickets)) ->
+            (deckID,) . (deck,) <$> unhashKeys tickets
+    loomsAndCloths <- do
+        looms <- unhashKeys $ recipLooms recips
+        for looms $ \ (loomID, (LoomFamilyRoutes loom cloths)) ->
+            (loomID,) . (loom,) <$> unhashKeys cloths
+
+    -- Grab local actor sets whose stages are allowed for delivery
+    let allowStages'
+            :: (famili -> routes)
+            -> (routes -> Bool)
+            -> (Key record -> LocalActorBy Key)
+            -> (Key record, famili)
+            -> Bool
+        allowStages' = allowStages isAuthor
+
+        peopleForStages =
+            filter (allowStages' id routePerson LocalActorPerson) people
+        groupsForStages =
+            filter (allowStages' id routeGroup LocalActorGroup) groups
+        reposForStages =
+            filter (allowStages' id routeRepo LocalActorRepo) repos
+        decksAndTicketsForStages =
+            filter (allowStages' fst routeDeck LocalActorDeck) decksAndTickets
+        loomsAndClothsForStages =
+            filter (allowStages' fst routeLoom LocalActorLoom) loomsAndCloths
+
+    -- Grab local actors being addressed
+    let localActorsForSelf = concat
+            [ [ LocalActorPerson key | (key, routes) <- people, routePerson routes ]
+            , [ LocalActorGroup key | (key, routes) <- groups, routeGroup routes ]
+            , [ LocalActorRepo key | (key, routes) <- repos, routeRepo routes ]
+            , [ LocalActorDeck key | (key, (routes, _)) <- decksAndTickets, routeDeck routes ]
+            , [ LocalActorLoom key | (key, (routes, _)) <- loomsAndCloths, routeLoom routes ]
+            ]
+
+    -- Grab local actors whose followers are going to be delivered to
+    let personIDsForFollowers =
+            [ key | (key, routes) <- peopleForStages, routePersonFollowers routes ]
+        groupIDsForFollowers =
+            [ key | (key, routes) <- groupsForStages, routeGroupFollowers routes ]
+        repoIDsForFollowers =
+            [ key | (key, routes) <- reposForStages, routeRepoFollowers routes ]
+        deckIDsForFollowers =
+            [ key | (key, (routes, _)) <- decksAndTicketsForStages, routeDeckFollowers routes ]
+        loomIDsForFollowers =
+            [ key | (key, (routes, _)) <- loomsAndClothsForStages, routeLoomFollowers routes ]
+
+    -- Grab tickets and cloths whose followers are going to be delivered to
+    let ticketSetsForFollowers =
+            mapMaybe
+                (\ (deckID, (_, tickets)) -> (deckID,) <$>
+                        NE.nonEmpty
+                        [ ticketDeckID | (ticketDeckID, routes) <- tickets
+                                       , routeTicketFollowers routes
+                        ]
+                )
+                decksAndTicketsForStages
+        clothSetsForFollowers =
+            mapMaybe
+                (\ (loomID, (_, cloths)) -> (loomID,) <$>
+                        NE.nonEmpty
+                        [ ticketLoomID | (ticketLoomID, routes) <- cloths
+                                       , routeClothFollowers routes
+                        ]
+                )
+                loomsAndClothsForStages
+
+    (localFollowers, remoteFollowers) <- withDB $ do
+        -- Get actor and work item FollowerSet IDs from DB
+        followerSetIDs <- do
+            actorIDs <- concat <$> sequenceA
+                [ selectActorIDs personActor personIDsForFollowers
+                , selectActorIDs groupActor groupIDsForFollowers
+                , selectActorIDs repoActor repoIDsForFollowers
+                , selectActorIDs deckActor deckIDsForFollowers
+                , selectActorIDs loomActor loomIDsForFollowers
+                ]
+            ticketIDs <-
+                concat <$>
+                    ((++)
+                        <$> traverse
+                                (selectTicketIDs ticketDeckTicket TicketDeckDeck)
+                                ticketSetsForFollowers
+                        <*> traverse
+                                (selectTicketIDs ticketLoomTicket TicketLoomLoom)
+                                clothSetsForFollowers
+                    )
+            (++)
+                <$> (map (actorFollowers . entityVal) <$>
+                        selectList [ActorId <-. actorIDs] []
+                    )
+                <*> (map (ticketFollowers . entityVal) <$>
+                        selectList [TicketId <-. ticketIDs] []
+                    )
+
+        -- Get the local and remote followers of the follower sets from DB
+        locals <- concat <$> sequenceA
+                [ selectFollowers LocalActorPerson PersonActor followerSetIDs
+                , selectFollowers LocalActorGroup  GroupActor  followerSetIDs
+                , selectFollowers LocalActorRepo   RepoActor   followerSetIDs
+                , selectFollowers LocalActorDeck   DeckActor   followerSetIDs
+                , selectFollowers LocalActorLoom   LoomActor   followerSetIDs
+                ]
+        remotes <- getRemoteFollowers followerSetIDs
+        return (locals, remotes)
+
+    -- Insert activity to message queues of all local live actors who are
+    -- recipients, i.e. either directly addressed or listed in a local stage
+    -- addressed
+    let liveRecips =
+            let s = HS.fromList $ localFollowers ++ localActorsForSelf
+            in  case maidAuthor of
+                    Nothing -> s
+                    Just a -> HS.delete a s
+    sendMany liveRecips $ Left event
+
+    -- Return remote followers, to whom we need to deliver via HTTP
+    return remoteFollowers
+    where
+    orderedUnion = foldl' LO.union []
+
+    unhashKeys
+        :: ToBackendKey SqlBackend record
+        => [(KeyHashid record, routes)]
+        -> Act [(Key record, routes)]
+    unhashKeys actorSets = do
+        unhash <- decodeKeyHashidPure <$> asksEnv stageHashidsContext
+        return $ mapMaybe (unhashKey unhash) actorSets
+        where
+        unhashKey unhash (hash, famili) = (,famili) <$> unhash hash
+
+    isAuthor =
+        case mauthor of
+            Nothing -> const False
+            Just author -> (== author)
+
+    allowStages
+        :: (LocalActorBy Key -> Bool)
+        -> (famili -> routes)
+        -> (routes -> Bool)
+        -> (Key record -> LocalActorBy Key)
+        -> (Key record, famili)
+        -> Bool
+    allowStages isAuthor familyActor routeActor makeActor (actorID, famili)
+        =  routeActor (familyActor famili)
+        || not requireOwner
+        || isAuthor (makeActor actorID)
+
+    selectActorIDs
+        :: (MonadIO m, PersistRecordBackend record SqlBackend)
+        => (record -> ActorId)
+        -> [Key record]
+        -> ReaderT SqlBackend m [ActorId]
+    selectActorIDs grabActor ids =
+        map (grabActor . entityVal) <$> selectList [persistIdField <-. ids] []
+
+    selectTicketIDs
+        :: ( MonadIO m
+           , PersistRecordBackend tracker SqlBackend
+           , PersistRecordBackend item SqlBackend
+           )
+        => (item -> TicketId)
+        -> EntityField item (Key tracker)
+        -> (Key tracker, NonEmpty (Key item))
+        -> ReaderT SqlBackend m [TicketId]
+    selectTicketIDs grabTicket trackerField (trackerID, workItemIDs) = do
+        maybeTracker <- get trackerID
+        case maybeTracker of
+            Nothing -> pure []
+            Just _ ->
+                map (grabTicket . entityVal) <$>
+                    selectList [persistIdField <-. NE.toList workItemIDs, trackerField ==. trackerID] []
+
+    getRemoteFollowers
+        :: MonadIO m
+        => [FollowerSetId]
+        -> ReaderT SqlBackend m
+            [((InstanceId, Host), NonEmpty RemoteRecipient)]
+    getRemoteFollowers fsids =
+        fmap groupRemotes $
+            E.select $ E.from $ \ (rf `E.InnerJoin` ra `E.InnerJoin` ro `E.InnerJoin` i) -> do
+                E.on $ ro E.^. RemoteObjectInstance E.==. i E.^. InstanceId
+                E.on $ ra E.^. RemoteActorIdent E.==. ro E.^. RemoteObjectId
+                E.on $ rf E.^. RemoteFollowActor E.==. ra E.^. RemoteActorId
+                E.where_ $ rf E.^. RemoteFollowTarget `E.in_` E.valList fsids
+                E.orderBy [E.asc $ i E.^. InstanceId, E.asc $ ra E.^. RemoteActorId]
+                return
+                    ( i E.^. InstanceId
+                    , i E.^. InstanceHost
+                    , ra E.^. RemoteActorId
+                    , ro E.^. RemoteObjectIdent
+                    , ra E.^. RemoteActorInbox
+                    , ra E.^. RemoteActorErrorSince
+                    )
+        where
+        groupRemotes = groupWithExtractBy ((==) `on` fst) fst snd . map toTuples
+            where
+            toTuples (E.Value iid, E.Value h, E.Value raid, E.Value luA, E.Value luI, E.Value ms) = ((iid, h), RemoteRecipient raid luA luI ms)
+
+    selectFollowers makeLocalActor actorField followerSetIDs =
+        fmap (map (makeLocalActor . E.unValue)) $
+        E.select $ E.from $ \ (f `E.InnerJoin` p) -> do
+            E.on $ f E.^. FollowActor E.==. p E.^. actorField
+            E.where_ $ f E.^. FollowTarget `E.in_` E.valList followerSetIDs
+            return $ p E.^. persistIdField

src/Vervis/Actor/Person.hs

@@ -26,10 +26,12 @@ import Control.Monad.Trans.Class
 import Control.Monad.Trans.Except
 import Control.Monad.Trans.Maybe
 import Control.Monad.Trans.Reader
+import Data.Bitraversable
 import Data.ByteString (ByteString)
 import Data.Foldable
 import Data.Text (Text)
 import Data.Time.Clock
+import Data.Traversable
 import Database.Persist
 import Database.Persist.Sql
 import Yesod.Persist.Core
@@ -38,6 +40,7 @@ import qualified Data.Text as T
 
 import Control.Concurrent.Actor
 import Network.FedURI
+import Web.Actor.Persist
 import Yesod.MonadSite
 
 import qualified Web.ActivityPub as AP
@@ -46,28 +49,23 @@ import Control.Monad.Trans.Except.Local
 import Database.Persist.Local
 
 import Vervis.Actor
+import Vervis.Actor2
 import Vervis.Cloth
+import Vervis.Data.Collab
 import Vervis.Data.Discussion
 import Vervis.FedURI
 import Vervis.Federation.Util
 import Vervis.Foundation
 import Vervis.Model
+import Vervis.Recipient (makeRecipientSet, LocalStageBy (..))
 import Vervis.Persist.Actor
+import Vervis.Persist.Collab
 import Vervis.Persist.Discussion
 import Vervis.Ticket
 
-insertActivityToInbox
+------------------------------------------------------------------------------
-    :: MonadIO m
+-- Commenting
-    => UTCTime -> ActorId -> OutboxItemId -> ReaderT SqlBackend m Bool
+------------------------------------------------------------------------------
-insertActivityToInbox now recipActorID outboxItemID = do
-    inboxID <- actorInbox <$> getJust recipActorID
-    inboxItemID <- insert $ InboxItem True now
-    maybeItem <- insertUnique $ InboxItemLocal inboxID outboxItemID inboxItemID
-    case maybeItem of
-        Nothing -> do
-            delete inboxItemID
-            return False
-        Just _ -> return True
 
 -- Meaning: Someone commented on an issue/PR
 -- Behavior: Insert to inbox
@@ -79,7 +77,7 @@ personCreateNote
     -> Maybe (RecipientRoutes, ByteString)
     -> LocalURI
     -> AP.Note URIMode
-    -> ExceptT Text Act (Text, Act (), Next)
+    -> ActE (Text, Act (), Next)
 personCreateNote now recipPersonID author body mfwd luCreate note = do
 
     -- Check input
@@ -145,10 +143,109 @@ personCreateNote now recipPersonID author body mfwd luCreate note = do
                         unless (messageRoot m == did) $
                             throwE "Remote parent belongs to a different discussion"
 
+------------------------------------------------------------------------------
+-- Access
+------------------------------------------------------------------------------
+
+-- Meaning: A remote actor published a Grant
+-- Behavior:
+--      * Insert to my inbox
+--      * If I'm the target, forward the Grant to my followers
+personGrant
+    :: UTCTime
+    -> PersonId
+    -> RemoteAuthor
+    -> ActivityBody
+    -> Maybe (RecipientRoutes, ByteString)
+    -> LocalURI
+    -> AP.Grant URIMode
+    -> ActE (Text, Act (), Next)
+personGrant now recipPersonID author body mfwd luGrant grant = do
+
+    -- Check input
+    (_remoteResource, recipient) <- do
+        (resource, recip) <- parseGrant grant
+        let u@(ObjURI h _) = remoteAuthorURI author
+        resourceURI <-
+            case resource of
+                Right (ObjURI h' r) | h == h' -> return (u, r)
+                _ -> throwE "Grant resource and Grant author are from different instances"
+        when (recip == Right u) $
+            throwE "Grant sender and target are the same remote actor"
+        return (resourceURI, recip)
+
+    maybeGrant <- withDBExcept $ do
+
+        -- Grab recipient person from DB
+        (personRecip, actorRecip) <- lift $ do
+            p <- getJust recipPersonID
+            (p,) <$> getJust (personActor p)
+
+        mractid <- lift $ insertToInbox now author body (actorInbox actorRecip) luGrant True
+        for mractid $ \ grantID -> do
+
+            -- If recipient is local, find it in our DB
+            _recipientDB <-
+                bitraverse
+                    (flip getGrantRecip "Grant local target not found in DB")
+                    pure
+                    recipient
+
+            return (personActor personRecip, grantID)
+
+    case maybeGrant of
+        Nothing -> done "I already have this activity in my inbox"
+        Just (actorID, grantID) -> do
+            let targetIsRecip =
+                    case recipient of
+                        Left (GrantRecipPerson p) -> p == recipPersonID
+                        _ -> False
+            if not targetIsRecip
+                then done "I'm not the target; Inserted to inbox"
+                else case mfwd of
+                    Nothing ->
+                        done
+                            "I'm the target; Inserted to inbox; \
+                            \Forwarding not approved"
+                    Just (localRecips, sig) -> do
+                        recipHash <- encodeKeyHashid recipPersonID
+                        let sieve =
+                                makeRecipientSet
+                                    []
+                                    [LocalStagePersonFollowers recipHash]
+                        lift $ forwardActivity
+                            (actbBL body) localRecips sig
+                            actorID
+                            (LocalActorPerson recipPersonID) sieve
+                            (EventRemoteGrantLocalRecipFwdToFollower grantID)
+                        done
+                            "I'm the target; Inserted to inbox; \
+                            \Forwarded to followers if addressed"
+
+------------------------------------------------------------------------------
+-- Main behavior function
+------------------------------------------------------------------------------
+
+insertActivityToInbox
+    :: MonadIO m
+    => UTCTime -> ActorId -> OutboxItemId -> ReaderT SqlBackend m Bool
+insertActivityToInbox now recipActorID outboxItemID = do
+    inboxID <- actorInbox <$> getJust recipActorID
+    inboxItemID <- insert $ InboxItem True now
+    maybeItem <- insertUnique $ InboxItemLocal inboxID outboxItemID inboxItemID
+    case maybeItem of
+        Nothing -> do
+            delete inboxItemID
+            return False
+        Just _ -> return True
+
 personBehavior :: UTCTime -> PersonId -> Verse -> ActE (Text, Act (), Next)
 personBehavior now personID (Left event) =
     case event of
-        EventFwdRemoteGrantToSomeoneElse grantID -> do
+        -- Meaning: Someone X received a Grant and forwarded it to me because
+        --          I'm a follower of X
+        -- Behavior: Insert to my inbox
+        EventRemoteGrantLocalRecipFwdToFollower grantID -> do
             lift $ withDB $ do
                 (_personRecip, actorRecip) <- do
                     p <- getJust personID
@@ -157,6 +254,8 @@ personBehavior now personID (Left event) =
                 itemID <- insert $ InboxItem True now
                 insert_ $ InboxItemRemote inboxID grantID itemID
             done "Inserted Grant to inbox"
+        -- Meaning: A remote actor has forwarded to me a remote activity
+        -- Behavior: Insert it to my inbox
         EventRemoteFwdLocalActivity authorByKey outboxItemID -> withDBExcept $ do
                 recipPerson <- lift $ getJust personID
                 verifyLocalActivityExistsInDB authorByKey outboxItemID
@@ -179,8 +278,10 @@ personBehavior now personID (Right (VerseRemote author body mfwd luActivity)) =
         {-
         AP.FollowActivity follow ->
             personFollowA now personID author body mfwd luActivity follow
+        -}
         AP.GrantActivity grant ->
-            personGrantA now personID author body mfwd luActivity grant
+            personGrant now personID author body mfwd luActivity grant
+        {-
         AP.InviteActivity invite ->
             personInviteA now personID author body mfwd luActivity invite
         AP.UndoActivity undo ->

src/Vervis/Actor2.hs

@@ -0,0 +1,294 @@
+{- This file is part of Vervis.
+ -
+ - Written in 2019, 2020, 2022, 2023 by fr33domlover <fr33domlover@riseup.net>.
+ -
+ - ♡ Copying is an act of love. Please copy, reuse and share.
+ -
+ - The author(s) have dedicated all copyright and related and neighboring
+ - rights to this software to the public domain worldwide. This software is
+ - distributed without any warranty.
+ -
+ - You should have received a copy of the CC0 Public Domain Dedication along
+ - with this software. If not, see
+ - <http://creativecommons.org/publicdomain/zero/1.0/>.
+ -}
+
+-- For the ugly existential-type trick that avoids Env depending on App
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
+
+-- | Everything I'd put in 'Vervis.Actor' but currently depends on
+-- 'Vervis.Foundation', and therefore needs a separate module.
+module Vervis.Actor2
+    ( -- * Sending messages to actors
+      sendActivity
+    , forwardActivity
+    )
+where
+
+import Control.Concurrent.STM.TVar
+import Control.Monad.IO.Class
+import Control.Monad.Trans.Class
+import Control.Monad.Trans.Except
+import Data.Barbie
+import Data.ByteString (ByteString)
+import Data.Either
+import Data.Hashable
+import Data.List.NonEmpty (NonEmpty)
+import Data.Text (Text)
+import Data.Time.Clock
+import Data.Traversable
+import Data.Typeable
+import Database.Persist.Sql
+import GHC.Generics
+import UnliftIO.Exception
+import Web.Hashids
+
+import qualified Data.Aeson as A
+import qualified Data.ByteString.Lazy as BL
+import qualified Data.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 Web.ActivityPub as AP
+
+import Vervis.Actor
+import Vervis.Data.Actor
+import Vervis.FedURI
+import Vervis.Foundation
+import Vervis.Model hiding (Actor, Message)
+import Vervis.Recipient (renderLocalActor, localRecipSieve')
+import Vervis.Settings
+
+instance StageWebRoute Env where
+    type StageRoute Env = Route App
+    askUrlRenderParams = do
+        Env _ _ _ _ _ render <- askEnv
+        case cast render of
+            Nothing -> error "Env site isn't App"
+            Just r -> pure r
+    pageParamName _ = "page"
+
+askLatestInstanceKey :: Act (Maybe (Route App, ActorKey))
+askLatestInstanceKey = do
+    maybeTVar <- asksEnv envActorKeys
+    for maybeTVar $ \ tvar -> do
+        (akey1, akey2, new1) <- liftIO $ readTVarIO tvar
+        return $
+            if new1
+                then (ActorKey1R, akey1)
+                else (ActorKey2R, akey2)
+
+prepareSendIK
+    :: (Route App, 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
+        actorR = renderLocalActor actorByHash
+        idR = activityRoute actorByHash itemHash
+    prepareToSend keyR sign True actorR idR action
+
+prepareSendAK
+    :: ActorId
+    -> LocalActorBy KeyHashid
+    -> OutboxItemId
+    -> AP.Action URIMode
+    -> ActDB (AP.Envelope URIMode)
+prepareSendAK actorID actorByHash itemID action = do
+    Entity keyID key <- do
+        mk <- getBy $ UniqueSigKey actorID
+        case mk of
+            Nothing -> error "Actor has no keys!"
+            Just k -> return k
+    itemHash <- encodeKeyHashid itemID
+    keyHash <- encodeKeyHashid keyID
+    let keyR = stampRoute actorByHash keyHash
+        sign = actorKeySign $ sigKeyMaterial key
+        actorR = renderLocalActor actorByHash
+        idR = activityRoute actorByHash itemHash
+    prepareToSend keyR sign False actorR idR action
+
+prepareSendP
+    :: ActorId
+    -> LocalActorBy KeyHashid
+    -> OutboxItemId
+    -> AP.Action URIMode
+    -> ActDB (AP.Envelope URIMode)
+prepareSendP actorID actorByHash itemID action = do
+    maybeKey <- lift askLatestInstanceKey
+    case maybeKey of
+        Nothing -> prepareSendAK actorID actorByHash itemID action
+        Just key -> lift $ prepareSendIK key actorByHash itemID action
+
+prepareSendH
+    :: ActorId
+    -> LocalActorBy KeyHashid
+    -> OutboxItemId
+    -> AP.Action URIMode
+    -> Act (AP.Envelope URIMode)
+prepareSendH actorID actorByHash itemID action = do
+    maybeKey <- askLatestInstanceKey
+    case maybeKey of
+        Nothing -> withDB $ prepareSendAK actorID actorByHash itemID action
+        Just key -> prepareSendIK key actorByHash itemID action
+
+-- | Given a list of local and remote recipients, which may include actors and
+-- collections,
+--
+-- * Insert event to message queues of local actors listed
+-- * Insert event to message queues of local members of local collections
+--   listed
+-- * Launch asynchronously sending activity to remote recipients and remote
+--   member of local collections listed
+--
+-- This function reads the follower sets, remote recipient data and the
+-- sender's signing key from the PostgreSQL database. Don't use it inside a
+-- database transaction.
+sendActivity
+    :: LocalActorBy Key
+    -- ^ Activity author and sender
+    --
+    -- * Its collections are excluded from requiring an owner, i.e.
+    --   even if owner is required, this actor's collections will be delivered
+    --   to, even if this actor isn't addressed
+    -- * Its inbox is excluded from delivery, even if this actor is listed in
+    --   the recipient set
+    -> ActorId
+    -- ^ Actor key for the sender, for fetching its signing key from the DB
+    -> RecipientRoutes
+    -- ^ Local recipients
+    -> [(Host, NonEmpty LocalURI)]
+    -- ^ Remote recipients
+    -> [Host]
+    -- ^ Instances for which the sender is approving to forward this activity
+    -> OutboxItemId
+    -- ^ DB ID of the item in the author's outbox
+    -> Event
+    -- ^ Event to send to local live actors
+    -> AP.Action URIMode
+    -- ^ Activity to send to remote actors
+    -> Act ()
+sendActivity senderByKey senderActorID localRecips remoteRecips fwdHosts itemID event action = do
+    moreRemoteRecips <-
+        let justSender = Just senderByKey
+        in  sendToLocalActors event True justSender justSender localRecips
+    envelope <- do
+        senderByHash <- hashLocalActor senderByKey
+        prepareSendH senderActorID senderByHash itemID action
+    let (yesFwd, noFwd) =
+            let remoteRecipsList =
+                    concatMap
+                        (\ ((_, h), rrs) -> NE.toList $ NE.map (decideFwd h . remoteRecipientId) rrs)
+                        moreRemoteRecips
+                moreList =
+                    concatMap
+                        (\ (h, lus) -> NE.toList $ NE.map (decideFwd h) lus)
+                        remoteRecips
+                allRemotes = remoteRecipsList ++ moreList
+            in  partitionEithers allRemotes
+    dt <- asksEnv stageDeliveryTheater
+    liftIO $ do
+        sendHttp dt (MethodDeliverLocal envelope True) yesFwd
+        sendHttp dt (MethodDeliverLocal envelope False) noFwd
+    where
+    decideFwd h =
+        if h `elem` fwdHosts
+            then Left . ObjURI h
+            else Right . ObjURI h
+
+prepareForwardIK
+    :: (Route App, ActorKey)
+    -> LocalActorBy KeyHashid
+    -> BL.ByteString
+    -> ByteString
+    -> Act (AP.Errand URIMode)
+prepareForwardIK (keyR, akey) fwderByHash body proof = do
+    let sign = actorKeySign akey
+        fwderR = renderLocalActor fwderByHash
+    prepareToForward keyR sign True fwderR body proof
+
+prepareForwardAK
+    :: ActorId
+    -> LocalActorBy KeyHashid
+    -> BL.ByteString
+    -> ByteString
+    -> ActDB (AP.Errand URIMode)
+prepareForwardAK actorID fwderByHash body proof = do
+    Entity keyID key <- do
+        mk <- getBy $ UniqueSigKey actorID
+        case mk of
+            Nothing -> error "Actor has no keys!"
+            Just k -> return k
+    keyHash <- encodeKeyHashid keyID
+    let keyR = stampRoute fwderByHash keyHash
+        sign = actorKeySign $ sigKeyMaterial key
+        fwderR = renderLocalActor fwderByHash
+    prepareToForward keyR sign False fwderR body proof
+
+prepareForwardP
+    :: ActorId
+    -> LocalActorBy KeyHashid
+    -> BL.ByteString
+    -> ByteString
+    -> ActDB (AP.Errand URIMode)
+prepareForwardP actorID fwderByHash body proof = do
+    maybeKey <- lift askLatestInstanceKey
+    case maybeKey of
+        Nothing -> prepareForwardAK actorID fwderByHash body proof
+        Just key -> lift $ prepareForwardIK key fwderByHash body proof
+
+prepareForwardH
+    :: ActorId
+    -> LocalActorBy KeyHashid
+    -> BL.ByteString
+    -> ByteString
+    -> Act (AP.Errand URIMode)
+prepareForwardH actorID fwderByHash body proof = do
+    maybeKey <- askLatestInstanceKey
+    case maybeKey of
+        Nothing -> withDB $ prepareForwardAK actorID fwderByHash body proof
+        Just key -> prepareForwardIK key fwderByHash body proof
+
+-- | Given a list of local recipients, which may include actors and
+-- collections,
+--
+-- * Insert event to message queues of actors listed
+-- * Insert event to message queues of local members of collections listed
+-- * Launch asynchronously sending activity, with a forwarded signature, to
+--   remote member of collections listed
+--
+-- This function reads remote recipient data and the sender's signing key from
+-- the PostgreSQL database. Don't use it inside a database transaction.
+forwardActivity
+    :: BL.ByteString
+    -> RecipientRoutes
+    -> ByteString
+    -> ActorId
+    -> LocalActorBy Key
+    -> RecipientRoutes
+    -> Event
+    -> Act ()
+forwardActivity body localRecips sig fwderActorID fwderByKey sieve event = do
+    remoteRecips <-
+        let localRecipsFinal = localRecipSieve' sieve False False localRecips
+            justSender = Just fwderByKey
+        in  sendToLocalActors event False justSender justSender localRecipsFinal
+    errand <- do
+        fwderByHash <- hashLocalActor fwderByKey
+        prepareForwardH fwderActorID fwderByHash body sig
+    let remoteRecipsList =
+            concatMap
+                (\ ((_, h), rrs) -> NE.toList $ NE.map (ObjURI h . remoteRecipientId) rrs)
+                remoteRecips
+    dt <- asksEnv stageDeliveryTheater
+    liftIO $ sendHttp dt (MethodForwardRemote errand) remoteRecipsList

src/Vervis/Application.hs

@@ -16,6 +16,8 @@
 
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 
+{- LANGUAGE RankNTypes #-}
+
 module Vervis.Application
     ( getApplicationDev
     , appMain
@@ -92,6 +94,8 @@ import Crypto.ActorKey
 import Data.KeyFile
 import Development.PatchMediaType
 import Network.FedURI
+import Web.Actor.Deliver
+import Yesod.ActivityPub
 import Yesod.Hashids
 import Yesod.MonadSite
 
@@ -188,9 +192,6 @@ makeFoundation appSettings = do
 
     appActorFetchShare <- newResultShare actorFetchShareAction
 
-    -- Temporarily blank actor map, we'll replace it in a moment
-    --appTheatre <- startTheater (error "logFunc") (error "env") []
-
     appActivities <-
         case appInboxDebugReportLength appSettings of
             Nothing -> return Nothing
@@ -239,15 +240,25 @@ makeFoundation appSettings = do
         migrate "Vervis" $ migrateDB hLocal hashidsCtx
         migrate "Dvara" $ migrateDvara (Proxy :: Proxy App) schemaBackend
         verifyRepoDir
-        fixRunningDeliveries
+        --fixRunningDeliveries
         deleteUnusedURAs
         writePostReceiveHooks
         writePostApplyHooks
 
     -- Launch actor threads and fill the actor map
-    actors <- flip runWorker app $ runSiteDB loadTheatre
+    let delieryStateDir = appDeliveryStateDir appSettings
-    let env = Env appSettings pool hashidsCtx
+    exists <- doesDirectoryExist delieryStateDir
-    theater <- startTheater logFunc env actors
+    unless exists $ error $ "delivery-state-dir not found: " ++ delieryStateDir
+    delivery <- do
+        micros <- intervalMicros $ appDeliveryRetryBase appSettings
+        startDeliveryTheater
+            (sitePostSignedHeaders app) micros appHttpManager logFunc delieryStateDir
+    let root = renderObjURI $ flip ObjURI topLocalURI $ appInstanceHost appSettings
+        --render :: Yesod y => y -> Route y -> [(Text, Text)] -> Text
+        render = yesodRender app root
+        env = Env appSettings pool hashidsCtx appActorKeys delivery render
+    actors <- flip runWorker app $ runSiteDB $ loadTheater env
+    theater <- startTheater logFunc actors
 
     let hostString = T.unpack $ renderAuthority hLocal
     writeHookConfig hostString Config
@@ -276,6 +287,8 @@ makeFoundation appSettings = do
                 " [" ++ T.unpack (versionControlSystemName vcs) ++ "]"
     reposFromDir = do
         dir <- askRepoRootDir
+        exists <- liftIO $ doesDirectoryExist dir
+        unless exists $ error $ "repo-dir not found: " ++ dir
         subdirs <- liftIO $ sort <$> listDirectory dir
         for subdirs $ \ subdir -> do
             checkDir $ dir </> subdir
@@ -322,7 +335,8 @@ makeFoundation appSettings = do
                     , T.pack $ show from, " ==> ", T.pack $ show to
                     ]
 
-    loadTheatre = concat <$> sequenceA
+    loadTheater :: Env -> WorkerDB [(LocalActorBy Key, Env, Verse -> Act (Either Text Text, Act (), Next))]
+    loadTheater env = concat <$> sequenceA
         [ selectAll LocalActorPerson personBehavior
         , selectAll LocalActorGroup  groupBehavior
         , selectAll LocalActorRepo   repoBehavior
@@ -333,10 +347,10 @@ makeFoundation appSettings = do
         selectAll
             :: PersistRecordBackend a SqlBackend
             => (Key a -> LocalActorBy Key)
-            -> (UTCTime -> Key a -> Verse -> ExceptT Text Act (Text, Act (), Next))
+            -> (UTCTime -> Key a -> Verse -> ActE (Text, Act (), Next))
-            -> WorkerDB [(LocalActorBy Key, Verse -> Act (Either Text Text, Act (), Next))]
+            -> WorkerDB [(LocalActorBy Key, Env, Verse -> Act (Either Text Text, Act (), Next))]
         selectAll makeLocalActor behavior =
-            map (\ xid -> (makeLocalActor xid, behave behavior xid)) <$>
+            map (\ xid -> (makeLocalActor xid, env, behave behavior xid)) <$>
                 selectKeysList [] []
 
 -- | Convert our foundation to a WAI Application by calling @toWaiAppPlain@ and
@@ -396,10 +410,12 @@ actorKeyPeriodicRotator :: App -> Maybe (IO ())
 actorKeyPeriodicRotator app =
     actorKeyRotator (appActorKeyRotation $ appSettings app) <$> appActorKeys app
 
+{-
 deliveryRunner :: App -> IO ()
 deliveryRunner app =
     let interval = appDeliveryRetryFreq $ appSettings app
     in  runWorker (periodically interval retryOutboxDelivery) app
+-}
 
 sshServer :: App -> IO ()
 sshServer foundation =
@@ -452,8 +468,11 @@ appMain = do
     runWorker fillPerActorKeys foundation
 
     -- Run periodic activity delivery retry runner
+    -- Disabled because we're using the DeliveryTheater now
+    {-
     when (appFederation $ appSettings foundation) $
         forkCheck $ deliveryRunner foundation
+    -}
 
     -- Run SSH server
     forkCheck $ sshServer foundation

src/Vervis/Data/Actor.hs

@@ -40,6 +40,7 @@ import qualified Data.HashMap.Strict as HM
 import qualified Data.Text as T
 
 import Network.FedURI
+import Web.Actor
 import Yesod.ActivityPub
 import Yesod.Actor
 import Yesod.FedURI

src/Vervis/Data/Collab.hs

@@ -40,18 +40,22 @@ import Data.Text (Text)
 import Database.Persist.Types
 import GHC.Generics
 
+import Control.Concurrent.Actor
 import Network.FedURI
+import Web.Actor
+import Web.Actor.Persist
 import Yesod.ActivityPub
 import Yesod.Actor
 import Yesod.FedURI
 import Yesod.Hashids
-import Yesod.MonadSite
+import Yesod.MonadSite (asksSite)
 
 import qualified Web.ActivityPub as AP
 
 import Control.Monad.Trans.Except.Local
 
 import Vervis.Access
+import Vervis.Actor
 import Vervis.Data.Actor
 import Vervis.FedURI
 import Vervis.Foundation
@@ -75,10 +79,17 @@ unhashGrantRecipPure ctx = f
     f (GrantRecipPerson p) =
         GrantRecipPerson <$> decodeKeyHashidPure ctx p
 
-unhashGrantRecip resource = do
+unhashGrantRecipOld resource = do
     ctx <- asksSite siteHashidsContext
     return $ unhashGrantRecipPure ctx resource
 
+unhashGrantRecip resource = do
+    ctx <- asksEnv stageHashidsContext
+    return $ unhashGrantRecipPure ctx resource
+
+unhashGrantRecipEOld resource e =
+    ExceptT $ maybe (Left e) Right <$> unhashGrantRecipOld resource
+
 unhashGrantRecipE resource e =
     ExceptT $ maybe (Left e) Right <$> unhashGrantRecip resource
 
@@ -122,7 +133,7 @@ parseInvite sender (AP.Invite instrument object target) = do
                         (parseGrantRecip route)
                         "Not a grant recipient route"
                 recipKey <-
-                    unhashGrantRecipE
+                    unhashGrantRecipEOld
                         recipHash
                         "Contains invalid hashid"
                 case recipKey of
@@ -146,7 +157,7 @@ parseJoin (AP.Join instrument object) = do
 
 parseGrant
     :: AP.Grant URIMode
-    -> ExceptT Text Handler
+    -> ActE
         ( Either (GrantResourceBy Key) FedURI
         , Either (GrantRecipBy Key) FedURI
         )
@@ -159,7 +170,7 @@ parseGrant (AP.Grant object context target) = do
     verifyRole (Right _) =
         throwE "ForgeFed Admin is the only role allowed currently"
     parseContext u@(ObjURI h lu) = do
-        hl <- hostIsLocalOld h
+        hl <- hostIsLocal h
         if hl
             then Left <$> do
                 route <-
@@ -170,7 +181,7 @@ parseGrant (AP.Grant object context target) = do
                     fromMaybeE
                         (parseGrantResource route)
                         "Grant context isn't a shared resource route"
-                unhashGrantResourceE
+                unhashGrantResourceE'
                     resourceHash
                     "Grant resource contains invalid hashid"
             else pure $ Right u
@@ -180,7 +191,7 @@ parseGrant (AP.Grant object context target) = do
         parseGrantResource (LoomR l) = Just $ GrantResourceLoom l
         parseGrantResource _         = Nothing
     parseTarget u@(ObjURI h lu) = do
-        hl <- hostIsLocalOld h
+        hl <- hostIsLocal h
         if hl
             then Left <$> do
                 route <-

src/Vervis/Data/Discussion.hs

@@ -33,6 +33,7 @@ import Data.Time.Clock
 
 import Control.Concurrent.Actor
 import Network.FedURI
+import Web.Actor
 import Web.Actor.Persist
 import Web.Text
 import Yesod.ActivityPub
@@ -46,6 +47,7 @@ import qualified Yesod.Hashids as YH
 import Control.Monad.Trans.Except.Local
 
 import Vervis.Actor
+import Vervis.Actor2
 import Vervis.Data.Actor
 import Vervis.FedURI
 import Vervis.Foundation

src/Vervis/Federation/Auth.hs

@@ -95,7 +95,7 @@ import Data.Tuple.Local
 import Database.Persist.Local
 import Yesod.Persist.Local
 
-import Vervis.Actor
+import Vervis.Actor (RemoteAuthor (..), ActivityBody (..))
 import Vervis.ActivityPub
 import Vervis.Data.Actor
 import Vervis.FedURI

src/Vervis/Federation/Collab.hs

@@ -16,8 +16,8 @@
 {-# LANGUAGE RankNTypes #-}
 
 module Vervis.Federation.Collab
-    ( personInviteF
+    ( --personInviteF
-    , topicInviteF
+      topicInviteF
 
     , repoJoinF
     , deckJoinF
@@ -27,7 +27,7 @@ module Vervis.Federation.Collab
     , deckAcceptF
     , loomAcceptF
 
-    , personGrantF
+    --, personGrantF
     )
 where
 
@@ -76,7 +76,7 @@ import Yesod.Persist.Local
 
 import Vervis.Access
 import Vervis.ActivityPub
-import Vervis.Actor
+import Vervis.Actor (RemoteAuthor (..), ActivityBody (..))
 import Vervis.Data.Actor
 import Vervis.Data.Collab
 import Vervis.Web.Delivery
@@ -90,100 +90,6 @@ import Vervis.Persist.Collab
 import Vervis.Recipient
 import Vervis.RemoteActorStore
 
-personInviteF
-    :: UTCTime
-    -> KeyHashid Person
-    -> RemoteAuthor
-    -> ActivityBody
-    -> Maybe (RecipientRoutes, ByteString)
-    -> LocalURI
-    -> AP.Invite URIMode
-    -> ExceptT Text Handler (Text, Maybe (ExceptT Text Worker Text))
-personInviteF now recipHash author body mfwd luInvite invite = (,Nothing) <$> do
-
-    -- Check input
-    (resourceAndCap, recipient) <- do
-
-        -- Check the invite-specific data
-        (resource, recip) <-
-            parseInvite (Right $ remoteAuthorURI author) invite
-
-        -- Verify the capability URI is one of:
-        --   * Outbox item URI of a local actor, i.e. a local activity
-        --   * A remote URI
-        capability <- do
-            let muCap = AP.activityCapability $ actbActivity body
-            uCap <- fromMaybeE muCap "No capability provided"
-            nameExceptT "Invite capability" $ parseActivityURI uCap
-
-        -- Verify that capability is either a local activity of a local
-        -- resource, or both resource and capability are of the same remote
-        -- instance
-        (,recip) <$> case (resource, capability) of
-            (Left r, Left (actor, _, item)) -> do
-                unless (grantResourceLocalActor r == actor) $
-                    throwE "Local capability belongs to actor that isn't the resource"
-                return $ Left (r, item)
-            (Left _, Right _) ->
-                throwE "Remote capability obviously doesn't belong to local resource"
-            (Right _, Left _) ->
-                throwE "Local capability obviously doesn't belong to remote resource"
-            (Right (ObjURI h r), Right (ObjURI h' c)) -> do
-                unless (h == h') $
-                    throwE "Capability and resource are on different remote instances"
-                return $ Right (ObjURI h r, c)
-
-    -- Find recipient person in DB, returning 404 if doesn't exist because
-    -- we're in the person's inbox post handler
-    personRecipID <- decodeKeyHashid404 recipHash
-    mhttp <- runDBExcept $ do
-        (personRecip, actorRecip) <- lift $ do
-            p <- get404 personRecipID
-            (p,) <$> getJust (personActor p)
-
-        mractid <- lift $ insertToInbox now author body (actorInbox actorRecip) luInvite True
-        for mractid $ \ inviteID -> do
-
-            -- If resource is local, find it in our DB
-            _resourceDB <-
-                bitraverse
-                    (flip getGrantResource "Invite local target not found in DB" . fst)
-                    pure
-                    resourceAndCap
-
-            -- If recipient is local, find it in our DB
-            _recipientDB <-
-                bitraverse
-                    (flip getGrantRecip "Invite local object not found in DB")
-                    pure
-                    recipient
-
-            -- Forward the Invite activity to relevant local stages, and
-            -- schedule delivery for unavailable remote members of them
-            lift $ for mfwd $ \ (localRecips, sig) -> do
-                let inviteeIsRecip =
-                        case recipient of
-                            Left (GrantRecipPerson p) -> p == personRecipID
-                            _ -> False
-                    sieve =
-                        if inviteeIsRecip
-                            then makeRecipientSet [] [LocalStagePersonFollowers recipHash]
-                            else makeRecipientSet [] []
-                forwardActivityDB
-                    (actbBL body) localRecips sig (personActor personRecip)
-                    (LocalActorPerson recipHash) sieve inviteID
-
-    -- Launch asynchronous HTTP forwarding of the Invite activity
-    case mhttp of
-        Nothing -> return "I already have this activity in my inbox, doing nothing"
-        Just maybeForwardHttpInvite -> do
-            for_ maybeForwardHttpInvite $
-                forkWorker "personInviteF inbox-forwarding"
-            return $
-                case maybeForwardHttpInvite of
-                    Nothing -> "Inserted to inbox, no inbox-forwarding to do"
-                    Just _ -> "Inserted to inbox and ran inbox-forwarding of the Invite"
-
 topicInviteF
     :: UTCTime
     -> GrantResourceBy KeyHashid
@@ -681,69 +587,3 @@ loomAcceptF
     -> AP.Accept URIMode
     -> ExceptT Text Handler (Text, Maybe (ExceptT Text Worker Text))
 loomAcceptF = topicAcceptF loomActor GrantResourceLoom
-
-personGrantF
-    :: UTCTime
-    -> KeyHashid Person
-    -> RemoteAuthor
-    -> ActivityBody
-    -> Maybe (RecipientRoutes, ByteString)
-    -> LocalURI
-    -> AP.Grant URIMode
-    -> ExceptT Text Handler (Text, Maybe (ExceptT Text Worker Text))
-personGrantF now recipHash author body mfwd luGrant grant = (,Nothing) <$> do
-
-    -- Check input
-    (_remoteResource, recipient) <- do
-        (resource, recip) <- parseGrant grant
-        let u@(ObjURI h _) = remoteAuthorURI author
-        resourceURI <-
-            case resource of
-                Right (ObjURI h' r) | h == h' -> return (u, r)
-                _ -> throwE "Grant resource and Grant author are from different instances"
-        when (recip == Right u) $
-            throwE "Grant sender and target are the same remote actor"
-        return (resourceURI, recip)
-
-    -- Find recipient person in DB, returning 404 if doesn't exist because
-    -- we're in the person's inbox post handler
-    personRecipID <- decodeKeyHashid404 recipHash
-    mhttp <- runDBExcept $ do
-        (personRecip, actorRecip) <- lift $ do
-            p <- get404 personRecipID
-            (p,) <$> getJust (personActor p)
-
-        mractid <- lift $ insertToInbox now author body (actorInbox actorRecip) luGrant True
-        for mractid $ \ grantID -> do
-
-            -- If recipient is local, find it in our DB
-            _recipientDB <-
-                bitraverse
-                    (flip getGrantRecip "Grant local target not found in DB")
-                    pure
-                    recipient
-
-            -- Forward the Grant activity to relevant local stages, and
-            -- schedule delivery for unavailable remote members of them
-            lift $ for mfwd $ \ (localRecips, sig) -> do
-                let targetIsRecip =
-                        case recipient of
-                            Left (GrantRecipPerson p) -> p == personRecipID
-                            _ -> False
-                    sieve =
-                        if targetIsRecip
-                            then makeRecipientSet [] [LocalStagePersonFollowers recipHash]
-                            else makeRecipientSet [] []
-                forwardActivityDB
-                    (actbBL body) localRecips sig (personActor personRecip)
-                    (LocalActorPerson recipHash) sieve grantID
-
-    -- Launch asynchronous HTTP forwarding of the Grant activity
-    case mhttp of
-        Nothing -> return "I already have this activity in my inbox, doing nothing"
-        Just mhttpFwd -> do
-            for_ mhttpFwd $ forkWorker "personGrantF inbox-forwarding"
-            return $
-                case mhttpFwd of
-                    Nothing -> "Inserted to inbox, no inbox-forwarding to do"
-                    Just _ -> "Inserted to inbox and ran inbox-forwarding of the Grant"

src/Vervis/Foundation.hs

@@ -155,9 +155,6 @@ type TicketDeckKeyHashid        = KeyHashid TicketDeck
 type TicketLoomKeyHashid        = KeyHashid TicketLoom
 type SigKeyKeyHashid            = KeyHashid SigKey
 
-instance StageYesod Env where
-    type StageSite Env = App
-
 -- This is where we define all of the routes in our application. For a full
 -- explanation of the syntax, please see:
 -- http://www.yesodweb.com/book/routing-and-handlers

src/Vervis/Recipient.hs

@@ -131,7 +131,14 @@ import qualified Web.ActivityPub as AP
 import Data.List.Local
 import Data.List.NonEmpty.Local
 
-import Vervis.Actor
+import Vervis.Actor hiding
+    ( getHashLocalActor
+    , hashLocalActor
+    , unhashLocalActor
+    , unhashLocalActorF
+    , unhashLocalActorM
+    , unhashLocalActorE
+    )
 import Vervis.FedURI
 import Vervis.Foundation
 import Vervis.Model
@@ -248,16 +255,6 @@ localActorFollowers (LocalActorLoom l)   = LocalStageLoomFollowers l
 -- Converting between KeyHashid, Key, Identity and Entity
 -------------------------------------------------------------------------------
 
-hashLocalActorPure
-    :: HashidsContext -> LocalActorBy Key -> LocalActorBy KeyHashid
-hashLocalActorPure ctx = f
-    where
-    f (LocalActorPerson p) = LocalActorPerson $ encodeKeyHashidPure ctx p
-    f (LocalActorGroup g)  = LocalActorGroup $ encodeKeyHashidPure ctx g
-    f (LocalActorRepo r)   = LocalActorRepo $ encodeKeyHashidPure ctx r
-    f (LocalActorDeck d)   = LocalActorDeck $ encodeKeyHashidPure ctx d
-    f (LocalActorLoom l)   = LocalActorLoom $ encodeKeyHashidPure ctx l
-
 getHashLocalActor
     :: (MonadSite m, YesodHashids (SiteEnv m))
     => m (LocalActorBy Key -> LocalActorBy KeyHashid)
@@ -272,16 +269,6 @@ hashLocalActor actor = do
     hash <- getHashLocalActor
     return $ hash actor
 
-unhashLocalActorPure
-    :: HashidsContext -> LocalActorBy KeyHashid -> Maybe (LocalActorBy Key)
-unhashLocalActorPure ctx = f
-    where
-    f (LocalActorPerson p) = LocalActorPerson <$> decodeKeyHashidPure ctx p
-    f (LocalActorGroup g)  = LocalActorGroup <$> decodeKeyHashidPure ctx g
-    f (LocalActorRepo r)   = LocalActorRepo <$> decodeKeyHashidPure ctx r
-    f (LocalActorDeck d)   = LocalActorDeck <$> decodeKeyHashidPure ctx d
-    f (LocalActorLoom l)   = LocalActorLoom <$> decodeKeyHashidPure ctx l
-
 unhashLocalActor
     :: (MonadSite m, YesodHashids (SiteEnv m))
     => LocalActorBy KeyHashid -> m (Maybe (LocalActorBy Key))
@@ -305,16 +292,6 @@ unhashLocalActorE
 unhashLocalActorE actor e =
     ExceptT $ maybe (Left e) Right <$> unhashLocalActor actor
 
-unhashLocalActor404
-    :: ( MonadSite m
-       , MonadHandler m
-       , HandlerSite m ~ SiteEnv m
-       , YesodHashids (HandlerSite m)
-       )
-    => LocalActorBy KeyHashid
-    -> m (LocalActorBy Key)
-unhashLocalActor404 actor = maybe notFound return =<< unhashLocalActor actor
-
 hashLocalStagePure
     :: HashidsContext -> LocalStageBy Key -> LocalStageBy KeyHashid
 hashLocalStagePure ctx = f

src/Vervis/Settings.hs

@@ -90,6 +90,8 @@ data AppSettings = AppSettings
       -- | Maximal number of keys (personal keys or usage of shared keys) to
       -- remember cached in our database per remote actor.
     , appMaxActorKeys           :: Maybe Int
+      -- | Path of the directory in which DeliveryTheater actor state is stored
+    , appDeliveryStateDir       :: FilePath
       -- | The instance's host (e.g. \"dev.angeley.es\"). Used for determining
       -- which requests are remote and which are for this instance, and for
       -- generating URLs. The database relies on this value, and you shouldn't
@@ -183,9 +185,11 @@ data AppSettings = AppSettings
       -- we periodically retry to deliver them activities. After that period of
       -- time, we stop trying to deliver and we remove them from follower lists
       -- of local actors.
+      --
+      -- TODO this probably isn't working anymore since the switch to DeliveryTheater
     , appDropDeliveryAfter        :: NominalDiffTime
-      -- | How much time to wait between retries of failed deliveries.
+      -- | Base time to wait before first retry of a failed delivery.
-    , appDeliveryRetryFreq        :: TimeInterval
+    , appDeliveryRetryBase        :: TimeInterval
       -- | How many activities to remember in the debug report list, showing
       -- latest activities received in local inboxes and the result of their
       -- processing. 'Nothing' means disable the report page entirely.
@@ -210,6 +214,7 @@ instance FromJSON AppSettings where
         appDatabaseConf           <- o .: "database"
         appMaxInstanceKeys        <- o .:? "max-instance-keys"
         appMaxActorKeys           <- o .:? "max-actor-keys"
+        appDeliveryStateDir       <- o .: "delivery-state-dir"
         port                      <- o .: "http-port"
         appInstanceHost           <- do
             h <- o .: "instance-host"
@@ -252,7 +257,7 @@ instance FromJSON AppSettings where
         appHashidsSaltFile          <- o .: "hashids-salt-file"
         appRejectOnMaxKeys          <- o .: "reject-on-max-keys"
         appDropDeliveryAfter        <- ndt <$> o .: "drop-delivery-after"
-        appDeliveryRetryFreq        <- interval <$> o .: "retry-delivery-every"
+        appDeliveryRetryBase        <- interval <$> o .: "retry-delivery-base"
         appInboxDebugReportLength   <- o .:? "activity-debug-reports"
         appInstances                <- o .:? "instances" .!= []
 

src/Vervis/Web/Actor.hs

@@ -95,7 +95,7 @@ import Yesod.Persist.Local
 import qualified Data.Aeson.Encode.Pretty.ToEncoding as P
 import qualified Web.ActivityPub as AP
 
-import Vervis.Actor
+import Vervis.Actor (RemoteAuthor (..), ActivityBody (..), VerseRemote (..), Event (..))
 import Vervis.ActivityPub
 import Vervis.API
 import Vervis.Data.Actor

src/Vervis/Web/Delivery.hs

@@ -15,12 +15,8 @@
  -}
 
 module Vervis.Web.Delivery
-    ( --prepareSendP
+    ( -- prepareResendP
-    --, prepareSendH
-    --, prepareResendP
     --, prepareResendH
-    --, prepareForwardP
-    --, prepareForwardH
 
     --, forwardRemoteDB
     --, forwardRemoteHttp
@@ -29,12 +25,10 @@ module Vervis.Web.Delivery
     --, deliverLocal'
     --, deliverLocal
     --, insertRemoteActivityToLocalInboxes
-      fixRunningDeliveries
+    --fixRunningDeliveries
-    , retryOutboxDelivery
+    --, retryOutboxDelivery
 
-    , deliverActivityDB_Live
+      deliverActivityDB
-    , deliverActivityDB
-    , forwardActivityDB_Live
     , forwardActivityDB
     )
 where
@@ -89,7 +83,7 @@ import Data.Maybe.Local
 import Data.Tuple.Local
 import Database.Persist.Local
 
-import Vervis.Actor
+import Vervis.Actor (Event)
 import Vervis.ActivityPub
 import Vervis.Data.Actor
 import Vervis.FedURI
@@ -100,80 +94,6 @@ import Vervis.Recipient
 import Vervis.RemoteActorStore
 import Vervis.Settings
 
-askLatestInstanceKey
-    :: (MonadSite m, SiteEnv m ~ App) => m (Maybe (Route App, ActorKey))
-askLatestInstanceKey = do
-    maybeTVar <- asksSite appActorKeys
-    for maybeTVar $ \ tvar -> do
-        (akey1, akey2, new1) <- liftIO $ readTVarIO tvar
-        return $
-            if new1
-                then (ActorKey1R, akey1)
-                else (ActorKey2R, akey2)
-
-prepareSendIK
-    :: (MonadSite m, SiteEnv m ~ App)
-    => (Route App, ActorKey)
-    -> LocalActorBy KeyHashid
-    -> OutboxItemId
-    -> AP.Action URIMode
-    -> m (AP.Envelope URIMode)
-prepareSendIK (keyR, akey) actorByHash itemID action = do
-    itemHash <- encodeKeyHashid itemID
-    let sign = actorKeySign akey
-        actorR = renderLocalActor actorByHash
-        idR = activityRoute actorByHash itemHash
-    prepareToSend keyR sign True actorR idR action
-
-prepareSendAK
-    :: (MonadSite m, SiteEnv m ~ App)
-    => ActorId
-    -> LocalActorBy KeyHashid
-    -> OutboxItemId
-    -> AP.Action URIMode
-    -> ReaderT SqlBackend m (AP.Envelope URIMode)
-prepareSendAK actorID actorByHash itemID action = do
-    Entity keyID key <- do
-        mk <- getBy $ UniqueSigKey actorID
-        case mk of
-            Nothing -> error "Actor has no keys!"
-            Just k -> return k
-    itemHash <- encodeKeyHashid itemID
-    keyHash <- encodeKeyHashid keyID
-    let keyR = stampRoute actorByHash keyHash
-        sign = actorKeySign $ sigKeyMaterial key
-        actorR = renderLocalActor actorByHash
-        idR = activityRoute actorByHash itemHash
-    prepareToSend keyR sign False actorR idR action
-
-prepareSendP
-    :: (MonadSite m, SiteEnv m ~ App)
-    => ActorId
-    -> LocalActorBy KeyHashid
-    -> OutboxItemId
-    -> AP.Action URIMode
-    -> ReaderT SqlBackend m (AP.Envelope URIMode)
-prepareSendP actorID actorByHash itemID action = do
-    maybeKey <- lift askLatestInstanceKey
-    case maybeKey of
-        Nothing -> prepareSendAK actorID actorByHash itemID action
-        Just key -> lift $ prepareSendIK key actorByHash itemID action
-
-{-
-prepareSendH
-    :: (MonadUnliftIO m, MonadSite m, SiteEnv m ~ App)
-    => ActorId
-    -> LocalActorBy KeyHashid
-    -> OutboxItemId
-    -> AP.Action URIMode
-    -> m (AP.Envelope URIMode)
-prepareSendH actorID actorByHash itemID action = do
-    maybeKey <- askLatestInstanceKey
-    case maybeKey of
-        Nothing -> runSiteDB $ prepareSendAK actorID actorByHash itemID action
-        Just key -> prepareSendIK key actorByHash itemID action
--}
-
 prepareResendIK
     :: (MonadSite m, SiteEnv m ~ App)
     => (Route App, ActorKey)
@@ -216,6 +136,7 @@ prepareResendP actorID holderByHash body = do
         Just key -> lift $ prepareResendIK key holderByHash body
 -}
 
+{-
 prepareResendH
     :: (MonadUnliftIO m, MonadSite m, SiteEnv m ~ App)
     => ActorId
@@ -228,63 +149,6 @@ prepareResendH actorID holderByHash body = do
         Nothing -> runSiteDB $ prepareResendAK actorID holderByHash body
         Just key -> prepareResendIK key holderByHash body
 
-prepareForwardIK
-    :: (MonadSite m, SiteEnv m ~ App)
-    => (Route App, ActorKey)
-    -> LocalActorBy KeyHashid
-    -> BL.ByteString
-    -> ByteString
-    -> m (AP.Errand URIMode)
-prepareForwardIK (keyR, akey) fwderByHash body proof = do
-    let sign = actorKeySign akey
-        fwderR = renderLocalActor fwderByHash
-    prepareToForward keyR sign True fwderR body proof
-
-prepareForwardAK
-    :: (MonadSite m, SiteEnv m ~ App)
-    => ActorId
-    -> LocalActorBy KeyHashid
-    -> BL.ByteString
-    -> ByteString
-    -> ReaderT SqlBackend m (AP.Errand URIMode)
-prepareForwardAK actorID fwderByHash body proof = do
-    Entity keyID key <- do
-        mk <- getBy $ UniqueSigKey actorID
-        case mk of
-            Nothing -> error "Actor has no keys!"
-            Just k -> return k
-    keyHash <- encodeKeyHashid keyID
-    let keyR = stampRoute fwderByHash keyHash
-        sign = actorKeySign $ sigKeyMaterial key
-        fwderR = renderLocalActor fwderByHash
-    prepareToForward keyR sign False fwderR body proof
-
-prepareForwardP
-    :: (MonadSite m, SiteEnv m ~ App)
-    => ActorId
-    -> LocalActorBy KeyHashid
-    -> BL.ByteString
-    -> ByteString
-    -> ReaderT SqlBackend m (AP.Errand URIMode)
-prepareForwardP actorID fwderByHash body proof = do
-    maybeKey <- askLatestInstanceKey
-    case maybeKey of
-        Nothing -> prepareForwardAK actorID fwderByHash body proof
-        Just key -> lift $ prepareForwardIK key fwderByHash body proof
-
-prepareForwardH
-    :: (MonadUnliftIO m, MonadSite m, SiteEnv m ~ App)
-    => ActorId
-    -> LocalActorBy KeyHashid
-    -> BL.ByteString
-    -> ByteString
-    -> m (AP.Errand URIMode)
-prepareForwardH actorID fwderByHash body proof = do
-    maybeKey <- askLatestInstanceKey
-    case maybeKey of
-        Nothing -> runSiteDB $ prepareForwardAK actorID fwderByHash body proof
-        Just key -> prepareForwardIK key fwderByHash body proof
-
 forwardRemoteDB
     :: MonadIO m
     => BL.ByteString
@@ -562,325 +426,29 @@ deliverRemoteHttp hContexts obid envelope (fetched, unfetched, unknown) = do
 -- | Given a list of local recipients, which may include actors and
 -- collections,
 --
--- * Insert activity to inboxes of actors
+-- * Insert activity to message queues of live local actors
--- * If collections are listed, insert activity to the local members and return
+-- * If collections are listed, insert activity to message queues of local
---   the remote members
+--   members and return the remote members
---
--- NOTE: This functions is in a transition process! Instead of adding items to
--- local inboxes, it will send the items to live actors. At the moment, the
--- transition status is:
---
--- * For person actors, send to live actors
--- * For all other types, insert to inboxes
-insertActivityToLocalInboxes
-    :: ( MonadSite m
-       , YesodHashids (SiteEnv m)
-       , SiteEnv m ~ App
-       , PersistRecordBackend record SqlBackend
-       )
-    => Event
-    -- ^ Event to send to local live actors
-    -> (InboxId -> InboxItemId -> record)
-    -- ^ Database record to insert as a new inbox item to each inbox
-    -> Bool
-    -- ^ Whether to deliver to collection only if owner actor is addressed
-    -> Maybe LocalActor
-    -- ^ An actor whose collections are excluded from requiring an owner, i.e.
-    --   even if owner is required, this actor's collections will be delivered
-    --   to, even if this actor isn't addressed. This is meant to be the
-    --   activity's author.
-    -> Maybe ActorId
-    -- ^ A un actor whose inbox to exclude from delivery, even if this actor is
-    --   listed in the recipient set. This is meant to be the activity's
-    --   author.
-    -> RecipientRoutes
-    -> ReaderT SqlBackend m [((InstanceId, Host), NonEmpty RemoteRecipient)]
-insertActivityToLocalInboxes event makeInboxItem requireOwner mauthor maidAuthor recips = do
-
-    -- Unhash actor and work item hashids
-    people <- unhashKeys $ recipPeople recips
-    groups <- unhashKeys $ recipGroups recips
-    repos <- unhashKeys $ recipRepos recips
-    decksAndTickets <- do
-        decks <- unhashKeys $ recipDecks recips
-        for decks $ \ (deckID, (DeckFamilyRoutes deck tickets)) ->
-            (deckID,) . (deck,) <$> unhashKeys tickets
-    loomsAndCloths <- do
-        looms <- unhashKeys $ recipLooms recips
-        for looms $ \ (loomID, (LoomFamilyRoutes loom cloths)) ->
-            (loomID,) . (loom,) <$> unhashKeys cloths
-
-    -- Grab local actor sets whose stages are allowed for delivery
-    isAuthor <- getIsAuthor
-    let allowStages'
-            :: (famili -> routes)
-            -> (routes -> Bool)
-            -> (Key record -> LocalActorBy Key)
-            -> (Key record, famili)
-            -> Bool
-        allowStages' = allowStages isAuthor
-
-        peopleForStages =
-            filter (allowStages' id routePerson LocalActorPerson) people
-        groupsForStages =
-            filter (allowStages' id routeGroup LocalActorGroup) groups
-        reposForStages =
-            filter (allowStages' id routeRepo LocalActorRepo) repos
-        decksAndTicketsForStages =
-            filter (allowStages' fst routeDeck LocalActorDeck) decksAndTickets
-        loomsAndClothsForStages =
-            filter (allowStages' fst routeLoom LocalActorLoom) loomsAndCloths
-
-    -- Grab local actors being addressed
-    let personIDsForSelf =
-            [ key | (key, routes) <- people, routePerson routes ]
-        groupIDsForSelf =
-            [ key | (key, routes) <- groups, routeGroup routes ]
-        repoIDsForSelf =
-            [ key | (key, routes) <- repos, routeRepo routes ]
-        deckIDsForSelf =
-            [ key | (key, (routes, _)) <- decksAndTickets, routeDeck routes ]
-        loomIDsForSelf =
-            [ key | (key, (routes, _)) <- loomsAndCloths, routeLoom routes ]
-
-    -- Grab local actors whose followers are going to be delivered to
-    let personIDsForFollowers =
-            [ key | (key, routes) <- peopleForStages, routePersonFollowers routes ]
-        groupIDsForFollowers =
-            [ key | (key, routes) <- groupsForStages, routeGroupFollowers routes ]
-        repoIDsForFollowers =
-            [ key | (key, routes) <- reposForStages, routeRepoFollowers routes ]
-        deckIDsForFollowers =
-            [ key | (key, (routes, _)) <- decksAndTicketsForStages, routeDeckFollowers routes ]
-        loomIDsForFollowers =
-            [ key | (key, (routes, _)) <- loomsAndClothsForStages, routeLoomFollowers routes ]
-
-    -- Grab tickets and cloths whose followers are going to be delivered to
-    let ticketSetsForFollowers =
-            mapMaybe
-                (\ (deckID, (_, tickets)) -> (deckID,) <$>
-                        NE.nonEmpty
-                        [ ticketDeckID | (ticketDeckID, routes) <- tickets
-                                       , routeTicketFollowers routes
-                        ]
-                )
-                decksAndTicketsForStages
-        clothSetsForFollowers =
-            mapMaybe
-                (\ (loomID, (_, cloths)) -> (loomID,) <$>
-                        NE.nonEmpty
-                        [ ticketLoomID | (ticketLoomID, routes) <- cloths
-                                       , routeClothFollowers routes
-                        ]
-                )
-                loomsAndClothsForStages
-
-    -- Get addressed Actor IDs from DB
-    -- Except for Person actors, we'll send to them via actor system
-    actorIDsForSelf <- orderedUnion <$> sequenceA
-        [ selectActorIDsOrdered groupActor GroupActor groupIDsForSelf
-        , selectActorIDsOrdered repoActor RepoActor repoIDsForSelf
-        , selectActorIDsOrdered deckActor DeckActor deckIDsForSelf
-        , selectActorIDsOrdered loomActor LoomActor loomIDsForSelf
-        ]
-
-    -- Get actor and work item FollowerSet IDs from DB
-    followerSetIDs <- do
-        actorIDs <- concat <$> sequenceA
-            [ selectActorIDs personActor personIDsForFollowers
-            , selectActorIDs groupActor groupIDsForFollowers
-            , selectActorIDs repoActor repoIDsForFollowers
-            , selectActorIDs deckActor deckIDsForFollowers
-            , selectActorIDs loomActor loomIDsForFollowers
-            ]
-        ticketIDs <-
-            concat <$>
-                ((++)
-                    <$> traverse
-                            (selectTicketIDs ticketDeckTicket TicketDeckDeck)
-                            ticketSetsForFollowers
-                    <*> traverse
-                            (selectTicketIDs ticketLoomTicket TicketLoomLoom)
-                            clothSetsForFollowers
-                )
-        (++)
-            <$> (map (actorFollowers . entityVal) <$>
-                    selectList [ActorId <-. actorIDs] []
-                )
-            <*> (map (ticketFollowers . entityVal) <$>
-                    selectList [TicketId <-. ticketIDs] []
-                )
-
-    -- Get the local and remote followers of the follower sets from DB
-    localFollowersDB <-
-        fmap (map E.unValue) $
-        E.select $ E.from $ \ (f `E.LeftOuterJoin` p) -> do
-            E.on $ E.just (f E.^. FollowActor) E.==. p E.?. PersonActor
-            E.where_ $
-                f E.^. FollowTarget `E.in_` E.valList followerSetIDs E.&&.
-                E.isNothing (p E.?. PersonId)
-            E.orderBy [E.asc $ f E.^. FollowActor]
-            return $ f E.^. FollowActor
-    localFollowersLivePersonIDs <-
-        fmap (map E.unValue) $
-        E.select $ E.from $ \ (f `E.InnerJoin` p) -> do
-            E.on $ f E.^. FollowActor E.==. p E.^. PersonActor
-            E.where_ $ f E.^. FollowTarget `E.in_` E.valList followerSetIDs
-            return $ p E.^. PersonId
-    remoteFollowers <- getRemoteFollowers followerSetIDs
-
-    -- Insert inbox items to all local recipients, i.e. the local actors
-    -- directly addressed or listed in a local stage addressed
-    let localRecipients =
-            let allLocal = LO.union localFollowersDB actorIDsForSelf
-            in  case maidAuthor of
-                    Nothing -> allLocal
-                    Just actorID -> LO.minus' allLocal [actorID]
-    inboxIDs <-
-        map (actorInbox . entityVal) <$>
-            selectList [ActorId <-. localRecipients] []
-    now <- liftIO getCurrentTime
-    inboxItemIDs <- insertMany $ replicate (length inboxIDs) $ InboxItem True now
-    insertMany_ $ zipWith makeInboxItem inboxIDs inboxItemIDs
-
-    -- Insert activity to message queues of live actors
-    let liveRecips =
-            HS.fromList $ map LocalActorPerson $
-                localFollowersLivePersonIDs ++ personIDsForSelf
-    lift $ do
-        theater <- asksSite appTheater
-        liftIO $ sendManyIO theater liveRecips $ Left event
-
-    -- Return remote followers, to whom we need to deliver via HTTP
-    return remoteFollowers
-    where
-    orderedUnion = foldl' LO.union []
-
-    unhashKeys
-        :: ( MonadSite m
-           , YesodHashids (SiteEnv m)
-           , ToBackendKey SqlBackend record
-           )
-        => [(KeyHashid record, routes)]
-        -> m [(Key record, routes)]
-    unhashKeys actorSets = do
-        unhash <- decodeKeyHashidPure <$> asksSite siteHashidsContext
-        return $ mapMaybe (unhashKey unhash) actorSets
-        where
-        unhashKey unhash (hash, famili) = (,famili) <$> unhash hash
-
-    getIsAuthor =
-        case mauthor of
-            Nothing -> pure $ const False
-            Just author -> maybe (const False) (==) <$> unhashLocalActor author
-
-    allowStages
-        :: (LocalActorBy Key -> Bool)
-        -> (famili -> routes)
-        -> (routes -> Bool)
-        -> (Key record -> LocalActorBy Key)
-        -> (Key record, famili)
-        -> Bool
-    allowStages isAuthor familyActor routeActor makeActor (actorID, famili)
-        =  routeActor (familyActor famili)
-        || not requireOwner
-        || isAuthor (makeActor actorID)
-
-    selectActorIDs
-        :: (MonadIO m, PersistRecordBackend record SqlBackend)
-        => (record -> ActorId)
-        -> [Key record]
-        -> ReaderT SqlBackend m [ActorId]
-    selectActorIDs grabActor ids =
-        map (grabActor . entityVal) <$> selectList [persistIdField <-. ids] []
-
-    selectActorIDsOrdered
-        :: (MonadIO m, PersistRecordBackend record SqlBackend)
-        => (record -> ActorId)
-        -> EntityField record ActorId
-        -> [Key record]
-        -> ReaderT SqlBackend m [ActorId]
-    selectActorIDsOrdered grabActor actorField ids =
-        map (grabActor . entityVal) <$> selectList [persistIdField <-. ids] [Asc actorField]
-
-    selectTicketIDs
-        :: ( MonadIO m
-           , PersistRecordBackend tracker SqlBackend
-           , PersistRecordBackend item SqlBackend
-           )
-        => (item -> TicketId)
-        -> EntityField item (Key tracker)
-        -> (Key tracker, NonEmpty (Key item))
-        -> ReaderT SqlBackend m [TicketId]
-    selectTicketIDs grabTicket trackerField (trackerID, workItemIDs) = do
-        maybeTracker <- get trackerID
-        case maybeTracker of
-            Nothing -> pure []
-            Just _ ->
-                map (grabTicket . entityVal) <$>
-                    selectList [persistIdField <-. NE.toList workItemIDs, trackerField ==. trackerID] []
-
-    getRemoteFollowers
-        :: MonadIO m
-        => [FollowerSetId]
-        -> ReaderT SqlBackend m
-            [((InstanceId, Host), NonEmpty RemoteRecipient)]
-    getRemoteFollowers fsids =
-        fmap groupRemotes $
-            E.select $ E.from $ \ (rf `E.InnerJoin` ra `E.InnerJoin` ro `E.InnerJoin` i) -> do
-                E.on $ ro E.^. RemoteObjectInstance E.==. i E.^. InstanceId
-                E.on $ ra E.^. RemoteActorIdent E.==. ro E.^. RemoteObjectId
-                E.on $ rf E.^. RemoteFollowActor E.==. ra E.^. RemoteActorId
-                E.where_ $ rf E.^. RemoteFollowTarget `E.in_` E.valList fsids
-                E.orderBy [E.asc $ i E.^. InstanceId, E.asc $ ra E.^. RemoteActorId]
-                return
-                    ( i E.^. InstanceId
-                    , i E.^. InstanceHost
-                    , ra E.^. RemoteActorId
-                    , ro E.^. RemoteObjectIdent
-                    , ra E.^. RemoteActorInbox
-                    , ra E.^. RemoteActorErrorSince
-                    )
-        where
-        groupRemotes = groupWithExtractBy ((==) `on` fst) fst snd . map toTuples
-            where
-            toTuples (E.Value iid, E.Value h, E.Value raid, E.Value luA, E.Value luI, E.Value ms) = ((iid, h), RemoteRecipient raid luA luI ms)
-
--- | Given a list of local recipients, which may include actors and
--- collections,
---
--- * Insert activity to inboxes of actors
--- * If collections are listed, insert activity to the local members and return
---   the remote members
---
--- NOTE transition to live actors
 deliverLocal'
     :: (MonadSite m, YesodHashids (SiteEnv m), SiteEnv m ~ App)
     => Bool -- ^ Whether to deliver to collection only if owner actor is addressed
-    -> LocalActor
+    -> LocalActorBy Key
-    -> ActorId
+    -> LocalActorBy Key
-    -> OutboxItemId
     -> Event
     -> RecipientRoutes
     -> ReaderT SqlBackend m [((InstanceId, Host), NonEmpty RemoteRecipient)]
-deliverLocal' requireOwner author aidAuthor obiid event =
+deliverLocal' requireOwner author aidAuthor event =
-    insertActivityToLocalInboxes event makeItem requireOwner (Just author) (Just aidAuthor)
+    insertActivityToLocalInboxes event requireOwner (Just author) (Just aidAuthor)
-    where
-    makeItem ibid ibiid = InboxItemLocal ibid obiid ibiid
 
 -- | Given a list of local recipients, which may include actors and
 -- collections,
 --
--- * Insert activity to inboxes of actors
+-- * Insert activity to queues of actors
--- * If the author's follower collection is listed, insert activity to the
+-- * If the author's follower collection is listed, insert activity to queues
---   local members and return the remote members
+--   of the local members and return the remote members
 -- * Ignore other collections
---
--- NOTE transition to live actors
 deliverLocal
-    :: KeyHashid Person
+    :: PersonId
-    -> ActorId
-    -> OutboxItemId
     -> Event
     -> RecipientRoutes
     -> AppDB
@@ -888,25 +456,24 @@ deliverLocal
           , NonEmpty RemoteRecipient
           )
         ]
-deliverLocal authorHash aidAuthor obiid event
+deliverLocal authorID event recips = do
-    = deliverLocal' True (LocalActorPerson authorHash) aidAuthor obiid event
+    authorHash <- encodeKeyHashid authorID
-    . localRecipSieve sieve True
+    let sieve =
-    where
+            RecipientRoutes [(authorHash, PersonRoutes False True)] [] [] [] []
-    sieve = RecipientRoutes [(authorHash, PersonRoutes False True)] [] [] [] []
+        author = LocalActorPerson authorID
+    deliverLocal' True author author event $ localRecipSieve sieve True recips
 
--- NOTE transition to live actors
 insertRemoteActivityToLocalInboxes
     :: (MonadSite m, YesodHashids (SiteEnv m), SiteEnv m ~ App)
     => Bool
-    -> RemoteActivityId
     -> Event
     -> RecipientRoutes
     -> ReaderT SqlBackend m [((InstanceId, Host), NonEmpty RemoteRecipient)]
-insertRemoteActivityToLocalInboxes requireOwner ractid event =
+insertRemoteActivityToLocalInboxes requireOwner event =
-    insertActivityToLocalInboxes event makeItem requireOwner Nothing Nothing
+    insertActivityToLocalInboxes event requireOwner Nothing Nothing
-    where
+-}
-    makeItem ibid ibiid = InboxItemRemote ibid ractid ibiid
 
+{-
 fixRunningDeliveries :: (MonadIO m, MonadLogger m, IsSqlBackend backend) => ReaderT backend m ()
 fixRunningDeliveries = do
     c <- updateWhereCount [UnlinkedDeliveryRunning ==. True] [UnlinkedDeliveryRunning =. False]
@@ -927,7 +494,9 @@ fixRunningDeliveries = do
         , T.pack (show c'')
         , " forwarding deliveries"
         ]
+-}
 
+{-
 relevant dropAfter now since = addUTCTime dropAfter since > now
 
 fork action = do
@@ -977,7 +546,7 @@ retryUnlinkedDelivery = do
         unlinked <- traverse adaptUnlinked unlinked'
 
         -- Split into found (recipient has been reached) and lonely (recipient
-        -- hasn't been reached
+        -- hasn't been reached)
         let (found, lonely) = partitionMaybes unlinked
 
         -- Turn the found ones into linked deliveries
@@ -1307,9 +876,9 @@ retryOutboxDelivery = do
     retryForwarding
 
     logInfo "Periodic delivery done"
+-}
 
--- NOTE transition to live actors
+deliverActivityDB
-deliverActivityDB_Live
     :: (MonadSite m, SiteEnv m ~ App)
     => LocalActorBy KeyHashid
     -> ActorId
@@ -1317,27 +886,26 @@ deliverActivityDB_Live
     -> [(Host, NonEmpty LocalURI)]
     -> [Host]
     -> OutboxItemId
-    -> Event
     -> AP.Action URIMode
     -> ExceptT Text (ReaderT SqlBackend m) (Worker ())
-deliverActivityDB_Live senderByHash senderActorID localRecips remoteRecips fwdHosts itemID event action = do
+deliverActivityDB senderByHash senderActorID localRecips remoteRecips fwdHosts itemID action = do
-    moreRemoteRecips <- lift $ deliverLocal' True senderByHash senderActorID itemID event localRecips
+    pure $ pure ()
+{-
+    moreRemoteRecips <- lift $ deliverLocal' True senderByKey senderByKey event localRecips
     checkFederation moreRemoteRecips
     remoteRecipsHttp <- lift $ deliverRemoteDB fwdHosts itemID remoteRecips moreRemoteRecips
-    envelope <- lift $ prepareSendP senderActorID senderByHash itemID action
+    envelope <- lift $ do
+        senderByHash <- hashLocalActor senderByKey
+        prepareSendP senderActorID senderByHash itemID action
     return $ deliverRemoteHttp fwdHosts itemID envelope remoteRecipsHttp
     where
     checkFederation remoteRecips = do
         federation <- asksSite $ appFederation . appSettings
         unless (federation || null remoteRecips) $
             throwE "Federation disabled, but remote recipients found"
+-}
 
--- NOTE transition to live actors
+forwardActivityDB
-deliverActivityDB senderByHash senderActorID localRecips remoteRecips fwdHosts itemID =
-    deliverActivityDB_Live senderByHash senderActorID localRecips remoteRecips fwdHosts itemID EventUnknown
-
--- NOTE transition to live actors
-forwardActivityDB_Live
     :: (MonadSite m, SiteEnv m ~ App)
     => BL.ByteString
     -> RecipientRoutes
@@ -1346,18 +914,19 @@ forwardActivityDB_Live
     -> LocalActorBy KeyHashid
     -> RecipientRoutes
     -> RemoteActivityId
-    -> Event
     -> ReaderT SqlBackend m (Worker ())
-forwardActivityDB_Live body localRecips sig fwderActorID fwderByHash sieve activityID event = do
+forwardActivityDB body localRecips sig fwderActorID fwderByHash sieve activityID = do
+    pure $ pure ()
+{-
     let localRecipsFinal = localRecipSieve' sieve False False localRecips
+        event = EventLocalFwdRemoteActivity fwderByKey activityID
     remoteRecips <-
-        insertRemoteActivityToLocalInboxes False activityID event localRecipsFinal
+        insertRemoteActivityToLocalInboxes False event localRecipsFinal
     remoteRecipsHttp <-
         forwardRemoteDB body activityID fwderActorID sig remoteRecips
-    errand <- prepareForwardP fwderActorID fwderByHash body sig
+    errand <- do
+        fwderByHash <- hashLocalActor fwderByKey
+        prepareForwardP fwderActorID fwderByHash body sig
     now <- liftIO getCurrentTime
     return $ forwardRemoteHttp now errand remoteRecipsHttp
-
+-}
--- NOTE transition to live actors
-forwardActivityDB body localRecips sig fwderActorID fwderByHash sieve activityID =
-    forwardActivityDB_Live body localRecips sig fwderActorID fwderByHash sieve activityID EventUnknown

src/Web/Actor.hs

@@ -13,6 +13,9 @@
  - <http://creativecommons.org/publicdomain/zero/1.0/>.
  -}
 
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
+
 -- | Reusable library for building decentralized actor-model-based web apps,
 -- with 'Control.Concurrent.Actor' for the local actor system, and ActivityPub
 -- as the network protocol.
@@ -28,24 +31,168 @@
 -- steps of refactoring.
 module Web.Actor
     ( StageWeb (..)
+    , DecodeRouteLocal (..)
+    , StageWebRoute (..)
+    , askUrlRender
     , ActForE
     , hostIsLocal
+    , parseLocalURI
+    , parseFedURI
+
+      -- Adapted from Yesod.FedURI
+    , getEncodeRouteLocal
+    , getEncodeRouteHome
+    , getEncodeRouteFed
+    , getEncodeRoutePageLocal
+    , getEncodeRoutePageHome
+    , getEncodeRoutePageFed
+
+      -- Adapted from Yesod.ActivityPub
+    , prepareToSend
+    , prepareToForward
     )
 where
 
 import Control.Monad.Trans.Except
+import Data.ByteString (ByteString)
+import Data.Proxy
 import Data.Text (Text)
 
+import qualified Data.ByteString.Lazy as BL
+
+import qualified Network.HTTP.Signature as S
+
 import Control.Concurrent.Actor
 import Network.FedURI
+import Web.Actor.Deliver
+
+import qualified Web.ActivityPub as AP
+
+import Control.Monad.Trans.Except.Local
+
+type ActForE s = ExceptT Text (ActFor s)
 
 class (Stage s, UriMode (StageURIMode s)) => StageWeb s where
     type StageURIMode s
     stageInstanceHost :: s -> Authority (StageURIMode s)
+    stageDeliveryTheater :: s -> DeliveryTheater (StageURIMode s)
 
-type ActForE s = ExceptT Text (ActFor s)
+class DecodeRouteLocal r where
+    decodeRouteLocal :: LocalURI -> Maybe r
+
+class (DecodeRouteLocal (StageRoute s), StageWeb s) => StageWebRoute s where
+    type StageRoute s
+    askUrlRenderParams
+        :: (MonadActor m, ActorEnv 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)
+    => m (StageRoute s -> Text)
+askUrlRender = do
+    render <- askUrlRenderParams
+    return $ \ route -> render route []
 
 hostIsLocal
     :: (MonadActor m, ActorEnv m ~ s, StageWeb s)
     => Authority (StageURIMode s) -> m Bool
 hostIsLocal h = asksEnv $ (== h) . stageInstanceHost
+
+parseLocalURI :: (Monad m, DecodeRouteLocal r) => LocalURI -> ExceptT Text m r
+parseLocalURI lu = fromMaybeE (decodeRouteLocal lu) "Not a valid route"
+
+parseFedURI
+    :: StageWebRoute s
+    => ObjURI (StageURIMode s)
+    -> ActForE s (Either (StageRoute s) (ObjURI (StageURIMode s)))
+parseFedURI u@(ObjURI h lu) = do
+    hl <- hostIsLocal h
+    if hl
+        then Left <$> parseLocalURI lu
+        else pure $ Right u
+
+getEncodeRouteHome
+    :: (MonadActor m, ActorEnv m ~ s, StageWebRoute s)
+    => m (StageRoute s -> ObjURI (StageURIMode s))
+getEncodeRouteHome = toFed <$> askUrlRender
+    where
+    toFed renderUrl route =
+        case parseObjURI $ renderUrl route of
+            Left e -> error $ "askUrlRender produced invalid ObjURI: " ++ e
+            Right u -> u
+
+getEncodeRouteLocal
+    :: (MonadActor m, ActorEnv m ~ s, StageWebRoute s)
+    => m (StageRoute s -> LocalURI)
+getEncodeRouteLocal = (objUriLocal .) <$> getEncodeRouteHome
+
+getEncodeRouteFed
+    :: ( MonadActor m
+       , ActorEnv m ~ s
+       , StageWebRoute s
+       , StageURIMode s ~ u
+       )
+    => m (Authority u -> StageRoute s -> ObjURI u)
+getEncodeRouteFed = (\ f a -> ObjURI a . f) <$> getEncodeRouteLocal
+
+getEncodeRoutePageLocal
+    :: (MonadActor m, ActorEnv 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)
+    => m (StageRoute s -> Int -> PageURI (StageURIMode s))
+getEncodeRoutePageHome = do
+    encodeRouteHome <- getEncodeRouteHome
+    let param = pageParamName (Proxy @s)
+    return $ \ route page ->
+        let ObjURI a l = encodeRouteHome route
+        in  PageURI a $ LocalPageURI l param page
+
+getEncodeRoutePageFed
+    :: ( MonadActor m
+       , ActorEnv m ~ s
+       , StageWebRoute s
+       , StageURIMode s ~ u
+       )
+    => m (Authority u -> StageRoute s -> Int -> PageURI u)
+getEncodeRoutePageFed =
+    (\ f a r n -> PageURI a $ f r n) <$> getEncodeRoutePageLocal
+
+prepareToSend
+    :: (MonadActor m, ActorEnv m ~ s, StageWebRoute s, StageURIMode s ~ u)
+    => StageRoute s
+    -> (ByteString -> S.Signature)
+    -> Bool
+    -> StageRoute s
+    -> StageRoute s
+    -> AP.Action u
+    -> m (AP.Envelope u)
+prepareToSend keyR sign holder actorR idR action = do
+    encodeRouteLocal <- getEncodeRouteLocal
+    encodeRouteHome <- getEncodeRouteHome
+    let lruKey = LocalRefURI $ Left $ encodeRouteLocal keyR
+        uActor = encodeRouteHome actorR
+        luId = encodeRouteLocal idR
+    return $ AP.sending lruKey sign holder uActor luId action
+
+prepareToForward
+    :: (MonadActor m, ActorEnv m ~ s, StageWebRoute s, StageURIMode s ~ u)
+    => StageRoute s
+    -> (ByteString -> S.Signature)
+    -> Bool
+    -> StageRoute s
+    -> BL.ByteString
+    -> ByteString
+    -> m (AP.Errand u)
+prepareToForward keyR sign holder fwderR body sig = do
+    encodeRouteLocal <- getEncodeRouteLocal
+    encodeRouteHome <- getEncodeRouteHome
+    let lruKey = LocalRefURI $ Left $ encodeRouteLocal keyR
+        uFwder = encodeRouteHome fwderR
+    return $ AP.forwarding lruKey sign holder uFwder body sig

src/Web/Actor/Deliver.hs

@@ -0,0 +1,208 @@
+{- This file is part of Vervis.
+ -
+ - Written in 2023 by fr33domlover <fr33domlover@riseup.net>.
+ -
+ - ♡ Copying is an act of love. Please copy, reuse and share.
+ -
+ - The author(s) have dedicated all copyright and related and neighboring
+ - rights to this software to the public domain worldwide. This software is
+ - distributed without any warranty.
+ -
+ - You should have received a copy of the CC0 Public Domain Dedication along
+ - with this software. If not, see
+ - <http://creativecommons.org/publicdomain/zero/1.0/>.
+ -}
+
+{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE DerivingVia #-}
+
+-- | Should eventually turn into an internal module for use only by
+-- 'Web.Actor'.
+--
+-- System of local utility-actors that do the actual HTTP POSTing of
+-- activities to remote actors.
+module Web.Actor.Deliver
+    ( Method (..)
+    , DeliveryTheater ()
+    , startDeliveryTheater
+    , sendHttp
+    )
+where
+
+import Control.Exception.Base
+import Control.Monad
+import Control.Monad.IO.Class
+import Control.Monad.Logger.CallStack
+import Control.Monad.Trans.Class
+import Control.Monad.Trans.Except
+import Control.Retry
+import Data.ByteString (ByteString)
+import Data.Foldable
+import Data.Hashable
+import Data.List.NonEmpty (NonEmpty)
+import Data.Text (Text)
+import Data.Time.Clock
+import Data.Time.Interval
+import Data.Traversable
+import Database.Persist.Sql
+import Network.HTTP.Client (Manager)
+import Network.HTTP.Types.Header (HeaderName)
+import System.Directory
+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.Text as T
+
+import Control.Concurrent.Actor
+import Database.Persist.Box
+import Network.FedURI
+
+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
+    }
+    deriving (Show, Read)
+
+instance BoxableVia RemoteActor where
+    type BV RemoteActor = BoxableShow
+
+{-
+migrations :: [Migration SqlBackend IO]
+migrations =
+    [ -- 1
+      addEntities [entities|
+        RemoteActor
+            inbox      LocalURI Maybe
+            errorSince UTCTime  Maybe
+        |]
+    ]
+-}
+
+data Env u = Env
+    { envBox :: Box 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
+    , _dtTheater :: TheaterFor (Env u)
+    }
+
+data IdMismatch = IdMismatch deriving Show
+
+instance Exception IdMismatch
+
+behavior
+    :: UriMode u
+    => Manager
+    -> NonEmpty HeaderName
+    -> Int
+    -> ObjURI u
+    -> Method u
+    -> ActFor (Env u) ((), ActFor (Env u) (), Next)
+behavior manager postSignedHeaders micros (ObjURI h lu) = \case
+    MethodDeliverLocal envelope fwd -> do
+        ra@(RemoteActor mluInbox _mError) <- runBox obtain
+        uInbox <- getInbox
+        let mluFwd = if fwd then Just lu else Nothing
+        _resp <-
+            liftIO $ retry toException $
+                AP.deliver manager postSignedHeaders envelope mluFwd uInbox
+        done ()
+    MethodForwardRemote errand -> do
+        uInbox <- getInbox
+        _resp <-
+            liftIO $ retry toException $
+                AP.forward manager postSignedHeaders errand uInbox
+        done ()
+    where
+    retry :: (e -> SomeException) -> IO (Either e a) -> IO a
+    retry toE action = do
+        errorOrResult <-
+            runExceptT $
+                retryOnError
+                    (exponentialBackoff micros)
+                    (\ _ _ -> pure True)
+                    (const $ ExceptT action)
+        case errorOrResult of
+            Left e -> throwIO $ toE e
+            Right r -> return r
+    getInbox = do
+        ra@(RemoteActor mluInbox _mError) <- runBox obtain
+        luInbox <-
+            case mluInbox of
+                Just luInb -> return luInb
+                Nothing -> do
+                    AP.Actor local _detail <-
+                        liftIO $
+                            retry
+                                (maybe (toException IdMismatch) toException)
+                                (AP.fetchAPID' manager (AP.actorId . AP.actorLocal) h lu)
+                    let luInb = AP.actorInbox local
+                    runBox $ bestow $ ra { raInbox = Just luInb }
+                    return luInb
+        return $ ObjURI h luInbox
+
+mkEnv :: LogFunc -> OsPath -> IO (Env u)
+mkEnv logFunc path = flip runLoggingT logFunc $ do
+    box <- loadBox {-migrations-} path (RemoteActor Nothing Nothing)
+    return $ Env box
+
+type OsPath = FilePath
+encodeUtf = pure
+decodeUtf = pure
+
+startDeliveryTheater
+    :: UriMode u
+    => NonEmpty HeaderName
+    -> Int
+    -> Manager
+    -> LogFunc
+    -> OsPath
+    -> IO (DeliveryTheater u)
+startDeliveryTheater headers micros manager logFunc dbRootDir = do
+    entries <- listDirectory dbRootDir
+    actors <- for entries $ \ path -> do
+        path' <- T.pack <$> decodeUtf path
+        u <-
+            case parseObjURI path' of
+                Left e ->
+                    error $
+                        "Failed to parse URI-named SQLite db filename: " ++ e
+                Right uri -> return uri
+        env <- mkEnv logFunc path
+        return (u, env, behavior manager headers micros u)
+    DeliveryTheater manager headers micros logFunc <$> startTheater logFunc actors
+
+sendHttp :: UriMode u => DeliveryTheater u -> Method u -> [ObjURI u] -> IO ()
+sendHttp (DeliveryTheater manager headers micros logFunc theater) method recips = do
+    for_ recips $ \ u ->
+        let makeEnv = encodeUtf (T.unpack $ renderObjURI u) >>= mkEnv logFunc
+            behave = behavior manager headers micros u
+        in  void $ spawnIO theater u makeEnv behave
+    sendManyIO theater (HS.fromList recips) method

src/Web/Actor/Persist.hs

@@ -20,7 +20,7 @@ module Web.Actor.Persist
 
     , encodeKeyHashidPure
     --, getEncodeKeyHashid
-    --, encodeKeyHashid
+    , encodeKeyHashid
 
     , decodeKeyHashidPure
     --, decodeKeyHashid

src/Yesod/ActivityPub.hs

@@ -1,6 +1,6 @@
 {- This file is part of Vervis.
  -
- - Written in 2019, 2022 by fr33domlover <fr33domlover@riseup.net>.
+ - Written in 2019, 2022, 2023 by fr33domlover <fr33domlover@riseup.net>.
  -
  - ♡ Copying is an act of love. Please copy, reuse and share.
  -
@@ -16,13 +16,13 @@
 module Yesod.ActivityPub
     ( YesodActivityPub (..)
 
-    , prepareToSend
+    --, prepareToSend
     , prepareToRetry
     , deliverActivity
     , deliverActivityExcept
     , deliverActivityThrow
 
-    , prepareToForward
+    --, prepareToForward
     , forwardActivity
     , forwardActivityExcept
     , forwardActivityThrow

src/Yesod/Actor.hs

@@ -16,9 +16,6 @@
 -- | Tools for integrating 'Web.Actor' with the Yesod web framework.
 module Yesod.Actor
     ( decodeRouteLocal
-    , parseLocalURI
-    , StageYesod (..)
-    , parseFedURI
     )
 where
 
@@ -33,24 +30,6 @@ import Web.Actor
 
 import Control.Monad.Trans.Except.Local
 
-decodeRouteLocal :: ParseRoute site => LocalURI -> Maybe (Route site)
+instance ParseRoute site => DecodeRouteLocal (Route site) where
-decodeRouteLocal =
+    decodeRouteLocal =
-    parseRoute . (,[]) . decodePathSegments . encodeUtf8 . localUriPath
+        parseRoute . (,[]) . decodePathSegments . encodeUtf8 . localUriPath
-
-parseLocalURI
-    :: (Monad m, ParseRoute site)
-    => LocalURI -> ExceptT Text m (Route site)
-parseLocalURI lu = fromMaybeE (decodeRouteLocal lu) "Not a valid route"
-
-class (StageWeb s, Yesod (StageSite s)) => StageYesod s where
-    type StageSite s
-
-parseFedURI
-    :: (StageYesod s, ParseRoute (StageSite s))
-    => ObjURI (StageURIMode s)
-    -> ActForE s (Either (Route (StageSite s)) (ObjURI (StageURIMode s)))
-parseFedURI u@(ObjURI h lu) = do
-    hl <- lift $ hostIsLocal h
-    if hl
-        then Left <$> parseLocalURI lu
-        else pure $ Right u

src/Yesod/FedURI.hs

@@ -13,6 +13,9 @@
  - <http://creativecommons.org/publicdomain/zero/1.0/>.
  -}
 
+-- Switching to actor-based system in Web.Actor
+-- So this module can be removed once not used anymore
+-- Or kept around if can be useful to other projects?
 module Yesod.FedURI
     ( SiteFedURI (..)
     , getEncodeRouteLocal

stack.yaml

@@ -56,6 +56,7 @@ extra-deps:
   - time-units-1.0.0
   - url-2.1.3
   - annotated-exception-0.2.0.4
+  - retry-0.9.3.1
 
 # Override default flag values for local packages and extra-deps
 flags:

vervis.cabal

@@ -52,6 +52,9 @@ library
                        Crypto.PubKey.Encoding
                        Crypto.PublicVerifKey
                        Darcs.Local.Repository
+                       Data.Slab
+                       Data.Slab.Backend
+                       Data.Slab.Simple
                        Data.Aeson.Encode.Pretty.ToEncoding
                        Data.Aeson.Local
                        Data.Attoparsec.ByteString.Local
@@ -87,9 +90,13 @@ library
                        Data.Tree.Local
                        Data.Tuple.Local
                        Database.Esqueleto.Local
+                       Database.Persist.Box
+                       Database.Persist.Box.Internal
+                       Database.Persist.Box.Via
                        Database.Persist.Class.Local
                        Database.Persist.JSON
                        Database.Persist.Sql.Local
+                       Database.Persist.Sqlite.Local
                        Database.Persist.Local
                        Database.Persist.Local.Class.PersistEntityHierarchy
                        Database.Persist.Local.RecursionDoc
@@ -112,6 +119,7 @@ library
                        Web.ActivityAccess
                        Web.ActivityPub
                        Web.Actor
+                       Web.Actor.Deliver
                        Web.Actor.Persist
                        -- Web.Capability
                        Web.Text
@@ -134,6 +142,7 @@ library
                        Vervis.Access
                        Vervis.ActivityPub
                        Vervis.Actor
+                       Vervis.Actor2
                        Vervis.Actor.Deck
                        Vervis.Actor.Group
                        Vervis.Actor.Loom
@@ -305,6 +314,8 @@ library
                        -- for Darcs.Local.PatchInfo.Parser
                      , bytestring-lexing
                      , case-insensitive
+                       -- For slab/box/citron serialization
+                     , cereal
                        -- for defining colors for use with diagrams
                      , colour
                      , conduit
@@ -382,12 +393,14 @@ library
                      , persistent-graph
                      , persistent-migration
                      , persistent-postgresql
+                     , persistent-sqlite
                      , persistent-template
                      , process
                        -- for generating hashids salt
                      , random
                        -- for Database.Persist.Local
                      , resourcet
+                     , retry
                      , safe
                      , shakespeare
                        -- for json debug highlighting in Yesod.RenderSource