{-# LANGUAGE DeriveDataTypeable #-}

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

import Data.Typeable
import Network.QUIC.Event
import System.IO.Unsafe (unsafePerformIO)
import UnliftIO.Concurrent
import qualified UnliftIO.Exception as E
import UnliftIO.STM

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

data TimeoutException = TimeoutException 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

globalTimeoutQ :: TQueue (IO ())
globalTimeoutQ :: TQueue (IO ())
globalTimeoutQ = forall a. IO a -> a
unsafePerformIO forall (m :: * -> *) a. MonadIO m => m (TQueue a)
newTQueueIO
{-# NOINLINE globalTimeoutQ #-}

timeouter :: IO ()
timeouter :: IO ()
timeouter = forall (f :: * -> *) a b. Applicative f => f a -> f b
forever forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => m (m a) -> m a
join forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (forall a. TQueue a -> STM a
readTQueue TQueue (IO ())
globalTimeoutQ)

timeout :: Microseconds -> IO a -> IO (Maybe a)
timeout :: forall a. Microseconds -> IO a -> IO (Maybe a)
timeout (Microseconds Int
ms) IO a
action = do
    ThreadId
tid <- forall (m :: * -> *). MonadIO m => m ThreadId
myThreadId
    TimerManager
timmgr <- IO TimerManager
getSystemTimerManager
    let killMe :: IO ()
killMe = forall e (m :: * -> *).
(Exception e, MonadIO m) =>
ThreadId -> e -> m ()
E.throwTo ThreadId
tid TimeoutException
TimeoutException
        onTimeout :: IO ()
onTimeout = forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically forall a b. (a -> b) -> a -> b
$ forall a. TQueue a -> a -> STM ()
writeTQueue TQueue (IO ())
globalTimeoutQ IO ()
killMe
        setup :: IO TimeoutKey
setup = TimerManager -> Int -> IO () -> IO TimeoutKey
registerTimeout TimerManager
timmgr Int
ms IO ()
onTimeout
        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
TimeoutException -> 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