diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,3 +1,3 @@ #!/usr/bin/env runhaskell import Distribution.Simple -main = defaultMainWithHooks defaultUserHooks +main = defaultMainWithHooks simpleUserHooks 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: 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 diff --git a/src/Happstack/Crypto/Base64.hs b/src/Happstack/Crypto/Base64.hs --- a/src/Happstack/Crypto/Base64.hs +++ b/src/Happstack/Crypto/Base64.hs @@ -29,7 +29,6 @@ import Data.Array.Unboxed import Data.Bits -import Data.Int import Data.Char (chr,ord) diff --git a/src/Happstack/Crypto/MD5.hs b/src/Happstack/Crypto/MD5.hs --- a/src/Happstack/Crypto/MD5.hs +++ b/src/Happstack/Crypto/MD5.hs @@ -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 diff --git a/src/Happstack/Crypto/SHA1.lhs b/src/Happstack/Crypto/SHA1.lhs --- a/src/Happstack/Crypto/SHA1.lhs +++ b/src/Happstack/Crypto/SHA1.lhs @@ -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) diff --git a/src/Happstack/Crypto/W64.hs b/src/Happstack/Crypto/W64.hs --- a/src/Happstack/Crypto/W64.hs +++ b/src/Happstack/Crypto/W64.hs @@ -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] 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,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 + 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/OpenExclusively.hs b/src/Happstack/Util/OpenExclusively.hs new file mode 100644 --- /dev/null +++ b/src/Happstack/Util/OpenExclusively.hs @@ -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 + 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 @@ -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 +-} diff --git a/src/Happstack/Util/TimeOut.hs b/src/Happstack/Util/TimeOut.hs deleted file mode 100644 --- a/src/Happstack/Util/TimeOut.hs +++ /dev/null @@ -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 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 @@ -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 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