From efe6ade9372ca70e318a07312f3e989b0dcc44ef Mon Sep 17 00:00:00 2001 From: Gregory Collins Date: Sun, 19 Jun 2011 11:11:16 -0400 Subject: [PATCH 01/11] Create 0.6 branch --- snap-server.cabal | 4 ++-- test/snap-server-testsuite.cabal | 6 +++--- 2 files changed, 5 insertions(+), 5 deletions(-) diff --git a/snap-server.cabal b/snap-server.cabal index dff17eb4..7a0dd12c 100644 --- a/snap-server.cabal +++ b/snap-server.cabal @@ -1,5 +1,5 @@ name: snap-server -version: 0.5.0 +version: 0.6.0 synopsis: A fast, iteratee-based, epoll-enabled web server for the Snap Framework description: Snap is a simple and fast web development framework and server written in @@ -118,7 +118,7 @@ Library murmur-hash >= 0.1 && < 0.2, network >= 2.3 && <2.4, old-locale, - snap-core >= 0.5 && <0.6, + snap-core >= 0.6 && <0.7, template-haskell, text >= 0.11 && <0.12, time, diff --git a/test/snap-server-testsuite.cabal b/test/snap-server-testsuite.cabal index 9e4e91e6..acc6f2f3 100644 --- a/test/snap-server-testsuite.cabal +++ b/test/snap-server-testsuite.cabal @@ -46,7 +46,7 @@ Executable testsuite old-locale, parallel > 2, process, - snap-core >= 0.5 && <0.6, + snap-core >= 0.6 && <0.7, template-haskell, test-framework >= 0.3.1 && <0.4, test-framework-hunit >= 0.2.5 && < 0.3, @@ -107,7 +107,7 @@ Executable pongserver parallel > 2, MonadCatchIO-transformers >= 0.2.1 && < 0.3, network == 2.3.*, - snap-core >= 0.5 && <0.6, + snap-core >= 0.6 && <0.7, template-haskell, time, transformers, @@ -185,7 +185,7 @@ Executable testserver network == 2.3.*, old-locale, parallel > 2, - snap-core >= 0.5 && <0.6, + snap-core >= 0.6 && <0.7, template-haskell, test-framework >= 0.3.1 && <0.4, test-framework-hunit >= 0.2.5 && < 0.3, From 4d3a9f6d1676bbd866212fb7c1b8f575862c0856 Mon Sep 17 00:00:00 2001 From: Gregory Collins Date: Sat, 30 Jul 2011 11:45:04 +0200 Subject: [PATCH 02/11] Changes for testing branch: move some parsing code to snap-core, change how post params are incorporated into requests --- src/Snap/Internal/Http/Parser.hs | 51 -------------------------------- src/Snap/Internal/Http/Server.hs | 3 +- test/.ghci | 3 ++ 3 files changed, 5 insertions(+), 52 deletions(-) create mode 100644 test/.ghci diff --git a/src/Snap/Internal/Http/Parser.hs b/src/Snap/Internal/Http/Parser.hs index be45bfa9..4bc837a6 100644 --- a/src/Snap/Internal/Http/Parser.hs +++ b/src/Snap/Internal/Http/Parser.hs @@ -225,54 +225,3 @@ pGetTransferChunk = do where fromHex :: ByteString -> Int fromHex s = Cvt.hex (L.fromChunks [s]) - - ------------------------------------------------------------------------------- --- COOKIE PARSING ------------------------------------------------------------------------------- - --- these definitions try to mirror RFC-2068 (the HTTP/1.1 spec) and RFC-2109 --- (cookie spec): please point out any errors! - ------------------------------------------------------------------------------- -pCookies :: Parser [Cookie] -pCookies = do - -- grab kvps and turn to strict bytestrings - kvps <- pAvPairs - - return $ map toCookie $ filter (not . S.isPrefixOf "$" . fst) kvps - - where - toCookie (nm,val) = Cookie nm val Nothing Nothing Nothing - - ------------------------------------------------------------------------------- -parseCookie :: ByteString -> Maybe [Cookie] -parseCookie = parseToCompletion pCookies - - ------------------------------------------------------------------------------- --- application/x-www-form-urlencoded ------------------------------------------------------------------------------- - ------------------------------------------------------------------------------- -parseUrlEncoded :: ByteString -> Map ByteString [ByteString] -parseUrlEncoded s = foldl' (\m (k,v) -> Map.insertWith' (++) k [v] m) - Map.empty - decoded - where - breakApart = (second (S.drop 1)) . S.break (== '=') - - parts :: [(ByteString,ByteString)] - parts = map breakApart $ S.split '&' s - - urldecode = parseToCompletion pUrlEscaped - - decodeOne (a,b) = do - a' <- urldecode a - b' <- urldecode b - return (a',b') - - decoded = catMaybes $ map decodeOne parts - - diff --git a/src/Snap/Internal/Http/Server.hs b/src/Snap/Internal/Http/Server.hs index 156757e0..3b640271 100644 --- a/src/Snap/Internal/Http/Server.hs +++ b/src/Snap/Internal/Http/Server.hs @@ -567,7 +567,8 @@ receiveRequest writeEnd = do e st' liftIO $ writeIORef (rqBody req) $ SomeEnumerator e' - return $ req { rqParams = rqParams req `mappend` newParams } + return $ req { rqParams = Map.unionWith (++) (rqParams req) + newParams } -------------------------------------------------------------------------- diff --git a/test/.ghci b/test/.ghci new file mode 100644 index 00000000..ca847662 --- /dev/null +++ b/test/.ghci @@ -0,0 +1,3 @@ +:set -i../src +:set -isuite +:set -icommon From 6f77804bc67cb6c28de4fddf52ff82cdcf9eaeba Mon Sep 17 00:00:00 2001 From: Ozgun Ataman Date: Sat, 30 Jul 2011 15:06:23 -0400 Subject: [PATCH 03/11] Bump version and some deps --- snap-server.cabal | 6 +++--- test/snap-server-testsuite.cabal | 18 +++++++++--------- 2 files changed, 12 insertions(+), 12 deletions(-) diff --git a/snap-server.cabal b/snap-server.cabal index 3f72cc66..0d3ae683 100644 --- a/snap-server.cabal +++ b/snap-server.cabal @@ -1,5 +1,5 @@ name: snap-server -version: 0.5.2 +version: 0.6.0 synopsis: A fast, iteratee-based, epoll-enabled web server for the Snap Framework description: Snap is a simple and fast web development framework and server written in @@ -108,7 +108,7 @@ Library blaze-builder-enumerator >= 0.2.0 && <0.3, bytestring, bytestring-nums, - case-insensitive >= 0.2 && < 0.3, + case-insensitive >= 0.3 && < 0.4, containers, directory-tree, enumerator >= 0.4.13.1 && <0.5, @@ -118,7 +118,7 @@ Library murmur-hash >= 0.1 && < 0.2, network >= 2.3 && <2.4, old-locale, - snap-core >= 0.5.2 && <0.6, + snap-core >= 0.6 && < 0.7, template-haskell, text >= 0.11 && <0.12, time, diff --git a/test/snap-server-testsuite.cabal b/test/snap-server-testsuite.cabal index ff228579..56b96d72 100644 --- a/test/snap-server-testsuite.cabal +++ b/test/snap-server-testsuite.cabal @@ -40,15 +40,15 @@ Executable testsuite haskell98, http-enumerator >= 0.6.5.4 && <0.7, HUnit >= 1.2 && < 2, - monads-fd >= 0.1.0.4 && <0.2, + monads-fd >= 0.2, murmur-hash >= 0.1 && < 0.2, network == 2.3.*, old-locale, parallel > 2, process, - snap-core >= 0.5.2 && <0.6, + snap-core >= 0.6 && < 0.7, template-haskell, - test-framework >= 0.3.1 && <0.4, + test-framework >= 0.4 && < 0.5, test-framework-hunit >= 0.2.5 && < 0.3, test-framework-quickcheck2 >= 0.2.6 && < 0.3, text >= 0.11 && <0.12, @@ -102,13 +102,13 @@ Executable pongserver filepath, haskell98, HUnit >= 1.2 && < 2, - monads-fd >= 0.1.0.4 && <0.2, + monads-fd >= 0.2, murmur-hash >= 0.1 && < 0.2, old-locale, parallel > 2, MonadCatchIO-transformers >= 0.2.1 && < 0.3, network == 2.3.*, - snap-core >= 0.5.1 && <0.6, + snap-core >= 0.6 && < 0.7, template-haskell, time, transformers, @@ -173,7 +173,7 @@ Executable testserver blaze-builder-enumerator >= 0.2.0 && <0.3, bytestring, bytestring-nums >= 0.3.1 && < 0.4, - case-insensitive >= 0.2 && < 0.3, + case-insensitive >= 0.3 && < 0.4, containers, directory-tree, enumerator >= 0.4.7 && <0.5, @@ -181,14 +181,14 @@ Executable testserver haskell98, HUnit >= 1.2 && < 2, MonadCatchIO-transformers >= 0.2.1 && < 0.3, - monads-fd >= 0.1.0.4 && <0.2, + monads-fd >= 0.2, murmur-hash >= 0.1 && < 0.2, network == 2.3.*, old-locale, parallel > 2, - snap-core >= 0.5.1 && <0.6, + snap-core >= 0.6 && < 0.7, template-haskell, - test-framework >= 0.3.1 && <0.4, + test-framework >= 0.4 && < 0.5, test-framework-hunit >= 0.2.5 && < 0.3, test-framework-quickcheck2 >= 0.2.6 && < 0.3, text >= 0.11 && <0.12, From 1876dbd303ea5bbc7d7447f6961e20a47b7645b3 Mon Sep 17 00:00:00 2001 From: Ozgun Ataman Date: Sat, 30 Jul 2011 15:06:36 -0400 Subject: [PATCH 04/11] Add support for Secure and HttpOnly cookies --- src/Snap/Internal/Http/Parser.hs | 2 +- src/Snap/Internal/Http/Server.hs | 6 ++- test/suite/Snap/Internal/Http/Parser/Tests.hs | 6 +-- test/suite/Snap/Internal/Http/Server/Tests.hs | 44 ++++++++----------- 4 files changed, 26 insertions(+), 32 deletions(-) diff --git a/src/Snap/Internal/Http/Parser.hs b/src/Snap/Internal/Http/Parser.hs index c63dd21e..74cfce74 100644 --- a/src/Snap/Internal/Http/Parser.hs +++ b/src/Snap/Internal/Http/Parser.hs @@ -243,7 +243,7 @@ pCookies = do return $ map toCookie $ filter (not . S.isPrefixOf "$" . fst) kvps where - toCookie (nm,val) = Cookie nm val Nothing Nothing Nothing + toCookie (nm,val) = Cookie nm val Nothing Nothing Nothing False False ------------------------------------------------------------------------------ diff --git a/src/Snap/Internal/Http/Server.hs b/src/Snap/Internal/Http/Server.hs index 156757e0..73515c8c 100644 --- a/src/Snap/Internal/Http/Server.hs +++ b/src/Snap/Internal/Http/Server.hs @@ -918,12 +918,14 @@ toHeaders kvps = foldl' f Map.empty kvps' ------------------------------------------------------------------------------ -- | Convert 'Cookie' into 'ByteString' for output. cookieToBS :: Cookie -> ByteString -cookieToBS (Cookie k v mbExpTime mbDomain mbPath) = cookie +cookieToBS (Cookie k v mbExpTime mbDomain mbPath isSec isHOnly) = cookie where - cookie = S.concat [k, "=", v, path, exptime, domain] + cookie = S.concat [k, "=", v, path, exptime, domain, secure, hOnly] path = maybe "" (S.append "; path=") mbPath domain = maybe "" (S.append "; domain=") mbDomain exptime = maybe "" (S.append "; expires=" . fmt) mbExpTime + secure = if isSec then "; Secure" else "" + hOnly = if isHOnly then "; HttpOnly" else "" fmt = fromStr . formatTime defaultTimeLocale "%a, %d-%b-%Y %H:%M:%S GMT" diff --git a/test/suite/Snap/Internal/Http/Parser/Tests.hs b/test/suite/Snap/Internal/Http/Parser/Tests.hs index b5cced13..2bb105cf 100644 --- a/test/suite/Snap/Internal/Http/Parser/Tests.hs +++ b/test/suite/Snap/Internal/Http/Parser/Tests.hs @@ -137,15 +137,13 @@ testCookie = assertEqual "cookie parsing" (Just [cv]) cv2 where - cv = Cookie nm v Nothing Nothing Nothing + cv = Cookie nm v Nothing Nothing Nothing False False cv2 = parseCookie ct nm = "foo" v = "bar" - ct = S.concat [ nm - , "=" - , v ] + ct = S.concat [ nm , "=" , v ] testFormEncoded :: Test diff --git a/test/suite/Snap/Internal/Http/Server/Tests.hs b/test/suite/Snap/Internal/Http/Server/Tests.hs index 43ab0db2..2c2385d2 100644 --- a/test/suite/Snap/Internal/Http/Server/Tests.hs +++ b/test/suite/Snap/Internal/Http/Server/Tests.hs @@ -189,8 +189,9 @@ testHttpRequest1 = assertEqual "parse body" "0123456789" body - assertEqual "cookie" [Cookie "foo" "bar\"" Nothing Nothing Nothing] $ - rqCookies req + assertEqual "cookie" + [Cookie "foo" "bar\"" Nothing Nothing Nothing False False] + (rqCookies req) assertEqual "continued headers" (Just ["foo bar"]) $ Map.lookup "x-random-other-header" $ rqHeaders req @@ -491,37 +492,30 @@ testHttpResponseCookies :: Test testHttpResponseCookies = testCase "server/HttpResponseCookies" $ do buf <- allocBuffer 16384 req <- mkRequest sampleRequest + b <- run_ $ rsm $ - sendResponse req rsp2 buf copyingStream2Stream testOnSendFile >>= - return . snd - b2 <- run_ $ rsm $ - sendResponse req rsp3 buf copyingStream2Stream testOnSendFile >>= + sendResponse req rsp2 buf copyingStream2Stream testOnSendFile >>= return . snd - assertEqual "http response cookie" (L.concat [ + -- Having some weird issues here with lazy ByteString comparison; run thru + -- strict ByteString to get around it. Slow/lame, but whatever. + assertEqual "http response multi-cookies" (L.fromChunks . return . S.concat $ [ "HTTP/1.0 304 Test\r\n" , "Content-Length: 0\r\n" - , "Set-Cookie: foo=bar; path=/; expires=Sat, 30-Jan-2010 00:00:00 GMT; domain=.foo.com\r\n\r\n" - ]) b - - - assertEqual "http response multi-cookies" (L.concat [ - "HTTP/1.0 304 Test\r\n" - , "Content-Length: 0\r\n" - , "Set-Cookie: foo=bar; path=/; expires=Sat, 30-Jan-2010 00:00:00 GMT; domain=.foo.com\r\n" - , "Set-Cookie: zoo=baz; path=/; expires=Sat, 30-Jan-2010 00:00:00 GMT; domain=.foo.com\r\n\r\n" - ]) b2 + , "Set-Cookie: ck1=bar; path=/; expires=Sat, 30-Jan-2010 00:00:00 GMT; domain=.foo.com; Secure\r\n" + , "Set-Cookie: ck2=bar; path=/; expires=Sat, 30-Jan-2010 00:00:00 GMT; domain=.foo.com; HttpOnly\r\n" + , "Set-Cookie: ck3=bar\r\n\r\n" + ]) (L.fromChunks . return . S.concat . L.toChunks $ b) where - rsp1 = setResponseStatus 304 "Test" $ - emptyResponse { rspHttpVersion = (1,0) } - rsp2 = addResponseCookie cook rsp1 - rsp3 = addResponseCookie cook2 rsp2 + rsp1 = setResponseStatus 304 "Test" $ emptyResponse { rspHttpVersion = (1,0) } + rsp2 = addResponseCookie cook3 . addResponseCookie cook2 + . addResponseCookie cook $ rsp1 utc = UTCTime (ModifiedJulianDay 55226) 0 - cook = Cookie "foo" "bar" (Just utc) (Just ".foo.com") (Just "/") - cook2 = Cookie "zoo" "baz" (Just utc) (Just ".foo.com") (Just "/") - cook3 = Cookie "boo" "baz" Nothing Nothing Nothing + cook = Cookie "ck1" "bar" (Just utc) (Just ".foo.com") (Just "/") True False + cook2 = Cookie "ck2" "bar" (Just utc) (Just ".foo.com") (Just "/") False True + cook3 = Cookie "ck3" "bar" Nothing Nothing Nothing False False @@ -548,7 +542,7 @@ echoServer2 _ _ req = do (rq,rsp) <- echoServer (const $ return ()) (const $ return ()) req return (rq, addResponseCookie cook rsp) where - cook = Cookie "foo" "bar" (Just utc) (Just ".foo.com") (Just "/") + cook = Cookie "foo" "bar" (Just utc) (Just ".foo.com") (Just "/") False False utc = UTCTime (ModifiedJulianDay 55226) 0 From 152d9bc5beb5ead3095ed5573c7e1c5e8673c43f Mon Sep 17 00:00:00 2001 From: Gregory Collins Date: Wed, 10 Aug 2011 19:26:55 +0200 Subject: [PATCH 05/11] Move cookie parsing test from snap-server to snap-core --- snap-server.cabal | 2 +- test/snap-server-testsuite.cabal | 6 +++--- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/snap-server.cabal b/snap-server.cabal index 0d3ae683..0d600fd9 100644 --- a/snap-server.cabal +++ b/snap-server.cabal @@ -114,7 +114,7 @@ Library enumerator >= 0.4.13.1 && <0.5, filepath, MonadCatchIO-transformers >= 0.2.1 && < 0.3, - mtl == 2.0.*, + mtl >= 2 && <3, murmur-hash >= 0.1 && < 0.2, network >= 2.3 && <2.4, old-locale, diff --git a/test/snap-server-testsuite.cabal b/test/snap-server-testsuite.cabal index 56b96d72..55c6184e 100644 --- a/test/snap-server-testsuite.cabal +++ b/test/snap-server-testsuite.cabal @@ -40,7 +40,7 @@ Executable testsuite haskell98, http-enumerator >= 0.6.5.4 && <0.7, HUnit >= 1.2 && < 2, - monads-fd >= 0.2, + mtl >= 2 && <3, murmur-hash >= 0.1 && < 0.2, network == 2.3.*, old-locale, @@ -102,7 +102,7 @@ Executable pongserver filepath, haskell98, HUnit >= 1.2 && < 2, - monads-fd >= 0.2, + mtl >= 2 && <3, murmur-hash >= 0.1 && < 0.2, old-locale, parallel > 2, @@ -181,7 +181,7 @@ Executable testserver haskell98, HUnit >= 1.2 && < 2, MonadCatchIO-transformers >= 0.2.1 && < 0.3, - monads-fd >= 0.2, + mtl >= 2 && <3, murmur-hash >= 0.1 && < 0.2, network == 2.3.*, old-locale, From c4005d8b6f8021d7fb357b08c86b50b0350d2a74 Mon Sep 17 00:00:00 2001 From: Gregory Collins Date: Sat, 13 Aug 2011 15:16:25 +0100 Subject: [PATCH 06/11] Rename Snap.Types to Snap.Core --- src/Snap/Http/Server.hs | 2 +- src/Snap/Http/Server/Config.hs | 2 +- test/common/Test/Common/TestHandler.hs | 2 +- test/pongserver/Main.hs | 2 +- test/suite/Snap/Internal/Http/Server/Tests.hs | 2 +- 5 files changed, 5 insertions(+), 5 deletions(-) diff --git a/src/Snap/Http/Server.hs b/src/Snap/Http/Server.hs index aa2bb9e8..e18a319e 100644 --- a/src/Snap/Http/Server.hs +++ b/src/Snap/Http/Server.hs @@ -28,7 +28,7 @@ import Data.Maybe import Prelude hiding (catch) import Snap.Http.Server.Config import qualified Snap.Internal.Http.Server as Int -import Snap.Types +import Snap.Core import Snap.Util.GZip #ifndef PORTABLE import System.Posix.Env diff --git a/src/Snap/Http/Server/Config.hs b/src/Snap/Http/Server/Config.hs index a7d4b890..3176b538 100644 --- a/src/Snap/Http/Server/Config.hs +++ b/src/Snap/Http/Server/Config.hs @@ -66,7 +66,7 @@ import Data.Monoid import qualified Data.Text as T import qualified Data.Text.Encoding as T import Prelude hiding (catch) -import Snap.Types +import Snap.Core import Snap.Iteratee ((>==>), enumBuilder) import Snap.Internal.Debug (debug) import System.Console.GetOpt diff --git a/test/common/Test/Common/TestHandler.hs b/test/common/Test/Common/TestHandler.hs index e43d17e1..19859dff 100644 --- a/test/common/Test/Common/TestHandler.hs +++ b/test/common/Test/Common/TestHandler.hs @@ -14,7 +14,7 @@ import Data.Maybe import Data.Monoid import Snap.Iteratee hiding (Enumerator) import qualified Snap.Iteratee as I -import Snap.Types +import Snap.Core import Snap.Util.FileServe import Snap.Util.FileUploads import Snap.Util.GZip diff --git a/test/pongserver/Main.hs b/test/pongserver/Main.hs index ae3a7f2a..3e6eb05f 100644 --- a/test/pongserver/Main.hs +++ b/test/pongserver/Main.hs @@ -6,7 +6,7 @@ import Control.Concurrent import Control.Exception (finally) import Snap.Iteratee -import Snap.Types +import Snap.Core import Snap.Http.Server -- FIXME: need better primitives for output diff --git a/test/suite/Snap/Internal/Http/Server/Tests.hs b/test/suite/Snap/Internal/Http/Server/Tests.hs index ca5c9678..34356f5e 100644 --- a/test/suite/Snap/Internal/Http/Server/Tests.hs +++ b/test/suite/Snap/Internal/Http/Server/Tests.hs @@ -44,6 +44,7 @@ import Test.HUnit hiding (Test, path) import qualified Snap.Http.Server as Svr +import Snap.Core import Snap.Internal.Debug import Snap.Internal.Http.Types import Snap.Internal.Http.Server @@ -51,7 +52,6 @@ import qualified Snap.Iteratee as I import Snap.Iteratee hiding (map) import Snap.Internal.Http.Server.Backend import Snap.Test.Common -import Snap.Types data TestException = TestException deriving (Show, Typeable) From a5d415306c516a5c6b7853b81358900cc25c0a05 Mon Sep 17 00:00:00 2001 From: Gregory Collins Date: Sat, 13 Aug 2011 16:16:18 +0100 Subject: [PATCH 07/11] Remove TH stuff from hashmap --- snap-server.cabal | 1 - src/Data/Concurrent/HashMap.hs | 42 +++++++++++-------------- src/Data/Concurrent/HashMap/Internal.hs | 16 ---------- 3 files changed, 18 insertions(+), 41 deletions(-) delete mode 100644 src/Data/Concurrent/HashMap/Internal.hs diff --git a/snap-server.cabal b/snap-server.cabal index 0a22769d..a7be4ac7 100644 --- a/snap-server.cabal +++ b/snap-server.cabal @@ -86,7 +86,6 @@ Library other-modules: Paths_snap_server, Data.Concurrent.HashMap, - Data.Concurrent.HashMap.Internal, Snap.Internal.Http.Parser, Snap.Internal.Http.Server, Snap.Internal.Http.Server.Date, diff --git a/src/Data/Concurrent/HashMap.hs b/src/Data/Concurrent/HashMap.hs index 1c649cc5..5a361c56 100644 --- a/src/Data/Concurrent/HashMap.hs +++ b/src/Data/Concurrent/HashMap.hs @@ -2,7 +2,6 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TemplateHaskell #-} module Data.Concurrent.HashMap ( HashMap @@ -43,38 +42,33 @@ import GHC.Exts ( Word(..), Int(..), shiftRL# ) import Data.Word #endif -import Data.Concurrent.HashMap.Internal - - hashString :: String -> Word -hashString = $(whichHash [| Murmur.asWord32 . Murmur.hash32 |] - [| Murmur.asWord64 . Murmur.hash64 |]) +hashString = if bitSize (undefined :: Word) == 32 + then fromIntegral . Murmur.asWord32 . Murmur.hash32 + else fromIntegral . Murmur.asWord64 . Murmur.hash64 {-# INLINE hashString #-} hashInt :: Int -> Word -hashInt = $(whichHash [| Murmur.asWord32 . Murmur.hash32 |] - [| Murmur.asWord64 . Murmur.hash64 |]) +hashInt = if bitSize (undefined :: Word) == 32 + then fromIntegral . Murmur.asWord32 . Murmur.hash32 + else fromIntegral . Murmur.asWord64 . Murmur.hash64 {-# INLINE hashInt #-} hashBS :: B.ByteString -> Word -hashBS = - $(let h32 = [| \s -> s `seq` - Murmur.asWord32 $ - B.foldl' (\h c -> h `seq` c `seq` - Murmur.hash32AddInt (fromEnum c) h) - (Murmur.hash32 ([] :: [Int])) - s - |] - h64 = [| \s -> s `seq` - Murmur.asWord64 $ - B.foldl' (\h c -> h `seq` c `seq` - Murmur.hash64AddInt (fromEnum c) h) - (Murmur.hash64 ([] :: [Int])) - s - |] - in whichHash h32 h64) +hashBS = if bitSize (undefined :: Word) == 32 then h32 else h64 + where + h32 s = fromIntegral $ Murmur.asWord32 $ + B.foldl' (\h c -> h `seq` c `seq` + Murmur.hash32AddInt (fromEnum c) h) + (Murmur.hash32 ([] :: [Int])) + s + h64 s = fromIntegral $ Murmur.asWord64 $ + B.foldl' (\h c -> h `seq` c `seq` + Murmur.hash64AddInt (fromEnum c) h) + (Murmur.hash64 ([] :: [Int])) + s {-# INLINE hashBS #-} diff --git a/src/Data/Concurrent/HashMap/Internal.hs b/src/Data/Concurrent/HashMap/Internal.hs deleted file mode 100644 index 3ff3f6b1..00000000 --- a/src/Data/Concurrent/HashMap/Internal.hs +++ /dev/null @@ -1,16 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE TemplateHaskell #-} - -module Data.Concurrent.HashMap.Internal where - -import Data.Bits -import Data.Word -import Language.Haskell.TH - - -whichHash :: ExpQ -> ExpQ -> Q Exp -whichHash as32 as64 = if bitSize (undefined :: Word) == 32 - then [| \x -> fromIntegral $ $as32 x |] - else [| \x -> fromIntegral $ $as64 x |] From 12ba87e2d3f56c1145b18f10c359410d4cdb2265 Mon Sep 17 00:00:00 2001 From: Gregory Collins Date: Sat, 13 Aug 2011 16:54:54 +0100 Subject: [PATCH 08/11] Fix build breakage due to Headers. --- src/Snap/Internal/Http/Server.hs | 46 +++++++++---------- test/common/Test/Common/TestHandler.hs | 18 ++++---- test/suite/Snap/Internal/Http/Server/Tests.hs | 11 +++-- 3 files changed, 38 insertions(+), 37 deletions(-) diff --git a/src/Snap/Internal/Http/Server.hs b/src/Snap/Internal/Http/Server.hs index fd5eb9cb..8c7c0786 100644 --- a/src/Snap/Internal/Http/Server.hs +++ b/src/Snap/Internal/Http/Server.hs @@ -16,7 +16,6 @@ import Control.Arrow (first, second) import Control.Monad.State.Strict import Control.Exception import Data.Char -import Data.CaseInsensitive (CI) import qualified Data.CaseInsensitive as CI import Data.ByteString (ByteString) import qualified Data.ByteString as S @@ -55,6 +54,9 @@ import Snap.Internal.Iteratee.Debug import Snap.Iteratee hiding (head, take, map) import qualified Snap.Iteratee as I +import Snap.Types.Headers (Headers) +import qualified Snap.Types.Headers as H + import qualified Paths_snap_server as V @@ -246,8 +248,8 @@ logA' logger req rsp = do let reql = S.intercalate " " [ method, rqURI req, ver ] let status = rspStatus rsp let cl = rspContentLength rsp - let referer = maybe Nothing (Just . head) $ Map.lookup "referer" hdrs - let userAgent = maybe "-" head $ Map.lookup "user-agent" hdrs + let referer = maybe Nothing (Just . head) $ H.lookup "referer" hdrs + let userAgent = maybe "-" head $ H.lookup "user-agent" hdrs msg <- combinedLogEntry host user reql status cl referer userAgent logMsg logger msg @@ -297,8 +299,8 @@ runHTTP defaultTimeout alog elog handler lh sinfo readEnd writeEnd onSendFile ------------------------------------------------------------------------------ -sERVER_HEADER :: [ByteString] -sERVER_HEADER = [S.concat ["Snap/", snapServerVersion]] +sERVER_HEADER :: ByteString +sERVER_HEADER = S.concat ["Snap/", snapServerVersion] ------------------------------------------------------------------------------ @@ -379,8 +381,8 @@ httpSession defaultTimeout writeEnd' buffer onSendFile tickle handler = do "sending response" date <- liftIO getDateString - let ins = Map.insert "Date" [date] . - Map.insert "Server" sERVER_HEADER + let ins = H.set "Date" date . + H.set "Server" sERVER_HEADER let rsp' = updateHeaders ins rsp (bytesSent,_) <- sendResponse req rsp' buffer writeEnd onSendFile @@ -493,7 +495,7 @@ receiveRequest writeEnd = do where isChunked = maybe False ((== ["chunked"]) . map CI.mk) - (Map.lookup "transfer-encoding" hdrs) + (H.lookup "transfer-encoding" hdrs) hasContentLength :: Int64 -> ServerMonad () hasContentLength len = do @@ -527,7 +529,7 @@ receiveRequest writeEnd = do hdrs = rqHeaders req - mbCL = Map.lookup "content-length" hdrs >>= return . Cvt.int . head + mbCL = H.lookup "content-length" hdrs >>= return . Cvt.int . head -------------------------------------------------------------------------- @@ -535,7 +537,7 @@ receiveRequest writeEnd = do parseForm req = {-# SCC "receiveRequest/parseForm" #-} if doIt then getIt else return req where - mbCT = liftM head $ Map.lookup "content-type" (rqHeaders req) + mbCT = liftM head $ H.lookup "content-type" (rqHeaders req) trimIt = fst . SC.spanEnd isSpace . SC.takeWhile (/= ';') . SC.dropWhile isSpace mbCT' = liftM trimIt mbCT @@ -584,7 +586,7 @@ receiveRequest writeEnd = do let (serverName, serverPort) = fromMaybe (localHostname, lport) (liftM (parseHost . head) - (Map.lookup "host" hdrs)) + (H.lookup "host" hdrs)) -- will override in "setEnumerator" enum <- liftIO $ newIORef $ SomeEnumerator (enumBS "") @@ -621,12 +623,12 @@ receiveRequest writeEnd = do hdrs = toHeaders kvps mbContentLength = liftM (Cvt.int . head) $ - Map.lookup "content-length" hdrs + H.lookup "content-length" hdrs cookies = concat $ maybe [] (catMaybes . map parseCookie) - (Map.lookup "cookie" hdrs) + (H.lookup "cookie" hdrs) contextPath = "/" @@ -729,13 +731,12 @@ sendResponse req rsp' buffer writeEnd' onSendFile = do -------------------------------------------------------------------------- - buildHdrs :: Map (CI ByteString) [ByteString] - -> (Builder,Int) + buildHdrs :: Headers -> (Builder,Int) buildHdrs hdrs = {-# SCC "buildHdrs" #-} - Map.foldlWithKey f (mempty,0) hdrs + H.fold f (mempty,0) hdrs where - f (b,len) k ys = + f (!b,!len) !k !ys = let (!b',len') = h k ys in (b `mappend` b', len+len') @@ -819,7 +820,7 @@ sendResponse req rsp' buffer writeEnd' onSendFile = do -------------------------------------------------------------------------- handle304 :: Response -> Response handle304 r = setResponseBody (enumBuilder mempty) $ - updateHeaders (Map.delete "Transfer-Encoding") $ + updateHeaders (H.delete "Transfer-Encoding") $ setContentLength 0 r @@ -829,7 +830,7 @@ sendResponse req rsp' buffer writeEnd' onSendFile = do where f h = if null cookies then h - else Map.insertWith (flip (++)) "Set-Cookie" cookies h + else foldl' (\m v -> H.insert "Set-Cookie" v m) h cookies cookies = fmap cookieToBS . Map.elems $ rspCookies r @@ -903,17 +904,16 @@ checkConnectionClose ver hdrs = then modify $ \s -> s { _forceConnectionClose = True } else return () where - l = liftM (map tl) $ Map.lookup "Connection" hdrs + l = liftM (map tl) $ H.lookup "Connection" hdrs tl = S.map (c2w . toLower . w2c) ------------------------------------------------------------------------------ -- FIXME: whitespace-trim the values here. toHeaders :: [(ByteString,ByteString)] -> Headers -toHeaders kvps = foldl' f Map.empty kvps' +toHeaders kvps = H.fromList kvps' where - kvps' = map (first CI.mk . second (:[])) kvps - f m (k,v) = Map.insertWith' (flip (++)) k v m + kvps' = map (first CI.mk) kvps ------------------------------------------------------------------------------ diff --git a/test/common/Test/Common/TestHandler.hs b/test/common/Test/Common/TestHandler.hs index 19859dff..d1ba9ed3 100644 --- a/test/common/Test/Common/TestHandler.hs +++ b/test/common/Test/Common/TestHandler.hs @@ -139,13 +139,13 @@ uploadHandler = do testHandler :: Snap () testHandler = withCompression $ - route [ ("pong" , pongHandler ) - , ("echo" , echoHandler ) - , ("rot13" , rot13Handler ) - , ("echoUri" , echoUriHandler ) - , ("fileserve" , fileServe "testserver/static") - , ("bigresponse" , bigResponseHandler ) - , ("respcode/:code" , responseHandler ) - , ("upload/form" , uploadForm ) - , ("upload/handle" , uploadHandler ) + route [ ("pong" , pongHandler ) + , ("echo" , echoHandler ) + , ("rot13" , rot13Handler ) + , ("echoUri" , echoUriHandler ) + , ("fileserve" , serveDirectory "testserver/static") + , ("bigresponse" , bigResponseHandler ) + , ("respcode/:code" , responseHandler ) + , ("upload/form" , uploadForm ) + , ("upload/handle" , uploadHandler ) ] diff --git a/test/suite/Snap/Internal/Http/Server/Tests.hs b/test/suite/Snap/Internal/Http/Server/Tests.hs index 34356f5e..345fc73a 100644 --- a/test/suite/Snap/Internal/Http/Server/Tests.hs +++ b/test/suite/Snap/Internal/Http/Server/Tests.hs @@ -52,6 +52,7 @@ import qualified Snap.Iteratee as I import Snap.Iteratee hiding (map) import Snap.Internal.Http.Server.Backend import Snap.Test.Common +import qualified Snap.Types.Headers as H data TestException = TestException deriving (Show, Typeable) @@ -195,7 +196,7 @@ testHttpRequest1 = (rqCookies req) assertEqual "continued headers" (Just ["foo bar"]) $ - Map.lookup "x-random-other-header" $ rqHeaders req + H.lookup "x-random-other-header" $ rqHeaders req assertEqual "parse URI" "/foo/bar.html?param1=abc¶m2=def%20+¶m1=abc" @@ -308,7 +309,7 @@ testHttpRequest3 = assertEqual "no cookies" [] $ rqCookies req assertEqual "multiheader" (Just ["1","2"]) $ - Map.lookup "Multiheader" (rqHeaders req) + H.lookup "Multiheader" (rqHeaders req) assertEqual "host" ("localhost", 80) $ (rqServerName req, rqServerPort req) @@ -397,7 +398,7 @@ testHttpResponse1 = testCase "server/HttpResponse1" $ do ]) b where - rsp1 = updateHeaders (Map.insert "Foo" ["Bar"]) $ + rsp1 = updateHeaders (H.insert "Foo" "Bar") $ setContentLength 10 $ setResponseStatus 600 "Test" $ modifyResponseBody (>==> (enumBuilder $ @@ -427,7 +428,7 @@ testHttpResponse2 = testCase "server/HttpResponse2" $ do , "0123456789" ]) b2 where - rsp1 = updateHeaders (Map.insert "Foo" ["Bar"]) $ + rsp1 = updateHeaders (H.insert "Foo" "Bar") $ setContentLength 10 $ setResponseStatus 600 "Test" $ modifyResponseBody (>==> (enumBuilder $ @@ -458,7 +459,7 @@ testHttpResponse3 = testCase "server/HttpResponse3" $ do where - rsp1 = updateHeaders (Map.insert "Foo" ["Bar"]) $ + rsp1 = updateHeaders (H.insert "Foo" "Bar") $ setContentLength 10 $ setResponseStatus 600 "Test" $ modifyResponseBody (>==> (enumBuilder $ From 67b12118113ae63235520482eee4c7a2eb70c7a0 Mon Sep 17 00:00:00 2001 From: Carl Howells Date: Mon, 12 Sep 2011 21:54:51 -0700 Subject: [PATCH 09/11] whitespace --- src/Snap/Http/Server/Config.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Snap/Http/Server/Config.hs b/src/Snap/Http/Server/Config.hs index de534dbb..fc6f4f7a 100644 --- a/src/Snap/Http/Server/Config.hs +++ b/src/Snap/Http/Server/Config.hs @@ -445,7 +445,7 @@ defaultErrorHandler e = do let sm = smsg req debug $ toString sm logError sm - + finishWith $ setContentType "text/plain; charset=utf-8" . setContentLength (fromIntegral $ B.length msg) . setResponseStatus 500 "Internal Server Error" From f22951ed057e952d2757c5cf35afbc81844d110e Mon Sep 17 00:00:00 2001 From: Carl Howells Date: Mon, 12 Sep 2011 21:55:50 -0700 Subject: [PATCH 10/11] whitespace --- src/Snap/Http/Server.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Snap/Http/Server.hs b/src/Snap/Http/Server.hs index e18a319e..47fb520a 100644 --- a/src/Snap/Http/Server.hs +++ b/src/Snap/Http/Server.hs @@ -49,7 +49,7 @@ snapServerVersion = Int.snapServerVersion -- This function is like 'httpServe' except it doesn't setup compression or the -- error handler; this allows it to be used from 'MonadSnap'. simpleHttpServe :: MonadSnap m => Config m a -> Snap () -> IO () -simpleHttpServe config handler = do +simpleHttpServe config handler = do conf <- completeConfig config let output = when (fromJust $ getVerbose conf) . hPutStrLn stderr mapM_ (output . ("Listening on "++) . show) $ listeners conf From 7a57948b79d1840ab5e10454e775962157764837 Mon Sep 17 00:00:00 2001 From: Carl Howells Date: Mon, 12 Sep 2011 21:56:36 -0700 Subject: [PATCH 11/11] Add a Typeable1 instance for (Config m) --- src/Snap/Http/Server/Config.hs | 13 +++++++++++++ 1 file changed, 13 insertions(+) diff --git a/src/Snap/Http/Server/Config.hs b/src/Snap/Http/Server/Config.hs index fc6f4f7a..216cdb31 100644 --- a/src/Snap/Http/Server/Config.hs +++ b/src/Snap/Http/Server/Config.hs @@ -1,5 +1,6 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} {-| @@ -66,6 +67,7 @@ import Data.Maybe import Data.Monoid import qualified Data.Text as T import qualified Data.Text.Encoding as T +import Data.Typeable import Prelude hiding (catch) import Snap.Core import Snap.Iteratee ((>==>), enumBuilder) @@ -206,6 +208,17 @@ instance Monoid (Config m a) where ov f x y = getLast $! (mappend `on` (Last . f)) x y +------------------------------------------------------------------------------ +-- | The 'Typeable1' instance is here so 'Config' values can be +-- dynamically loaded with Hint. +configTyCon :: TyCon +configTyCon = mkTyCon "Snap.Http.Server.Config.Config" +{-# NOINLINE configTyCon #-} + +instance (Typeable1 m) => Typeable1 (Config m) where + typeOf1 _ = mkTyConApp configTyCon [typeOf1 (undefined :: m ())] + + ------------------------------------------------------------------------------ -- | These are the default values for the options defaultConfig :: MonadSnap m => Config m a