diff --git a/LICENSE b/LICENSE new file mode 100644 index 0000000..c9ff04f --- /dev/null +++ b/LICENSE @@ -0,0 +1,26 @@ +Copyright (c) 2012, Alpha Heavy Industries +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + +- Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. +- Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. +- Neither the names of the copyright owners nor the names of the + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 index 0000000..9a994af --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/System/Timeout/Control.hs b/System/Timeout/Control.hs new file mode 100644 index 0000000..d613e19 --- /dev/null +++ b/System/Timeout/Control.hs @@ -0,0 +1,123 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | +-- Add updatable timeout functionality to a 'Control.Monad.Monad' transformer stack layered on 'System.IO.IO' + +module System.Timeout.Control + ( runTimeout + -- , disableTimeout + , updateTimeout + , Timeout + , TimeoutException(..) + , Microseconds(..) + ) where + +import Control.Applicative +import Control.Concurrent (myThreadId) +import Control.Exception (Exception, throwTo) +import Control.Exception.Lifted (try) +import Control.Monad (liftM) +import Control.Monad.Base +import Control.Monad.Trans.Control +import Control.Monad.Reader (MonadReader, ReaderT, ask, runReaderT) +import Control.Monad.Trans (MonadIO, MonadTrans, liftIO) +import Data.Typeable (Typeable) +import Data.Unique (Unique, newUnique) +import qualified GHC.Event as E (EventManager, TimeoutKey, getSystemEventManager, registerTimeout, unregisterTimeout, updateTimeout) + +-- | +-- A duration measured in microseconds +newtype Microseconds = Microseconds Int + deriving (Num, Show) + +data TimeoutException + = TimeoutException Unique -- ^ A timeout occurred + | MissingSystemEventManagerException -- ^ The system event manager was unavailable + deriving (Eq, Typeable) + +instance Exception TimeoutException + +instance Show TimeoutException where + show TimeoutException{} = "TimeoutException" + show MissingSystemEventManagerException{} = "MissingSystemEventManagerException" + + +data TimeoutState = TimeoutState {timeoutManager :: E.EventManager, timeoutKey :: E.TimeoutKey} + +newtype Timeout m a = Timeout {unTimeout :: ReaderT TimeoutState m a} + deriving (Applicative, Functor, Monad, MonadReader TimeoutState, MonadIO, MonadTrans) + +instance MonadTransControl Timeout where + newtype StT Timeout a = StTimeoutT {unStAction :: StT (ReaderT TimeoutState) a} + liftWith f = Timeout $ liftWith $ \runReader' -> + f (liftM StTimeoutT . runReader' . unTimeout) + restoreT = Timeout . restoreT . liftM unStAction + +instance MonadBase b m => MonadBase b (Timeout m) where + liftBase = liftBaseDefault + +instance MonadBaseControl b m => MonadBaseControl b (Timeout m) where + newtype StM (Timeout m) a = StMT {unStMT :: ComposeSt Timeout m a} + liftBaseWith = defaultLiftBaseWith StMT + restoreM = defaultRestoreM unStMT + + +-- | +-- Run the timeout transformer +runTimeout + :: (Functor m, MonadBaseControl IO m, MonadIO m) + => Microseconds -- ^ Microseconds in the future + -> Timeout m a -- ^ Timeout action to run + -> m (Either TimeoutException a) -- ^ The result or a 'TimeoutException' +{-# INLINEABLE runTimeout #-} +runTimeout (Microseconds us) (Timeout action) = do + eventMgr <- liftIO $ E.getSystemEventManager + case eventMgr of + Nothing -> return . Left $ MissingSystemEventManagerException + Just eventMgr' -> do + state <- liftIO $ do + tid <- myThreadId + uni <- fmap TimeoutException newUnique + key <- E.registerTimeout eventMgr' us (throwTo tid uni) + return $! TimeoutState{timeoutManager = eventMgr', timeoutKey = key} + try $ do + val <- runReaderT action state + unregisterTimeout_ state + return $! val + +-- | +-- Reset the timeout duration +updateTimeout + :: MonadIO m + => Microseconds -- ^ Microseconds in the future + -> Timeout m () +{-# INLINE updateTimeout #-} +updateTimeout (Microseconds us) = do + TimeoutState{timeoutManager, timeoutKey} <- ask + liftIO $ E.updateTimeout timeoutManager timeoutKey us + +unregisterTimeout_ :: MonadIO m => TimeoutState -> m () +unregisterTimeout_ TimeoutState{timeoutManager, timeoutKey} = + liftIO $ E.unregisterTimeout timeoutManager timeoutKey + +{- + - + - NOTE: commented out until 'runTimeout' allows updating the timeout key + +-- | +-- Disable timeouts for the remainder of execution. +disableTimeout + :: MonadIO m + => Timeout m () +disableTimeout = do + state <- ask + unregisterTimeout_ state +-} + diff --git a/timeout-control.cabal b/timeout-control.cabal new file mode 100644 index 0000000..1313dcc --- /dev/null +++ b/timeout-control.cabal @@ -0,0 +1,31 @@ +Name: timeout-control +Version: 0.1 +Synopsis: Updatable timeouts as a Monad transformer +Description: Add updatable timeout functionality to a Monad transformer stack layered on IO +License: BSD3 +License-File: LICENSE +Author: Nathan Howell +Maintainer: Nathan Howell +Homepage: http://github.com/alphaHeavy/timeout-control +Bug-Reports: http://github.com/alphaHeavy/timeout-control/issues +Category: Concurrency, Control + +Build-type: Simple +Cabal-version: >= 1.10 + +Library + Default-Language: Haskell2010 + Exposed-modules: System.Timeout.Control + Build-depends: base >= 3 && < 5, + ghc-prim == 0.2.*, + lifted-base == 0.1.*, + monad-control == 0.3.*, + mtl >= 2.0 && < 3.0, + transformers-base >= 0.4.1 && < 0.5 + + GHC-Options: -Wall + +Source-Repository head + Type: git + Location: https://github.com/alphaHeavy/timeout-control.git +