diff --git a/snap-server.cabal b/snap-server.cabal --- a/snap-server.cabal +++ b/snap-server.cabal @@ -1,5 +1,5 @@ name: snap-server -version: 0.9.4.3 +version: 0.9.4.4 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 diff --git a/src/Snap/Internal/Http/Server.hs b/src/Snap/Internal/Http/Server.hs --- a/src/Snap/Internal/Http/Server.hs +++ b/src/Snap/Internal/Http/Server.hs @@ -12,64 +12,65 @@ import Blaze.ByteString.Builder.Char8 import Blaze.ByteString.Builder.Enumerator import Blaze.ByteString.Builder.HTTP -import Control.Arrow (first, second) -import Control.Monad.CatchIO hiding ( bracket - , catches - , finally - , Handler - ) -import qualified Control.Monad.CatchIO as CatchIO +import Control.Arrow (first, second) +import Control.Exception hiding (catch, throw) +import Control.Monad.CatchIO hiding (Handler, + bracket, catches, + finally) +import qualified Control.Monad.CatchIO as CatchIO import Control.Monad.State.Strict -import Control.Exception hiding (catch, throw) +import Data.ByteString (ByteString) +import qualified Data.ByteString as S +import qualified Data.ByteString.Char8 as SC +import Data.ByteString.Internal (c2w, w2c) +import qualified Data.ByteString.Lazy as L +import qualified Data.CaseInsensitive as CI import Data.Char -import qualified Data.CaseInsensitive as CI -import Data.ByteString (ByteString) -import qualified Data.ByteString as S -import qualified Data.ByteString.Char8 as SC -import qualified Data.ByteString.Lazy as L -import Data.ByteString.Internal (c2w, w2c) 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 - , isNothing ) +import Data.List (foldl') +import qualified Data.Map as Map +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 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) +import Network.Socket (Socket, withSocketsDo) #if !MIN_VERSION_base(4,6,0) -import Prelude hiding (catch) +import Prelude hiding (catch) #endif import System.IO import System.Locale ------------------------------------------------------------------------------ -import System.FastLogger (timestampedLogEntry, combinedLogEntry) -import Snap.Internal.Http.Types import Snap.Internal.Debug -import Snap.Internal.Exceptions (EscapeHttpException (..)) +import Snap.Internal.Exceptions (EscapeHttpException (..)) import Snap.Internal.Http.Parser import Snap.Internal.Http.Server.Date +import Snap.Internal.Http.Types +import System.FastLogger (combinedLogEntry, + timestampedLogEntry) import Snap.Internal.Http.Server.Backend import Snap.Internal.Http.Server.HttpPort -import qualified Snap.Internal.Http.Server.TLS as TLS import Snap.Internal.Http.Server.SimpleBackend +import qualified Snap.Internal.Http.Server.TLS as TLS import Snap.Internal.Iteratee.Debug -import Snap.Internal.Parsing (unsafeFromInt) -import Snap.Iteratee hiding (head, take, map) -import qualified Snap.Iteratee as I +import Snap.Internal.Parsing (unsafeFromInt) +import Snap.Iteratee hiding (head, map, + take) +import qualified Snap.Iteratee as I -import Snap.Types.Headers (Headers) -import qualified Snap.Types.Headers as H +import Snap.Types.Headers (Headers) +import qualified Snap.Types.Headers as H -import qualified Paths_snap_server as V +import qualified Paths_snap_server as V ------------------------------------------------------------------------------ @@ -122,11 +123,11 @@ ------------------------------------------------------------------------------ data ServerState = ServerState - { _forceConnectionClose :: Bool - , _localHostname :: ByteString - , _sessionPort :: SessionInfo - , _logAccess :: Request -> Response -> IO () - , _logError :: ByteString -> IO () + { _forceConnectionClose :: Bool + , _localHostname :: ByteString + , _sessionPort :: SessionInfo + , _logAccess :: Request -> Response -> IO () + , _logError :: ByteString -> IO () } @@ -431,7 +432,7 @@ then id else insHeader let rsp' = updateHeaders ins rsp - (bytesSent,_) <- sendResponse rsp' buffer writeEnd onSendFile + (bytesSent,_) <- sendResponse req rsp' buffer writeEnd onSendFile `catch` errCatch "sending response" req debug $ "Server.httpSession: sent " ++ @@ -716,13 +717,15 @@ ------------------------------------------------------------------------------ -- Response must be well-formed here -sendResponse :: forall a . Response +sendResponse :: forall a . + Request + -> Response -> Buffer -> Iteratee ByteString IO a -- ^ iteratee write end -> (FilePath -> Int64 -> Int64 -> IO a) -- ^ function to call on -- sendfile -> ServerMonad (Int64, a) -sendResponse rsp0 buffer writeEnd' onSendFile = do +sendResponse req rsp0 buffer writeEnd' onSendFile = do let rsp1 = renderCookies rsp0 let (rsp, shouldClose) = if isNothing $ rspContentLength rsp1 @@ -751,16 +754,18 @@ -------------------------------------------------------------------------- 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) + if rqMethod req == HEAD + then let r' = r { rspBody = Enum $ enumBuilder mempty } + in (r', False) + else 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 #-} diff --git a/test/common/Test/Common/TestHandler.hs b/test/common/Test/Common/TestHandler.hs --- a/test/common/Test/Common/TestHandler.hs +++ b/test/common/Test/Common/TestHandler.hs @@ -1,27 +1,27 @@ -{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE BangPatterns #-} {-# LANGUAGE OverloadedStrings #-} module Test.Common.TestHandler (testHandler) where import Blaze.ByteString.Builder -import Control.Concurrent (threadDelay) +import Control.Concurrent (threadDelay) import Control.Monad import Control.Monad.Trans -import qualified Data.ByteString.Char8 as S +import qualified Data.ByteString.Char8 as S import qualified Data.ByteString.Lazy.Char8 as L import Data.List -import qualified Data.Map as Map +import qualified Data.Map as Map import Data.Maybe import Data.Monoid -import Snap.Internal.Debug -import Snap.Iteratee hiding (Enumerator) -import qualified Snap.Iteratee as I import Snap.Core +import Snap.Internal.Debug +import Snap.Iteratee hiding (Enumerator) +import qualified Snap.Iteratee as I import Snap.Util.FileServe import Snap.Util.FileUploads import Snap.Util.GZip import System.Directory -import Test.Common.Rot13 (rot13) +import Test.Common.Rot13 (rot13) @@ -189,6 +189,10 @@ serverHeaderHandler = modifyResponse $ setHeader "Server" "foo" +chunkedResponse :: Snap () +chunkedResponse = writeBS "chunked" + + testHandler :: Snap () testHandler = withCompression $ route [ ("pong" , pongHandler ) @@ -203,4 +207,5 @@ , ("timeout/tickle" , timeoutTickleHandler ) , ("timeout/badtickle" , badTimeoutTickleHandler ) , ("server-header" , serverHeaderHandler ) + , ("chunked" , chunkedResponse ) ] diff --git a/test/snap-server-testsuite.cabal b/test/snap-server-testsuite.cabal --- a/test/snap-server-testsuite.cabal +++ b/test/snap-server-testsuite.cabal @@ -28,7 +28,9 @@ bytestring, conduit >= 0.5 && <0.6, containers, + cprng-aes <0.4, cryptocipher >= 0.3.7 && <0.4, + crypto-api <0.13, directory, directory-tree, enumerator >= 0.4.15 && <0.5, @@ -209,4 +211,4 @@ build-depends: base >= 4 && < 5, network >= 2.3 && < 2.6, - criterion >= 0.6 && < 0.7 + criterion >= 0.8 && < 0.9 diff --git a/test/suite/Snap/Internal/Http/Server/Tests.hs b/test/suite/Snap/Internal/Http/Server/Tests.hs --- a/test/suite/Snap/Internal/Http/Server/Tests.hs +++ b/test/suite/Snap/Internal/Http/Server/Tests.hs @@ -50,6 +50,7 @@ import Snap.Internal.Http.Types import Snap.Iteratee hiding (map) import qualified Snap.Iteratee as I +import qualified Snap.Test as Test import Snap.Test.Common import qualified Snap.Types.Headers as H @@ -373,9 +374,9 @@ testHttpResponse1 :: Test testHttpResponse1 = testCase "server/HttpResponse1" $ do buf <- allocBuffer 16384 - + req <- Test.buildRequest $ return () b <- run_ $ rsm $ - sendResponse rsp1 buf copyingStream2Stream testOnSendFile >>= + sendResponse req rsp1 buf copyingStream2Stream testOnSendFile >>= return . snd assertBool "http response" (b == text1 || b == text2) @@ -424,8 +425,9 @@ testHttpResponse2 :: Test testHttpResponse2 = testCase "server/HttpResponse2" $ do buf <- allocBuffer 16384 + req <- Test.buildRequest $ return () b2 <- liftM (S.concat . L.toChunks) $ run_ $ rsm $ - sendResponse rsp2 buf copyingStream2Stream testOnSendFile >>= + sendResponse req rsp2 buf copyingStream2Stream testOnSendFile >>= return . snd assertBool "http prefix" @@ -454,9 +456,9 @@ testHttpResponse3 :: Test testHttpResponse3 = testCase "server/HttpResponse3" $ do buf <- allocBuffer 16384 - + req <- Test.buildRequest $ return () b3 <- run_ $ rsm $ - sendResponse rsp3 buf copyingStream2Stream testOnSendFile >>= + sendResponse req rsp3 buf copyingStream2Stream testOnSendFile >>= return . snd let lns = LC.lines b3 @@ -497,9 +499,9 @@ testHttpResponse4 :: Test testHttpResponse4 = testCase "server/HttpResponse4" $ do buf <- allocBuffer 16384 - + req <- Test.buildRequest $ return () b <- run_ $ rsm $ - sendResponse rsp1 buf copyingStream2Stream testOnSendFile >>= + sendResponse req rsp1 buf copyingStream2Stream testOnSendFile >>= return . snd assertEqual "http response" (L.concat [ @@ -516,8 +518,9 @@ testHttpResponseCookies :: Test testHttpResponseCookies = testCase "server/HttpResponseCookies" $ do buf <- allocBuffer 16384 + req <- Test.buildRequest $ return () b <- run_ $ rsm $ - sendResponse rsp2 buf copyingStream2Stream testOnSendFile >>= + sendResponse req rsp2 buf copyingStream2Stream testOnSendFile >>= return . snd let lns = LC.lines b diff --git a/test/suite/Test/Blackbox.hs b/test/suite/Test/Blackbox.hs --- a/test/suite/Test/Blackbox.hs +++ b/test/suite/Test/Blackbox.hs @@ -62,6 +62,7 @@ , testTimeoutTickle , testTimeoutBadTickle , testServerHeader + , testChunkedHead ] @@ -289,6 +290,26 @@ N.sendAll sock "." waitabit loris sock + + +------------------------------------------------------------------------------ +testChunkedHead :: Bool -> Int -> String -> Test +testChunkedHead ssl port name = testCase (name ++ "blackbox/chunkedHead") $ + if ssl then return () else withSock port go + where + go sock = do + N.sendAll sock $ "HEAD /chunked HTTP/1.1\r\n\r\n" + s <- N.recv sock 4096 + assertBool "no body" $ isOK s + + split x l | S.null x = reverse l + | otherwise = let (a, b) = S.break (== '\r') x + b' = S.drop 2 b + in split b' (a : l) + + isOK s = let lns = split s [] + lns' = Prelude.drop 1 $ dropWhile (not . S.null) lns + in null lns' ------------------------------------------------------------------------------