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)
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
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 <- 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
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]