diff --git a/src/Control/Concurrent/Local.hs b/src/Control/Concurrent/Local.hs new file mode 100644 index 0000000..2229148 --- /dev/null +++ b/src/Control/Concurrent/Local.hs @@ -0,0 +1,31 @@ +{- This file is part of Vervis. + - + - Written in 2019 by fr33domlover . + - + - ♡ 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 + - . + -} + +module Control.Concurrent.Local + ( forkCheck + ) +where + +import Prelude + +import Control.Concurrent +import Data.Functor (void) + +-- | Like 'forkIO', but if the new thread terminates with an exception, +-- re-throw it in the current thread. +forkCheck :: IO () -> IO () +forkCheck run = do + tid <- myThreadId + void $ forkFinally run $ either (throwTo tid) (const $ return ()) diff --git a/src/Vervis/Application.hs b/src/Vervis/Application.hs index 830671b..ed8aee6 100644 --- a/src/Vervis/Application.hs +++ b/src/Vervis/Application.hs @@ -1,6 +1,6 @@ {- This file is part of Vervis. - - - Written in 2016, 2018 by fr33domlover . + - Written in 2016, 2018, 2019 by fr33domlover . - - ♡ Copying is an act of love. Please copy, reuse and share. - @@ -30,7 +30,6 @@ module Vervis.Application ) where -import Control.Concurrent (forkIO) import Control.Monad.Logger (liftLoc, runLoggingT, logInfo, logError) import Database.Persist.Postgresql (createPostgresqlPool, pgConnStr, pgPoolSize, runSqlPool) @@ -54,6 +53,10 @@ import Yesod.Mail.Send (runMailer) import qualified Data.Text as T (unpack) +import Control.Concurrent.Local (forkCheck) + +import Vervis.ActorKey (generateActorKey, actorKeyRotator) + -- Import all relevant handler modules here. -- Don't forget to add new modules to your cabal file! import Vervis.Handler.Common @@ -229,10 +232,10 @@ appMain = do app <- makeApplication foundation -- Run SSH server - forkIO $ sshServer foundation + forkCheck $ sshServer foundation -- Run mailer if SMTP is enabled - forkIO $ mailer foundation + forkCheck $ mailer foundation -- Run the application with Warp runSettings (warpSettings foundation) app diff --git a/vervis.cabal b/vervis.cabal index cf4193c..3b08e74 100644 --- a/vervis.cabal +++ b/vervis.cabal @@ -39,6 +39,7 @@ flag library-only library exposed-modules: Control.Applicative.Local + Control.Concurrent.Local Darcs.Local.Repository Data.Attoparsec.ByteString.Local Data.Binary.Local