module Freckle.App.Async
  ( async
  , immortalCreate
  , immortalCreateLogged
  )
where

import Freckle.App.Prelude

import Blammo.Logging
import qualified Control.Immortal as Immortal
import Control.Monad (forever)
import qualified Data.Aeson.Compat as KeyMap
import UnliftIO.Async (Async)
import qualified UnliftIO.Async as UnliftIO
import UnliftIO.Concurrent (threadDelay)

-- | 'UnliftIO.Async.async' but passing the thread context along
async :: (MonadMask m, MonadUnliftIO m) => m a -> m (Async a)
async :: forall (m :: * -> *) a.
(MonadMask m, MonadUnliftIO m) =>
m a -> m (Async a)
async m a
f = do
  [(Key, Value)]
tc <- IO [(Key, Value)] -> m [(Key, Value)]
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [(Key, Value)] -> m [(Key, Value)])
-> IO [(Key, Value)] -> m [(Key, Value)]
forall a b. (a -> b) -> a -> b
$ KeyMap Value -> [(Key, Value)]
forall v. KeyMap v -> [(Key, v)]
KeyMap.toList (KeyMap Value -> [(Key, Value)])
-> IO (KeyMap Value) -> IO [(Key, Value)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO (KeyMap Value)
forall (m :: * -> *). (MonadIO m, MonadThrow m) => m (KeyMap Value)
myThreadContext
  m a -> m (Async a)
forall (m :: * -> *) a. MonadUnliftIO m => m a -> m (Async a)
UnliftIO.async (m a -> m (Async a)) -> m a -> m (Async a)
forall a b. (a -> b) -> a -> b
$ [(Key, Value)] -> m a -> m a
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
[(Key, Value)] -> m a -> m a
withThreadContext [(Key, Value)]
tc m a
f

-- | Wrapper around creating "Control.Immortal" processes
--
-- Features:
--
-- - Ensures the thread context is correctly passed to both your spawned action
--   and your error handler
-- - Blocks forever after spawning your thread.
immortalCreate
  :: (MonadMask m, MonadUnliftIO m)
  => (Either SomeException () -> m ())
  -- ^ How to handle unexpected finish
  -> m ()
  -- ^ The action to run persistently
  -> m a
immortalCreate :: forall (m :: * -> *) a.
(MonadMask m, MonadUnliftIO m) =>
(Either SomeException () -> m ()) -> m () -> m a
immortalCreate Either SomeException () -> m ()
onUnexpected m ()
act = do
  [(Key, Value)]
tc <- IO [(Key, Value)] -> m [(Key, Value)]
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [(Key, Value)] -> m [(Key, Value)])
-> IO [(Key, Value)] -> m [(Key, Value)]
forall a b. (a -> b) -> a -> b
$ KeyMap Value -> [(Key, Value)]
forall v. KeyMap v -> [(Key, v)]
KeyMap.toList (KeyMap Value -> [(Key, Value)])
-> IO (KeyMap Value) -> IO [(Key, Value)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO (KeyMap Value)
forall (m :: * -> *). (MonadIO m, MonadThrow m) => m (KeyMap Value)
myThreadContext

  let
    act' :: m ()
act' = [(Key, Value)] -> m () -> m ()
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
[(Key, Value)] -> m a -> m a
withThreadContext [(Key, Value)]
tc m ()
act
    onUnexpected' :: Either SomeException () -> m ()
onUnexpected' = [(Key, Value)] -> m () -> m ()
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
[(Key, Value)] -> m a -> m a
withThreadContext [(Key, Value)]
tc (m () -> m ())
-> (Either SomeException () -> m ())
-> Either SomeException ()
-> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either SomeException () -> m ()
onUnexpected

  m Thread -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m Thread -> m ()) -> m Thread -> m ()
forall a b. (a -> b) -> a -> b
$ (Thread -> m ()) -> m Thread
forall (m :: * -> *).
MonadUnliftIO m =>
(Thread -> m ()) -> m Thread
Immortal.create ((Thread -> m ()) -> m Thread) -> (Thread -> m ()) -> m Thread
forall a b. (a -> b) -> a -> b
$ \Thread
thread -> do
    Thread -> (Either SomeException () -> m ()) -> m () -> m ()
forall (m :: * -> *).
MonadUnliftIO m =>
Thread -> (Either SomeException () -> m ()) -> m () -> m ()
Immortal.onUnexpectedFinish Thread
thread Either SomeException () -> m ()
onUnexpected' m ()
act'

  m () -> m a
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (m () -> m a) -> m () -> m a
forall a b. (a -> b) -> a -> b
$ Int -> m ()
forall (m :: * -> *). MonadIO m => Int -> m ()
threadDelay Int
forall a. Bounded a => a
maxBound

-- | 'immortalCreate' with logging of unexpected finishes
immortalCreateLogged
  :: (MonadMask m, MonadUnliftIO m, MonadLogger m) => m () -> m a
immortalCreateLogged :: forall (m :: * -> *) a.
(MonadMask m, MonadUnliftIO m, MonadLogger m) =>
m () -> m a
immortalCreateLogged = (Either SomeException () -> m ()) -> m () -> m a
forall (m :: * -> *) a.
(MonadMask m, MonadUnliftIO m) =>
(Either SomeException () -> m ()) -> m () -> m a
immortalCreate ((Either SomeException () -> m ()) -> m () -> m a)
-> (Either SomeException () -> m ()) -> m () -> m a
forall a b. (a -> b) -> a -> b
$ (SomeException -> m ())
-> (() -> m ()) -> Either SomeException () -> m ()
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either SomeException -> m ()
forall {m :: * -> *} {e}. (MonadLogger m, Exception e) => e -> m ()
logEx () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
 where
  logEx :: e -> m ()
logEx e
ex = Message -> m ()
forall (m :: * -> *).
(HasCallStack, MonadLogger m) =>
Message -> m ()
logError (Message -> m ()) -> Message -> m ()
forall a b. (a -> b) -> a -> b
$ Text
"Unexpected Finish" Text -> [SeriesElem] -> Message
:# [Key
"exception" Key -> String -> SeriesElem
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> SeriesElem
.= e -> String
forall e. Exception e => e -> String
displayException e
ex]