diff --git a/happstack-util.cabal b/happstack-util.cabal --- a/happstack-util.cabal +++ b/happstack-util.cabal @@ -1,5 +1,5 @@ Name: happstack-util -Version: 0.5.0.3 +Version: 6.0.0 Synopsis: Web framework License: BSD3 License-file: COPYING @@ -14,7 +14,7 @@ source-repository head type: darcs subdir: happstack-util - location: http://patch-tag.com/r/mae/happstack/pullrepo + location: http://patch-tag.com/r/mae/happstack Flag base4 Description: Choose the even newer, even smaller, split-up base package. @@ -36,8 +36,6 @@ process, time, random, - SMTPClient >= 1.0.2 && < 1.1, - strict-concurrency, network >= 2.2 && < 3, template-haskell, unix-compat, @@ -68,14 +66,12 @@ Happstack.Util.Daemonize, Happstack.Util.HostAddress, Happstack.Util.LogFormat, - Happstack.Util.Mail, Happstack.Util.OpenExclusively, - Happstack.Util.TimeOut, Happstack.Util.TH, Happstack.Util.FileManip if flag(tests) Build-Depends: - QuickCheck >= 2 && < 3, + QuickCheck >= 2 && < 2.5, HUnit Exposed-modules: Happstack.Util.Testing, Happstack.Util.Tests, @@ -83,7 +79,10 @@ 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 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/Util/FileManip.hs b/src/Happstack/Util/FileManip.hs --- a/src/Happstack/Util/FileManip.hs +++ b/src/Happstack/Util/FileManip.hs @@ -91,7 +91,7 @@ filteredPaths <- forM names $ \name -> do let path' = dir name unsafeInterleaveIO $ E.handle (errHandler path') - (F.getSymbolicLinkStatus path >>= visit path' depth) + (F.getSymbolicLinkStatus path' >>= visit path' depth) filterPath dir depth dirSt (concat filteredPaths) filterPath path' depth st result = return $ if evalFI filter path' depth st diff --git a/src/Happstack/Util/Mail.hs b/src/Happstack/Util/Mail.hs deleted file mode 100644 --- a/src/Happstack/Util/Mail.hs +++ /dev/null @@ -1,94 +0,0 @@ ------------------------------------------------------------------------------ --- | --- 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/Testing.hs b/src/Happstack/Util/Testing.hs --- a/src/Happstack/Util/Testing.hs +++ b/src/Happstack/Util/Testing.hs @@ -16,10 +16,12 @@ HU.TestCase $ do result <- QC.quickCheckWithResult args prop case result of - (QC.Success _) -> return () - (QC.GaveUp ntest _) -> HU.assertFailure $ "Arguments exhausted after" ++ show ntest ++ (if ntest == 1 then " test." else " tests.") - (QC.Failure _ usedSize reason _) -> HU.assertFailure reason - (QC.NoExpectedFailure _) -> HU.assertFailure $ "No Expected Failure" + (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 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,151 +0,0 @@ -{-# LANGUAGE StandaloneDeriving, DeriveDataTypeable, RecursiveDo, - BangPatterns, UnboxedTuples #-} - ------------------------------------------------------------------------------ --- | --- 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 qualified Control.Concurrent.MVar.Strict as SM -import Control.Exception.Extensible as E -import Data.Typeable(Typeable) -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 :: SM.MVar TimeOutTId -timeOutIdState = unsafePerformIO $ SM.newMVar minBound - -nextTimeOutId :: IO TimeOutTId -nextTimeOutId = - SM.modifyMVar timeOutIdState $ \a -> - let nid = nextId a in return (nid `seq` (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 and @Just a@ if computation --- returns @a@. -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,13 +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 = randomR (minBound,maxBound) +#endif propShowHostAddress :: HostAddress -> Bool propShowHostAddress a = new == old