{-# 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