snap-server 0.8.1 → 0.8.1.1

raw patch · 4 files changed

+36/−3 lines, 4 files

Files

• snap-server.cabal +1/−1
• src/Snap/Internal/Http/Server.hs +5/−2
• test/common/Test/Common/TestHandler.hs +5/−0
• test/suite/Test/Blackbox.hs +25/−0

@@ -1,5 +1,5 @@ name:           snap-server-version:        0.8.1+version:        0.8.1.1 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

@@ -34,7 +34,7 @@ import           Data.IORef import           Data.List (foldl') import qualified Data.Map as Map-import           Data.Maybe (catMaybes, fromJust, fromMaybe)+import           Data.Maybe (catMaybes, fromJust, fromMaybe, isJust) import           Data.Monoid import           Data.Time import           Data.Typeable@@ -413,8 +413,11 @@                            "sending response"            date <- liftIO getDateString+          let insHeader = H.set "Server" sERVER_HEADER           let ins = H.set "Date" date .-                    H.set "Server" sERVER_HEADER+                    if isJust (getHeader "Server" rsp)+                       then id+                       else insHeader           let rsp' = updateHeaders ins rsp           (bytesSent,_) <- sendResponse req rsp' buffer writeEnd onSendFile                            `catch` errCatch "sending response" req

@@ -185,6 +185,10 @@                             else disallow  +serverHeaderHandler :: Snap ()+serverHeaderHandler = modifyResponse $ setHeader "Server" "foo"++ testHandler :: Snap () testHandler = withCompression $     route [ ("pong"              , pongHandler                       )@@ -198,4 +202,5 @@           , ("upload/handle"     , uploadHandler                     )           , ("timeout/tickle"    , timeoutTickleHandler              )           , ("timeout/badtickle" , badTimeoutTickleHandler           )+          , ("server-header"     , serverHeaderHandler               )           ]

@@ -59,6 +59,7 @@                 , testFileUpload                 , testTimeoutTickle                 , testTimeoutBadTickle+                , testServerHeader                 ]  @@ -398,6 +399,19 @@   ------------------------------------------------------------------------------+fetchResponse :: String -> IO (HTTP.Response)+fetchResponse url = do+    req <- parseURL url `catch` (\(e::SomeException) -> do+               debug $ "parseURL threw exception: " ++ show e+               throwIO e)+    go req `catch` (\(e::SomeException) -> do+                       debug $ "simpleHttp threw exception: " ++ show e+                       throwIO e)+  where+    go req = HTTP.withManager $ HTTP.httpLbs req+++------------------------------------------------------------------------------ fetch :: String -> IO (L.ByteString) fetch url = do     req <- parseURL url `catch` (\(e::SomeException) -> do@@ -442,3 +456,14 @@         let uri = (if ssl then "https" else "http")                   ++ "://127.0.0.1:" ++ show port ++ "/timeout/badtickle"         expectException $ fetch uri+++------------------------------------------------------------------------------+testServerHeader :: Bool -> Int -> String -> Test+testServerHeader ssl port name =+    testCase (name ++ "/blackbox/server-header") $ do+        let uri = (if ssl then "https" else "http")+                  ++ "://127.0.0.1:" ++ show port ++ "/server-header"+        rsp <- fetchResponse uri+        let serverHeader = lookup "server" $ HTTP.responseHeaders rsp+        assertEqual "server header" (Just "foo") serverHeader