diff --git a/Network/Wai/Handler/Warp.hs b/Network/Wai/Handler/Warp.hs --- a/Network/Wai/Handler/Warp.hs +++ b/Network/Wai/Handler/Warp.hs @@ -23,6 +23,7 @@ , runSettingsSocket , runSettingsConnection , runSettingsConnectionMaker + , runSettingsConnectionMakerSecure -- * Settings , Settings , defaultSettings diff --git a/Network/Wai/Handler/Warp/Request.hs b/Network/Wai/Handler/Warp/Request.hs --- a/Network/Wai/Handler/Warp/Request.hs +++ b/Network/Wai/Handler/Warp/Request.hs @@ -216,8 +216,8 @@ status = THStatus len' lines' id in if start < bsLen then -- more bytes in this chunk, push again - let bs' = SU.unsafeDrop start bs - in push status bs' + let bs'' = SU.unsafeDrop start bs + in push status bs'' else -- no more bytes in this chunk, ask for more await >>= maybe close (push status) diff --git a/Network/Wai/Handler/Warp/Response.hs b/Network/Wai/Handler/Warp/Response.hs --- a/Network/Wai/Handler/Warp/Response.hs +++ b/Network/Wai/Handler/Warp/Response.hs @@ -215,7 +215,7 @@ where hs = addAcceptRanges hs0 s2 = H.status404 - hs2 = replaceHeader H.hContentType "text/plain" hs0 + hs2 = replaceHeader H.hContentType "text/plain; charset=utf-8" hs0 body = fromByteString "File not found" ---------------------------------------------------------------- diff --git a/Network/Wai/Handler/Warp/Run.hs b/Network/Wai/Handler/Warp/Run.hs --- a/Network/Wai/Handler/Warp/Run.hs +++ b/Network/Wai/Handler/Warp/Run.hs @@ -1,6 +1,7 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} {-# OPTIONS_GHC -fno-warn-deprecations #-} module Network.Wai.Handler.Warp.Run where @@ -124,10 +125,18 @@ (conn, sa) <- getConn return (return conn, sa) +runSettingsConnectionMaker :: Settings -> IO (IO Connection, SockAddr) -> Application -> IO () +runSettingsConnectionMaker x y = + runSettingsConnectionMakerSecure x (go y) + where + go = fmap (\(a, b) -> (fmap (, False) a, b)) + -- | Allows you to provide a function which will return a function -- which will return 'Connection'. -runSettingsConnectionMaker :: Settings -> IO (IO Connection, SockAddr) -> Application -> IO () -runSettingsConnectionMaker set getConnMaker app = do +-- +-- Since 2.1.4 +runSettingsConnectionMakerSecure :: Settings -> IO (IO (Connection, Bool), SockAddr) -> Application -> IO () +runSettingsConnectionMakerSecure set getConnMaker app = do settingsBeforeMainLoop set -- Note that there is a thorough discussion of the exception safety of the @@ -175,7 +184,7 @@ -- We grab the connection before registering timeouts since the -- timeouts will be useless during connection creation, due to the -- fact that async exceptions are still masked. - bracket mkConn connClose $ \conn' -> + bracket mkConn (connClose . fst) $ \(conn', isSecure') -> -- We need to register a timeout handler for this thread, and -- cancel that handler as soon as we exit. @@ -195,7 +204,7 @@ -- Actually serve this connection. -- onnClose above ensures the termination of the connection. - when goingon $ serveConnection conn ii addr set app + when goingon $ serveConnection conn ii addr isSecure' set app where -- FIXME: only IOEception is caught. What about other exceptions? getConnLoop = getConnMaker `E.catch` \(e :: IOException) -> do @@ -222,10 +231,11 @@ serveConnection :: Connection -> InternalInfo -> SockAddr + -> Bool -- ^ is secure? -> Settings -> Application -> IO () -serveConnection conn ii addr settings app = do +serveConnection conn ii addr isSecure' settings app = do istatus <- newIORef False recvSendLoop istatus (connSource conn th istatus) `E.catch` \e -> do sendErrorResponse istatus e @@ -244,7 +254,8 @@ errorResponse e = settingsOnExceptionResponse settings e recvSendLoop istatus fromClient = do - (req, idxhdr, getSource, leftover') <- recvRequest settings conn ii addr fromClient + (req', idxhdr, getSource, leftover') <- recvRequest settings conn ii addr fromClient + let req = req' { isSecure = isSecure' } intercept' <- settingsIntercept settings req case intercept' of Nothing -> do diff --git a/Network/Wai/Handler/Warp/Settings.hs b/Network/Wai/Handler/Warp/Settings.hs --- a/Network/Wai/Handler/Warp/Settings.hs +++ b/Network/Wai/Handler/Warp/Settings.hs @@ -1,4 +1,5 @@ {-# LANGUAGE OverloadedStrings, ScopedTypeVariables, ViewPatterns #-} +{-# LANGUAGE PatternGuards #-} module Network.Wai.Handler.Warp.Settings where @@ -7,7 +8,6 @@ import qualified Data.ByteString as S import qualified Data.Text as T import qualified Data.Text.IO as TIO -import qualified Data.ByteString.Lazy.Char8 as L8 import Data.Conduit import Data.Conduit.Network (HostPreference) import GHC.IO.Exception (IOErrorType(..)) @@ -16,8 +16,10 @@ import Network.Wai import Network.Wai.Handler.Warp.Timeout import Network.Wai.Handler.Warp.Types -import System.IO (hPrint, stderr) +import System.IO (stderr) import System.IO.Error (ioeGetErrorType) +import qualified Data.Text.Lazy as TL +import qualified Data.Text.Lazy.Encoding as TLE -- | Various Warp server settings. This is purposely kept as an abstract data -- type so that new settings can be added without breaking backwards @@ -97,11 +99,11 @@ $ TIO.hPutStrLn stderr $ T.pack $ show e defaultExceptionResponse :: SomeException -> Response -defaultExceptionResponse _ = responseLBS H.internalServerError500 [(H.hContentType, "text/plain")] "Something went wrong" +defaultExceptionResponse _ = responseLBS H.internalServerError500 [(H.hContentType, "text/plain; charset=utf-8")] "Something went wrong" -- | Default implementation of 'settingsOnExceptionResponse' for the debugging purpose. 500, text/plain, a showed exception. exceptionResponseForDebug :: SomeException -> Response -exceptionResponseForDebug e = responseLBS H.internalServerError500 [(H.hContentType, "text/plain")] (L8.pack $ "Exception: " ++ show e) +exceptionResponseForDebug e = responseLBS H.internalServerError500 [(H.hContentType, "text/plain; charset=utf-8")] (TLE.encodeUtf8 $ TL.pack $ "Exception: " ++ show e) {-# DEPRECATED settingsPort "Use setPort instead" #-} {-# DEPRECATED settingsHost "Use setHost instead" #-} diff --git a/test/ExceptionSpec.hs b/test/ExceptionSpec.hs --- a/test/ExceptionSpec.hs +++ b/test/ExceptionSpec.hs @@ -13,13 +13,21 @@ import Network.Wai.Handler.Warp import System.IO.Unsafe (unsafePerformIO) import Test.Hspec +import Control.Exception +import qualified Data.Streaming.Network as N +import Control.Concurrent.Async (withAsync) +import Network.Socket (sClose) main :: IO () main = hspec spec -testServer :: IO () -testServer = - run 2345 testApp +withTestServer :: (Int -> IO a) -> IO a +withTestServer inner = bracket + (N.bindRandomPortTCP "*4") + (sClose . snd) + $ \(port, lsocket) -> do + withAsync (runSettingsSocket defaultSettings lsocket testApp) + $ \_ -> inner port testApp :: Application testApp (Network.Wai.Internal.Request {pathInfo = [x]}) @@ -38,8 +46,7 @@ return $ responseLBS ok200 [] "foo" spec :: Spec -spec = unsafePerformIO $ (forkIO testServer >> threadDelay 100000 >>) $ return $ - describe "responds even if there is an exception" $ do +spec = describe "responds even if there is an exception" $ do {- Disabling these tests. We can consider forcing evaluation in Warp. it "statusError" $ do sc <- rspCode <$> sendGET "http://localhost:2345/statusError" @@ -54,8 +61,8 @@ sc <- rspCode <$> sendGET "http://localhost:2345/bodyError" sc `shouldBe` (5,0,0) -} - it "ioException" $ do - sc <- rspCode <$> sendGET "http://localhost:2345/ioException" + it "ioException" $ withTestServer $ \port -> do + sc <- rspCode <$> sendGET (concat $ ["http://localhost:", show port, "/ioException"]) sc `shouldBe` (5,0,0) ---------------------------------------------------------------- diff --git a/test/RequestSpec.hs b/test/RequestSpec.hs --- a/test/RequestSpec.hs +++ b/test/RequestSpec.hs @@ -16,9 +16,6 @@ import qualified Data.ByteString.Lazy as L import qualified Network.HTTP.Types.Header as HH -deriving instance Show HH.ByteRange -deriving instance Eq HH.ByteRange - main :: IO () main = hspec spec diff --git a/warp.cabal b/warp.cabal --- a/warp.cabal +++ b/warp.cabal @@ -1,5 +1,5 @@ Name: warp -Version: 2.1.3.3 +Version: 2.1.4 Synopsis: A fast, light-weight web server for WAI applications. License: MIT License-file: LICENSE @@ -124,7 +124,7 @@ , conduit >= 0.5 , ghc-prim , HTTP - , http-types >= 0.7 + , http-types >= 0.8.4 , lifted-base >= 0.1 , network-conduit , simple-sendfile >= 0.2.4 && < 0.3 @@ -140,7 +140,8 @@ , old-locale , text , conduit-extra - , streaming-commons + , streaming-commons >= 0.1.1 + , async if (os(linux) || os(freebsd) || os(darwin)) && flag(allow-sendfilefd) Cpp-Options: -DSENDFILEFD