snap-server 0.9.0 → 0.9.2
raw patch · 13 files changed
+148/−412 lines, 13 filesdep −arraydep −bytestring-numsdep −murmur-hashdep ~binarydep ~bytestringdep ~network
Dependencies removed: array, bytestring-nums, murmur-hash, vector, vector-algorithms
Dependency ranges changed: binary, bytestring, network, snap-core, template-haskell
Files
- snap-server.cabal +7/−13
- src/Data/Concurrent/HashMap.hs +0/−231
- src/Snap/Http/Server.hs +2/−0
- src/Snap/Internal/Http/Parser.hs +2/−6
- src/Snap/Internal/Http/Server.hs +80/−102
- src/Snap/Internal/Http/Server/Config.hs +2/−0
- src/Snap/Internal/Http/Server/SimpleBackend.hs +2/−0
- src/System/FastLogger.hs +5/−2
- src/System/SendFile/FreeBSD.hsc +9/−0
- src/System/SendFile/Linux.hsc +10/−0
- test/snap-server-testsuite.cabal +8/−26
- test/suite/Snap/Internal/Http/Server/Tests.hs +20/−28
- test/suite/TestSuite.hs +1/−4
snap-server.cabal view
@@ -1,5 +1,5 @@ name: snap-server-version: 0.9.0+version: 0.9.2 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@@ -72,7 +72,6 @@ other-modules: Paths_snap_server,- Data.Concurrent.HashMap, Snap.Internal.Http.Parser, Snap.Internal.Http.Server, Snap.Internal.Http.Server.Address,@@ -86,15 +85,13 @@ Snap.Internal.Http.Server.TLS build-depends:- array >= 0.2 && <0.5, attoparsec >= 0.10 && < 0.11, attoparsec-enumerator >= 0.3 && < 0.4, base >= 4 && < 5,- binary >= 0.5 && < 0.6,+ binary >= 0.5 && < 0.7, blaze-builder >= 0.2.1.4 && < 0.4, blaze-builder-enumerator >= 0.2.0 && < 0.3,- bytestring >= 0.9.1 && < 0.10,- bytestring-nums,+ bytestring >= 0.9.1 && < 0.11, case-insensitive >= 0.3 && < 0.5, containers >= 0.3 && < 0.6, directory-tree >= 0.10 && < 0.11,@@ -102,17 +99,14 @@ filepath >= 1.1 && < 1.4, MonadCatchIO-transformers >= 0.2.1 && < 0.4, mtl >= 2 && < 3,- murmur-hash >= 0.1 && < 0.2,- network >= 2.3 && < 2.4,+ network >= 2.3 && < 2.5, old-locale,- snap-core >= 0.9 && < 0.10,- template-haskell >= 2.2 && < 2.8,+ snap-core >= 0.9.2 && < 0.10,+ template-haskell >= 2.2 && < 2.9, text >= 0.11 && < 0.12, time >= 1.0 && < 1.5, transformers >= 0.2 && < 0.4,- unix-compat >= 0.2 && < 0.4,- vector >= 0.7 && < 0.10,- vector-algorithms >= 0.4 && < 0.6+ unix-compat >= 0.2 && < 0.4 extensions: BangPatterns,
− src/Data/Concurrent/HashMap.hs
@@ -1,231 +0,0 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE MagicHash #-}-{-# LANGUAGE Rank2Types #-}--module Data.Concurrent.HashMap- ( HashMap- , new- , new'- , null- , insert- , delete- , lookup- , update- , fromList- , toList- , hashString- , hashBS- , hashInt- , nextHighestPowerOf2 ) where----------------------------------------------------------------------------------import Control.Concurrent.MVar-import Control.Monad-import Data.Bits-import qualified Data.ByteString as B-import qualified Data.Digest.Murmur32 as Murmur-import qualified Data.Digest.Murmur64 as Murmur-import Data.IntMap (IntMap)-import qualified Data.IntMap as IM-import Data.Maybe-import qualified Data.Vector as V-import Data.Vector (Vector)-import GHC.Conc (numCapabilities)-import Prelude hiding (lookup, null)-import qualified Prelude--#if __GLASGOW_HASKELL__ >= 503-import GHC.Exts ( Word(..), Int(..), shiftRL# )-#else-import Data.Word-#endif--hashString :: String -> Word-hashString = if bitSize (undefined :: Word) == 32- then fromIntegral . Murmur.asWord32 . Murmur.hash32- else fromIntegral . Murmur.asWord64 . Murmur.hash64-{-# INLINE hashString #-}---hashInt :: Int -> Word-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 = 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 #-}---data HashMap k v = HM {- _hash :: !(k -> Word)- , _hashToBucket :: !(Word -> Word)- , _maps :: !(Vector (MVar (Submap k v)))-}----null :: HashMap k v -> IO Bool-null ht = liftM V.and $ V.mapM f $ _maps ht-- where- f mv = withMVar mv (return . IM.null)---new' :: Eq k =>- Int -- ^ number of locks to use- -> (k -> Word) -- ^ hash function- -> IO (HashMap k v)-new' numLocks hashFunc = do- vector <- V.replicateM (fromEnum n) (newMVar IM.empty)- return $! HM hf bh vector-- where- hf !x = hashFunc x- bh !x = x .&. (n-1)- !n = nextHighestPowerOf2 $ toEnum numLocks---new :: Eq k =>- (k -> Word) -- ^ hash function- -> IO (HashMap k v)-new = new' defaultNumberOfLocks---insert :: k -> v -> HashMap k v -> IO ()-insert key value ht =- modifyMVar_ submap $ \m ->- return $! insSubmap hashcode key value m-- where- hashcode = _hash ht key- bucket = _hashToBucket ht hashcode- submap = V.unsafeIndex (_maps ht) (fromEnum bucket)---delete :: (Eq k) => k -> HashMap k v -> IO ()-delete key ht =- modifyMVar_ submap $ \m ->- return $! delSubmap hashcode key m- where- hashcode = _hash ht key- bucket = _hashToBucket ht hashcode- submap = V.unsafeIndex (_maps ht) (fromEnum bucket)---lookup :: (Eq k) => k -> HashMap k v -> IO (Maybe v)-lookup key ht =- withMVar submap $ \m ->- return $! lookupSubmap hashcode key m- where- hashcode = _hash ht key- bucket = _hashToBucket ht hashcode- submap = V.unsafeIndex (_maps ht) (fromEnum bucket)---update :: (Eq k) => k -> v -> HashMap k v -> IO Bool-update key value ht =- modifyMVar submap $ \m ->- return $! updateSubmap hashcode key value m- where- hashcode = _hash ht key- bucket = _hashToBucket ht hashcode- submap = V.unsafeIndex (_maps ht) (fromEnum bucket)---toList :: HashMap k v -> IO [(k,v)]-toList ht = liftM (concat . V.toList) $ V.mapM f $ _maps ht- where- f m = withMVar m $ \sm -> return $ concat $ IM.elems sm---fromList :: (Eq k) => (k -> Word) -> [(k,v)] -> IO (HashMap k v)-fromList hf xs = do- ht <- new hf- mapM_ (\(k,v) -> insert k v ht) xs- return $! ht------------------------------------------------------------------------------------ helper functions----------------------------------------------------------------------------------- nicked this technique from Data.IntMap--shiftRL :: Word -> Int -> Word-#if __GLASGOW_HASKELL__-{--------------------------------------------------------------------- GHC: use unboxing to get @shiftRL@ inlined.---------------------------------------------------------------------}-shiftRL (W# x) (I# i)- = W# (shiftRL# x i)-#else-shiftRL x i = shiftR x i-#endif---type Submap k v = IntMap [(k,v)]---nextHighestPowerOf2 :: Word -> Word-nextHighestPowerOf2 w = highestBitMask (w-1) + 1---highestBitMask :: Word -> Word-highestBitMask !x0 = case (x0 .|. shiftRL x0 1) of- x1 -> case (x1 .|. shiftRL x1 2) of- x2 -> case (x2 .|. shiftRL x2 4) of- x3 -> case (x3 .|. shiftRL x3 8) of- x4 -> case (x4 .|. shiftRL x4 16) of- x5 -> x5 .|. shiftRL x5 32----insSubmap :: Word -> k -> v -> Submap k v -> Submap k v-insSubmap hashcode key value m = let !x = f m in x- where- f = IM.insertWith (++) (fromIntegral hashcode) [(key,value)]---delSubmap :: (Eq k) => Word -> k -> Submap k v -> Submap k v-delSubmap hashcode key m =- let !z = IM.update f (fromIntegral hashcode) m in z-- where- f l = let l' = del l in if Prelude.null l' then Nothing else Just l'-- del = filter ((/= key) . fst)---lookupSubmap :: (Eq k) => Word -> k -> Submap k v -> Maybe v-lookupSubmap hashcode key m = maybe Nothing (Prelude.lookup key) mbBucket- where- mbBucket = IM.lookup (fromIntegral hashcode) m---updateSubmap :: (Eq k) => Word -> k -> v -> Submap k v -> (Submap k v, Bool)-updateSubmap hashcode key value m = (m'', b)- where- oldV = lookupSubmap hashcode key m- m' = maybe m (const $ delSubmap hashcode key m) oldV- m'' = insSubmap hashcode key value m'- b = isJust oldV---defaultNumberOfLocks :: Int-defaultNumberOfLocks = 8 * numCapabilities
src/Snap/Http/Server.hs view
@@ -26,7 +26,9 @@ import qualified Data.ByteString as BS import Data.List import Data.Maybe+#if !MIN_VERSION_base(4,6,0) import Prelude hiding (catch)+#endif import Snap.Http.Server.Config import qualified Snap.Internal.Http.Server as Int import Snap.Internal.Http.Server.Config (emptyStartupInfo,
src/Snap/Internal/Http/Parser.hs view
@@ -28,7 +28,6 @@ import qualified Data.ByteString.Unsafe as S import Data.ByteString.Internal (w2c) import qualified Data.ByteString.Lazy.Char8 as L-import qualified Data.ByteString.Nums.Careless.Hex as Cvt import Data.Char import Data.Int import Data.Typeable@@ -207,15 +206,12 @@ ------------------------------------------------------------------------------ pGetTransferChunk :: Parser (Maybe ByteString) pGetTransferChunk = do- !hex <- liftM fromHex $ (takeWhile (isHexDigit . w2c))+ !hex <- liftM unsafeFromHex $ (takeWhile (isHexDigit . w2c)) takeTill ((== '\r') . w2c) crlf- if hex <= 0+ if hex <= (0 :: Int) then return Nothing else do x <- take hex crlf return $! Just x- where- fromHex :: ByteString -> Int- fromHex s = Cvt.hex (L.fromChunks [s])
src/Snap/Internal/Http/Server.hs view
@@ -28,22 +28,25 @@ import qualified Data.ByteString.Char8 as SC import qualified Data.ByteString.Lazy as L import Data.ByteString.Internal (c2w, w2c)-import qualified Data.ByteString.Nums.Careless.Int as Cvt import Data.Enumerator.Internal import Data.Int import Data.IORef import Data.List (foldl') import qualified Data.Map as Map-import Data.Maybe (catMaybes, fromJust, fromMaybe, isJust)+import Data.Maybe ( catMaybes, fromJust, fromMaybe, isJust+ , isNothing ) import Data.Monoid+import qualified Data.Text as T+import qualified Data.Text.Encoding as T import Data.Time import Data.Typeable import Data.Version import GHC.Conc import Network.Socket (withSocketsDo, Socket)+#if !MIN_VERSION_base(4,6,0) import Prelude hiding (catch)-import System.PosixCompat.Files hiding (setFileSize)-import System.Posix.Types (FileOffset)+#endif+import System.IO import System.Locale ------------------------------------------------------------------------------ import System.FastLogger (timestampedLogEntry, combinedLogEntry)@@ -59,6 +62,7 @@ import Snap.Internal.Http.Server.SimpleBackend import Snap.Internal.Iteratee.Debug+import Snap.Internal.Parsing (unsafeFromInt) import Snap.Iteratee hiding (head, take, map) import qualified Snap.Iteratee as I @@ -152,10 +156,40 @@ -> ServerHandler -- ^ handler procedure -> IO () httpServe defaultTimeout ports localHostname alog' elog' initial handler =- withSocketsDo $ spawnAll alog' elog'+ withSocketsDo $ spawnAll alog' elog' `catches` errorHandlers where --------------------------------------------------------------------------+ errorHandlers = [ Handler sslException+ , Handler threadWasKilled+ , Handler otherException ]++ --------------------------------------------------------------------------+ sslException (e :: TLS.TLSException) = do+ let msg = SC.concat [+ "This version of snap-server was not built with SSL "+ , "support.\n"+ , "Please compile snap-server with -fopenssl to enable it."+ ]++ logE elog' msg+ SC.hPutStrLn stderr msg+ throw e++ ------------------------------------------------------------------------------+ threadWasKilled (_ :: AsyncException) = return ()++ ------------------------------------------------------------------------------+ otherException (e :: SomeException) = do+ let msg = SC.concat [+ "Error on startup: \n"+ , T.encodeUtf8 $ T.pack $ show e+ ]+ logE elog' msg+ SC.hPutStrLn stderr msg+ throw e++ -------------------------------------------------------------------------- spawnAll alog elog = {-# SCC "httpServe/spawnAll" #-} do logE elog $ S.concat [ "Server.httpServe: START, binding to "@@ -397,7 +431,7 @@ then id else insHeader let rsp' = updateHeaders ins rsp- (bytesSent,_) <- sendResponse req rsp' buffer writeEnd onSendFile+ (bytesSent,_) <- sendResponse rsp' buffer writeEnd onSendFile `catch` errCatch "sending response" req debug $ "Server.httpSession: sent " ++@@ -566,7 +600,7 @@ hdrs = rqHeaders req- mbCL = H.lookup "content-length" hdrs >>= return . Cvt.int . head+ mbCL = H.lookup "content-length" hdrs >>= return . unsafeFromInt . head --------------------------------------------------------------------------@@ -660,7 +694,7 @@ hdrs = toHeaders kvps - mbContentLength = liftM (Cvt.int . head) $+ mbContentLength = liftM (unsafeFromInt . head) $ H.lookup "content-length" hdrs cookies = concat $@@ -670,7 +704,7 @@ contextPath = "/" - parseHost h = (a, Cvt.int (S.drop 1 b))+ parseHost h = (a, unsafeFromInt (S.drop 1 b)) where (a,b) = S.break (== (c2w ':')) h @@ -682,16 +716,21 @@ ------------------------------------------------------------------------------ -- Response must be well-formed here-sendResponse :: forall a . Request- -> Response+sendResponse :: forall a . Response -> Buffer -> Iteratee ByteString IO a -- ^ iteratee write end -> (FilePath -> Int64 -> Int64 -> IO a) -- ^ function to call on -- sendfile -> ServerMonad (Int64, a)-sendResponse req rsp' buffer writeEnd' onSendFile = do- let rsp'' = renderCookies rsp'- rsp <- fixupResponse rsp''+sendResponse rsp0 buffer writeEnd' onSendFile = do+ let rsp1 = renderCookies rsp0++ let (rsp, shouldClose) = if isNothing $ rspContentLength rsp1+ then noCL rsp1+ else (rsp1, False)++ when shouldClose $ modify $! \s -> s { _forceConnectionClose = True }+ let (!headerString,!hlen) = mkHeaderBuilder rsp let writeEnd = fixCLIteratee hlen rsp writeEnd' @@ -710,6 +749,32 @@ where --------------------------------------------------------------------------+ noCL :: Response -> (Response, Bool)+ noCL r =+ if rspHttpVersion r >= (1,1)+ then+ let r' = setHeader "Transfer-Encoding" "chunked" r+ origE = rspBodyToEnum $ rspBody r+ e = \i -> joinI $ origE $$ chunkIt i+ in (r' { rspBody = Enum e }, False)+ else+ -- HTTP/1.0 and no content-length? We'll have to close the+ -- socket.+ (setHeader "Connection" "close" r, True)+ {-# INLINE noCL #-}+++ --------------------------------------------------------------------------+ chunkIt :: forall x . Enumeratee Builder Builder IO x+ chunkIt = checkDone $ continue . step+ where+ step k EOF = k (Chunks [chunkedTransferTerminator]) >>== return+ step k (Chunks []) = continue $ step k+ step k (Chunks xs) = k (Chunks [chunkedTransferEncoding $ mconcat xs])+ >>== chunkIt+++ -------------------------------------------------------------------------- whenEnum :: Iteratee ByteString IO a -> Builder -> Int@@ -770,7 +835,7 @@ --------------------------------------------------------------------------- (major,minor) = rspHttpVersion rsp'+ (major,minor) = rspHttpVersion rsp0 --------------------------------------------------------------------------@@ -799,36 +864,6 @@ --------------------------------------------------------------------------- noCL :: Response- -> ServerMonad Response- noCL r = {-# SCC "noCL" #-} do- -- are we in HTTP/1.1?- let sendChunked = (rspHttpVersion r) == (1,1)- if sendChunked- then do- let r' = setHeader "Transfer-Encoding" "chunked" r- let origE = rspBodyToEnum $ rspBody r-- let e = \i -> joinI $ origE $$ chunkIt i-- return $! r' { rspBody = Enum e }-- else do- -- HTTP/1.0 and no content-length? We'll have to close the- -- socket.- modify $! \s -> s { _forceConnectionClose = True }- return $! setHeader "Connection" "close" r-- --------------------------------------------------------------------------- chunkIt :: forall x . Enumeratee Builder Builder IO x- chunkIt = checkDone $ continue . step- where- step k EOF = k (Chunks [chunkedTransferTerminator]) >>== return- step k (Chunks []) = continue $ step k- step k (Chunks xs) = k (Chunks [chunkedTransferEncoding $ mconcat xs])- >>== chunkIt-- -------------------------------------------------------------------------- fixCLIteratee :: Int -- ^ header length -> Response -- ^ response -> Iteratee ByteString IO a -- ^ write end@@ -842,32 +877,8 @@ mbCL = rspContentLength resp - --------------------------------------------------------------------------- hasCL :: Int64- -> Response- -> ServerMonad Response- hasCL cl r = {-# SCC "hasCL" #-}- -- set the content-length header- return $! setHeader "Content-Length" (toByteString $ fromShow cl) r - --------------------------------------------------------------------------- setFileSize :: FilePath -> Response -> ServerMonad Response- setFileSize fp r =- {-# SCC "setFileSize" #-}- do- fs <- liftM fromIntegral $ liftIO $ getFileSize fp- return $! r { rspContentLength = Just fs }--- --------------------------------------------------------------------------- handle304 :: Response -> Response- handle304 r = setResponseBody (enumBuilder mempty) $- updateHeaders (H.delete "Transfer-Encoding") $- setContentLength 0 r--- -------------------------------------------------------------------------- renderCookies :: Response -> Response renderCookies r = updateHeaders f r where@@ -878,34 +889,6 @@ --------------------------------------------------------------------------- fixupResponse :: Response- -> ServerMonad Response- fixupResponse r = {-# SCC "fixupResponse" #-} do- let r' = deleteHeader "Content-Length" r- let code = rspStatus r'- let r'' = if code == 204 || code == 304- then handle304 r'- else r'-- r''' <- do- z <- case rspBody r'' of- (Enum _) -> return r''- (SendFile f Nothing) -> setFileSize f r''- (SendFile _ (Just (s,e))) -> return $!- setContentLength (e-s) r''-- case rspContentLength z of- Nothing -> noCL z- (Just sz) -> hasCL sz z-- -- HEAD requests cannot have bodies per RFC 2616 sec. 9.4- if rqMethod req == HEAD- then return $! deleteHeader "Transfer-Encoding" $- r''' { rspBody = Enum $ enumBuilder mempty }- else return $! r'''--- -------------------------------------------------------------------------- mkHeaderBuilder :: Response -> (Builder,Int) mkHeaderBuilder r = {-# SCC "mkHeaderBuilder" #-} ( mconcat [ fromByteString "HTTP/"@@ -972,11 +955,6 @@ hOnly = if isHOnly then "; HttpOnly" else "" fmt = fromStr . formatTime defaultTimeLocale "%a, %d-%b-%Y %H:%M:%S GMT"----------------------------------------------------------------------------------getFileSize :: FilePath -> IO FileOffset-getFileSize fp = liftM fileSize $ getFileStatus fp ------------------------------------------------------------------------------
src/Snap/Internal/Http/Server/Config.hs view
@@ -28,7 +28,9 @@ import qualified Data.Text.Encoding as T import Data.Typeable import Network(Socket)+#if !MIN_VERSION_base(4,6,0) import Prelude hiding (catch)+#endif import Snap.Core import Snap.Iteratee ((>==>), enumBuilder) import Snap.Internal.Debug (debug)
src/Snap/Internal/Http/Server/SimpleBackend.hs view
@@ -26,7 +26,9 @@ import Foreign.C import GHC.Conc (labelThread, forkOnIO) import Network.Socket+#if !MIN_VERSION_base(4,6,0) import Prelude hiding (catch)+#endif ------------------------------------------------------------------------------ import Snap.Internal.Debug import Snap.Internal.Http.Server.Date
src/System/FastLogger.hs view
@@ -1,5 +1,6 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} module System.FastLogger@@ -27,7 +28,9 @@ import Data.Monoid import qualified Data.Text as T import qualified Data.Text.Encoding as T+#if !MIN_VERSION_base(4,6,0) import Prelude hiding (catch)+#endif import System.IO import Snap.Internal.Http.Server.Date
src/System/SendFile/FreeBSD.hsc view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE ForeignFunctionInterface #-} -- | FreeBSD system-dependent code for 'sendfile'. module System.SendFile.FreeBSD (sendFile) where@@ -5,11 +6,19 @@ import Control.Concurrent (threadWaitWrite) import Data.Int import Foreign.C.Error (eAGAIN, eINTR, getErrno, throwErrno)+#if MIN_VERSION_base(4,5,0)+import Foreign.C.Types (CSize(..), CInt(..))+#else import Foreign.C.Types (CInt, CSize)+#endif import Foreign.Marshal.Alloc (alloca) import Foreign.Ptr (Ptr, nullPtr) import Foreign.Storable (peek)+#if MIN_VERSION_base(4,5,0)+import System.Posix.Types (COff(..), Fd(..))+#else import System.Posix.Types (COff, Fd)+#endif sendFile :: IO () -> Fd -> Fd -> Int64 -> Int64 -> IO Int64 sendFile onBlock out_fd in_fd off count
src/System/SendFile/Linux.hsc view
@@ -1,14 +1,24 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE ForeignFunctionInterface #-}+ -- | Linux system-dependent code for 'sendfile'. module System.SendFile.Linux (sendFile) where import Data.Int import Foreign.C.Error (eAGAIN, getErrno, throwErrno)+#if MIN_VERSION_base(4,5,0)+import Foreign.C.Types (CSize(..), CInt(..))+#else import Foreign.C.Types (CSize)+#endif import Foreign.Marshal (alloca) import Foreign.Ptr (Ptr, nullPtr) import Foreign.Storable (poke)+#if MIN_VERSION_base(4,5,0)+import System.Posix.Types (Fd(..), COff(..), CSsize(..))+#else import System.Posix.Types (Fd, COff, CSsize)+#endif sendFile :: IO () -> Fd -> Fd -> Int64 -> Int64 -> IO Int64 sendFile onBlock out_fd in_fd off count
test/snap-server-testsuite.cabal view
@@ -18,16 +18,14 @@ build-depends: QuickCheck >= 2,- array >= 0.3 && <0.5, attoparsec >= 0.10 && <0.11, attoparsec-enumerator >= 0.3 && <0.4, base >= 4 && <5, base16-bytestring == 0.1.*,- binary >= 0.5 && <0.6,+ binary >= 0.5 && <0.7, blaze-builder >= 0.2.1.4 && <0.4, blaze-builder-enumerator >= 0.2.0 && <0.3, bytestring,- bytestring-nums >= 0.3.1 && <0.4, containers, directory, directory-tree,@@ -36,12 +34,11 @@ http-enumerator >= 0.7.3 && <0.8, HUnit >= 1.2 && <2, mtl >= 2 && <3,- murmur-hash >= 0.1 && <0.2,- network == 2.3.*,+ network >= 2.3 && <2.5, old-locale, parallel >= 2 && <4, process,- snap-core >= 0.9 && <0.10,+ snap-core >= 0.9.2 && <0.10, template-haskell, test-framework >= 0.6 && <0.7, test-framework-hunit >= 0.2.7 && <0.3,@@ -50,10 +47,7 @@ time, tls >= 0.8.2 && <0.9.2, tls-extra >= 0.4 && <0.4.5,- transformers,- vector >= 0.7 && <0.10,- vector-algorithms >= 0.4 && <0.6,- PSQueue >= 1.1 && <1.2+ transformers extensions: BangPatterns,@@ -91,7 +85,6 @@ build-depends: QuickCheck >= 2,- array >= 0.3 && <0.5, attoparsec >= 0.10 && <0.11, attoparsec-enumerator >= 0.3 && <0.4, base >= 4 && <5,@@ -99,7 +92,6 @@ blaze-builder >= 0.2.1.4 && <0.4, blaze-builder-enumerator >= 0.2.0 && <0.3, bytestring,- bytestring-nums >= 0.3.1 && <0.4, cereal >= 0.3 && <0.4, containers, directory-tree,@@ -107,20 +99,16 @@ filepath, HUnit >= 1.2 && <2, mtl >= 2 && <3,- murmur-hash >= 0.1 && <0.2, old-locale, parallel >= 3.2 && <4, MonadCatchIO-transformers >= 0.2.1 && <0.4, network == 2.3.*,- snap-core >= 0.9 && <0.10,+ snap-core >= 0.9.2 && <0.10, template-haskell, time, transformers, unix-compat >= 0.2 && <0.4,- utf8-string >= 0.3.6 && <0.4,- vector >= 0.7 && <0.10,- vector-algorithms >= 0.4 && <0.6,- PSQueue >= 1.1 && <1.2+ utf8-string >= 0.3.6 && <0.4 if flag(portable) || os(windows) cpp-options: -DPORTABLE@@ -163,7 +151,6 @@ build-depends: QuickCheck >= 2,- array >= 0.3 && <0.5, attoparsec >= 0.10 && <0.11, attoparsec-enumerator >= 0.3 && <0.4, base >= 4 && <5,@@ -171,7 +158,6 @@ blaze-builder >= 0.2.1.4 && <0.4, blaze-builder-enumerator >= 0.2.0 && <0.3, bytestring,- bytestring-nums >= 0.3.1 && <0.4, case-insensitive >= 0.3 && <0.5, containers, directory-tree,@@ -180,20 +166,16 @@ HUnit >= 1.2 && <2, MonadCatchIO-transformers >= 0.2.1 && <0.4, mtl >= 2 && <3,- murmur-hash >= 0.1 && <0.2, network == 2.3.*, old-locale, parallel >= 3.2 && <4,- snap-core >= 0.9 && <0.10,+ snap-core >= 0.9.2 && <0.10, template-haskell, test-framework >= 0.6 && <0.7, test-framework-hunit >= 0.2.7 && <0.3, test-framework-quickcheck2 >= 0.2.12.1 && <0.3, text >= 0.11 && <0.12,- time,- vector >= 0.7 && <0.10,- vector-algorithms >= 0.4 && <0.6,- PSQueue >= 1.1 && <1.2+ time if !os(windows) build-depends: unix
test/suite/Snap/Internal/Http/Server/Tests.hs view
@@ -160,13 +160,6 @@ dummyIter = consume >> return () -mkRequest :: ByteString -> IO Request-mkRequest s = do- step <- runIteratee $ liftM fromJust $ rsm $ receiveRequest dummyIter- let iter = enumBS s step- run_ iter-- testReceiveRequest :: Iteratee ByteString IO (Request,L.ByteString) testReceiveRequest = do r <- liftM fromJust $ rsm $ receiveRequest dummyIter@@ -383,11 +376,10 @@ testHttpResponse1 :: Test testHttpResponse1 = testCase "server/HttpResponse1" $ do- req <- mkRequest sampleRequest buf <- allocBuffer 16384 b <- run_ $ rsm $- sendResponse req rsp1 buf copyingStream2Stream testOnSendFile >>=+ sendResponse rsp1 buf copyingStream2Stream testOnSendFile >>= return . snd assertBool "http response" (b == text1 || b == text2)@@ -406,7 +398,7 @@ ] rsp1 = updateHeaders (H.insert "Foo" "Bar") $- setContentLength 10 $+ setContentLength' 10 $ setResponseStatus 600 "Test" $ modifyResponseBody (>==> (enumBuilder $ fromByteString "0123456789")) $@@ -435,10 +427,9 @@ testHttpResponse2 :: Test testHttpResponse2 = testCase "server/HttpResponse2" $ do- req <- mkRequest sampleRequest buf <- allocBuffer 16384 b2 <- liftM (S.concat . L.toChunks) $ run_ $ rsm $- sendResponse req rsp2 buf copyingStream2Stream testOnSendFile >>=+ sendResponse rsp2 buf copyingStream2Stream testOnSendFile >>= return . snd assertBool "http prefix"@@ -455,7 +446,7 @@ where rsp1 = updateHeaders (H.insert "Foo" "Bar") $- setContentLength 10 $+ setContentLength' 10 $ setResponseStatus 600 "Test" $ modifyResponseBody (>==> (enumBuilder $ fromByteString "0123456789")) $@@ -466,11 +457,10 @@ testHttpResponse3 :: Test testHttpResponse3 = testCase "server/HttpResponse3" $ do- req <- mkRequest sampleRequest buf <- allocBuffer 16384 b3 <- run_ $ rsm $- sendResponse req rsp3 buf copyingStream2Stream testOnSendFile >>=+ sendResponse rsp3 buf copyingStream2Stream testOnSendFile >>= return . snd let lns = LC.lines b3@@ -498,13 +488,13 @@ hdrs = strToHeaders s rsp1 = updateHeaders (H.insert "Foo" "Bar") $- setContentLength 10 $+ setContentLength' 10 $ setResponseStatus 600 "Test" $ modifyResponseBody (>==> (enumBuilder $ fromByteString "0123456789")) $ setResponseBody returnI $ emptyResponse { rspHttpVersion = (1,0) }- rsp2 = rsp1 { rspContentLength = Nothing }+ rsp2 = deleteHeader "Content-Length" $ rsp1 { rspContentLength = Nothing } rsp3 = setContentType "text/plain" $ (rsp2 { rspHttpVersion = (1,1) }) @@ -512,10 +502,8 @@ testHttpResponse4 = testCase "server/HttpResponse4" $ do buf <- allocBuffer 16384 - req <- mkRequest sampleRequest- b <- run_ $ rsm $- sendResponse req rsp1 buf copyingStream2Stream testOnSendFile >>=+ sendResponse rsp1 buf copyingStream2Stream testOnSendFile >>= return . snd assertEqual "http response" (L.concat [@@ -525,16 +513,15 @@ where rsp1 = setResponseStatus 304 "Test" $+ setContentLength' 0 $ emptyResponse { rspHttpVersion = (1,0) } testHttpResponseCookies :: Test testHttpResponseCookies = testCase "server/HttpResponseCookies" $ do buf <- allocBuffer 16384- req <- mkRequest sampleRequest- b <- run_ $ rsm $- sendResponse req rsp2 buf copyingStream2Stream testOnSendFile >>=+ sendResponse rsp2 buf copyingStream2Stream testOnSendFile >>= return . snd let lns = LC.lines b@@ -550,7 +537,7 @@ assertBool "http response" ok where- check s = (H.lookup "Content-Length" hdrs == Just ["0\r"]) &&+ check s = (H.lookup "Connection" hdrs == Just ["close\r"]) && (ch $ H.lookup "Set-Cookie" hdrs) where hdrs = strToHeaders s@@ -589,9 +576,9 @@ liftIO $ writeIORef (rqBody req) (SomeEnumerator $ joinI . I.take 0) return (req, rsp b cl) where- rsp s cl = emptyResponse { rspBody = Enum $- enumBuilder (fromLazyByteString s)- , rspContentLength = Just $ fromIntegral cl }+ rsp s cl = setContentLength' cl $+ emptyResponse { rspBody = Enum $+ enumBuilder (fromLazyByteString s) } echoServer2 :: ServerHandler@@ -928,7 +915,7 @@ pongServer :: Snap () pongServer = modifyResponse $ setResponseBody enum . setContentType "text/plain" .- setContentLength 4+ setContentLength' 4 where enum = enumBuilder $ fromByteString "PONG" @@ -1069,3 +1056,8 @@ maybe (return $ L.fromChunks $ reverse l) (\x -> let !z = S.copy x in go (z:l)) mbx+++setContentLength' :: Int64 -> Response -> Response+setContentLength' cl = setHeader "Content-Length" (S.pack $ show cl) .+ setContentLength cl
test/suite/TestSuite.hs view
@@ -13,7 +13,6 @@ import System.Environment import Snap.Http.Server.Config -import qualified Data.Concurrent.HashMap.Tests import qualified Snap.Internal.Http.Parser.Tests import qualified Snap.Internal.Http.Server.Tests import qualified Snap.Internal.Http.Server.TimeoutManager.Tests@@ -51,9 +50,7 @@ mapM_ takeMVar $ map snd tinfos where tests =- [ testGroup "Data.Concurrent.HashMap.Tests"- Data.Concurrent.HashMap.Tests.tests- , testGroup "Snap.Internal.Http.Parser.Tests"+ [ testGroup "Snap.Internal.Http.Parser.Tests" Snap.Internal.Http.Parser.Tests.tests , testGroup "Snap.Internal.Http.Server.Tests" Snap.Internal.Http.Server.Tests.tests