snap-server 0.9.4.3 → 0.9.4.4
raw patch · 6 files changed
+104/−68 lines, 6 files
Files
- snap-server.cabal +1/−1
- src/Snap/Internal/Http/Server.hs +55/−50
- test/common/Test/Common/TestHandler.hs +13/−8
- test/snap-server-testsuite.cabal +3/−1
- test/suite/Snap/Internal/Http/Server/Tests.hs +11/−8
- test/suite/Test/Blackbox.hs +21/−0
snap-server.cabal view
@@ -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
src/Snap/Internal/Http/Server.hs view
@@ -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 #-}
test/common/Test/Common/TestHandler.hs view
@@ -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 ) ]
test/snap-server-testsuite.cabal view
@@ -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
test/suite/Snap/Internal/Http/Server/Tests.hs view
@@ -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
test/suite/Test/Blackbox.hs view
@@ -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' ------------------------------------------------------------------------------