This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "snap-core".
The branch, master has been updated
via e6562edceca8deeb21a0e331cc85de9ca9839f2c (commit)
from c0d76f6c7f9f3124f76c29d0a4d53a546dc22c14 (commit)
Summary of changes:
test/suite/Snap/Internal/Http/Types/Tests.hs | 56 +++++++++++++++++++++++--
test/suite/Snap/Types/Tests.hs | 22 ++++++++++
2 files changed, 73 insertions(+), 5 deletions(-)
Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.
- Log -----------------------------------------------------------------
commit e6562edceca8deeb21a0e331cc85de9ca9839f2c
Author: Gregory Collins <[email protected]>
Date: Wed Jul 28 01:41:58 2010 -0400
Add some more tests
diff --git a/test/suite/Snap/Internal/Http/Types/Tests.hs
b/test/suite/Snap/Internal/Http/Types/Tests.hs
index 79a3db5..bf5382e 100644
--- a/test/suite/Snap/Internal/Http/Types/Tests.hs
+++ b/test/suite/Snap/Internal/Http/Types/Tests.hs
@@ -5,9 +5,11 @@ module Snap.Internal.Http.Types.Tests
import Control.Monad
import Control.Parallel.Strategies
+import Data.ByteString.Char8 ()
import Data.ByteString.Lazy.Char8 ()
import Data.IORef
import Data.Iteratee (stream2stream, run)
+import Data.List (sort)
import qualified Data.Map as Map
import Data.Time.Calendar
import Data.Time.Clock
@@ -21,7 +23,10 @@ import Snap.Internal.Http.Types
import Snap.Iteratee (enumBS, fromWrap)
tests :: [Test]
-tests = [ testTypes ]
+tests = [ testTypes
+ , testUrlDecode
+ , testFormatLogTime
+ , testAddHeader ]
mkRq :: IO Request
@@ -31,6 +36,29 @@ mkRq = do
enum Nothing GET (1,1) [] "" "/" "/" "/" "" Map.empty
+testFormatLogTime :: Test
+testFormatLogTime = testCase "formatLogTime" $ do
+ b <- formatLogTime 3804938
+ assertEqual "formatLogTime" "13/Feb/1970:19:55:38 -0500" b
+
+
+testAddHeader :: Test
+testAddHeader = testCase "addHeader" $ do
+ defReq <- mkRq
+
+ let req = addHeader "foo" "bar" $
+ addHeader "foo" "baz" defReq
+
+
+ let x = getHeader "foo" req
+ assertEqual "addHeader x 2" (Just "bar baz") x
+
+
+testUrlDecode :: Test
+testUrlDecode = testCase "urlDecode" $ do
+ assertEqual "bad hex" Nothing $ urlDecode "%qq"
+
+
testTypes :: Test
testTypes = testCase "show" $ do
defReq <- mkRq
@@ -40,7 +68,10 @@ testTypes = testCase "show" $ do
rqSetParam "foo" ["bar"] $
defReq
+ let req2 = (addHeader "zomg" "1234" req) { rqCookies = [ cook, cook2 ] }
+
let !a = show req `using` rdeepseq
+ let !_ = show req2 `using` rdeepseq
-- we don't care about the show instance really, we're just trying to shut
-- up hpc
@@ -48,7 +79,11 @@ testTypes = testCase "show" $ do
assertEqual "rqParam" (Just ["bar"]) (rqParam "foo" req)
assertEqual "lookup" (Just ["bbb"]) (Map.lookup "zzz" $ rqParams req)
assertEqual "lookup 2" (Just ["bbb"]) (Map.lookup "zzz" $ headers req)
- assertEqual "cookie" (Just ["foo=bar; path=/; expires=Sat, 30-Jan-2010
00:00:00 GMT; domain=.foo.com"]) cook'
+ assertEqual "cookie" (Just ["foo=bar; path=/; expires=Sat, 30-Jan-2010
00:00:00 GMT; domain=.foo.com"]) cookieHeader
+
+ assertEqual "cookie2" (Just ["foo=bar; path=/; expires=Sat, 30-Jan-2010
00:00:00 GMT; domain=.foo.com", "foo=baz; path=/; expires=Sat, 30-Jan-2010
00:00:00 GMT; domain=.foo.com"]) (liftM sort cookieHeader2)
+
+ assertEqual "cookie3" (Just ["foo=baz"]) cookieHeader3
assertEqual "response status" 555 $ rspStatus resp
assertEqual "response status reason" "bogus" $ rspStatusReason resp
@@ -61,6 +96,8 @@ testTypes = testCase "show" $ do
let !_ = GET == POST
let !_ = headers $ headers defReq
+ let !_ = show resp2 `using` rdeepseq
+
return ()
@@ -74,7 +111,16 @@ testTypes = testCase "show" $ do
emptyResponse
!b = show resp `using` rdeepseq
- utc = UTCTime (ModifiedJulianDay 55226) 0
- cook = Cookie "foo" "bar" (Just utc) (Just ".foo.com") (Just "/")
- cook' = Map.lookup "Set-Cookie" $ headers resp
+ resp2 = addCookie cook2 resp
+ resp3 = addCookie cook3 emptyResponse
+
+
+ utc = UTCTime (ModifiedJulianDay 55226) 0
+ cook = Cookie "foo" "bar" (Just utc) (Just ".foo.com") (Just "/")
+ cook2 = Cookie "foo" "baz" (Just utc) (Just ".foo.com") (Just "/")
+ cook3 = Cookie "foo" "baz" Nothing Nothing Nothing
+
+ cookieHeader = Map.lookup "Set-Cookie" $ headers resp
+ cookieHeader2 = Map.lookup "Set-Cookie" $ headers resp2
+ cookieHeader3 = Map.lookup "Set-Cookie" $ headers resp3
diff --git a/test/suite/Snap/Types/Tests.hs b/test/suite/Snap/Types/Tests.hs
index d6e8c8c..8e3dbdd 100644
--- a/test/suite/Snap/Types/Tests.hs
+++ b/test/suite/Snap/Types/Tests.hs
@@ -7,7 +7,9 @@ module Snap.Types.Tests
import Control.Applicative
import Control.Concurrent.MVar
+import Control.Exception (SomeException)
import Control.Monad
+import Control.Monad.CatchIO
import Control.Monad.Trans (liftIO)
import Data.ByteString.Char8 (ByteString)
import qualified Data.ByteString.Char8 as S
@@ -15,6 +17,7 @@ import qualified Data.ByteString.Lazy.Char8 as L
import Data.IORef
import Data.Iteratee
import qualified Data.Map as Map
+import Prelude hiding (catch)
import Test.Framework
import Test.Framework.Providers.HUnit
import Test.Framework.Providers.QuickCheck2
@@ -34,6 +37,7 @@ tests = [ testFail
, testTrivials
, testMethod
, testDir
+ , testCatchIO
, testWrites
, testParam
, testURLEncode1
@@ -88,6 +92,24 @@ mkRqWithBody = do
Map.empty
+testCatchIO :: Test
+testCatchIO = testCase "catchIO" $ do
+ (_,rsp) <- go f
+ (_,rsp2) <- go g
+
+ assertEqual "catchIO 1" (Just "bar") $ getHeader "foo" rsp
+ assertEqual "catchIO 2" Nothing $ getHeader "foo" rsp2
+
+ where
+ f :: Snap ()
+ f = (block $ unblock $ throw NoHandlerException) `catch` h
+
+ g :: Snap ()
+ g = return () `catch` h
+
+ h :: SomeException -> Snap ()
+ h e = e `seq` modifyResponse $ addHeader "foo" "bar"
+
go :: Snap a -> IO (Request,Response)
go m = do
zomgRq <- mkZomgRq
-----------------------------------------------------------------------
hooks/post-receive
--
snap-core
_______________________________________________
Snap mailing list
[email protected]
http://mailman-mail5.webfaction.com/listinfo/snap
