packages feed

happstack-util 0.2.1 → 6.0.3

raw patch · 18 files changed

Files

Setup.hs view
@@ -1,3 +1,3 @@ #!/usr/bin/env runhaskell import Distribution.Simple-main = defaultMainWithHooks defaultUserHooks+main = defaultMainWithHooks simpleUserHooks
happstack-util.cabal view
@@ -1,6 +1,5 @@-Cabal-version:       >=1.2.3 Name:                happstack-util-Version:             0.2.1+Version:             6.0.3 Synopsis:            Web framework License:             BSD3 License-file:        COPYING@@ -10,7 +9,13 @@ Category:            Web, Distributed Computing Description:         Miscellaneous utilities for Happstack packages. Build-type:          Simple+Cabal-version:       >=1.6 +source-repository head+    type:     darcs+    subdir:   happstack-util+    location: http://patch-tag.com/r/mae/happstack+ Flag base4     Description: Choose the even newer, even smaller, split-up base package. @@ -24,20 +29,25 @@                        directory,                        extensible-exceptions,                         hslogger >= 1.0.2,-                       mtl,+                       mtl >= 1.1 && < 2.1,                        old-locale,                        old-time,-                       parsec < 3,+                       parsec < 4,                        process,                        time,-                       QuickCheck < 2,                        random,-                       template-haskell+                       network >= 2.2 && < 3,+                       template-haskell,+                       unix-compat,+                       filepath   if flag(base4)-    Build-Depends:       base >= 4+    Build-Depends:       base >= 4 && < 5   else     Build-Depends:       base < 4-+    +  if !os(windows)+    build-depends: unix+       hs-source-dirs:      src   if flag(tests)     hs-source-dirs:    tests@@ -48,6 +58,7 @@                        Happstack.Crypto.SHA1,                        Happstack.Crypto.MD5,                        Happstack.Crypto.W64,+                       Happstack.Util.AutoBuild,                        Happstack.Util.ByteStringCompat,                        Happstack.Util.Common,                        Happstack.Util.Concurrent,@@ -55,26 +66,32 @@                        Happstack.Util.Daemonize,                        Happstack.Util.HostAddress,                        Happstack.Util.LogFormat,-                       Happstack.Util.TimeOut,+                       Happstack.Util.OpenExclusively,                        Happstack.Util.TH,-                       Happstack.Util.Testing+                       Happstack.Util.FileManip   if flag(tests)-    Exposed-modules:   Happstack.Util.Tests-    Exposed-modules:   Happstack.Util.Tests.HostAddress+    Build-Depends:+                       QuickCheck >= 2 && < 2.5,+                       HUnit+    Exposed-modules:   Happstack.Util.Testing,+                       Happstack.Util.Tests,+                       Happstack.Util.Tests.HostAddress    extensions:          CPP, UndecidableInstances, BangPatterns, StandaloneDeriving,                        DeriveDataTypeable, TemplateHaskell, RecursiveDo-  ghc-options:         -Wall+  if impl(ghc >= 6.12)+     ghc-options:      -Wall -fno-warn-unused-do-bind+  else+     ghc-options:      -Wall   GHC-Prof-Options:    -auto-all  Executable happstack-util-tests   Main-Is: Test.hs   GHC-Options: -threaded-  Build-depends: HUnit   hs-source-dirs: tests, src   if flag(tests)     Buildable: True-    Build-Depends: network+    Build-Depends: network, HUnit   else     Buildable: False
src/Happstack/Crypto/Base64.hs view
@@ -29,7 +29,6 @@  import Data.Array.Unboxed import Data.Bits-import Data.Int import Data.Char (chr,ord)
src/Happstack/Crypto/MD5.hs view
@@ -1,5 +1,5 @@ {-# LANGUAGE BangPatterns #-}-{-# OPTIONS_GHC -funbox-strict-fields -fvia-c -optc-funroll-all-loops -optc-O3 #-}+{-# OPTIONS_GHC -funbox-strict-fields #-} -- -- Module      : Happstack.Crypto.MD5 -- License     : BSD3
src/Happstack/Crypto/SHA1.lhs view
@@ -161,5 +161,5 @@ >     where getn n = chr (fromIntegral (x0 `shiftR` (n*8) .&. 0xFF))  > rotL :: Word32 -> Rotation -> Word32-> rotL a s = shiftL a s .|. shiftL a (s-32)+> rotL a s = shiftL a s .|. shiftR a (32 - s)
src/Happstack/Crypto/W64.hs view
@@ -4,6 +4,7 @@ import Happstack.Crypto.DES import Happstack.Crypto.SHA1 import Data.List+import Data.Bits import Numeric(readHex) #ifdef TEST import Test.QuickCheck@@ -31,7 +32,7 @@ quadCharToW64 :: (Num b, Enum a) => [a] -> b quadCharToW64 = fromInteger . impl . map (fromIntegral.fromEnum)     where impl :: [Integer] -> Integer-          impl [a,b,c,d]=(a*2^24+b*2^16+c*2^8+d)+          impl [a,b,c,d] = (a `shiftL` 24) + (b `shiftL` 16) + (c `shiftL` 8) + d           impl _ = error "Argument to quadCharToW64 must be length 4"  w64ToQuadChar :: (Integral a, Enum b) => a -> [b]
+ src/Happstack/Util/AutoBuild.hs view
@@ -0,0 +1,93 @@+-------------------------------------------------------------------------------+-- |+-- Module      :  Happstack.Util.AutoBuild+-- Copyright   :  Happstack.com 2009+-- License     :  BSD3+--+-- Maintainer  :  Matthew Elder+-- Stability   :  provisional+-- Portability :  linux/windows+--+-------------------------------------------------------------------------------+module Happstack.Util.AutoBuild (+    autoBuild+    ) where++import Control.Concurrent (forkIO, threadDelay)+import Control.Concurrent.MVar (MVar, newEmptyMVar, putMVar, takeMVar)+import Control.Exception (bracket)+import System.Directory (getModificationTime)+import System.Exit (ExitCode(..), exitFailure)+import System.Process+import System.Time (ClockTime)+import System.IO++-- | Functionality for the autoBuild tool.+--   Inspired by searchpath.+autoBuild :: String   -- ^ Build command+          -> String   -- ^ Path to binary+          -> [String] -- ^ Arguments to use when running binary+          -> IO ()+autoBuild buildCmd binPath binArgs = do+    putStrLn "Performing the initial build. . ."+    buildSuccess <- buildBin buildCmd -- initial build+    if buildSuccess+        then do+            mph <- newEmptyMVar+            newMod <- getModificationTime binPath+            forkIO (builder mph buildCmd binPath newMod)+            runner mph binPath binArgs+            +        else do+            putStrLn "Initial build failed, see 'build.out.log' and 'build.err.log'."+            exitFailure++-- builds the program+builder :: MVar ProcessHandle -> String -> FilePath -> ClockTime -> IO ()+builder mph buildCmd binPath lastMod = do+    -- add a delay between build attempts (5 seconds)+    threadDelay 5000000+    +    buildSuccess <- buildBin buildCmd+    newMod <- getModificationTime binPath+    +    -- if the build yielded a new binary, terminate the process+    if buildSuccess && (newMod /= lastMod)+        then do+            putStrLn "A new binary has been built, killing the existing one. . ."+            terminateProcess =<< takeMVar mph+        else return ()+        +    -- continue loop+    builder mph buildCmd binPath newMod++-- runs the program+runner :: MVar ProcessHandle -> FilePath -> [String] -> IO ()+runner mph binPath binArgs = do+    bracket+        (runBin binPath binArgs)+        (terminateProcess)+        (\ph -> putMVar mph ph >> waitForProcess ph)+    +    -- continue loop+    runner mph binPath binArgs++-- does not block, returns ph+runBin :: String -> [String] -> IO ProcessHandle+runBin binPath binArgs = do+    putStrLn $ "Running binary: " ++ (showCmd binPath binArgs)+    ph <- runProcess binPath binArgs Nothing Nothing Nothing Nothing Nothing+    return ph+    where showCmd bp [] = bp+          showCmd bp ba = bp ++ " " ++ unwords ba++-- blocks until built, returns True if build was a success+buildBin :: String -> IO Bool+buildBin buildCmd = do+    (_inp,out,err,ph) <- runInteractiveCommand buildCmd+    appendFile "build.out.log" =<< hGetContents out+    appendFile "build.err.log" =<< hGetContents err+    waitForProcess ph+    exitCode <- getProcessExitCode ph+    return (exitCode == Just ExitSuccess)+
src/Happstack/Util/Common.hs view
@@ -21,6 +21,7 @@ import System.Process import System.IO.Unsafe import System.Time+import Control.Arrow (first,second)  type Seconds = Int type EpochSeconds = Int64@@ -38,9 +39,8 @@  -- | Put a line into a handle followed by "\r\n" and echo to stdout hPutLine :: Handle -> String -> IO ()-hPutLine handle line = -	do-	hPutStr handle $ line+hPutLine handle line = do+	hPutStr handle line 	hPutStr handle "\r\n" 	hFlush handle 	logMC DEBUG line@@ -63,22 +63,31 @@   unBracket, ltrim, rtrim, trim :: String -> String+-- | Removes the whitespace surrounding a string as well+-- as the first and last character.+-- @unBracket "  (asdf) " = "asdf"@ unBracket = tail . init . trim +-- | Drops the whitespace at the start of the string ltrim = dropWhile isSpace +-- | Drops the whitespace at the end of the string rtrim = reverse.ltrim.reverse++-- | Trims the beginning and ending whitespace of a string trim=ltrim.rtrim +-- | Repeadly splits a list by the provided separator and collects the results splitList :: Eq a => a -> [a] -> [[a]] splitList _   [] = []-splitList sep list = first:splitList sep rest-	where (first,rest)=split (==sep) list+splitList sep list = h:splitList sep t+	where (h,t)=split (==sep) list +-- | Repeatedly splits a list and collects the results splitListBy :: (a -> Bool) -> [a] -> [[a]] splitListBy _ [] = []-splitListBy f list = first:splitListBy f rest-	where (first,rest)=split f list+splitListBy f list = h:splitListBy f t+	where (h,t)=split f list  -- | Split is like break, but the matching element is dropped. split :: (a -> Bool) -> [a] -> ([a], [a])@@ -94,21 +103,18 @@ 	(do text <- readFile path;return $ just text) 	`catch` \err -> if isDoesNotExistError err then return noth else ioError err -doSnd :: (a -> b) -> (c,a) -> (c,b)-doSnd f (x,y) = (x,f y)--doFst :: (a -> b) -> (a,c) -> (b,c)-doFst f (x,y) = (f x,y)-- mapFst :: (a -> b) -> [(a,x)] -> [(b,x)]-mapFst f = map (\ (x,y)->(f x,y)) +mapFst = map . first+ mapSnd :: (a -> b) -> [(x,a)] -> [(x,b)]-mapSnd f = map (\ (x,y)->(x,f y)) +mapSnd = map . second  +-- | applies the list of functions to the provided argument  revmap :: a -> [a -> b] -> [b] revmap item = map (\f->f item) +-- | @comp f a b@ compares @a@ and @b@ after apply+-- @f@. comp :: Ord t => (a -> t) -> a -> a -> Ordering comp f e1 e2 = f e1 `compare` f e2 @@ -131,7 +137,7 @@           do hPutStrLn stderr ("Running process "++unwords (cmd:args)++" FAILED ("++show e++")")              hPutStrLn stderr os              hPutStrLn stderr es-             hPutStrLn stderr ("Raising error...")+             hPutStrLn stderr "Raising error..."              fail "Running external command failed"  @@ -148,23 +154,29 @@  -- | Read in any monad. readM :: (Monad m, Read t) => String -> m t-readM s = case readsPrec 0 s of+readM s = case reads s of             [(v,"")] -> return v             _        -> fail "readM: parse error" --- | Convert Maybe into an another monad.+-- | Convert Maybe into an another monad.  This is a simple injection that calls+-- fail when given a Nothing. maybeM :: Monad m => Maybe a -> m a maybeM (Just x) = return x maybeM _        = fail "maybeM: Nothing" --- ! Convert Bool into another monad+-- | Lifts a bool into a MonadPlus, with False mapped to the mzero. boolM :: (MonadPlus m) => Bool -> m Bool boolM False = mzero boolM True  = return True +-- | @notMb a b@ returns @Just a@ if @b@ is @Nothing@ and @Nothing@ if+-- @b@ is @Just _@. notMb :: a-> Maybe a-> Maybe a-notMb v1 v2 = maybe (Just v1) (const Nothing) $ v2+notMb v1 v2 = maybe (Just v1) (const Nothing) v2 +-- | Takes a list of delays, in seconds, and an action to execute+-- repeatedly.  The action is then executed repeatedly in a separate thread+-- until the list has been consumed.  The first action takes place immediately.   periodic :: [Int] -> IO () -> IO ThreadId periodic ts = forkIO . periodic' ts @@ -172,6 +184,8 @@ infixr 8 .^ (.^) :: Int->Int->Int a .^ b = a ^ b++-- | Similar to 'periodic' but runs in the same thread periodic' :: [Int] -> IO a -> IO a periodic' [] x = x periodic' (t:ts) x = x >> threadDelay ((10 .^ 6)*t) >> periodic' ts x
src/Happstack/Util/Cron.hs view
@@ -8,8 +8,12 @@ -- f every t seconds with the first execution t seconds after cron is called. -- cron does not spawn a new thread. cron :: Seconds -> IO () -> IO a-cron seconds action-    = loop-    where loop = do threadDelay (10^(6 :: Int) * seconds)-                    action-                    loop+cron seconds0 action = loop seconds0+    where maxSeconds = (maxBound :: Int) `div`  10^(6 ::Int)+          loop seconds = +              if seconds <= maxSeconds+                then do threadDelay (10^(6 :: Int) * seconds)+                        action+                        loop seconds0+                else do threadDelay (10^(6 :: Int) * maxSeconds)+                        loop (seconds - maxSeconds)
src/Happstack/Util/Daemonize.hs view
@@ -26,7 +26,7 @@     tid1 <- exitIfAlreadyRunning startTime     mId <- myThreadId     tid2 <- appCheck binarylocation startTime mId-    main `finally` (mapM killThread [tid1,tid2])+    main `finally` mapM killThread [tid1,tid2]     where      seconds n = noTimeDiff { tdSec = n }     exitIfAlreadyRunning startTime = @@ -46,11 +46,7 @@         fe <- doesFileExist bl         if not fe then return () else do         appModTime <- getModificationTime bl-        if startTime < appModTime then -             E.throwTo mId $ -                              ExitSuccess -- throws to the main thread--           else return ()+        when (startTime < appModTime) (E.throwTo mId ExitSuccess) -- throws to the main thread  getDaemonizedId :: IO String getDaemonizedId
+ src/Happstack/Util/FileManip.hs view
@@ -0,0 +1,117 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++module Happstack.Util.FileManip (always, find) where++import qualified System.PosixCompat.Files as F+import Control.Monad.State+import qualified Control.Exception.Extensible as E+import System.IO+import Data.List (sort)+import System.Directory (getDirectoryContents)+import System.IO.Unsafe (unsafeInterleaveIO)+import System.FilePath ((</>))+++-- | Information collected during the traversal of a directory.+data FileInfo = FileInfo+    {+      infoPath :: FilePath -- ^ file path+    , infoDepth :: Int -- ^ current recursion depth+    , infoStatus :: F.FileStatus -- ^ status of file+    } deriving (Eq)+instance Eq F.FileStatus where+    a == b = F.deviceID a == F.deviceID b &&+             F.fileID a == F.fileID b++-- | Construct a 'FileInfo' value.++mkFI :: FilePath -> Int -> F.FileStatus -> FileInfo++mkFI = FileInfo++-- | Monadic container for file information, allowing for clean+-- construction of combinators.  Wraps the 'State' monad, but doesn't+-- allow 'get' or 'put'.+newtype FindClause a = FC { runFC :: State FileInfo a }+    deriving (Functor, Monad)++-- | Run the given 'FindClause' on the given 'FileInfo' and return its+-- result.  This can be useful if you are writing a function to pass+-- to 'fold'.+--+-- Example:+--+-- > myFoldFunc :: a -> FileInfo -> a+-- > myFoldFunc a i = let useThisFile = evalClause (fileName ==? "foo") i+-- >                  in if useThisFile+-- >                     then fiddleWith a+-- >                     else a+--+evalClause :: FindClause a -> FileInfo -> a+evalClause = evalState . runFC++evalFI :: FindClause a+       -> FilePath+       -> Int+       -> F.FileStatus+       -> a+evalFI m p d s = evalClause m (mkFI p d s)++type FilterPredicate = FindClause Bool+type RecursionPredicate = FindClause Bool++-- | List the files in the given directory, sorted, and without \".\"+-- or \"..\".+getDirContents :: FilePath -> IO [FilePath]++getDirContents dir = (sort . filter goodName) `liftM` getDirectoryContents dir+    where goodName "." = False+          goodName ".." = False+          goodName _ = True++-- | Search a directory recursively, with recursion controlled by a+-- 'RecursionPredicate'.  Lazily return a sorted list of all files+-- matching the given 'FilterPredicate'.  Any errors that occur are+-- dealt with by the given handler.+findWithHandler ::+    (FilePath -> E.SomeException -> IO [FilePath]) -- ^ error handler+    -> RecursionPredicate -- ^ control recursion into subdirectories+    -> FilterPredicate -- ^ decide whether a file appears in the result+    -> FilePath -- ^ directory to start searching+    -> IO [FilePath] -- ^ files that matched the 'FilterPredicate'++findWithHandler errHandler recurse filter path =+    E.handle (errHandler path) $ F.getSymbolicLinkStatus path >>= visit path 0+  where visit path' depth st =+            if F.isDirectory st && evalFI recurse path' depth st+              then unsafeInterleaveIO (traverse path' (succ depth) st)+              else filterPath path' depth st []+        traverse dir depth dirSt = do+            names <- E.catch (getDirContents dir) (errHandler dir)+            filteredPaths <- forM names $ \name -> do+                let path' = dir </> name+                unsafeInterleaveIO $ E.handle (errHandler path')+                    (F.getSymbolicLinkStatus path' >>= visit path' depth)+            filterPath dir depth dirSt (concat filteredPaths)+        filterPath path' depth st result =+            return $ if evalFI filter path' depth st+                then path':result+                else result++-- | Search a directory recursively, with recursion controlled by a+-- 'RecursionPredicate'.  Lazily return a sorted list of all files+-- matching the given 'FilterPredicate'.  Any errors that occur are+-- ignored, with warnings printed to 'stderr'.+find :: RecursionPredicate -- ^ control recursion into subdirectories+     -> FilterPredicate -- ^ decide whether a file appears in the result+     -> FilePath -- ^ directory to start searching+     -> IO [FilePath] -- ^ files that matched the 'FilterPredicate'++find = findWithHandler warnOnError+    where warnOnError path err =+              hPutStrLn stderr (path ++ ": " ++ show err) >> return []++-- | Unconditionally return 'True'.+always :: FindClause Bool+always = return True+
src/Happstack/Util/HostAddress.hs view
@@ -11,22 +11,22 @@ -- | Converts a HostAddress to a String in dot-decimal notation showHostAddress :: HostAddress -> String showHostAddress num = concat [show q1, ".", show q2, ".", show q3, ".", show q4]-  where (num',q1)   = (num `quotRem` 256)-        (num'',q2)  = (num' `quotRem` 256)-        (num''',q3) = (num'' `quotRem` 256)-        (_,q4)      = (num''' `quotRem` 256)+  where (num',q1)   = num `quotRem` 256+        (num'',q2)  = num' `quotRem` 256+        (num''',q3) = num'' `quotRem` 256+        (_,q4)      = num''' `quotRem` 256  -- | Converts a IPv6 HostAddress6 to standard hex notation showHostAddress6 :: HostAddress6 -> String showHostAddress6 (a,b,c,d) =-  (concat . intersperse ":" . map (flip showHex $ "")) $+  (concat . intersperse ":" . map (flip showHex ""))     [p1,p2,p3,p4,p5,p6,p7,p8]-  where (a',p2) = (a `quotRem` 65536)-        (_,p1)  = (a' `quotRem` 65536)-        (b',p4) = (b `quotRem` 65536)-        (_,p3)  = (b' `quotRem` 65536)-        (c',p6) = (c `quotRem` 65536)-        (_,p5)  = (c' `quotRem` 65536)-        (d',p8) = (d `quotRem` 65536)-        (_,p7)  = (d' `quotRem` 65536)+  where (a',p2) = a `quotRem` 65536+        (_,p1)  = a' `quotRem` 65536+        (b',p4) = b `quotRem` 65536+        (_,p3)  = b' `quotRem` 65536+        (c',p6) = c `quotRem` 65536+        (_,p5)  = c' `quotRem` 65536+        (d',p8) = d `quotRem` 65536+        (_,p7)  = d' `quotRem` 65536
src/Happstack/Util/LogFormat.hs view
@@ -6,7 +6,7 @@ import System.Locale (defaultTimeLocale) import Data.Time.Format (FormatTime(..), formatTime) --- Format the time as describe in the Apache combined log format.+-- | Format the time as describe in the Apache combined log format. --   http://httpd.apache.org/docs/2.2/logs.html#combined -- -- The format is:@@ -21,7 +21,7 @@ formatTimeCombined :: FormatTime t => t -> String formatTimeCombined = formatTime defaultTimeLocale "%d/%b/%Y:%H:%M:%S %z" --- Format the request as describe in the Apache combined log format.+-- | Format the request as describe in the Apache combined log format. --   http://httpd.apache.org/docs/2.2/logs.html#combined --  -- The format is: "%h - %u %t \"%r\" %>s %b \"%{Referer}i\" \"%{User-agent}i\""@@ -44,7 +44,7 @@   -> String   -> String formatRequestCombined host user time requestLine responseCode size referer userAgent =-  unwords $+  unwords      [ host     , user     , "[" ++ formattedTime ++ "]"
+ src/Happstack/Util/OpenExclusively.hs view
@@ -0,0 +1,25 @@+{-# LANGUAGE CPP #-}+ -- | Cross platform way to open a file exclusively+module Happstack.Util.OpenExclusively+    ( -- | Cross platform way to open a file exclusively+      openExclusively+    ) where+    +import System.IO++#ifdef mingw32_HOST_OS+-- Windows opens files for exclusive writing by default+openExclusively :: FilePath -> IO Handle+openExclusively fp = openFile fp ReadWriteMode+#endif++#ifndef mingw32_HOST_OS+import System.Posix.IO++-- Unix needs to use a special open call to open files for exclusive writing+openExclusively :: FilePath -> IO Handle+openExclusively fp =+    fdToHandle =<< openFd fp ReadWrite (Just 0o600) flags+    where flags = defaultFileFlags {exclusive = True, trunc = True}+#endif+
src/Happstack/Util/Testing.hs view
@@ -1,18 +1,31 @@-module Happstack.Util.Testing (qctest, qccheck, qcrun) where+module Happstack.Util.Testing (qctest, qccheck) where -import Test.HUnit as HU-import Test.QuickCheck as QC-import Test.QuickCheck.Batch (TestResult(..),TestOptions(..),run)+import qualified Test.HUnit as HU+import qualified Test.QuickCheck as QC+-- import Test.QuickCheck.Batch (TestResult(..),TestOptions(..),run) import System.Random--qctest :: QC.Testable a => a -> Test-qctest = qccheck defaultConfig-+{- qccheck :: QC.Testable a => Config -> a -> Test qccheck config a = TestCase $   do rnd <- newStdGen      tests config (evaluate a) rnd 0 0 []+-} +qccheck :: QC.Testable a => QC.Args -> a -> HU.Test+qccheck args prop = +  HU.TestCase $+    do result <- QC.quickCheckWithResult args prop+       case result of+         (QC.Success {}) -> return ()+         (QC.GaveUp {}) -> +             let ntest = QC.numTests result+             in HU.assertFailure $ "Arguments exhausted after" ++ show ntest ++ (if ntest == 1 then " test." else " tests.")+         (QC.Failure {}) -> HU.assertFailure (QC.reason result)+         (QC.NoExpectedFailure {}) -> HU.assertFailure $ "No Expected Failure"++qctest :: QC.Testable a => a -> HU.Test+qctest = qccheck QC.stdArgs+{- qcrun :: QC.Testable a => a -> TestOptions -> Test qcrun prop opts = TestCase $     do res <- run prop opts@@ -21,7 +34,7 @@          (TestExausted _ ntest _) ->               assertFailure $ "Arguments exhausted after" ++ show ntest ++ (if ntest == 1 then " test." else " tests.")          (TestFailed testArgs ntest) ->-             assertFailure $ ( "Falsifiable, after "+             assertFailure ( "Falsifiable, after "                    ++ show ntest                    ++ " tests:\n"                    ++ unlines testArgs@@ -41,12 +54,13 @@            Just True  ->              tests config gen rnd1 (ntest+1) nfail (stamp result:stamps)            Just False ->-             assertFailure $ ( "Falsifiable, after "+             assertFailure ("Falsifiable, after "                    ++ show ntest                    ++ " tests:\n"                    ++ unlines (arguments result)-                    )+                   )      where       result      = generate (configSize config ntest) rnd2 gen       (rnd1,rnd2) = split rnd0 +-}
− src/Happstack/Util/TimeOut.hs 
@@ -1,148 +0,0 @@-{-# LANGUAGE StandaloneDeriving, DeriveDataTypeable, RecursiveDo #-}---------------------------------------------------------------------------------- |--- Module      :  Happstack.Util.TimeOut--- Copyright   :  (c) Happstack.com, 2009; (c) HAppS.org, 2005--- License     :  BSD3--- --- Portability :  uses mdo------ Timeout implementation for performing operations in the IO monad--- with a timeout added. Both using Maybe and exceptions to handle--- timeouts are supported.------ Timeouts can be implemented in GHC with either a global handler--- or a per-timeout thread which sleeps until the timeout. The latter--- is used in this module. Blocking on foreign calls can cause--- problems as GHC has no way of interrupting such threads.--- The module provides a slightly slower alternative implementation--- which returns even if the computation has blocked on a foreign--- call. This should not be an issue unless -threaded is used.------ The timeouts are currently limited to a maximum of about--- 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 Happstack.Util.TimeOut -    (withTimeOut, withTimeOutMaybe,-     withSafeTimeOut, withSafeTimeOutMaybe,-     TimeOutException(..), second-    ) where--import Control.Concurrent-import Control.Exception.Extensible as E-import Data.Typeable(Typeable)-import Data.IORef-import Data.Maybe-import System.IO.Unsafe (unsafePerformIO)-import Control.Monad (when)--import Happstack.Util.Concurrent--type TimeOutTId = Int -- must be distinct within a thread only --{-# NOINLINE timeOutIdState #-}-timeOutIdState :: IORef TimeOutTId-timeOutIdState = unsafePerformIO $ newIORef minBound--nextTimeOutId :: IO TimeOutTId-nextTimeOutId = -  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)--data TimeOutException = TimeOutException -- that's the exception the user may catch -  deriving(Typeable)--instance Show TimeOutExceptionI where show _ = error "this TimeOutExceptionI should have been caught within this module"-instance E.Exception TimeOutExceptionI--deriving instance Show TimeOutException-instance E.Exception TimeOutException--throw' :: Exception exception => exception -> b-throw' = throw--throwTo' :: Exception e => ThreadId -> e -> IO ()-throwTo' = E.throwTo--catch' :: Exception e => IO a -> (e -> IO a) -> IO a-catch' = E.catch--try' :: IO a -> IO (Either SomeException a) -- give a type signature for try -try' = E.try----- module internal function -catchTimeOutI :: TimeOutTId -> IO a -> IO a -> IO a-catchTimeOutI toId op handler =-  op `catch'` (\e@(TimeOutExceptionI i) -> if i == toId then handler  else throw' e)---- | This handler returns Nothing if the timeout occurs.-withTimeOutMaybe :: Int -> IO a -> IO (Maybe a)-withTimeOutMaybe tout op = do -  toId <- nextTimeOutId-  wtid <- myThreadId-  ktid <- fork ( do threadDelay tout -                    throwTo' wtid (TimeOutExceptionI toId)-               )-  (catchTimeOutI toId) (fmap Just (op >>= \r -> killThread ktid >> return  r)) (return Nothing)---- | This is the normal timeout handler. It throws a TimeOutException exception,--- if the timeout occurs.-withTimeOut :: Int -> IO a -> IO a-withTimeOut tout op = maybeToEx =<< withTimeOutMaybe tout op--maybeToEx :: (Monad m) => Maybe t -> m t  -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 = 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 -          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)-          when e $ killThread wt-  eitherToEx =<< takeMVar mv-  where eitherToEx (Left e) = throw' e-        eitherToEx (Right r) = return r-  ---- | Constant representing one second.-second :: Int-second = 1000000
tests/Happstack/Util/Tests/HostAddress.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} module Happstack.Util.Tests.HostAddress (propShowHostAddress, propShowHostAddress6) where@@ -9,14 +10,16 @@ import System.Random import Test.QuickCheck +#if MIN_VERSION_QuickCheck(2,1,2)+#else instance Arbitrary Word32 where-  arbitrary = choose (minBound, maxBound)+    arbitrary = choose (minBound, maxBound)  instance Random Word32 where   randomR (a,b) g = (fromInteger i,g)     where (i,_) = randomR (toInteger a, toInteger b) g-  random g =-    randomR (minBound,maxBound) g+  random = randomR (minBound,maxBound)+#endif  propShowHostAddress :: HostAddress -> Bool propShowHostAddress a = new == old
tests/Test.hs view
@@ -14,6 +14,6 @@                   else do (c,st) <- runTestText putTextToShowS allTests                           putStrLn (st "")                           return c-       case (failures c) + (errors c) of+       case failures c + errors c of          0 -> return ()          n -> exitFailure