From 770983e8295f907773ec0ae89d9a25b7057798d7 Mon Sep 17 00:00:00 2001 From: fr33domlover Date: Fri, 10 May 2019 04:36:21 +0000 Subject: [PATCH] In outbox POST handler, run async delivery using Worker instead of Handler Worker is enough and seems much simpler. forkHandler does stuff with forkResourceT and more stuff that I don't exactly understand and which may involve more resource allocation. I guess forkWorker would generally be the preferred approach, and there are bugs with delivery leading to sudden CPU/memory peaks forcing me to kill the process. Maybe not related, just mentioning it ^_^ --- src/Vervis/Federation.hs | 23 +++++++++++------------ src/Yesod/MonadSite.hs | 22 +++++++++++++++++++++- 2 files changed, 32 insertions(+), 13 deletions(-) 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 ()