happstack-util 0.2.1 → 0.3.1

raw patch · 14 files changed

+437/−70 lines, 14 filesdep +SMTPClientdep +filepathdep +strict-concurrencydep ~networkPVP ok

version bump matches the API change (PVP)

Dependencies added: SMTPClient, filepath, strict-concurrency, unix, unix-compat

Dependency ranges changed: network

API changes (from Hackage documentation)

Files

• happstack-util.cabal +23/−6
• src/Happstack/Util/AutoBuild.hs +93/−0
• src/Happstack/Util/Common.hs +35/−21
• src/Happstack/Util/Cron.hs +9/−5
• src/Happstack/Util/Daemonize.hs +2/−6
• src/Happstack/Util/FileManip.hs +122/−0
• src/Happstack/Util/HostAddress.hs +13/−13
• src/Happstack/Util/LogFormat.hs +3/−3
• src/Happstack/Util/Mail.hs +94/−0
• src/Happstack/Util/OpenExclusively.hs +24/−0
• src/Happstack/Util/Testing.hs +3/−3
• src/Happstack/Util/TimeOut.hs +14/−10
• tests/Happstack/Util/Tests/HostAddress.hs +1/−2
• tests/Test.hs +1/−1

@@ -1,6 +1,5 @@-Cabal-version:       >=1.2.3 Name:                happstack-util-Version:             0.2.1+Version:             0.3.1 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/publicrepos/happstack+ Flag base4     Description: Choose the even newer, even smaller, split-up base package. @@ -32,12 +37,20 @@                        time,                        QuickCheck < 2,                        random,-                       template-haskell+                       SMTPClient >= 1.0.1 && < 1.1,+                       strict-concurrency,+                       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 +61,7 @@                        Happstack.Crypto.SHA1,                        Happstack.Crypto.MD5,                        Happstack.Crypto.W64,+                       Happstack.Util.AutoBuild,                        Happstack.Util.ByteStringCompat,                        Happstack.Util.Common,                        Happstack.Util.Concurrent,@@ -55,9 +69,12 @@                        Happstack.Util.Daemonize,                        Happstack.Util.HostAddress,                        Happstack.Util.LogFormat,+                       Happstack.Util.Mail,+                       Happstack.Util.OpenExclusively,                        Happstack.Util.TimeOut,                        Happstack.Util.TH,-                       Happstack.Util.Testing+                       Happstack.Util.Testing,+                       Happstack.Util.FileManip   if flag(tests)     Exposed-modules:   Happstack.Util.Tests     Exposed-modules:   Happstack.Util.Tests.HostAddress

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

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

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

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

@@ -0,0 +1,122 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++module Happstack.Util.FileManip (always, find) where++import qualified System.PosixCompat.Files as F+import qualified System.PosixCompat.Types as T+import Control.Monad+import Control.Monad.State+import Control.Exception.Extensible (Exception)+import qualified Control.Exception.Extensible as E+import Data.Bits+import System.IO+import Data.List (sort)+import System.Directory (getDirectoryContents)+import System.IO.Unsafe (unsafeInterleaveIO, unsafePerformIO)+import System.FilePath ((</>), takeDirectory, takeExtension, takeFileName)+++-- | 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+

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

@@ -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 ++ "]"

@@ -0,0 +1,94 @@+-----------------------------------------------------------------------------
+-- |
+-- Module      :  Happstack.Util.Mail
+-- Copyright   :  Happstack.com 2009
+-- License     :  BSD3
+--
+-- Maintainer  :  Matthew Elder
+-- Stability   :  provisional
+-- Portability :  linux/windows
+--
+-- Mail is a simple library with which you can add email functionality to your
+-- application. It assumes you have access to a smarthost which can relay all
+-- your mail.
+-- 
+-- As an example:
+--
+-- > import Happstack.Util.Mail
+-- > main :: IO ()
+-- > main = do
+-- >     sendSimpleMessages "10.2.23.11" "example.com" [message]
+-- >     where message = SimpleMessage
+-- >                         [NameAddr (Just "John Doe") "johnd@example.com"]
+-- >                         [NameAddr (Just "Patch-Tag Team") "team@patch-tag.com"]
+-- >                         "My test email using Happstack.Util.Mail"
+-- >                         "Hi, this is a test email which uses Happstack."
+
+module Happstack.Util.Mail
+    ( NameAddr(..)
+    , SimpleMessage(..)
+    , sendRawMessages
+    , sendSimpleMessages
+    ) where
+
+import Data.IORef (newIORef, readIORef)
+import Network.Socket
+    (SockAddr(..)
+    , inet_addr
+    )
+import Network.SMTP.Client
+import System.Log.Logger (Priority(..), logM)
+import System.Time
+    ( CalendarTime(..)
+    , getClockTime
+    , toCalendarTime
+    )
+
+data SimpleMessage
+    = SimpleMessage
+        { from :: [NameAddr] -- ^ The sender(s)
+        , to :: [NameAddr]   -- ^ The recipient(s)
+        , subject :: String  -- ^ The subject line
+        , body :: String     -- ^ The body
+        }
+    deriving (Show)
+
+toMessage :: CalendarTime -> SimpleMessage -> Message
+toMessage ct sm =
+    Message
+        [From (from sm), To (to sm), Subject (subject sm), Date ct]
+        (body sm)
+        
+log' :: Priority -> String -> IO ()
+log' = logM "Happstack.Util.Mail"
+
+-- | Simplest way to send mail.  Takes the smarthost ip, the HELO domain, and a list of SimpleMessage.
+sendSimpleMessages :: String          -- ^ IP address of the smarthost
+                   -> String          -- ^ HELO domain (should be the same as your from-address-domain)
+                   -> [SimpleMessage] -- ^ List of simple messages to send
+                   -> IO ()
+sendSimpleMessages smartHostIp heloDomain simpleMessages = do
+    nowCT <- toCalendarTime =<< getClockTime
+    hostAddr <- inet_addr smartHostIp
+    let smtpSockAddr = SockAddrInet 25 hostAddr
+    sendRawMessages smtpSockAddr heloDomain (map (toMessage nowCT) simpleMessages)
+
+-- | Use this if you need more control than sendSimpleMessages gives you.
+sendRawMessages :: SockAddr  -- ^ SockAddr for the smarthost
+                -> String    -- ^ HELO domain (should be the same as your from-address-domain)
+                -> [Message] -- ^ List of messages to send
+                -> IO ()
+sendRawMessages smtpSockAddr heloDomain messages = do
+    log' NOTICE $ "connecting to SMTP smarthost: " ++ show smtpSockAddr
+    sentRef <- newIORef []
+    sendSMTP' (log' INFO) (Just sentRef) heloDomain smtpSockAddr messages
+    statuses <- readIORef sentRef
+  
+    -- If no exception was caught, statuses is guaranteed to be
+    -- the same length as the list of input messages, therefore head won't fail here.
+    log' NOTICE $ "attempting to send messages:\n" ++ show messages
+    case head statuses of
+        Nothing ->
+            return ()
+        Just status ->
+            log' ERROR $ "message failed: " ++ show status

@@ -0,0 +1,24 @@+ -- | 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+

@@ -21,7 +21,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,11 +41,11 @@            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

@@ -1,4 +1,5 @@-{-# LANGUAGE StandaloneDeriving, DeriveDataTypeable, RecursiveDo #-}+{-# LANGUAGE StandaloneDeriving, DeriveDataTypeable, RecursiveDo,+             BangPatterns, UnboxedTuples #-}  ----------------------------------------------------------------------------- -- |@@ -47,9 +48,9 @@     ) where  import Control.Concurrent+import qualified Control.Concurrent.MVar.Strict as SM 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)@@ -59,16 +60,18 @@ type TimeOutTId = Int -- must be distinct within a thread only   {-# NOINLINE timeOutIdState #-}-timeOutIdState :: IORef TimeOutTId-timeOutIdState = unsafePerformIO $ newIORef minBound+timeOutIdState :: SM.MVar TimeOutTId+timeOutIdState = unsafePerformIO $ SM.newMVar 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+  SM.modifyMVar timeOutIdState $ \a ->+      let nid = nextId a in return (nid `seq` (nid,nid)) -data TimeOutExceptionI = TimeOutExceptionI TimeOutTId -- internal exception, should only be used within this module +  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 @@ -98,7 +101,8 @@ 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.+-- | This handler returns @Nothing@ if the timeout occurs and @Just a@ if computation +-- returns @a@. withTimeOutMaybe :: Int -> IO a -> IO (Maybe a) withTimeOutMaybe tout op = do    toId <- nextTimeOutId@@ -106,7 +110,7 @@   ktid <- fork ( do threadDelay tout                      throwTo' wtid (TimeOutExceptionI toId)                )-  (catchTimeOutI toId) (fmap Just (op >>= \r -> killThread ktid >> return  r)) (return Nothing)+  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.

@@ -15,8 +15,7 @@ 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)  propShowHostAddress :: HostAddress -> Bool propShowHostAddress a = new == old

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