diff --git a/happstack-util.cabal b/happstack-util.cabal --- a/happstack-util.cabal +++ b/happstack-util.cabal @@ -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 diff --git a/src/Happstack/Util/AutoBuild.hs b/src/Happstack/Util/AutoBuild.hs new file mode 100644 --- /dev/null +++ b/src/Happstack/Util/AutoBuild.hs @@ -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) + diff --git a/src/Happstack/Util/Common.hs b/src/Happstack/Util/Common.hs --- a/src/Happstack/Util/Common.hs +++ b/src/Happstack/Util/Common.hs @@ -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 diff --git a/src/Happstack/Util/Cron.hs b/src/Happstack/Util/Cron.hs --- a/src/Happstack/Util/Cron.hs +++ b/src/Happstack/Util/Cron.hs @@ -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) diff --git a/src/Happstack/Util/Daemonize.hs b/src/Happstack/Util/Daemonize.hs --- a/src/Happstack/Util/Daemonize.hs +++ b/src/Happstack/Util/Daemonize.hs @@ -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 diff --git a/src/Happstack/Util/FileManip.hs b/src/Happstack/Util/FileManip.hs new file mode 100644 --- /dev/null +++ b/src/Happstack/Util/FileManip.hs @@ -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 + diff --git a/src/Happstack/Util/HostAddress.hs b/src/Happstack/Util/HostAddress.hs --- a/src/Happstack/Util/HostAddress.hs +++ b/src/Happstack/Util/HostAddress.hs @@ -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 diff --git a/src/Happstack/Util/LogFormat.hs b/src/Happstack/Util/LogFormat.hs --- a/src/Happstack/Util/LogFormat.hs +++ b/src/Happstack/Util/LogFormat.hs @@ -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 ++ "]" diff --git a/src/Happstack/Util/Mail.hs b/src/Happstack/Util/Mail.hs new file mode 100644 --- /dev/null +++ b/src/Happstack/Util/Mail.hs @@ -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 diff --git a/src/Happstack/Util/OpenExclusively.hs b/src/Happstack/Util/OpenExclusively.hs new file mode 100644 --- /dev/null +++ b/src/Happstack/Util/OpenExclusively.hs @@ -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 + diff --git a/src/Happstack/Util/Testing.hs b/src/Happstack/Util/Testing.hs --- a/src/Happstack/Util/Testing.hs +++ b/src/Happstack/Util/Testing.hs @@ -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 diff --git a/src/Happstack/Util/TimeOut.hs b/src/Happstack/Util/TimeOut.hs --- a/src/Happstack/Util/TimeOut.hs +++ b/src/Happstack/Util/TimeOut.hs @@ -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. diff --git a/tests/Happstack/Util/Tests/HostAddress.hs b/tests/Happstack/Util/Tests/HostAddress.hs --- a/tests/Happstack/Util/Tests/HostAddress.hs +++ b/tests/Happstack/Util/Tests/HostAddress.hs @@ -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 diff --git a/tests/Test.hs b/tests/Test.hs --- a/tests/Test.hs +++ b/tests/Test.hs @@ -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