{-# LANGUAGE TemplateHaskell #-}

-- This file is part of the Wire Server implementation.
--
-- Copyright (C) 2022 Wire Swiss GmbH <opensource@wire.com>
--
-- This program is free software: you can redistribute it and/or modify it under
-- the terms of the GNU Affero General Public License as published by the Free
-- Software Foundation, either version 3 of the License, or (at your option) any
-- later version.
--
-- This program is distributed in the hope that it will be useful, but WITHOUT
-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more
-- details.
--
-- You should have received a copy of the GNU Affero General Public License along
-- with this program. If not, see <https://www.gnu.org/licenses/>.

module Galley.Effects.FireAndForget
  ( FireAndForget,
    fireAndForget,
    spawnMany,
    interpretFireAndForget,
  )
where

import Imports
import Polysemy
import Polysemy.Final
import UnliftIO.Async (pooledMapConcurrentlyN_)

data FireAndForget m a where
  FireAndForgetOne :: m () -> FireAndForget m ()
  SpawnMany :: [m ()] -> FireAndForget m ()

makeSem ''FireAndForget

fireAndForget :: (Member FireAndForget r) => Sem r () -> Sem r ()
fireAndForget :: forall (r :: EffectRow).
Member FireAndForget r =>
Sem r () -> Sem r ()
fireAndForget = Sem r () -> Sem r ()
forall (r :: EffectRow).
Member FireAndForget r =>
Sem r () -> Sem r ()
fireAndForgetOne

-- | Run actions in separate threads and ignore results.
--
-- /Note/: this will also ignore any state and error effects contained in the
-- 'FireAndForget' action. Use with care.
interpretFireAndForget :: (Member (Final IO) r) => Sem (FireAndForget ': r) a -> Sem r a
interpretFireAndForget :: forall (r :: EffectRow) a.
Member (Final IO) r =>
Sem (FireAndForget : r) a -> Sem r a
interpretFireAndForget = forall (m :: * -> *) (e :: Effect) (r :: EffectRow) a.
Member (Final m) r =>
(forall x (rInitial :: EffectRow).
 e (Sem rInitial) x -> Strategic m (Sem rInitial) x)
-> Sem (e : r) a -> Sem r a
interpretFinal @IO ((forall x (rInitial :: EffectRow).
  FireAndForget (Sem rInitial) x -> Strategic IO (Sem rInitial) x)
 -> Sem (FireAndForget : r) a -> Sem r a)
-> (forall x (rInitial :: EffectRow).
    FireAndForget (Sem rInitial) x -> Strategic IO (Sem rInitial) x)
-> Sem (FireAndForget : r) a
-> Sem r a
forall a b. (a -> b) -> a -> b
$ \case
  FireAndForgetOne Sem rInitial ()
action -> do
    IO (f ())
action' <- Sem rInitial ()
-> Sem (WithStrategy IO f (Sem rInitial)) (IO (f ()))
forall (n :: * -> *) a (m :: * -> *) (f :: * -> *).
n a -> Sem (WithStrategy m f n) (m (f a))
runS Sem rInitial ()
action
    IO x
-> forall {f :: * -> *}.
   Functor f =>
   Sem (WithStrategy IO f (Sem rInitial)) (IO (f x))
forall (m :: * -> *) a (n :: * -> *).
Functor m =>
m a -> Strategic m n a
liftS (IO x
 -> forall {f :: * -> *}.
    Functor f =>
    Sem (WithStrategy IO f (Sem rInitial)) (IO (f x)))
-> IO x
-> forall {f :: * -> *}.
   Functor f =>
   Sem (WithStrategy IO f (Sem rInitial)) (IO (f x))
forall a b. (a -> b) -> a -> b
$ IO ThreadId -> IO x
IO ThreadId -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO ThreadId -> IO x)
-> (IO (f ()) -> IO ThreadId) -> IO (f ()) -> IO x
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO () -> IO ThreadId
forall (m :: * -> *). MonadUnliftIO m => m () -> m ThreadId
forkIO (IO () -> IO ThreadId)
-> (IO (f ()) -> IO ()) -> IO (f ()) -> IO ThreadId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO (f ()) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (f ()) -> IO x) -> IO (f ()) -> IO x
forall a b. (a -> b) -> a -> b
$ IO (f ())
action'
  SpawnMany [Sem rInitial ()]
actions -> do
    [IO (f ())]
actions' <- (Sem rInitial ()
 -> Sem (WithStrategy IO f (Sem rInitial)) (IO (f ())))
-> [Sem rInitial ()]
-> Sem (WithStrategy IO f (Sem rInitial)) [IO (f ())]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse Sem rInitial ()
-> Sem (WithStrategy IO f (Sem rInitial)) (IO (f ()))
forall (n :: * -> *) a (m :: * -> *) (f :: * -> *).
n a -> Sem (WithStrategy m f n) (m (f a))
runS [Sem rInitial ()]
actions
    -- I picked this number by fair dice roll, feel free to change it :P
    IO x
-> forall {f :: * -> *}.
   Functor f =>
   Sem (WithStrategy IO f (Sem rInitial)) (IO (f x))
forall (m :: * -> *) a (n :: * -> *).
Functor m =>
m a -> Strategic m n a
liftS (IO x
 -> forall {f :: * -> *}.
    Functor f =>
    Sem (WithStrategy IO f (Sem rInitial)) (IO (f x)))
-> IO x
-> forall {f :: * -> *}.
   Functor f =>
   Sem (WithStrategy IO f (Sem rInitial)) (IO (f x))
forall a b. (a -> b) -> a -> b
$ Int -> (IO (f ()) -> IO ()) -> [IO (f ())] -> IO ()
forall (m :: * -> *) (f :: * -> *) a b.
(MonadUnliftIO m, Foldable f) =>
Int -> (a -> m b) -> f a -> m ()
pooledMapConcurrentlyN_ Int
8 IO (f ()) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void [IO (f ())]
actions'