Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Browse files

Initial commit

  • Loading branch information...
commit 9d1b8a91d3e3fef2ab6873cb687c66ca672ce269 0 parents
@NathanHowell NathanHowell authored
26 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.
2  Setup.hs
@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain
123 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
+-}
+
31 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 <nhowell@alphaheavy.com>
+Maintainer: Nathan Howell <nhowell@alphaheavy.com>
+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
+
Please sign in to comment.
Something went wrong with that request. Please try again.