{-

Define timeouts for IO actions

-}
module Plutus.PAB.Timeout (Timeout(..), startTimeout) where

import Control.Concurrent (forkIO, threadDelay)
import Control.Concurrent.STM (TMVar)
import Control.Concurrent.STM qualified as STM
import Data.Default (Default (..))
import Data.Foldable (traverse_)
import Data.Time.Units (Second, toMicroseconds)

newtype Timeout = Timeout { Timeout -> Maybe Second
unTimeout :: Maybe Second }

instance Default Timeout where
    def :: Timeout
def = Maybe Second -> Timeout
Timeout Maybe Second
forall a. Maybe a
Nothing

-- | Create a 'TMVar' that is filled when the timeout expires. If the timeout
--   is 'Nothing', the 'TMVar' is never filled.
startTimeout :: Timeout -> IO (TMVar ())
startTimeout :: Timeout -> IO (TMVar ())
startTimeout (Timeout Maybe Second
t) = do
    TMVar ()
tmv <- IO (TMVar ())
forall a. IO (TMVar a)
STM.newEmptyTMVarIO
    ((Second -> IO ThreadId) -> Maybe Second -> IO ())
-> Maybe Second -> (Second -> IO ThreadId) -> IO ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Second -> IO ThreadId) -> Maybe Second -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ Maybe Second
t ((Second -> IO ThreadId) -> IO ())
-> (Second -> IO ThreadId) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Second
s -> do
        IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ do
            Int -> IO ()
threadDelay (Int -> IO ()) -> Int -> IO ()
forall a b. (a -> b) -> a -> b
$ Integer -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Integer -> Int) -> Integer -> Int
forall a b. (a -> b) -> a -> b
$ Second -> Integer
forall a. TimeUnit a => a -> Integer
toMicroseconds Second
s
            STM () -> IO ()
forall a. STM a -> IO a
STM.atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TMVar () -> () -> STM ()
forall a. TMVar a -> a -> STM ()
STM.putTMVar TMVar ()
tmv ()
    TMVar () -> IO (TMVar ())
forall (f :: * -> *) a. Applicative f => a -> f a
pure TMVar ()
tmv