warp 3.3.15 → 3.3.16
raw patch · 25 files changed
+97/−90 lines, 25 filesdep +unliftiodep −lifted-basedep ~asyncdep ~base
Dependencies added: unliftio
Dependencies removed: lifted-base
Dependency ranges changed: async, base
Files
- ChangeLog.md +6/−0
- Network/Wai/Handler/Warp.hs +1/−1
- Network/Wai/Handler/Warp/Conduit.hs +1/−1
- Network/Wai/Handler/Warp/FdCache.hs +1/−1
- Network/Wai/Handler/Warp/FileInfoCache.hs +9/−8
- Network/Wai/Handler/Warp/HTTP1.hs +6/−5
- Network/Wai/Handler/Warp/HTTP2.hs +3/−8
- Network/Wai/Handler/Warp/HTTP2/PushPromise.hs +3/−3
- Network/Wai/Handler/Warp/HTTP2/Response.hs +3/−3
- Network/Wai/Handler/Warp/Recv.hs +6/−6
- Network/Wai/Handler/Warp/Request.hs +1/−1
- Network/Wai/Handler/Warp/RequestHeader.hs +1/−1
- Network/Wai/Handler/Warp/Response.hs +3/−3
- Network/Wai/Handler/Warp/Run.hs +16/−14
- Network/Wai/Handler/Warp/SendFile.hs +2/−2
- Network/Wai/Handler/Warp/Settings.hs +2/−2
- Network/Wai/Handler/Warp/Types.hs +4/−4
- Network/Wai/Handler/Warp/Windows.hs +5/−4
- Network/Wai/Handler/Warp/WithApplication.hs +6/−6
- bench/Parser.hs +4/−4
- test/ExceptionSpec.hs +2/−2
- test/RunSpec.hs +2/−2
- test/SendFileSpec.hs +1/−1
- test/WithApplicationSpec.hs +4/−4
- warp.cabal +5/−4
ChangeLog.md view
@@ -1,3 +1,9 @@+# ChangeLog for warp++## 3.3.16++* Move exception handling over to `unliftio` for better async exception support [#845](https://github.com/yesodweb/wai/issues/845)+ ## 3.3.15 * Using http2 v3.
Network/Wai/Handler/Warp.hs view
@@ -125,7 +125,7 @@ , defaultPushPromise ) where -import Control.Exception (SomeException, throwIO)+import UnliftIO.Exception (SomeException, throwIO) import Data.Streaming.Network (HostPreference) import qualified Data.Vault.Lazy as Vault import Data.X509
Network/Wai/Handler/Warp/Conduit.hs view
@@ -2,7 +2,7 @@ module Network.Wai.Handler.Warp.Conduit where -import Control.Exception+import UnliftIO (assert, throwIO) import qualified Data.ByteString as S import qualified Data.IORef as I
Network/Wai/Handler/Warp/FdCache.hs view
@@ -14,7 +14,7 @@ ) where #ifndef WINDOWS-import Control.Exception (bracket)+import UnliftIO.Exception (bracket) import Control.Reaper import Data.IORef import Network.Wai.Handler.Warp.MultiMap as MM
Network/Wai/Handler/Warp/FileInfoCache.hs view
@@ -6,7 +6,7 @@ , getInfo -- test purpose only ) where -import Control.Exception as E+import qualified UnliftIO (onException, bracket, throwIO) import Control.Reaper import Network.HTTP.Date import System.PosixCompat.Files@@ -49,7 +49,7 @@ } return info else- throwIO (userError "FileInfoCache:getInfo")+ UnliftIO.throwIO (userError "FileInfoCache:getInfo") getInfoNaive :: FilePath -> IO FileInfo getInfoNaive = getInfo@@ -60,10 +60,10 @@ getAndRegisterInfo reaper@Reaper{..} path = do cache <- reaperRead case M.lookup path cache of- Just Negative -> throwIO (userError "FileInfoCache:getAndRegisterInfo")+ Just Negative -> UnliftIO.throwIO (userError "FileInfoCache:getAndRegisterInfo") Just (Positive x) -> return x Nothing -> positive reaper path- `E.onException` negative reaper path+ `UnliftIO.onException` negative reaper path positive :: FileInfoCache -> FilePath -> IO FileInfo positive Reaper{..} path = do@@ -74,7 +74,7 @@ negative :: FileInfoCache -> FilePath -> IO FileInfo negative Reaper{..} path = do reaperAdd (path, Negative)- throwIO (userError "FileInfoCache:negative")+ UnliftIO.throwIO (userError "FileInfoCache:negative") ---------------------------------------------------------------- @@ -86,9 +86,10 @@ -> IO a withFileInfoCache 0 action = action getInfoNaive withFileInfoCache duration action =- E.bracket (initialize duration)- terminate- (action . getAndRegisterInfo)+ UnliftIO.bracket+ (initialize duration)+ terminate+ (action . getAndRegisterInfo) initialize :: Int -> IO FileInfoCache initialize duration = mkReaper settings
Network/Wai/Handler/Warp/HTTP1.hs view
@@ -10,7 +10,8 @@ import "iproute" Data.IP (toHostAddress, toHostAddress6) import qualified Control.Concurrent as Conc (yield)-import Control.Exception as E+import qualified UnliftIO+import UnliftIO (SomeException, fromException, throwIO) import qualified Data.ByteString as BS import Data.Char (chr) import Data.IORef (IORef, newIORef, readIORef, writeIORef)@@ -84,7 +85,7 @@ http1server :: Settings -> InternalInfo -> Connection -> Transport -> Application -> SockAddr -> T.Handle -> IORef Bool -> Source -> IO () http1server settings ii conn transport app addr th istatus src =- loop True `E.catch` handler+ loop True `UnliftIO.catchAny` handler where handler e -- See comment below referencing@@ -99,7 +100,7 @@ loop firstRequest = do (req, mremainingRef, idxhdr, nextBodyFlush) <- recvRequest firstRequest settings conn ii th addr src transport keepAlive <- processRequest settings ii conn app th istatus src req mremainingRef idxhdr nextBodyFlush- `E.catch` \e -> do+ `UnliftIO.catchAny` \e -> do settingsOnException settings (Just req) e -- Don't throw the error again to prevent calling settingsOnException twice. return False@@ -124,7 +125,7 @@ -- creating the request, we need to make sure that we don't get -- an async exception before calling the ResponseSource. keepAliveRef <- newIORef $ error "keepAliveRef not filled"- r <- E.try $ app req $ \res -> do+ r <- UnliftIO.tryAny $ app req $ \res -> do T.resume th -- FIXME consider forcing evaluation of the res here to -- send more meaningful error messages to the user.@@ -135,7 +136,7 @@ return ResponseReceived case r of Right ResponseReceived -> return ()- Left e@(SomeException _)+ Left (e :: SomeException) | Just (ExceptionInsideResponseBody e') <- fromException e -> throwIO e' | otherwise -> do keepAlive <- sendErrorResponse settings ii conn th istatus req e
Network/Wai/Handler/Warp/HTTP2.hs view
@@ -9,7 +9,7 @@ , http2server ) where -import qualified Control.Exception as E+import qualified UnliftIO import qualified Data.ByteString as BS import Data.IORef (IORef, newIORef, writeIORef) import qualified Data.IORef as I@@ -73,7 +73,7 @@ http2server settings ii transport addr app h2req0 aux0 response = do req <- toWAIRequest h2req0 aux0 ref <- I.newIORef Nothing- eResponseReceived <- E.try $ app req $ \rsp -> do+ eResponseReceived <- UnliftIO.tryAny $ app req $ \rsp -> do (h2rsp,st,hasBody) <- fromResponse settings ii req rsp pps <- if hasBody then fromPushPromises ii req else return [] I.writeIORef ref $ Just (h2rsp, pps, st)@@ -85,12 +85,7 @@ let msiz = fromIntegral <$> H2.responseBodySize h2rsp logResponse req st msiz mapM_ (logPushPromise req) pps- Left e@(E.SomeException _)- -- killed by the local worker manager- | Just E.ThreadKilled <- E.fromException e -> return ()- -- killed by the local timeout manager- | Just T.TimeoutThread <- E.fromException e -> return ()- | otherwise -> do+ Left e -> do S.settingsOnException settings (Just req) e let ersp = S.settingsOnExceptionResponse settings e st = responseStatus ersp
Network/Wai/Handler/Warp/HTTP2/PushPromise.hs view
@@ -4,7 +4,7 @@ module Network.Wai.Handler.Warp.HTTP2.PushPromise where -import qualified Control.Exception as E+import qualified UnliftIO import qualified Network.HTTP.Types as H import qualified Network.HTTP2.Server as H2 @@ -25,9 +25,9 @@ fromPushPromise :: InternalInfo -> PushPromise -> IO (Maybe H2.PushPromise) fromPushPromise ii (PushPromise path file rsphdr w) = do- efinfo <- E.try $ getFileInfo ii file+ efinfo <- UnliftIO.tryIO $ getFileInfo ii file case efinfo of- Left (_ex :: E.IOException) -> return Nothing+ Left (_ex :: UnliftIO.IOException) -> return Nothing Right finfo -> do let !siz = fromIntegral $ fileInfoSize finfo !fileSpec = H2.FileSpec file 0 siz
Network/Wai/Handler/Warp/HTTP2/Response.hs view
@@ -7,7 +7,7 @@ fromResponse ) where -import qualified Control.Exception as E+import qualified UnliftIO import qualified Data.ByteString.Builder as BB import qualified Network.HTTP.Types as H import qualified Network.HTTP2.Server as H2@@ -69,9 +69,9 @@ !fileSpec = H2.FileSpec path off' bytes' responseFile _ rsphdr isHead path Nothing ii reqhdr = do- efinfo <- E.try $ getFileInfo ii path+ efinfo <- UnliftIO.tryIO $ getFileInfo ii path case efinfo of- Left (_ex :: E.IOException) -> return $ response404 rsphdr+ Left (_ex :: UnliftIO.IOException) -> return $ response404 rsphdr Right finfo -> do let reqidx = indexRequestHeader reqhdr rspidx = indexResponseHeader rsphdr
Network/Wai/Handler/Warp/Recv.hs view
@@ -9,7 +9,7 @@ , spell ) where -import qualified Control.Exception as E+import qualified UnliftIO import qualified Data.ByteString as BS import Data.IORef import Foreign.C.Error (eAGAIN, getErrno, throwErrno)@@ -55,13 +55,13 @@ return $ receiveN ref (receive s pool) (receiveBuf s) receiveN :: IORef ByteString -> Recv -> RecvBuf -> BufSize -> IO ByteString-receiveN ref recv recvBuf size = E.handle handler $ do+receiveN ref recv recvBuf size = UnliftIO.handleAny handler $ do cached <- readIORef ref (bs, leftover) <- spell cached size recv recvBuf writeIORef ref leftover return bs where- handler :: E.SomeException -> IO ByteString+ handler :: UnliftIO.SomeException -> IO ByteString handler _ = return "" ----------------------------------------------------------------@@ -100,7 +100,7 @@ -- In that case, an error of "Bad file descriptor" occurs. -- We ignores it because we expect TimeoutThread. receive :: Socket -> BufferPool -> Recv-receive sock pool = E.handle handler $ withBufferPool pool $ \ (ptr, size) -> do+receive sock pool = UnliftIO.handleIO handler $ withBufferPool pool $ \ (ptr, size) -> do #if MIN_VERSION_network(3,1,0) withFdSocket sock $ \fd -> do #elif MIN_VERSION_network(3,0,0)@@ -111,10 +111,10 @@ let size' = fromIntegral size fromIntegral <$> receiveloop fd ptr size' where- handler :: E.IOException -> IO ByteString+ handler :: UnliftIO.IOException -> IO ByteString handler e | E.ioeGetErrorType e == E.InvalidArgument = return ""- | otherwise = E.throwIO e+ | otherwise = UnliftIO.throwIO e receiveBuf :: Socket -> RecvBuf receiveBuf sock buf0 siz0 = do
Network/Wai/Handler/Warp/Request.hs view
@@ -14,7 +14,7 @@ ) where import qualified Control.Concurrent as Conc (yield)-import Control.Exception (throwIO, Exception)+import UnliftIO (throwIO, Exception) import Data.Array ((!)) import qualified Data.ByteString as S import qualified Data.ByteString.Unsafe as SU
Network/Wai/Handler/Warp/RequestHeader.hs view
@@ -4,7 +4,7 @@ parseHeaderLines ) where -import Control.Exception (throwIO)+import UnliftIO (throwIO) import qualified Data.ByteString as S import qualified Data.ByteString.Char8 as C8 (unpack) import Data.ByteString.Internal (memchr)
Network/Wai/Handler/Warp/Response.hs view
@@ -15,7 +15,7 @@ ) where import Data.ByteString.Builder.HTTP.Chunked (chunkedTransferEncoding, chunkedTransferTerminator)-import qualified Control.Exception as E+import qualified UnliftIO import Data.Array ((!)) import qualified Data.ByteString as S import Data.ByteString.Builder (byteString, Builder)@@ -275,9 +275,9 @@ -- Simple WAI applications. -- Status is ignored sendRsp conn ii th ver _ hs0 rspidxhdr (RspFile path Nothing reqidxhdr isHead hook) = do- efinfo <- E.try $ getFileInfo ii path+ efinfo <- UnliftIO.tryIO $ getFileInfo ii path case efinfo of- Left (_ex :: E.IOException) ->+ Left (_ex :: UnliftIO.IOException) -> #ifdef WARP_DEBUG print _ex >> #endif
Network/Wai/Handler/Warp/Run.hs view
@@ -8,7 +8,9 @@ module Network.Wai.Handler.Warp.Run where import Control.Arrow (first)-import Control.Exception as E+import Control.Exception (allowInterrupt)+import qualified UnliftIO+import UnliftIO (toException) import qualified Data.ByteString as S import Data.IORef (newIORef, readIORef) import Data.Streaming.Network (bindPortTCP)@@ -69,7 +71,7 @@ if tm == 0 then close s else- gracefulClose s tm `E.catch` \(E.SomeException _) -> return ()+ gracefulClose s tm `UnliftIO.catchAny` \(UnliftIO.SomeException _) -> return () #else , connClose = close s #endif@@ -81,11 +83,11 @@ , connHTTP2 = isH2 } where- sendAll' sock bs = E.handleJust+ sendAll' sock bs = UnliftIO.handleJust (\ e -> if ioeGetErrorType e == ResourceVanished then Just ConnectionClosedByPeer else Nothing)- throwIO+ UnliftIO.throwIO $ Sock.sendAll sock bs -- | Run an 'Application' on the given port.@@ -115,7 +117,7 @@ -- calls 'runSettingsSocket'. runSettings :: Settings -> Application -> IO () runSettings set app = withSocketsDo $- bracket+ UnliftIO.bracket (bindPortTCP (settingsPort set) (settingsHost set)) close (\socket -> do@@ -146,7 +148,7 @@ #endif setSocketCloseOnExec s -- NoDelay causes an error for AF_UNIX.- setSocketOption s NoDelay 1 `E.catch` \(E.SomeException _) -> return ()+ setSocketOption s NoDelay 1 `UnliftIO.catchAny` \(UnliftIO.SomeException _) -> return () conn <- socketConnection set s return (conn, sa) @@ -207,7 +209,7 @@ !timeoutInSeconds = settingsTimeout set * 1000000 withTimeoutManager f = case settingsManager set of Just tm -> f tm- Nothing -> bracket+ Nothing -> UnliftIO.bracket (T.initialize timeoutInSeconds) T.stopManager f@@ -237,7 +239,7 @@ -- acceptNewConnection and the registering of connClose. -- -- acceptLoop can be broken by closing the listening socket.- void $ mask_ acceptLoop+ void $ UnliftIO.mask_ acceptLoop -- In some cases, we want to stop Warp here without graceful shutdown. -- So, async exceptions are allowed here. -- That's why `finally` is not used.@@ -262,7 +264,7 @@ acceptLoop acceptNewConnection = do- ex <- try getConnMaker+ ex <- UnliftIO.tryIO getConnMaker case ex of Right x -> return $ Just x Left e -> do@@ -286,7 +288,7 @@ fork set mkConn addr app counter ii = settingsFork set $ \unmask -> -- Call the user-supplied on exception code if any -- exceptions are thrown.- handle (settingsOnException set Nothing) $+ UnliftIO.handleAny (settingsOnException set Nothing) $ -- Run the connection maker to get a new connection, and ensure -- that the connection is closed. If the mkConn call throws an -- exception, we will leak the connection. If the mkConn call is@@ -297,20 +299,20 @@ -- 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 cleanUp (serve unmask)+ UnliftIO.bracket mkConn cleanUp (serve unmask) where- cleanUp (conn, _) = connClose conn `finally` connFree conn+ cleanUp (conn, _) = connClose conn `UnliftIO.finally` connFree conn -- We need to register a timeout handler for this thread, and -- cancel that handler as soon as we exit.- serve unmask (conn, transport) = bracket register cancel $ \th -> do+ serve unmask (conn, transport) = UnliftIO.bracket register cancel $ \th -> do -- We now have fully registered a connection close handler in -- the case of all exceptions, so it is safe to once again -- allow async exceptions. unmask . -- Call the user-supplied code for connection open and -- close events- bracket (onOpen addr) (onClose addr) $ \goingon ->+ UnliftIO.bracket (onOpen addr) (onClose addr) $ \goingon -> -- Actually serve this connection. bracket with closeConn -- above ensures the connection is closed. when goingon $ serveConnection conn ii th addr transport set app
Network/Wai/Handler/Warp/SendFile.hs view
@@ -17,7 +17,7 @@ import Foreign.Ptr (plusPtr) import qualified System.IO as IO #else-import Control.Exception+import qualified UnliftIO import Foreign.C.Error (throwErrno) import Foreign.C.Types import Foreign.Ptr (Ptr, castPtr, plusPtr)@@ -112,7 +112,7 @@ #else readSendFile :: Buffer -> BufSize -> (ByteString -> IO ()) -> SendFile readSendFile buf siz send fid off0 len0 hook headers =- bracket setup teardown $ \fd -> do+ UnliftIO.bracket setup teardown $ \fd -> do hn <- packHeader buf siz send hook headers 0 let room = siz - hn buf' = buf `plusPtr` hn
Network/Wai/Handler/Warp/Settings.hs view
@@ -5,7 +5,7 @@ module Network.Wai.Handler.Warp.Settings where import Control.Concurrent (forkIOWithUnmask)-import Control.Exception+import UnliftIO (SomeException, fromException) import qualified Data.ByteString.Char8 as C8 import qualified Data.ByteString.Builder as Builder import Data.ByteString.Lazy (fromStrict)@@ -13,7 +13,7 @@ import qualified Data.Text as T import qualified Data.Text.IO as TIO import Data.Version (showVersion)-import GHC.IO.Exception (IOErrorType(..))+import GHC.IO.Exception (IOErrorType(..), AsyncException (ThreadKilled)) import qualified Network.HTTP.Types as H import Network.HTTP2.Frame (HTTP2Error (..), ErrorCodeId (..)) import Network.Socket (SockAddr)
Network/Wai/Handler/Warp/Types.hs view
@@ -4,7 +4,7 @@ module Network.Wai.Handler.Warp.Types where -import Control.Exception+import qualified UnliftIO import qualified Data.ByteString as S import Data.IORef (IORef, readIORef, writeIORef, newIORef) import Data.Typeable (Typeable)@@ -49,7 +49,7 @@ show OverLargeHeader = "Warp: Request headers too large, possible memory attack detected. Closing connection." show (BadProxyHeader s) = "Warp: Invalid PROXY protocol header: " ++ show s -instance Exception InvalidRequest+instance UnliftIO.Exception InvalidRequest ---------------------------------------------------------------- @@ -60,10 +60,10 @@ -- Used to determine whether keeping the HTTP1.1 connection / HTTP2 stream alive is safe -- or irrecoverable. -newtype ExceptionInsideResponseBody = ExceptionInsideResponseBody SomeException+newtype ExceptionInsideResponseBody = ExceptionInsideResponseBody UnliftIO.SomeException deriving (Show, Typeable) -instance Exception ExceptionInsideResponseBody+instance UnliftIO.Exception ExceptionInsideResponseBody ----------------------------------------------------------------
Network/Wai/Handler/Warp/Windows.hs view
@@ -4,9 +4,9 @@ ) where #if WINDOWS-import Control.Exception import Control.Concurrent.MVar import Control.Concurrent+import qualified Control.Exception import Network.Wai.Handler.Warp.Imports @@ -15,11 +15,12 @@ -- @since 3.2.17 windowsThreadBlockHack :: IO a -> IO a windowsThreadBlockHack act = do- var <- newEmptyMVar :: IO (MVar (Either SomeException a))- void . forkIO $ try act >>= putMVar var+ var <- newEmptyMVar :: IO (MVar (Either Control.Exception.SomeException a))+ -- Catch and rethrow even async exceptions, so don't bother with UnliftIO+ void . forkIO $ Control.Exception.try act >>= putMVar var res <- takeMVar var case res of- Left e -> throwIO e+ Left e -> Control.Exception.throwIO e Right r -> return r #else windowsThreadBlockHack :: IO a -> IO a
Network/Wai/Handler/Warp/WithApplication.hs view
@@ -9,8 +9,8 @@ ) where import Control.Concurrent-import Control.Concurrent.Async-import Control.Exception+import qualified UnliftIO+import UnliftIO.Async import Control.Monad (when) import Data.Streaming.Network (bindRandomPortTCP) import Network.Socket@@ -45,7 +45,7 @@ (runSettingsSocket settings sock app) (waitFor started >> action port) case result of- Left () -> throwIO $ ErrorCall "Unexpected: runSettingsSocket exited"+ Left () -> UnliftIO.throwString "Unexpected: runSettingsSocket exited" Right x -> return x -- | Same as 'withApplication' but with different exception handling: If the@@ -72,11 +72,11 @@ callingThread <- myThreadId app <- mkApp let wrappedApp request respond =- app request respond `catch` \ e -> do+ app request respond `UnliftIO.catchAny` \ e -> do when (defaultShouldDisplayException e) (throwTo callingThread e)- throwIO e+ UnliftIO.throwIO e withApplicationSettings settings (return wrappedApp) action data Waiter a@@ -101,4 +101,4 @@ -- | Like 'openFreePort' but closes the socket before exiting. withFreePort :: ((Port, Socket) -> IO a) -> IO a-withFreePort = bracket openFreePort (close . snd)+withFreePort = UnliftIO.bracket openFreePort (close . snd)
bench/Parser.hs view
@@ -4,7 +4,6 @@ module Main where -import Control.Exception (throwIO, throw) import Control.Monad import qualified Data.ByteString as S --import Data.ByteString.Char8 (ByteString)@@ -12,6 +11,7 @@ import qualified Network.HTTP.Types as H import Network.Wai.Handler.Warp.Types import Prelude hiding (lines)+import UnliftIO.Exception (throwIO, impureThrow) import Data.ByteString.Internal import Data.Word@@ -70,14 +70,14 @@ where (!method,!rest) = S.break (== 32) requestLine -- ' ' (!pathQuery,!httpVer')- | rest == "" = throw badmsg+ | rest == "" = impureThrow badmsg | otherwise = S.break (== 32) (S.drop 1 rest) -- ' ' (!path,!query) = S.break (== 63) pathQuery -- '?' !httpVer = S.drop 1 httpVer' (!http,!ver)- | httpVer == "" = throw badmsg+ | httpVer == "" = impureThrow badmsg | otherwise = S.break (== 47) httpVer -- '/'- !hv | http /= "HTTP" = throw NonHttp+ !hv | http /= "HTTP" = impureThrow NonHttp | ver == "/1.1" = H.http11 | otherwise = H.http10 !ret = (method,path,query,hv)
test/ExceptionSpec.hs view
@@ -11,9 +11,9 @@ import Network.Wai.Internal (Request(..)) import Network.Wai.Handler.Warp import Test.Hspec-import Control.Exception+import UnliftIO.Exception import qualified Data.Streaming.Network as N-import Control.Concurrent.Async (withAsync)+import UnliftIO.Async (withAsync) import Network.Socket (close) import HTTP
test/RunSpec.hs view
@@ -6,8 +6,8 @@ import Control.Concurrent (forkIO, killThread, threadDelay) import Control.Concurrent.MVar (newEmptyMVar, takeMVar, putMVar) import Control.Concurrent.STM-import qualified Control.Exception as E-import Control.Exception.Lifted (bracket, try, IOException, onException)+import qualified UnliftIO.Exception as E+import UnliftIO.Exception (bracket, try, IOException, onException) import Control.Monad (forM_, replicateM_, unless) import Control.Monad.IO.Class (MonadIO, liftIO) import Data.ByteString (ByteString)
test/SendFileSpec.hs view
@@ -2,7 +2,6 @@ module SendFileSpec where -import Control.Exception import Control.Monad (when) import Data.ByteString (ByteString) import qualified Data.ByteString as BS@@ -14,6 +13,7 @@ import qualified System.IO as IO import System.Process (system) import Test.Hspec+import UnliftIO.Exception main :: IO () main = hspec spec
test/WithApplicationSpec.hs view
@@ -2,12 +2,12 @@ module WithApplicationSpec where -import Control.Exception import Network.HTTP.Types import Network.Wai import System.Environment import System.Process import Test.Hspec+import UnliftIO.Exception import Network.Wai.Handler.Warp.WithApplication @@ -24,17 +24,17 @@ output `shouldBe` "foo" it "does not propagate exceptions from the server to the executing thread" $ do- let mkApp = return $ \ _request _respond -> throwIO $ ErrorCall "foo"+ let mkApp = return $ \ _request _respond -> throwString "foo" withApplication mkApp $ \ port -> do output <- readProcess "curl" ["-s", "localhost:" ++ show port] "" output `shouldContain` "Something went wron" describe "testWithApplication" $ do it "propagates exceptions from the server to the executing thread" $ do- let mkApp = return $ \ _request _respond -> throwIO $ ErrorCall "foo"+ let mkApp = return $ \ _request _respond -> throwString "foo" (testWithApplication mkApp $ \ port -> do readProcess "curl" ["-s", "localhost:" ++ show port] "")- `shouldThrow` (errorCall "foo")+ `shouldThrow` (\(StringException str _) -> str == "foo") {- The future netwrok library will not export MkSocket. describe "withFreePort" $ do
warp.cabal view
@@ -1,5 +1,5 @@ Name: warp-Version: 3.3.15+Version: 3.3.16 Synopsis: A fast, light-weight web server for WAI applications. License: MIT License-file: LICENSE@@ -33,9 +33,8 @@ Default: False Library- Build-Depends: base >= 4.10 && < 5+ Build-Depends: base >= 4.12 && < 5 , array- , async , auto-update >= 0.1.3 && < 0.2 , bsb-http-chunked < 0.1 , bytestring >= 0.9.1.4@@ -57,6 +56,7 @@ , wai >= 3.2 && < 3.3 , word8 , x509+ , unliftio if impl(ghc < 8) Build-Depends: semigroups if flag(network-bytestring)@@ -201,7 +201,6 @@ , http-types >= 0.12 , http2 >= 3.0 && < 3.1 , iproute >= 1.3.1- , lifted-base >= 0.1 , network , process , simple-sendfile >= 0.2.4 && < 0.3@@ -215,6 +214,7 @@ , wai >= 3.2 && < 3.3 , word8 , x509+ , unliftio -- Build-Tool-Depends: hspec-discover:hspec-discover if impl(ghc < 8) Build-Depends: semigroups@@ -254,6 +254,7 @@ , time-manager , unix-compat , x509+ , unliftio if impl(ghc < 8) Build-Depends: semigroups