happstack-util 0.5.0.3 → 6.0.0

raw patch · 7 files changed

+20/−260 lines, 7 filesdep −SMTPClientdep −strict-concurrencydep ~QuickCheckdep ~basedep ~old-timePVP ok

version bump matches the API change (PVP)

Dependencies removed: SMTPClient, strict-concurrency

Dependency ranges changed: QuickCheck, base, old-time, time

API changes (from Hackage documentation)

Files

• happstack-util.cabal +7/−8
• src/Happstack/Crypto/MD5.hs +1/−1
• src/Happstack/Util/FileManip.hs +1/−1
• src/Happstack/Util/Mail.hs +0/−94
• src/Happstack/Util/Testing.hs +6/−4
• src/Happstack/Util/TimeOut.hs +0/−151
• tests/Happstack/Util/Tests/HostAddress.hs +5/−1

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

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

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

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

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

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

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