{-|
Module      : Control.Immortal.Worker
Description : Immortal thread with logging and restart on exceptions.
Copyright   : (c) Anton Gushcha (ncrashed), 2020
License     : MIT
Maintainer  : ncrashed@gmail.com
Stability   : experimental
Portability : Portable

Here is a longer description of this module, containing some
commentary with @some markup@.

Typical usage:

@
worker "supervisor" $ const $ forever $ do
  logInfoN "Supervisor started"
  let subworkers = [
          subworker1
        , subworker2
        ]
  traverse_ (isolate_ "subworker") subworkers
  liftIO $ threadDelay 10_000_000
@

-}
module Control.Immortal.Worker(
    workerWith
  , worker
  , isolate
  , isolate_
  ) where

import Control.Concurrent (threadDelay)
import Control.DeepSeq
import Control.Exception.Safe (SomeException, catchDeep)
import Control.Monad.IO.Unlift
import Control.Monad.Logger
import Data.Text (pack)

import qualified Control.Immortal as I

-- | Start immortal worker that logs on exceptions and restarts.
--
-- Note that action is not looped implicitly. Add 'Control.Monad.forever' into action
-- manually to achive this.
workerWith :: (MonadUnliftIO m, MonadLogger m)
  => (String -> SomeException -> m ()) -- ^ Action to perform before worker restart
  -> String -- ^ Worker label for thred
  -> (I.Thread -> m ()) -- ^ Worker action (no looping is added)
  -> m I.Thread
workerWith :: (String -> SomeException -> m ())
-> String -> (Thread -> m ()) -> m Thread
workerWith String -> SomeException -> m ()
logthem String
lbl Thread -> m ()
f = String -> (Thread -> m ()) -> m Thread
forall (m :: * -> *).
MonadUnliftIO m =>
String -> (Thread -> m ()) -> m Thread
I.createWithLabel String
lbl ((Thread -> m ()) -> m Thread) -> (Thread -> m ()) -> m Thread
forall a b. (a -> b) -> a -> b
$ \Thread
thread ->
  Thread -> (Either SomeException () -> m ()) -> m () -> m ()
forall (m :: * -> *).
MonadUnliftIO m =>
Thread -> (Either SomeException () -> m ()) -> m () -> m ()
I.onUnexpectedFinish Thread
thread ((SomeException -> m ())
-> (() -> m ()) -> Either SomeException () -> m ()
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (String -> SomeException -> m ()
logthem String
lbl) (m () -> () -> m ()
forall a b. a -> b -> a
const (m () -> () -> m ()) -> m () -> () -> m ()
forall a b. (a -> b) -> a -> b
$ () -> m ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())) (Thread -> m ()
f Thread
thread)

-- | Helper that starts new immortal thread with logging of errors
worker :: (MonadUnliftIO m, MonadLogger m) => String -> (I.Thread -> m ()) -> m I.Thread
worker :: String -> (Thread -> m ()) -> m Thread
worker = (String -> SomeException -> m ())
-> String -> (Thread -> m ()) -> m Thread
forall (m :: * -> *).
(MonadUnliftIO m, MonadLogger m) =>
(String -> SomeException -> m ())
-> String -> (Thread -> m ()) -> m Thread
workerWith ((String -> SomeException -> m ())
 -> String -> (Thread -> m ()) -> m Thread)
-> (String -> SomeException -> m ())
-> String
-> (Thread -> m ())
-> m Thread
forall a b. (a -> b) -> a -> b
$ \String
lbl SomeException
e -> do
  Text -> m ()
forall (m :: * -> *). MonadLogger m => Text -> m ()
logErrorN (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ Text
"Worker " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
pack String
lbl Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" exit with: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (String -> Text
pack (String -> Text)
-> (SomeException -> String) -> SomeException -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SomeException -> String
forall a. Show a => a -> String
show) SomeException
e
  IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Int -> IO ()
threadDelay Int
1000000

-- | If computation fails, print log and return default value.
isolate :: (MonadUnliftIO m, MonadLogger m, NFData a) => String -> a -> m a -> m a
isolate :: String -> a -> m a -> m a
isolate String
title a
a0 m a
ma = do
  m a -> IO a
run <- m (m a -> IO a)
forall (m :: * -> *) a. MonadUnliftIO m => m (m a -> IO a)
askRunInIO
  IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> m a) -> IO a -> m a
forall a b. (a -> b) -> a -> b
$ IO a -> (SomeException -> IO a) -> IO a
forall (m :: * -> *) e a.
(MonadCatch m, MonadIO m, Exception e, NFData a) =>
m a -> (e -> m a) -> m a
catchDeep (m a -> IO a
run m a
ma) ((SomeException -> IO a) -> IO a)
-> (SomeException -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \(SomeException
e :: SomeException) -> m a -> IO a
run (m a -> IO a) -> m a -> IO a
forall a b. (a -> b) -> a -> b
$ do
    Text -> m ()
forall (m :: * -> *). MonadLogger m => Text -> m ()
logErrorN (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ Text
"Isolated action " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
pack String
title Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" failed: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (String -> Text
pack (String -> Text)
-> (SomeException -> String) -> SomeException -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SomeException -> String
forall a. Show a => a -> String
show) SomeException
e
    a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a0

-- | Same as `isolate` but returns empty tuple
isolate_ :: (MonadUnliftIO m, MonadLogger m) => String -> m () -> m ()
isolate_ :: String -> m () -> m ()
isolate_ String
lbl = String -> () -> m () -> m ()
forall (m :: * -> *) a.
(MonadUnliftIO m, MonadLogger m, NFData a) =>
String -> a -> m a -> m a
isolate String
lbl ()