{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveDataTypeable #-}

module Network.QUIC.Connection.Timeout (
    timeout
  , fire
  , cfire
  , delay
  ) where

import Data.Typeable
import Network.QUIC.Event
import UnliftIO.Concurrent
import qualified UnliftIO.Exception as E

import Network.QUIC.Connection.Types
import Network.QUIC.Connector
import Network.QUIC.Imports
import Network.QUIC.Types

data TimeoutException = TimeoutException String deriving (Int -> TimeoutException -> ShowS
[TimeoutException] -> ShowS
TimeoutException -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TimeoutException] -> ShowS
$cshowList :: [TimeoutException] -> ShowS
show :: TimeoutException -> String
$cshow :: TimeoutException -> String
showsPrec :: Int -> TimeoutException -> ShowS
$cshowsPrec :: Int -> TimeoutException -> ShowS
Show, Typeable)

instance E.Exception TimeoutException where
  fromException :: SomeException -> Maybe TimeoutException
fromException = forall e. Exception e => SomeException -> Maybe e
E.asyncExceptionFromException
  toException :: TimeoutException -> SomeException
toException = forall e. Exception e => e -> SomeException
E.asyncExceptionToException

timeout :: Microseconds -> String -> IO a -> IO (Maybe a)
timeout :: forall a. Microseconds -> String -> IO a -> IO (Maybe a)
timeout (Microseconds Int
ms) String
dmsg IO a
action = do
    ThreadId
tid <- forall (m :: * -> *). MonadIO m => m ThreadId
myThreadId
    TimerManager
timmgr <- IO TimerManager
getSystemTimerManager
#if defined(mingw32_HOST_OS)
    let killMe = void $ forkIO $ E.throwTo tid $ TimeoutException dmsg
#else
    let killMe :: IO ()
killMe = forall e (m :: * -> *).
(Exception e, MonadIO m) =>
ThreadId -> e -> m ()
E.throwTo ThreadId
tid forall a b. (a -> b) -> a -> b
$ String -> TimeoutException
TimeoutException String
dmsg
#endif
        setup :: IO TimeoutKey
setup = TimerManager -> Int -> IO () -> IO TimeoutKey
registerTimeout TimerManager
timmgr Int
ms IO ()
killMe
        cleanup :: TimeoutKey -> IO ()
cleanup TimeoutKey
key = TimerManager -> TimeoutKey -> IO ()
unregisterTimeout TimerManager
timmgr TimeoutKey
key
    forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
(e -> m a) -> m a -> m a
E.handleSyncOrAsync (\(TimeoutException String
_) -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing) forall a b. (a -> b) -> a -> b
$
        forall (m :: * -> *) a b c.
MonadUnliftIO m =>
m a -> (a -> m b) -> (a -> m c) -> m c
E.bracket IO TimeoutKey
setup TimeoutKey -> IO ()
cleanup forall a b. (a -> b) -> a -> b
$ \TimeoutKey
_ -> forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO a
action

fire :: Connection -> Microseconds -> TimeoutCallback -> IO ()
fire :: Connection -> Microseconds -> IO () -> IO ()
fire Connection
conn (Microseconds Int
microseconds) IO ()
action = do
    TimerManager
timmgr <- IO TimerManager
getSystemTimerManager
    forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ TimerManager -> Int -> IO () -> IO TimeoutKey
registerTimeout TimerManager
timmgr Int
microseconds IO ()
action'
  where
    action' :: IO ()
action' = do
        Bool
alive <- forall a. Connector a => a -> IO Bool
getAlive Connection
conn
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
alive IO ()
action forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> (e -> m a) -> m a
`E.catchSyncOrAsync` SomeException -> IO ()
ignore

cfire :: Connection -> Microseconds -> TimeoutCallback -> IO (IO ())
cfire :: Connection -> Microseconds -> IO () -> IO (IO ())
cfire Connection
conn (Microseconds Int
microseconds) IO ()
action = do
    TimerManager
timmgr <- IO TimerManager
getSystemTimerManager
    TimeoutKey
key <- TimerManager -> Int -> IO () -> IO TimeoutKey
registerTimeout TimerManager
timmgr Int
microseconds IO ()
action'
    let cancel :: IO ()
cancel = TimerManager -> TimeoutKey -> IO ()
unregisterTimeout TimerManager
timmgr TimeoutKey
key
    forall (m :: * -> *) a. Monad m => a -> m a
return IO ()
cancel
  where
    action' :: IO ()
action' = do
        Bool
alive <- forall a. Connector a => a -> IO Bool
getAlive Connection
conn
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
alive IO ()
action forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> (e -> m a) -> m a
`E.catchSyncOrAsync` SomeException -> IO ()
ignore

delay :: Microseconds -> IO ()
delay :: Microseconds -> IO ()
delay (Microseconds Int
microseconds) = forall (m :: * -> *). MonadIO m => Int -> m ()
threadDelay Int
microseconds