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)
import UnliftIO.Exception (SomeException, displayException)
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 <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall v. KeyMap v -> [(Key, v)]
KeyMap.toList forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). (MonadIO m, MonadThrow m) => m (KeyMap Value)
myThreadContext
forall (m :: * -> *) a. MonadUnliftIO m => m a -> m (Async a)
UnliftIO.async forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
[(Key, Value)] -> m a -> m a
withThreadContext [(Key, Value)]
tc m a
f
immortalCreate
:: (MonadMask m, MonadUnliftIO m)
=> (Either SomeException () -> m ())
-> m ()
-> 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 <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall v. KeyMap v -> [(Key, v)]
KeyMap.toList forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). (MonadIO m, MonadThrow m) => m (KeyMap Value)
myThreadContext
let
act' :: m ()
act' = forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
[(Key, Value)] -> m a -> m a
withThreadContext [(Key, Value)]
tc m ()
act
onUnexpected' :: Either SomeException () -> m ()
onUnexpected' = forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
[(Key, Value)] -> m a -> m a
withThreadContext [(Key, Value)]
tc forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either SomeException () -> m ()
onUnexpected
forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
MonadUnliftIO m =>
(Thread -> m ()) -> m Thread
Immortal.create forall a b. (a -> b) -> a -> b
$ \Thread
thread -> do
forall (m :: * -> *).
MonadUnliftIO m =>
Thread -> (Either SomeException () -> m ()) -> m () -> m ()
Immortal.onUnexpectedFinish Thread
thread Either SomeException () -> m ()
onUnexpected' m ()
act'
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). MonadIO m => Int -> m ()
threadDelay forall a. Bounded a => a
maxBound
immortalCreateLogged
:: (MonadMask m, MonadUnliftIO m, MonadLogger m) => m () -> m a
immortalCreateLogged :: forall (m :: * -> *) a.
(MonadMask m, MonadUnliftIO m, MonadLogger m) =>
m () -> m a
immortalCreateLogged = forall (m :: * -> *) a.
(MonadMask m, MonadUnliftIO m) =>
(Either SomeException () -> m ()) -> m () -> m a
immortalCreate forall a b. (a -> b) -> a -> b
$ forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall {m :: * -> *} {e}. (MonadLogger m, Exception e) => e -> m ()
logEx forall (f :: * -> *) a. Applicative f => a -> f a
pure
where
logEx :: e -> m ()
logEx e
ex = forall (m :: * -> *).
(HasCallStack, MonadLogger m) =>
Message -> m ()
logError forall a b. (a -> b) -> a -> b
$ Text
"Unexpected Finish" Text -> [SeriesElem] -> Message
:# [Key
"exception" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= forall e. Exception e => e -> String
displayException e
ex]