diff --git a/HAppS-Util.cabal b/HAppS-Util.cabal --- a/HAppS-Util.cabal +++ b/HAppS-Util.cabal @@ -1,5 +1,6 @@ +Cabal-version: >=1.2 Name: HAppS-Util -Version: 0.9.2.1 +Version: 0.9.3 Synopsis: Web framework License: BSD3 License-file: COPYING @@ -7,30 +8,41 @@ Author: HAppS LLC Category: Web, Distributed Computing Maintainer: AlexJacobson@HAppS.org -Build-Depends: base, mtl, hslogger >= 1.0.2, template-haskell, array, - bytestring, old-time, process, directory Build-type: Simple -hs-source-dirs: src -Exposed-modules: - HAppS.Crypto.Base64, - HAppS.Crypto.DES, - HAppS.Crypto.HMAC, - HAppS.Crypto.SHA1, - HAppS.Crypto.MD5, - HAppS.Crypto.W64, - HAppS.Util.ByteStringCompat - HAppS.Util.Common, - HAppS.Util.Concurrent, - HAppS.Util.Daemonize, - HAppS.Util.EventHandler, - HAppS.Util.Exception - HAppS.Util.TimeOut - HAppS.Util.TH -extensions: CPP, ForeignFunctionInterface, - OverlappingInstances, UndecidableInstances, - RecursiveDo, - RankNTypes, FlexibleInstances, - TypeSynonymInstances -cpp-options: -DUNIX -ghc-options: -W -fno-warn-incomplete-patterns -GHC-Prof-Options: -auto-all + +Flag base4 + Description: Choose the even newer, even smaller, split-up base package. + +Library + Build-Depends: mtl, hslogger >= 1.0.2, template-haskell, array, + bytestring, old-time, process, directory + if flag(base4) + Build-Depends: base >= 4 + else + Build-Depends: base < 4 + + hs-source-dirs: src + Exposed-modules: + HAppS.Crypto.Base64, + HAppS.Crypto.DES, + HAppS.Crypto.HMAC, + HAppS.Crypto.SHA1, + HAppS.Crypto.MD5, + HAppS.Crypto.W64, + HAppS.Util.ByteStringCompat + HAppS.Util.Common, + HAppS.Util.Concurrent, + HAppS.Util.Daemonize, + HAppS.Util.EventHandler, + HAppS.Util.TimeOut + HAppS.Util.TH + extensions: CPP, ForeignFunctionInterface, + OverlappingInstances, UndecidableInstances, + RecursiveDo, + RankNTypes, FlexibleInstances, + TypeSynonymInstances + cpp-options: -DUNIX + ghc-options: -W -fno-warn-incomplete-patterns + GHC-Prof-Options: -auto-all + if flag(base4) + cpp-options: -DEXTENSIBLE_EXCEPTIONS diff --git a/src/HAppS/Util/Concurrent.hs b/src/HAppS/Util/Concurrent.hs --- a/src/HAppS/Util/Concurrent.hs +++ b/src/HAppS/Util/Concurrent.hs @@ -26,11 +26,6 @@ writeChanRight chan x= writeChan chan (Right x) writeChanLeft chan x= writeChan chan (Left x) -ignoreFail ret op = op `catch` - (\err ->(error $ "\n\n\nFAILED"++(show err)) >> return ret) - - - fork_ :: IO a -> IO () fork_ c = fork c >> return () @@ -70,6 +65,3 @@ -- | Sleep N seconds sleep :: Int -> IO () sleep n = threadDelay (n * second) where second = 1000000 - - ---ignoreFail ret op = op `catch` (\err ->(error $ "\n\n\nFAILED"++(show err))) diff --git a/src/HAppS/Util/Daemonize.hs b/src/HAppS/Util/Daemonize.hs --- a/src/HAppS/Util/Daemonize.hs +++ b/src/HAppS/Util/Daemonize.hs @@ -46,7 +46,11 @@ if not fe then return () else do appModTime <- getModificationTime bl if startTime < appModTime then - throwTo mId $ ExitException ExitSuccess -- throws to the main thread + throwTo mId $ +#ifndef EXTENSIBLE_EXCEPTIONS + ExitException +#endif + ExitSuccess -- throws to the main thread -- raiseSignal softwareTermination -- can we eliminate posix dependency? else do return () diff --git a/src/HAppS/Util/Exception.hs b/src/HAppS/Util/Exception.hs deleted file mode 100644 --- a/src/HAppS/Util/Exception.hs +++ /dev/null @@ -1,9 +0,0 @@ -module HAppS.Util.Exception where - -import Control.Exception as E - -catchSome = E.catchJust interestingExceptions - -interestingExceptions x@(ArithException _) = Just x -interestingExceptions x@(ArrayException _) = Just x -interestingExceptions _ = Nothing diff --git a/src/HAppS/Util/TimeOut.hs b/src/HAppS/Util/TimeOut.hs --- a/src/HAppS/Util/TimeOut.hs +++ b/src/HAppS/Util/TimeOut.hs @@ -23,6 +23,21 @@ -- 2000 seconds. This is a feature of threadDelay, but -- supporting longer timeouts is certainly possible if -- that is desirable. +-- +-- For nested timeouts there are different ways to implement them: +-- a) attach an id to the exception so that the catch knows wether it may catch +-- this timout exception. I've choosen this because overhead is only passing +-- and incrementing an integer value. A integer wrap araound is possible but +-- too unlikely to happen to make me worry about it +-- b) start a new workiing and killing thread so that if the original thread +-- was run within withTimeOut itself it catches the exception and not an inner +-- timout. (this is done in withSafeTimeOut, for another reason though) +-- c) keep throwing exceptions until the the withTimeOut function kills the +-- killing thread. But consider sequence (forever (timeOut threadDelay 10sec) ) +-- In this case the exception will be called and the next timOut may be entered +-- before the second Exception has been thrown +-- +-- All exceptions but the internal TimeOutExceptionI are rethrown in the calling thread ----------------------------------------------------------------------------- module HAppS.Util.TimeOut (withTimeOut, withTimeOutMaybe, @@ -34,57 +49,102 @@ import Control.Exception as E import Data.Dynamic(toDyn) import Data.Typeable(Typeable) +import Data.IORef +import Data.Maybe +import System.IO.Unsafe (unsafePerformIO) import HAppS.Util.Concurrent -data TimeOutException = TimeOutException +type TimeOutTId = Int -- must be distinct within a thread only + +{-# NOINLINE timeOutIdState #-} +timeOutIdState :: IORef TimeOutTId +timeOutIdState = unsafePerformIO $ newIORef minBound + +nextTimeOutId :: IO TimeOutTId +nextTimeOutId = do + atomicModifyIORef timeOutIdState (\a -> let nid =nextId a in (nid,nid)) + where nextId i | i == maxBound = minBound + nextId i = i + 1 + +data TimeOutExceptionI = TimeOutExceptionI TimeOutTId -- internal exception, should only be used within this module deriving(Typeable) --- | This is the normal timeout handler. It throws a dynamic exception (TimeOutException), --- if the timeout occurs. +data TimeOutException = TimeOutException -- that's the exception the user may catch + deriving(Typeable) +#ifdef EXTENSIBLE_EXCEPTIONS +instance Show TimeOutExceptionI where show _ = error "this TimeOutExceptionI should have been caught within this module" +instance E.Exception TimeOutExceptionI -withTimeOut :: Int -> IO a -> IO a -withTimeOut tout op = do - wtid <- myThreadId - ktid <- fork (threadDelay tout >> throwDynTo wtid TimeOutException) - op `finally` killThread ktid +deriving instance Show TimeOutException +instance E.Exception TimeOutException +throw' :: Exception exception => exception -> b +throw' = throw +throwTo' = throwTo +catch' = E.catch --- | This is the normal timeout handler. If the computation fails or the timeout --- is reached it returns Nothing. +try' :: IO a -> IO (Either SomeException a) -- give a type signature for try +try' = E.try +#else +throw' :: Typeable exception => exception -> b +throw' = throwDyn +throwTo' = throwDynTo +try' = E.try +catch' = catchDyn +#endif + +-- module internal function +catchTimeOutI :: TimeOutTId -> IO a -> IO a -> IO a +catchTimeOutI id op handler = + op `catch'` (\e@(TimeOutExceptionI i) -> if i == id then handler else throw' e) + +#ifdef EXTENSIBLE_EXCEPTIONS +-- | This is the normal timeout handler. It throws a TimeOutException exception, +-- if the timeout occurs. +#else +-- | This is the normal timeout handler. It throws a dynamic exception (TimeOutException), +-- if the timeout occurs. +#endif withTimeOutMaybe :: Int -> IO a -> IO (Maybe a) -withTimeOutMaybe tout op = worker `E.catch` (\_ -> return Nothing) - where worker = do wtid <- myThreadId - ktid <- fork (threadDelay tout >> killThread wtid) - res <- op `finally` killThread ktid - return $ Just res +withTimeOutMaybe tout op = do + id <- nextTimeOutId + wtid <- myThreadId + ktid <- fork ( do threadDelay tout + throwTo' wtid (TimeOutExceptionI id) + ) + (catchTimeOutI id) (fmap Just (op >>= \r -> killThread ktid >> return r)) (return Nothing) +withTimeOut tout op = maybeToEx =<< withTimeOutMaybe tout op + +maybeToEx (Just r) = return r +maybeToEx Nothing = throw' TimeOutException -- | Like timeOut, but additionally it works even if the computation is blocking -- async exceptions (explicitely or by a blocking FFI call). This consumes -- more resources than timeOut, but is still quite fast. -withSafeTimeOut :: Int -> IO a -> IO a -withSafeTimeOut tout op = mdo - mv <- newEmptyMVar - wt <- fork $ do try op >>= tryPutMVar mv >> killThread kt - kt <- fork $ do threadDelay tout - e <- tryPutMVar mv $ Left $ DynException $ toDyn TimeOutException - if e then killThread wt else return () - either throw return =<< takeMVar mv +withSafeTimeOut tout op = maybeToEx =<< withSafeTimeOutMaybe tout op -- | Like withTimeOutMaybe, but handles the operation blocking exceptions like withSafeTimeOut -- does. withSafeTimeOutMaybe :: Int -> IO a -> IO (Maybe a) withSafeTimeOutMaybe tout op = mdo mv <- newEmptyMVar - wt <- fork $ do (op >>= putMVar mv . Just) `E.catch` (\_ -> tryPutMVar mv Nothing >> return ()) - killThread kt - kt <- fork $ do threadDelay tout - e <- tryPutMVar mv Nothing - if e then killThread wt else return () - takeMVar mv + wt <- fork $ do + t <- try' op + case t of + Left e -> tryPutMVar mv (Left e) + Right r -> tryPutMVar mv (Right (Just r)) + killThread kt + kt <- fork $ do + threadDelay tout + e <- tryPutMVar mv (Right Nothing) + if e then killThread wt else return () + eitherToEx =<< takeMVar mv + where eitherToEx (Left e) = throw' e + eitherToEx (Right r) = return r + -- | Constant representing one second. second :: Int second = 1000000 -