-- |
-- Module     : Control.Timeout
-- Copyright  : 2014 Fedor Gogolev, 2013 Selectel
-- License    : MIT
-- Maintainer : Fedor Gogolev <knsd@knsd.net>
-- Stability  : unstable
--
-- This module provides generalized 'sleep' and 'timeout' functions.
--
-- Example:
--
-- > module Main where
-- >
-- > import Control.Timeout (timeout, sleep)
--
-- > main :: IO ()
-- > main = do
-- >     timeout 1 $ sleep 2  -- Will return IO Nothing
-- >     timeout 2 $ sleep 1  -- Will return IO (Just ())
-- >     return ()
--

{-# LANGUAGE DeriveDataTypeable #-}

module Control.Timeout
    ( NominalDiffTime
    , Timeout(..)
    , timeout
    , sleep
    ) where

import Control.Exception (Exception)
import Control.Concurrent (myThreadId, forkIO, killThread, threadDelay, throwTo)
import Data.Typeable (Typeable)
import Data.Time.Clock (NominalDiffTime)
import Data.Unique (Unique, newUnique)

import Control.Monad.Catch (MonadMask(..), bracket, handleJust)
import Control.Monad.Trans (MonadIO, liftIO)

-- | Exception used for timeout handling
newtype Timeout = Timeout Unique
    deriving (Eq, Typeable)

instance Show Timeout where
    show _ = "<<timeout>>"

instance Exception Timeout

-- | Wrap an 'MonadIO' computation to time out and return @Nothing@ in case no result
-- is available within @n@ seconds. In case a result
-- is available before the timeout expires, @Just a@ is returned. A negative
-- timeout interval means \"timeout immediately\".
--
-- 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.
-- 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.
timeout :: (MonadMask m, MonadIO m) => NominalDiffTime -> m a -> m (Maybe a)
timeout t f | t <= 0 = return Nothing
            | otherwise = do
    pid <- liftIO myThreadId
    ex  <- liftIO newUnique >>= return . Timeout
    handleJust (\e -> if e == ex then Just () else Nothing)
               (\_ -> return Nothing)
               (bracket (liftIO $ forkIO (sleep t >> throwTo pid ex))
                        (liftIO . killThread)
                        (\_ -> f >>= return . Just))

-- | Sleep for 'NominalDiffTime', example:
--
-- > sleep 5  -- Will sleep for 5 seconds
sleep :: (MonadIO m) => NominalDiffTime -> m ()
sleep = liftIO . threadDelay . floor . (* 1000000) . toRational