diff --git a/src/Vervis/Federation.hs b/src/Vervis/Federation.hs
index e28204c..92a80ad 100644
--- a/src/Vervis/Federation.hs
+++ b/src/Vervis/Federation.hs
@@ -1148,8 +1148,7 @@ handleOutboxNote host (Note mluNote luAttrib aud muParent muContext mpublished c
     (lmid, obid, doc, remotesHttp) <- case result of
         Left (FedError t) -> throwE t
         Right r -> return r
-    let handleDeliveryError e = logError $ "Outbox POST handler: delivery failed! " <> T.pack (displayException e)
-    lift $ forkHandler handleDeliveryError $ deliverRemoteHttp (furiHost uContext) obid doc remotesHttp
+    lift $ forkWorker "Outbox POST handler: async HTTP delivery" $ deliverRemoteHttp (furiHost uContext) obid doc remotesHttp
     return lmid
     where
     verifyNothing :: Monad m => Maybe a -> e -> ExceptT e m ()
@@ -1547,7 +1546,7 @@ handleOutboxNote host (Note mluNote luAttrib aud muParent muContext mpublished c
            , [((InstanceId, Text), NonEmpty (UnfetchedRemoteActorId, LocalURI, UnlinkedDeliveryId))]
            , [((InstanceId, Text), NonEmpty (UnfetchedRemoteActorId, LocalURI, UnlinkedDeliveryId))]
            )
-        -> Handler ()
+        -> Worker ()
     deliverRemoteHttp hContext obid doc (fetched, unfetched, unknown) = do
         let deliver fwd h inbox = do
                 let fwd' = if h == hContext then Just fwd else Nothing
@@ -1557,7 +1556,7 @@ handleOutboxNote host (Note mluNote luAttrib aud muParent muContext mpublished c
         traverse_ (fork . deliverUnfetched deliver now) unfetched
         traverse_ (fork . deliverUnfetched deliver now) unknown
         where
-        fork = forkHandler $ \ e -> logError $ "Outbox POST handler: delivery failed! " <> T.pack (displayException e)
+        fork = forkWorker "Outbox POST handler: HTTP delivery"
         deliverFetched deliver now ((_, h), recips@(r :| rs)) = do
             let (raid, luActor, luInbox, dlid) = r
             (_, e) <- deliver luActor h luInbox
@@ -1574,12 +1573,12 @@ handleOutboxNote host (Note mluNote luAttrib aud muParent muContext mpublished c
                                 else Just False
                     Right _resp -> return $ Just True
             case e' of
-                Nothing -> runDB $ do
+                Nothing -> runSiteDB $ do
                     let recips' = NE.toList recips
                     updateWhere [RemoteActorId <-. map fst4 recips', RemoteActorErrorSince ==. Nothing] [RemoteActorErrorSince =. Just now]
                     updateWhere [DeliveryId <-. map fourth4 recips'] [DeliveryRunning =. False]
                 Just success -> do
-                    runDB $
+                    runSiteDB $
                         if success
                             then delete dlid
                             else do
@@ -1588,7 +1587,7 @@ handleOutboxNote host (Note mluNote luAttrib aud muParent muContext mpublished c
                     for_ rs $ \ (raid, luActor, luInbox, dlid) ->
                         fork $ do
                             (_, e) <- deliver luActor h luInbox
-                            runDB $
+                            runSiteDB $
                                 case e of
                                     Left err -> do
                                         logError $ T.concat
@@ -1610,7 +1609,7 @@ handleOutboxNote host (Note mluNote luAttrib aud muParent muContext mpublished c
                                 else Just Nothing
                         Right (Right era) -> Just $ Just era
             case e' of
-                Nothing -> runDB $ do
+                Nothing -> runSiteDB $ do
                     let recips' = NE.toList recips
                     updateWhere [UnfetchedRemoteActorId <-. map fst3 recips', UnfetchedRemoteActorSince ==. Nothing] [UnfetchedRemoteActorSince =. Just now]
                     updateWhere [UnlinkedDeliveryId <-. map thd3 recips'] [UnlinkedDeliveryRunning =. False]
@@ -1621,23 +1620,23 @@ handleOutboxNote host (Note mluNote luAttrib aud muParent muContext mpublished c
                             case e of
                                 Right (Right (Entity raid ra)) -> do
                                     (fwd, e') <- deliver luActor h $ remoteActorInbox ra
-                                    runDB $
+                                    runSiteDB $
                                         case e' of
                                             Left _ -> do
                                                 updateWhere [RemoteActorId ==. raid, RemoteActorErrorSince ==. Nothing] [RemoteActorErrorSince =. Just now]
                                                 delete udlid
                                                 insert_ $ Delivery raid obid fwd False
                                             Right _ -> delete udlid
-                                _ -> runDB $ do
+                                _ -> runSiteDB $ do
                                     updateWhere [UnfetchedRemoteActorId ==. uraid, UnfetchedRemoteActorSince ==. Nothing] [UnfetchedRemoteActorSince =. Just now]
                                     update udlid [UnlinkedDeliveryRunning =. False]
                     case mera of
-                        Nothing -> runDB $ do
+                        Nothing -> runSiteDB $ do
                             updateWhere [UnfetchedRemoteActorId ==. uraid, UnfetchedRemoteActorSince ==. Nothing] [UnfetchedRemoteActorSince =. Just now]
                             update udlid [UnlinkedDeliveryRunning =. False]
                         Just (Entity raid ra) -> do
                             (fwd, e'') <- deliver luActor h $ remoteActorInbox ra
-                            runDB $
+                            runSiteDB $
                                 case e'' of
                                     Left _ -> do
                                         updateWhere [RemoteActorId ==. raid, RemoteActorErrorSince ==. Nothing] [RemoteActorErrorSince =. Just now]
diff --git a/src/Yesod/MonadSite.hs b/src/Yesod/MonadSite.hs
index b84b1c4..867a665 100644
--- a/src/Yesod/MonadSite.hs
+++ b/src/Yesod/MonadSite.hs
@@ -25,6 +25,7 @@ module Yesod.MonadSite
     , runWorkerT
     , WorkerFor
     , runWorker
+    , forkWorker
     )
 where
 
@@ -42,10 +43,12 @@ import Data.Text (Text)
 import Database.Persist.Sql
 import UnliftIO.Async
 import UnliftIO.Concurrent
-import Yesod.Core
+import Yesod.Core hiding (logError)
 import Yesod.Core.Types
 import Yesod.Persist.Core
 
+import qualified Data.Text as T
+
 class PersistConfig (SitePersistConfig site) => Site site where
     type SitePersistConfig site
     siteApproot       :: site -> Text
@@ -123,3 +126,20 @@ type WorkerFor site = WorkerT site IO
 
 runWorker :: (Yesod site, Site site) => WorkerFor site a -> site -> IO a
 runWorker = runWorkerT
+
+forkWorker
+    :: (MonadSite m, Yesod site, Site site, SiteEnv m ~ site)
+    => Text
+    -> WorkerFor site ()
+    -> m ()
+forkWorker err worker = do
+    site <- askSite
+    void $ liftIO $ forkFinally (runWorker worker site) (handler site)
+    where
+    handler site r = flip runWorker site $
+        case r of
+            Left e ->
+                logError $
+                    "Worker thread threw exception: " <> err <> ": " <>
+                    T.pack (displayException e)
+            Right _ -> return ()