HAppS-Util 0.9.2.1 → 0.9.3

raw patch · 5 files changed

+134/−75 lines, 5 filesdep ~basePVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependency ranges changed: base

API changes (from Hackage documentation)

Files

• HAppS-Util.cabal +39/−27
• src/HAppS/Util/Concurrent.hs +0/−8
• src/HAppS/Util/Daemonize.hs +5/−1
• src/HAppS/Util/Exception.hs +0/−9
• src/HAppS/Util/TimeOut.hs +90/−30

@@ -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

@@ -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)))

@@ -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 ()

@@ -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

@@ -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-