{-# LANGUAGE CPP #-}
{-# LANGUAGE Safe #-}

-------------------------------------------------------------------------------
-- |
-- Module      :  System.Timeout
-- Copyright   :  (c) The University of Glasgow 2007
-- License     :  BSD-style (see the file libraries/base/LICENSE)
--
-- Maintainer  :  libraries@haskell.org
-- Stability   :  stable
-- Portability :  non-portable
--
-- Attach a timeout event to arbitrary 'IO' computations.
--
-------------------------------------------------------------------------------
-- TODO: Inspect is still suitable.
module System.Timeout ( Timeout, timeout ) where

#if !defined(mingw32_HOST_OS) && !defined(javascript_HOST_ARCH)
import Control.Monad
import GHC.Event           (getSystemTimerManager,
                            registerTimeout, unregisterTimeout)
#endif

import Control.Concurrent
import Control.Exception   (Exception(..), handleJust, bracket,
                            uninterruptibleMask_,
                            asyncExceptionToException,
                            asyncExceptionFromException)
import Data.Unique         (Unique, newUnique)

-- $setup
-- >>> import Prelude
-- >>> import Control.Concurrent (threadDelay)

-- An internal type that is thrown as a dynamic exception to
-- interrupt the running IO computation when the timeout has
-- expired.

-- | An exception thrown to a thread by 'timeout' to interrupt a timed-out
-- computation.
--
-- @since 4.0
newtype Timeout = Timeout Unique deriving Timeout -> Timeout -> Bool
(Timeout -> Timeout -> Bool)
-> (Timeout -> Timeout -> Bool) -> Eq Timeout
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Timeout -> Timeout -> Bool
== :: Timeout -> Timeout -> Bool
$c/= :: Timeout -> Timeout -> Bool
/= :: Timeout -> Timeout -> Bool
Eq

-- | @since 4.0
instance Show Timeout where
    show :: Timeout -> String
show Timeout
_ = String
"<<timeout>>"

-- Timeout is a child of SomeAsyncException
-- | @since 4.7.0.0
instance Exception Timeout where
  toException :: Timeout -> SomeException
toException = Timeout -> SomeException
forall e. Exception e => e -> SomeException
asyncExceptionToException
  fromException :: SomeException -> Maybe Timeout
fromException = SomeException -> Maybe Timeout
forall e. Exception e => SomeException -> Maybe e
asyncExceptionFromException

-- |Wrap an 'IO' computation to time out and return @Nothing@ in case no result
-- is available within @n@ microseconds (@1\/10^6@ seconds). In case a result
-- is available before the timeout expires, @Just a@ is returned. A negative
-- timeout interval means \"wait indefinitely\". When specifying long timeouts,
-- be careful not to exceed @maxBound :: Int@, which on 32-bit machines is only
-- 2147483647 μs, less than 36 minutes.
-- Consider using @Control.Concurrent.Timeout.timeout@ from @unbounded-delays@ package.
--
-- >>> timeout 1000000 (threadDelay 1000 *> pure "finished on time")
-- Just "finished on time"
--
-- >>> timeout 10000 (threadDelay 100000 *> pure "finished on time")
-- Nothing
--
-- The design of this combinator was guided by the objective that @timeout n f@
-- should behave exactly the same as @f@ as long as @f@ doesn't time out. This
-- means that @f@ has the same 'myThreadId' it would have without the timeout
-- wrapper. Any exceptions @f@ might throw cancel the timeout and propagate
-- further up. It also possible for @f@ to receive exceptions thrown to it by
-- another thread.
--
-- A tricky implementation detail is the question of how to abort an @IO@
-- computation. This combinator relies on asynchronous exceptions internally
-- (namely throwing the computation the 'Timeout' exception).  The technique
-- works very well for computations executing inside of the Haskell runtime
-- system, but it doesn't work at all for non-Haskell code.  Foreign function
-- calls, for example, cannot be timed out with this combinator simply because
-- an arbitrary C function cannot receive asynchronous exceptions. When
-- @timeout@ is used to wrap an FFI call that blocks, no timeout event can be
-- delivered until the FFI call returns, which pretty much negates the purpose
-- of the combinator. In practice, however, this limitation is less severe than
-- it may sound. Standard I\/O functions like 'System.IO.hGetBuf',
-- 'System.IO.hPutBuf', Network.Socket.accept, or 'System.IO.hWaitForInput'
-- appear to be blocking, but they really don't because the runtime system uses
-- scheduling mechanisms like @select(2)@ to perform asynchronous I\/O, so it
-- is possible to interrupt standard socket I\/O or file I\/O using this
-- combinator.
---
-- Note that 'timeout' cancels the computation by throwing it the 'Timeout'
-- exception. Consequently blanket exception handlers (e.g. catching
-- 'SomeException') within the computation will break the timeout behavior.
timeout :: Int -> IO a -> IO (Maybe a)
timeout :: forall a. Int -> IO a -> IO (Maybe a)
timeout Int
n IO a
f
    | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<  Int
0    = (a -> Maybe a) -> IO a -> IO (Maybe a)
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> Maybe a
forall a. a -> Maybe a
Just IO a
f
    | Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0    = Maybe a -> IO (Maybe a)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing
#if !defined(mingw32_HOST_OS) && !defined(javascript_HOST_ARCH)
    | rtsSupportsBoundThreads = do
        -- In the threaded RTS, we use the Timer Manager to delay the
        -- (fairly expensive) 'forkIO' call until the timeout has expired.
        --
        -- An additional thread is required for the actual delivery of
        -- the Timeout exception because killThread (or another throwTo)
        -- is the only way to reliably interrupt a throwTo in flight.
        pid <- myThreadId
        ex  <- fmap Timeout newUnique
        tm  <- getSystemTimerManager
        -- 'lock' synchronizes the timeout handler and the main thread:
        --  * the main thread can disable the handler by writing to 'lock';
        --  * the handler communicates the spawned thread's id through 'lock'.
        -- These two cases are mutually exclusive.
        lock <- newEmptyMVar
        let handleTimeout = do
                v <- isEmptyMVar lock
                when v $ void $ forkIOWithUnmask $ \unmask -> unmask $ do
                    v2 <- tryPutMVar lock =<< myThreadId
                    when v2 $ throwTo pid ex
            cleanupTimeout key = uninterruptibleMask_ $ do
                v <- tryPutMVar lock undefined
                if v then unregisterTimeout tm key
                     else takeMVar lock >>= killThread
        handleJust (\e -> if e == ex then Just () else Nothing)
                   (\_ -> return Nothing)
                   (bracket (registerTimeout tm n handleTimeout)
                            cleanupTimeout
                            (\_ -> fmap Just f))
#endif
    | Bool
otherwise = do
        ThreadId
pid <- IO ThreadId
myThreadId
        Timeout
ex  <- (Unique -> Timeout) -> IO Unique -> IO Timeout
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Unique -> Timeout
Timeout IO Unique
newUnique
        (Timeout -> Maybe ())
-> (() -> IO (Maybe a)) -> IO (Maybe a) -> IO (Maybe a)
forall e b a.
Exception e =>
(e -> Maybe b) -> (b -> IO a) -> IO a -> IO a
handleJust (\Timeout
e -> if Timeout
e Timeout -> Timeout -> Bool
forall a. Eq a => a -> a -> Bool
== Timeout
ex then () -> Maybe ()
forall a. a -> Maybe a
Just () else Maybe ()
forall a. Maybe a
Nothing)
                   (\()
_ -> Maybe a -> IO (Maybe a)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing)
                   (IO ThreadId
-> (ThreadId -> IO ())
-> (ThreadId -> IO (Maybe a))
-> IO (Maybe a)
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket (((forall a. IO a -> IO a) -> IO ()) -> IO ThreadId
forkIOWithUnmask (((forall a. IO a -> IO a) -> IO ()) -> IO ThreadId)
-> ((forall a. IO a -> IO a) -> IO ()) -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ \forall a. IO a -> IO a
unmask ->
                                 IO () -> IO ()
forall a. IO a -> IO a
unmask (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> IO ()
threadDelay Int
n IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ThreadId -> Timeout -> IO ()
forall e. Exception e => ThreadId -> e -> IO ()
throwTo ThreadId
pid Timeout
ex)
                            (IO () -> IO ()
forall a. IO a -> IO a
uninterruptibleMask_ (IO () -> IO ()) -> (ThreadId -> IO ()) -> ThreadId -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ThreadId -> IO ()
killThread)
                            (\ThreadId
_ -> (a -> Maybe a) -> IO a -> IO (Maybe a)
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> Maybe a
forall a. a -> Maybe a
Just IO a
f))
        -- #7719 explains why we need uninterruptibleMask_ above.