From c68dc9990442e0287edda236433436aba262dac3 Mon Sep 17 00:00:00 2001 From: Kazu Yamamoto Date: Wed, 23 Oct 2024 13:17:29 +0900 Subject: [PATCH 1/6] removing unliftio from time-manager --- time-manager/System/TimeManager.hs | 6 +++--- time-manager/time-manager.cabal | 1 - 2 files changed, 3 insertions(+), 4 deletions(-) diff --git a/time-manager/System/TimeManager.hs b/time-manager/System/TimeManager.hs index b3cdd9bf1..5e3a7e097 100644 --- a/time-manager/System/TimeManager.hs +++ b/time-manager/System/TimeManager.hs @@ -1,5 +1,5 @@ -{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveDataTypeable #-} module System.TimeManager ( -- ** Types @@ -29,11 +29,11 @@ module System.TimeManager ( ) where import Control.Concurrent (myThreadId) +import qualified Control.Exception as E import Control.Reaper import Data.IORef (IORef) import qualified Data.IORef as I import Data.Typeable (Typeable) -import qualified UnliftIO.Exception as E ---------------------------------------------------------------- @@ -144,7 +144,7 @@ cancel (Handle mgr _ stateRef) = do | stateRef == stateRef' = hs | otherwise = - let !hs'= filt hs + let !hs' = filt hs in h : hs' -- | Setting the state to paused. diff --git a/time-manager/time-manager.cabal b/time-manager/time-manager.cabal index 616f95604..64547daa3 100644 --- a/time-manager/time-manager.cabal +++ b/time-manager/time-manager.cabal @@ -16,7 +16,6 @@ Extra-Source-Files: ChangeLog.md Library Build-Depends: base >= 4.12 && < 5 , auto-update >= 0.2 && < 0.3 - , unliftio Default-Language: Haskell2010 Exposed-modules: System.TimeManager Ghc-Options: -Wall From 0acc63056ef080ec1baae3490a2bb7a3004dcd26 Mon Sep 17 00:00:00 2001 From: Kazu Yamamoto Date: Wed, 23 Oct 2024 13:23:54 +0900 Subject: [PATCH 2/6] removing unliftio from warp-tls --- warp-tls/Network/Wai/Handler/WarpTLS.hs | 35 ++++++++++++------------- warp-tls/warp-tls.cabal | 1 - 2 files changed, 17 insertions(+), 19 deletions(-) diff --git a/warp-tls/Network/Wai/Handler/WarpTLS.hs b/warp-tls/Network/Wai/Handler/WarpTLS.hs index 3961022dc..580b0d5a0 100644 --- a/warp-tls/Network/Wai/Handler/WarpTLS.hs +++ b/warp-tls/Network/Wai/Handler/WarpTLS.hs @@ -56,6 +56,20 @@ module Network.Wai.Handler.WarpTLS ( ) where import Control.Applicative ((<|>)) +import Control.Concurrent (newEmptyMVar, putMVar, takeMVar, forkIOWithUnmask) +import Control.Exception ( + Exception, + IOException, + SomeException (..), + bracket, + finally, + fromException, + handle, + handleJust, + onException, + throwIO, + try, + ) import Control.Monad (guard, void) import qualified Data.ByteString as S import qualified Data.ByteString.Lazy as L @@ -73,6 +87,7 @@ import Network.Socket ( #endif withSocketsDo, ) +import qualified Control.Exception as E import Network.Socket.BufferPool import Network.Socket.ByteString (sendAll) import qualified Network.TLS as TLS @@ -82,23 +97,7 @@ import Network.Wai.Handler.Warp import Network.Wai.Handler.Warp.Internal import Network.Wai.Handler.WarpTLS.Internal import System.IO.Error (ioeGetErrorType, isEOFError) -import UnliftIO.Exception ( - Exception, - IOException, - SomeException (..), - bracket, - finally, - fromException, - handle, - handleAny, - handleJust, - onException, - throwIO, - try, - ) -import qualified UnliftIO.Exception as E -import UnliftIO.Concurrent (newEmptyMVar, putMVar, takeMVar, forkIOWithUnmask) -import UnliftIO.Timeout (timeout) +import System.Timeout (timeout) ---------------------------------------------------------------- @@ -366,7 +365,7 @@ httpOverTls TLSSettings{..} set s bs0 params = case mconn of Nothing -> throwIO IncompleteHeaders Just conn -> return conn - wrappedRecvN recvN n = handleAny (const mempty) $ recvN n + wrappedRecvN recvN n = handle (\(SomeException _) -> mempty) $ recvN n backend recvN = TLS.Backend { TLS.backendFlush = return () diff --git a/warp-tls/warp-tls.cabal b/warp-tls/warp-tls.cabal index e032265b3..a7f7ecb4a 100644 --- a/warp-tls/warp-tls.cabal +++ b/warp-tls/warp-tls.cabal @@ -26,7 +26,6 @@ Library , network >= 2.2.1 , streaming-commons , tls-session-manager >= 0.0.4 - , unliftio , recv >= 0.1.0 && < 0.2.0 Exposed-modules: Network.Wai.Handler.WarpTLS Network.Wai.Handler.WarpTLS.Internal From 155ad18ee2aeeb8e88ae35d268880a579cf820bb Mon Sep 17 00:00:00 2001 From: Kazu Yamamoto Date: Tue, 29 Oct 2024 14:18:37 +0900 Subject: [PATCH 3/6] removing workaround for unliftio in warp-tls --- warp-tls/Network/Wai/Handler/WarpTLS.hs | 8 ++------ 1 file changed, 2 insertions(+), 6 deletions(-) diff --git a/warp-tls/Network/Wai/Handler/WarpTLS.hs b/warp-tls/Network/Wai/Handler/WarpTLS.hs index 580b0d5a0..418d8f4a8 100644 --- a/warp-tls/Network/Wai/Handler/WarpTLS.hs +++ b/warp-tls/Network/Wai/Handler/WarpTLS.hs @@ -322,12 +322,8 @@ mkConn -> params -> IO (Connection, Transport) mkConn tlsset set s params = do - var <- newEmptyMVar - _ <- forkIOWithUnmask $ \umask -> do - let tm = settingsTimeout set * 1000000 - mct <- umask (timeout tm recvFirstBS) - putMVar var mct - mbs <- takeMVar var + let tm = settingsTimeout set * 1000000 + mbs <- timeout tm recvFirstBS case mbs of Nothing -> throwIO IncompleteHeaders Just bs -> switch bs From 65c9669756de0107505750e908948eb90f4bff90 Mon Sep 17 00:00:00 2001 From: Kazu Yamamoto Date: Tue, 29 Oct 2024 14:18:21 +0900 Subject: [PATCH 4/6] removing unliftio from warp --- warp/Network/Wai/Handler/Warp.hs | 2 +- warp/Network/Wai/Handler/Warp/Conduit.hs | 2 +- warp/Network/Wai/Handler/Warp/FdCache.hs | 2 +- .../Network/Wai/Handler/Warp/FileInfoCache.hs | 12 ++-- warp/Network/Wai/Handler/Warp/HTTP1.hs | 55 +++++++++---------- warp/Network/Wai/Handler/Warp/HTTP2.hs | 15 +++-- .../Wai/Handler/Warp/HTTP2/PushPromise.hs | 6 +- .../Wai/Handler/Warp/HTTP2/Response.hs | 6 +- warp/Network/Wai/Handler/Warp/Request.hs | 2 +- .../Network/Wai/Handler/Warp/RequestHeader.hs | 2 +- warp/Network/Wai/Handler/Warp/Response.hs | 6 +- warp/Network/Wai/Handler/Warp/Run.hs | 43 +++++++-------- warp/Network/Wai/Handler/Warp/SendFile.hs | 4 +- warp/Network/Wai/Handler/Warp/Settings.hs | 2 +- warp/Network/Wai/Handler/Warp/Types.hs | 8 +-- .../Wai/Handler/Warp/WithApplication.hs | 12 ++-- warp/bench/Parser.hs | 2 +- warp/test/ExceptionSpec.hs | 4 +- warp/test/RunSpec.hs | 4 +- warp/test/SendFileSpec.hs | 2 +- warp/test/WithApplicationSpec.hs | 8 +-- warp/warp.cabal | 9 ++- 22 files changed, 104 insertions(+), 104 deletions(-) diff --git a/warp/Network/Wai/Handler/Warp.hs b/warp/Network/Wai/Handler/Warp.hs index 330190f99..fd22f89a5 100644 --- a/warp/Network/Wai/Handler/Warp.hs +++ b/warp/Network/Wai/Handler/Warp.hs @@ -141,7 +141,7 @@ module Network.Wai.Handler.Warp ( import Data.Streaming.Network (HostPreference) import qualified Data.Vault.Lazy as Vault -import UnliftIO.Exception (SomeException, throwIO) +import Control.Exception (SomeException, throwIO) #ifdef MIN_VERSION_crypton_x509 import Data.X509 #endif diff --git a/warp/Network/Wai/Handler/Warp/Conduit.hs b/warp/Network/Wai/Handler/Warp/Conduit.hs index f9d846366..cc0b95465 100644 --- a/warp/Network/Wai/Handler/Warp/Conduit.hs +++ b/warp/Network/Wai/Handler/Warp/Conduit.hs @@ -2,10 +2,10 @@ module Network.Wai.Handler.Warp.Conduit where +import Control.Exception (assert, throwIO) import qualified Data.ByteString as S import qualified Data.IORef as I import Data.Word8 (_0, _9, _A, _F, _a, _cr, _f, _lf) -import UnliftIO (assert, throwIO) import Network.Wai.Handler.Warp.Imports import Network.Wai.Handler.Warp.Types diff --git a/warp/Network/Wai/Handler/Warp/FdCache.hs b/warp/Network/Wai/Handler/Warp/FdCache.hs index 1872c9ebc..9f2bbea6e 100644 --- a/warp/Network/Wai/Handler/Warp/FdCache.hs +++ b/warp/Network/Wai/Handler/Warp/FdCache.hs @@ -26,7 +26,7 @@ import System.Posix.IO ( openFd, setFdOption, ) -import UnliftIO.Exception (bracket) +import Control.Exception (bracket) #endif import System.Posix.Types (Fd) diff --git a/warp/Network/Wai/Handler/Warp/FileInfoCache.hs b/warp/Network/Wai/Handler/Warp/FileInfoCache.hs index 83c5cc09e..8ddabd5d2 100644 --- a/warp/Network/Wai/Handler/Warp/FileInfoCache.hs +++ b/warp/Network/Wai/Handler/Warp/FileInfoCache.hs @@ -7,6 +7,7 @@ module Network.Wai.Handler.Warp.FileInfoCache ( getInfo, -- test purpose only ) where +import Control.Exception (bracket, onException, throwIO) import Control.Reaper import Network.HTTP.Date #if WINDOWS @@ -14,7 +15,6 @@ import System.PosixCompat.Files #else import System.Posix.Files #endif -import qualified UnliftIO (bracket, onException, throwIO) import Network.Wai.Handler.Warp.HashMap (HashMap) import qualified Network.Wai.Handler.Warp.HashMap as M @@ -58,7 +58,7 @@ getInfo path = do , fileInfoDate = date } return info - else UnliftIO.throwIO (userError "FileInfoCache:getInfo") + else throwIO (userError "FileInfoCache:getInfo") getInfoNaive :: FilePath -> IO FileInfo getInfoNaive = getInfo @@ -69,11 +69,11 @@ getAndRegisterInfo :: FileInfoCache -> FilePath -> IO FileInfo getAndRegisterInfo reaper path = do cache <- reaperRead reaper case M.lookup path cache of - Just Negative -> UnliftIO.throwIO (userError "FileInfoCache:getAndRegisterInfo") + Just Negative -> throwIO (userError "FileInfoCache:getAndRegisterInfo") Just (Positive x) -> return x Nothing -> positive reaper path - `UnliftIO.onException` negative reaper path + `onException` negative reaper path positive :: FileInfoCache -> FilePath -> IO FileInfo positive reaper path = do @@ -84,7 +84,7 @@ positive reaper path = do negative :: FileInfoCache -> FilePath -> IO FileInfo negative reaper path = do reaperAdd reaper (path, Negative) - UnliftIO.throwIO (userError "FileInfoCache:negative") + throwIO (userError "FileInfoCache:negative") ---------------------------------------------------------------- @@ -97,7 +97,7 @@ withFileInfoCache -> IO a withFileInfoCache 0 action = action getInfoNaive withFileInfoCache duration action = - UnliftIO.bracket + bracket (initialize duration) terminate (action . getAndRegisterInfo) diff --git a/warp/Network/Wai/Handler/Warp/HTTP1.hs b/warp/Network/Wai/Handler/Warp/HTTP1.hs index 5e11239d5..8ad016f55 100644 --- a/warp/Network/Wai/Handler/Warp/HTTP1.hs +++ b/warp/Network/Wai/Handler/Warp/HTTP1.hs @@ -9,6 +9,7 @@ module Network.Wai.Handler.Warp.HTTP1 ( ) where import qualified Control.Concurrent as Conc (yield) +import Control.Exception (SomeException, catch, fromException, throwIO, try) import qualified Data.ByteString as BS import Data.Char (chr) import Data.IORef (IORef, newIORef, readIORef, writeIORef) @@ -17,8 +18,6 @@ import Network.Socket (SockAddr (SockAddrInet, SockAddrInet6)) import Network.Wai import Network.Wai.Internal (ResponseReceived (ResponseReceived)) import qualified System.TimeManager as T -import UnliftIO (SomeException, fromException, throwIO) -import qualified UnliftIO import "iproute" Data.IP (toHostAddress, toHostAddress6) import Network.Wai.Handler.Warp.Header @@ -115,7 +114,7 @@ http1server -> Source -> IO () http1server settings ii conn transport app addr th istatus src = - loop FirstRequest `UnliftIO.catchAny` handler + loop FirstRequest `catch` handler where handler e -- See comment below referencing @@ -151,7 +150,7 @@ http1server settings ii conn transport app addr th istatus src = mremainingRef idxhdr nextBodyFlush - `UnliftIO.catchAny` \e -> do + `catch` \e -> do settingsOnException settings (Just req) e -- Don't throw the error again to prevent calling settingsOnException twice. return CloseConnection @@ -166,8 +165,8 @@ http1server settings ii conn transport app addr th istatus src = -- and ignore. See: https://github.com/yesodweb/wai/issues/618 case keepAlive of - ReuseConnection -> loop SubsequentRequest - CloseConnection -> return () + ReuseConnection -> loop SubsequentRequest + CloseConnection -> return () data ReuseConnection = ReuseConnection | CloseConnection @@ -192,7 +191,7 @@ processRequest settings ii conn app th istatus src req mremainingRef idxhdr next -- 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 <- UnliftIO.tryAny $ app req $ \res -> do + r <- try $ app req $ \res -> do T.resume th -- FIXME consider forcing evaluation of the res here to -- send more meaningful error messages to the user. @@ -226,27 +225,27 @@ processRequest settings ii conn app th istatus src req mremainingRef idxhdr next then -- If there is an unknown or large amount of data to still be read -- from the request body, simple drop this connection instead of -- reading it all in to satisfy a keep-alive request. - case settingsMaximumBodyFlush settings of - Nothing -> do - flushEntireBody nextBodyFlush - T.resume th - return ReuseConnection - Just maxToRead -> do - let tryKeepAlive = do - -- flush the rest of the request body - isComplete <- flushBody nextBodyFlush maxToRead - if isComplete - then do - T.resume th - return ReuseConnection - else return CloseConnection - case mremainingRef of - Just ref -> do - remaining <- readIORef ref - if remaining <= maxToRead - then tryKeepAlive - else return CloseConnection - Nothing -> tryKeepAlive + case settingsMaximumBodyFlush settings of + Nothing -> do + flushEntireBody nextBodyFlush + T.resume th + return ReuseConnection + Just maxToRead -> do + let tryKeepAlive = do + -- flush the rest of the request body + isComplete <- flushBody nextBodyFlush maxToRead + if isComplete + then do + T.resume th + return ReuseConnection + else return CloseConnection + case mremainingRef of + Just ref -> do + remaining <- readIORef ref + if remaining <= maxToRead + then tryKeepAlive + else return CloseConnection + Nothing -> tryKeepAlive else return CloseConnection sendErrorResponse diff --git a/warp/Network/Wai/Handler/Warp/HTTP2.hs b/warp/Network/Wai/Handler/Warp/HTTP2.hs index 0e6705635..0a722afbc 100644 --- a/warp/Network/Wai/Handler/Warp/HTTP2.hs +++ b/warp/Network/Wai/Handler/Warp/HTTP2.hs @@ -9,6 +9,7 @@ module Network.Wai.Handler.Warp.HTTP2 ( http2server, ) where +import qualified Control.Exception as E import qualified Data.ByteString as BS import Data.IORef (readIORef) import qualified Data.IORef as I @@ -20,7 +21,6 @@ import Network.Socket.BufferPool import Network.Wai import Network.Wai.Internal (ResponseReceived (..)) import qualified System.TimeManager as T -import qualified UnliftIO import Network.Wai.Handler.Warp.HTTP2.File import Network.Wai.Handler.Warp.HTTP2.PushPromise @@ -93,7 +93,7 @@ http2server label settings ii transport addr app h2req0 aux0 response = do labelThread tid (label ++ " http2server " ++ show addr) req <- toWAIRequest h2req0 aux0 ref <- I.newIORef Nothing - eResponseReceived <- UnliftIO.tryAny $ app req $ \rsp -> do + eResponseReceived <- E.try $ 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) @@ -105,7 +105,12 @@ http2server label settings ii transport addr app h2req0 aux0 response = do let msiz = fromIntegral <$> H2.responseBodySize h2rsp logResponse req st msiz mapM_ (logPushPromise req) pps - Left e -> do + Left e + -- 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 S.settingsOnException settings (Just req) e let ersp = S.settingsOnExceptionResponse settings e st = responseStatus ersp @@ -135,7 +140,7 @@ http2server label settings ii transport addr app h2req0 aux0 response = do wrappedRecvN :: T.Handle -> Int -> (BufSize -> IO ByteString) -> (BufSize -> IO ByteString) wrappedRecvN th slowlorisSize readN bufsize = do - bs <- UnliftIO.handleAny handler $ readN bufsize + bs <- E.handle handler $ readN bufsize -- TODO: think about the slowloris protection in HTTP2: current code -- might open a slow-loris attack vector. Rather than timing we should -- consider limiting the per-client connections assuming that in HTTP2 @@ -146,7 +151,7 @@ wrappedRecvN th slowlorisSize readN bufsize = do T.tickle th return bs where - handler :: UnliftIO.SomeException -> IO ByteString + handler :: E.SomeException -> IO ByteString handler _ = return "" -- connClose must not be called here since Run:fork calls it diff --git a/warp/Network/Wai/Handler/Warp/HTTP2/PushPromise.hs b/warp/Network/Wai/Handler/Warp/HTTP2/PushPromise.hs index 4083b3e00..f75ef0cd2 100644 --- a/warp/Network/Wai/Handler/Warp/HTTP2/PushPromise.hs +++ b/warp/Network/Wai/Handler/Warp/HTTP2/PushPromise.hs @@ -3,9 +3,9 @@ module Network.Wai.Handler.Warp.HTTP2.PushPromise where +import qualified Control.Exception as E import qualified Network.HTTP.Types as H import qualified Network.HTTP2.Server as H2 -import qualified UnliftIO import Network.Wai import Network.Wai.Handler.Warp.FileInfoCache @@ -22,9 +22,9 @@ fromPushPromises ii req = do fromPushPromise :: InternalInfo -> PushPromise -> IO (Maybe H2.PushPromise) fromPushPromise ii (PushPromise path file rsphdr w) = do - efinfo <- UnliftIO.tryIO $ getFileInfo ii file + efinfo <- E.try $ getFileInfo ii file case efinfo of - Left (_ex :: UnliftIO.IOException) -> return Nothing + Left (_ex :: E.IOException) -> return Nothing Right finfo -> do let !siz = fromIntegral $ fileInfoSize finfo !fileSpec = H2.FileSpec file 0 siz diff --git a/warp/Network/Wai/Handler/Warp/HTTP2/Response.hs b/warp/Network/Wai/Handler/Warp/HTTP2/Response.hs index ca0f78d57..5dbf5379e 100644 --- a/warp/Network/Wai/Handler/Warp/HTTP2/Response.hs +++ b/warp/Network/Wai/Handler/Warp/HTTP2/Response.hs @@ -6,13 +6,13 @@ module Network.Wai.Handler.Warp.HTTP2.Response ( fromResponse, ) where +import qualified Control.Exception as E import qualified Data.ByteString.Builder as BB import qualified Data.List as L (find) import qualified Network.HTTP.Types as H import qualified Network.HTTP2.Server as H2 import Network.Wai hiding (responseBuilder, responseFile, responseStream) import Network.Wai.Internal (Response (..)) -import qualified UnliftIO import Network.Wai.Handler.Warp.File import Network.Wai.Handler.Warp.HTTP2.Request (getHTTP2Data) @@ -81,9 +81,9 @@ responseFile st rsphdr method path (Just fp) _ _ = !bytes' = fromIntegral $ filePartByteCount fp !fileSpec = H2.FileSpec path off' bytes' responseFile _ rsphdr method path Nothing ii reqhdr = do - efinfo <- UnliftIO.tryIO $ getFileInfo ii path + efinfo <- E.try $ getFileInfo ii path case efinfo of - Left (_ex :: UnliftIO.IOException) -> return $ response404 rsphdr + Left (_ex :: E.IOException) -> return $ response404 rsphdr Right finfo -> do let reqidx = indexRequestHeader reqhdr rspidx = indexResponseHeader rsphdr diff --git a/warp/Network/Wai/Handler/Warp/Request.hs b/warp/Network/Wai/Handler/Warp/Request.hs index e9632d56a..53e135317 100644 --- a/warp/Network/Wai/Handler/Warp/Request.hs +++ b/warp/Network/Wai/Handler/Warp/Request.hs @@ -27,7 +27,7 @@ import Data.Word8 (_cr, _lf) #ifdef MIN_VERSION_crypton_x509 import Data.X509 #endif -import UnliftIO (Exception, throwIO) +import Control.Exception (Exception, throwIO) import qualified Network.HTTP.Types as H import Network.Socket (SockAddr) import Network.Wai diff --git a/warp/Network/Wai/Handler/Warp/RequestHeader.hs b/warp/Network/Wai/Handler/Warp/RequestHeader.hs index 1caf79dd6..ce44379e3 100644 --- a/warp/Network/Wai/Handler/Warp/RequestHeader.hs +++ b/warp/Network/Wai/Handler/Warp/RequestHeader.hs @@ -13,7 +13,7 @@ import Foreign.ForeignPtr (withForeignPtr) import Foreign.Ptr (Ptr, minusPtr, nullPtr, plusPtr) import Foreign.Storable (peek) import qualified Network.HTTP.Types as H -import UnliftIO (throwIO) +import Control.Exception (throwIO) import Network.Wai.Handler.Warp.Imports import Network.Wai.Handler.Warp.Types diff --git a/warp/Network/Wai/Handler/Warp/Response.hs b/warp/Network/Wai/Handler/Warp/Response.hs index e8bc8df5d..cd46a383d 100644 --- a/warp/Network/Wai/Handler/Warp/Response.hs +++ b/warp/Network/Wai/Handler/Warp/Response.hs @@ -14,6 +14,7 @@ module Network.Wai.Handler.Warp.Response ( addAltSvc, ) where +import qualified Control.Exception as E import Data.Array ((!)) import qualified Data.ByteString as S import Data.ByteString.Builder (Builder, byteString) @@ -38,7 +39,6 @@ import Network.Wai import Network.Wai.Internal import qualified Paths_warp import qualified System.TimeManager as T -import qualified UnliftIO import Network.Wai.Handler.Warp.Buffer (toBuilderBuffer) import qualified Network.Wai.Handler.Warp.Date as D @@ -315,9 +315,9 @@ sendRsp conn ii th ver s0 hs0 rspidxhdr maxRspBufSize method (RspFile path (Just -- Simple WAI applications. -- Status is ignored sendRsp conn ii th ver _ hs0 rspidxhdr maxRspBufSize method (RspFile path Nothing reqidxhdr hook) = do - efinfo <- UnliftIO.tryIO $ getFileInfo ii path + efinfo <- E.try $ getFileInfo ii path case efinfo of - Left (_ex :: UnliftIO.IOException) -> + Left (_ex :: E.IOException) -> #ifdef WARP_DEBUG print _ex >> #endif diff --git a/warp/Network/Wai/Handler/Warp/Run.hs b/warp/Network/Wai/Handler/Warp/Run.hs index 5a941bf1d..37bd1f7a0 100644 --- a/warp/Network/Wai/Handler/Warp/Run.hs +++ b/warp/Network/Wai/Handler/Warp/Run.hs @@ -9,8 +9,7 @@ module Network.Wai.Handler.Warp.Run where import Control.Arrow (first) -import Control.Exception (allowInterrupt) -import qualified Control.Exception +import qualified Control.Exception as E import qualified Data.ByteString as S import Data.IORef (newIORef, readIORef) import Data.Streaming.Network (bindPortTCP) @@ -39,8 +38,6 @@ import System.Environment (lookupEnv) import System.IO.Error (ioeGetErrorType) import qualified System.TimeManager as T import System.Timeout (timeout) -import UnliftIO (toException) -import qualified UnliftIO import Network.Wai.Handler.Warp.Buffer import Network.Wai.Handler.Warp.Counter @@ -84,7 +81,7 @@ socketConnection _ s = do else settingsGracefulCloseTimeout1 set if tm == 0 then close s - else gracefulClose s tm `UnliftIO.catchAny` \(UnliftIO.SomeException _) -> return () + else gracefulClose s tm `E.catch` \(E.SomeException _) -> return () #else , connClose = close s #endif @@ -95,12 +92,12 @@ socketConnection _ s = do , connMySockAddr = mysa } where - receive' sock pool = UnliftIO.handleIO handler $ receive sock pool + receive' sock pool = E.handle handler $ receive sock pool where - handler :: UnliftIO.IOException -> IO ByteString + handler :: E.IOException -> IO ByteString handler e | ioeGetErrorType e == InvalidArgument = return "" - | otherwise = UnliftIO.throwIO e + | otherwise = E.throwIO e sendfile writeBufferRef fid offset len hook headers = do writeBuffer <- readIORef writeBufferRef @@ -118,13 +115,13 @@ socketConnection _ s = do sendall = sendAll' s sendAll' sock bs = - UnliftIO.handleJust + E.handleJust ( \e -> if ioeGetErrorType e == ResourceVanished then Just ConnectionClosedByPeer else Nothing ) - UnliftIO.throwIO + E.throwIO $ Sock.sendAll sock bs -- | Run an 'Application' on the given port. @@ -154,7 +151,7 @@ runEnv p app = do runSettings :: Settings -> Application -> IO () runSettings set app = withSocketsDo $ - UnliftIO.bracket + E.bracket (bindPortTCP (settingsPort set) (settingsHost set)) close ( \socket -> do @@ -182,7 +179,7 @@ runSettingsSocket set@Settings{settingsAccept = accept'} socket app = do (s, sa) <- accept' socket setSocketCloseOnExec s -- NoDelay causes an error for AF_UNIX. - setSocketOption s NoDelay 1 `UnliftIO.catchAny` \(UnliftIO.SomeException _) -> return () + setSocketOption s NoDelay 1 `E.catch` \(E.SomeException _) -> return () conn <- socketConnection set s return (conn, sa) @@ -247,7 +244,7 @@ withII set action = withTimeoutManager f = case settingsManager set of Just tm -> f tm Nothing -> - UnliftIO.bracket + E.bracket (T.initialize timeoutInSeconds) T.stopManager f @@ -278,7 +275,7 @@ acceptConnection set getConnMaker app counter ii = do -- acceptNewConnection and the registering of connClose. -- -- acceptLoop can be broken by closing the listening socket. - void $ UnliftIO.mask_ acceptLoop + void $ E.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. @@ -286,7 +283,7 @@ acceptConnection set getConnMaker app counter ii = do where acceptLoop = do -- Allow async exceptions before receiving the next connection maker. - allowInterrupt + E.allowInterrupt -- acceptNewConnection will try to receive the next incoming -- request. It returns a /connection maker/, not a connection, @@ -303,7 +300,7 @@ acceptConnection set getConnMaker app counter ii = do acceptLoop acceptNewConnection = do - ex <- UnliftIO.tryIO getConnMaker + ex <- E.try getConnMaker case ex of Right x -> return $ Just x Left e -> do @@ -311,11 +308,11 @@ acceptConnection set getConnMaker app counter ii = do isErrno err = ioe_errno e == Just (getErrno err) if | isErrno eCONNABORTED -> acceptNewConnection | isErrno eMFILE -> do - settingsOnException set Nothing $ toException e + settingsOnException set Nothing $ E.toException e waitForDecreased counter acceptNewConnection | otherwise -> do - settingsOnException set Nothing $ toException e + settingsOnException set Nothing $ E.toException e return Nothing -- Fork a new worker thread for this connection maker, and ask for a @@ -338,7 +335,7 @@ fork set mkConn addr app counter ii = settingsFork set $ \unmask -> do -- catch all exceptions and avoid them from propagating, even -- async exceptions. See: -- https://github.com/yesodweb/wai/issues/850 - Control.Exception.handle (settingsOnException set Nothing) $ + E.handle (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 @@ -349,16 +346,16 @@ fork set mkConn addr app counter ii = settingsFork set $ \unmask -> do -- 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. - UnliftIO.bracket mkConn cleanUp (serve unmask) + E.bracket mkConn cleanUp (serve unmask) where cleanUp (conn, _) = - connClose conn `UnliftIO.finally` do + connClose conn `E.finally` do writeBuffer <- readIORef $ connWriteBuffer conn bufFree writeBuffer -- We need to register a timeout handler for this thread, and -- cancel that handler as soon as we exit. - serve unmask (conn, transport) = UnliftIO.bracket register cancel $ \th -> do + serve unmask (conn, transport) = E.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. @@ -366,7 +363,7 @@ fork set mkConn addr app counter ii = settingsFork set $ \unmask -> do . -- Call the user-supplied code for connection open and -- close events - UnliftIO.bracket (onOpen addr) (onClose addr) + E.bracket (onOpen addr) (onClose addr) $ \goingon -> -- Actually serve this connection. bracket with closeConn -- above ensures the connection is closed. diff --git a/warp/Network/Wai/Handler/Warp/SendFile.hs b/warp/Network/Wai/Handler/Warp/SendFile.hs index 19f5dd3c2..ff558bca1 100644 --- a/warp/Network/Wai/Handler/Warp/SendFile.hs +++ b/warp/Network/Wai/Handler/Warp/SendFile.hs @@ -19,13 +19,13 @@ import Foreign.ForeignPtr (newForeignPtr_) import Foreign.Ptr (plusPtr) import qualified System.IO as IO #else +import qualified Control.Exception as E import Foreign.C.Error (throwErrno) import Foreign.C.Types import Foreign.Ptr (Ptr, castPtr, plusPtr) import Network.Sendfile import Network.Wai.Handler.Warp.FdCache (openFile, closeFile) import System.Posix.Types -import qualified UnliftIO #endif import Network.Wai.Handler.Warp.Buffer @@ -118,7 +118,7 @@ readSendFile buf siz send fid off0 len0 hook headers = do #else readSendFile :: Buffer -> BufSize -> (ByteString -> IO ()) -> SendFile readSendFile buf siz send fid off0 len0 hook headers = - UnliftIO.bracket setup teardown $ \fd -> do + E.bracket setup teardown $ \fd -> do hn <- packHeader buf siz send hook headers 0 let room = siz - hn buf' = buf `plusPtr` hn diff --git a/warp/Network/Wai/Handler/Warp/Settings.hs b/warp/Network/Wai/Handler/Warp/Settings.hs index dc6715fe8..f397f5e30 100644 --- a/warp/Network/Wai/Handler/Warp/Settings.hs +++ b/warp/Network/Wai/Handler/Warp/Settings.hs @@ -9,6 +9,7 @@ module Network.Wai.Handler.Warp.Settings where +import Control.Exception (SomeException, fromException) import qualified Data.ByteString.Builder as Builder import qualified Data.ByteString.Char8 as C8 import Data.Streaming.Network (HostPreference) @@ -25,7 +26,6 @@ import qualified Paths_warp import System.IO (stderr) import System.IO.Error (ioeGetErrorType) import System.TimeManager -import UnliftIO (SomeException, fromException) import Network.Wai.Handler.Warp.Imports import Network.Wai.Handler.Warp.Types diff --git a/warp/Network/Wai/Handler/Warp/Types.hs b/warp/Network/Wai/Handler/Warp/Types.hs index df6d4abc9..086fc3f26 100644 --- a/warp/Network/Wai/Handler/Warp/Types.hs +++ b/warp/Network/Wai/Handler/Warp/Types.hs @@ -7,7 +7,7 @@ module Network.Wai.Handler.Warp.Types where import qualified Data.ByteString as S import Data.IORef (IORef, newIORef, readIORef, writeIORef) import Data.Typeable (Typeable) -import qualified UnliftIO +import qualified Control.Exception as E #ifdef MIN_VERSION_crypton_x509 import Data.X509 #endif @@ -60,7 +60,7 @@ instance Show InvalidRequest where show RequestHeaderFieldsTooLarge = "Request header fields too large" show PayloadTooLarge = "Payload too large" -instance UnliftIO.Exception InvalidRequest +instance E.Exception InvalidRequest ---------------------------------------------------------------- @@ -70,10 +70,10 @@ instance UnliftIO.Exception InvalidRequest -- -- Used to determine whether keeping the HTTP1.1 connection / HTTP2 stream alive is safe -- or irrecoverable. -newtype ExceptionInsideResponseBody = ExceptionInsideResponseBody UnliftIO.SomeException +newtype ExceptionInsideResponseBody = ExceptionInsideResponseBody E.SomeException deriving (Show, Typeable) -instance UnliftIO.Exception ExceptionInsideResponseBody +instance E.Exception ExceptionInsideResponseBody ---------------------------------------------------------------- diff --git a/warp/Network/Wai/Handler/Warp/WithApplication.hs b/warp/Network/Wai/Handler/Warp/WithApplication.hs index 4259931ee..b20dc02b1 100644 --- a/warp/Network/Wai/Handler/Warp/WithApplication.hs +++ b/warp/Network/Wai/Handler/Warp/WithApplication.hs @@ -10,6 +10,8 @@ module Network.Wai.Handler.Warp.WithApplication ( ) where import Control.Concurrent +import Control.Concurrent.Async +import qualified Control.Exception as E import Control.Monad (when) import Data.Streaming.Network (bindRandomPortTCP) import Network.Socket @@ -17,8 +19,6 @@ import Network.Wai import Network.Wai.Handler.Warp.Run import Network.Wai.Handler.Warp.Settings import Network.Wai.Handler.Warp.Types -import qualified UnliftIO -import UnliftIO.Async -- | Runs the given 'Application' on a free port. Passes the port to the given -- operation and executes it, while the 'Application' is running. Shuts down the @@ -47,7 +47,7 @@ withApplicationSettings settings' mkApp action = do (runSettingsSocket settings sock app) (waitFor started >> action port) case result of - Left () -> UnliftIO.throwString "Unexpected: runSettingsSocket exited" + Left () -> E.throwIO $ E.ErrorCall "Unexpected: runSettingsSocket exited" Right x -> return x -- | Same as 'withApplication' but with different exception handling: If the @@ -75,11 +75,11 @@ testWithApplicationSettings settings mkApp action = do callingThread <- myThreadId app <- mkApp let wrappedApp request respond = - app request respond `UnliftIO.catchAny` \e -> do + app request respond `E.catch` \e -> do when (defaultShouldDisplayException e) (throwTo callingThread e) - UnliftIO.throwIO e + E.throwIO e withApplicationSettings settings (return wrappedApp) action data Waiter a = Waiter @@ -104,4 +104,4 @@ openFreePort = bindRandomPortTCP "127.0.0.1" -- | Like 'openFreePort' but closes the socket before exiting. withFreePort :: ((Port, Socket) -> IO a) -> IO a -withFreePort = UnliftIO.bracket openFreePort (close . snd) +withFreePort = E.bracket openFreePort (close . snd) diff --git a/warp/bench/Parser.hs b/warp/bench/Parser.hs index ea58d3fe3..2d33dbdbf 100644 --- a/warp/bench/Parser.hs +++ b/warp/bench/Parser.hs @@ -16,7 +16,7 @@ import Foreign.ForeignPtr import Foreign.Ptr import Foreign.Storable import qualified Network.HTTP.Types as H -import UnliftIO.Exception (impureThrow, throwIO) +import Control.Exception (impureThrow, throwIO) import Prelude hiding (lines) import Network.Wai.Handler.Warp.Request (FirstRequest (..), headerLines) diff --git a/warp/test/ExceptionSpec.hs b/warp/test/ExceptionSpec.hs index 947806bae..afd3d9934 100644 --- a/warp/test/ExceptionSpec.hs +++ b/warp/test/ExceptionSpec.hs @@ -6,6 +6,8 @@ module ExceptionSpec (main, spec) where #if __GLASGOW_HASKELL__ < 709 import Control.Applicative #endif +import Control.Concurrent.Async (withAsync) +import Control.Exception import Control.Monad import qualified Data.Streaming.Network as N import Network.HTTP.Types hiding (Header) @@ -14,8 +16,6 @@ import Network.Wai hiding (Response, responseStatus) import Network.Wai.Handler.Warp import Network.Wai.Internal (Request (..)) import Test.Hspec -import UnliftIO.Async (withAsync) -import UnliftIO.Exception import HTTP diff --git a/warp/test/RunSpec.hs b/warp/test/RunSpec.hs index ab80e9215..8fab12f7b 100644 --- a/warp/test/RunSpec.hs +++ b/warp/test/RunSpec.hs @@ -23,8 +23,8 @@ import Network.Wai.Handler.Warp import System.IO.Unsafe (unsafePerformIO) import System.Timeout (timeout) import Test.Hspec -import UnliftIO.Exception (IOException, bracket, onException, try) -import qualified UnliftIO.Exception as E +import Control.Exception (IOException, bracket, onException, try) +import qualified Control.Exception as E import HTTP diff --git a/warp/test/SendFileSpec.hs b/warp/test/SendFileSpec.hs index 8b385a54f..d2587f0c6 100644 --- a/warp/test/SendFileSpec.hs +++ b/warp/test/SendFileSpec.hs @@ -13,7 +13,7 @@ import System.Exit import qualified System.IO as IO import System.Process (system) import Test.Hspec -import UnliftIO.Exception +import Control.Exception main :: IO () main = hspec spec diff --git a/warp/test/WithApplicationSpec.hs b/warp/test/WithApplicationSpec.hs index 8d534fd6a..bda4af070 100644 --- a/warp/test/WithApplicationSpec.hs +++ b/warp/test/WithApplicationSpec.hs @@ -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 @@ -30,17 +30,17 @@ spec = do output `shouldBe` "foo" it "does not propagate exceptions from the server to the executing thread" $ do - let mkApp = return $ \_request _respond -> throwString "foo" + let mkApp = return $ \_request _respond -> throwIO $ ErrorCall "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 -> throwString "foo" + let mkApp = return $ \_request _respond -> throwIO $ ErrorCall "foo" testWithApplication mkApp ( \port -> do readProcess "curl" ["-s", "localhost:" ++ show port] "" ) - `shouldThrow` (\(StringException str _) -> str == "foo") + `shouldThrow` (errorCall "foo") diff --git a/warp/warp.cabal b/warp/warp.cabal index dc908a38e..ee6d59b6b 100644 --- a/warp/warp.cabal +++ b/warp/warp.cabal @@ -86,6 +86,7 @@ library base >=4.12 && <5, array, auto-update >=0.2.2 && <0.3, + async, bsb-http-chunked <0.1, bytestring >=0.9.1.4, case-insensitive >=0.2, @@ -104,8 +105,7 @@ library time-manager >=0.1 && <0.2, vault >=0.3, wai >=3.2.4 && <3.3, - word8, - unliftio + word8 if flag(x509) build-depends: crypton-x509 @@ -217,6 +217,7 @@ test-suite spec QuickCheck, array, auto-update, + async, bsb-http-chunked <0.1, bytestring >=0.9.1.4, case-insensitive >=0.2, @@ -240,8 +241,7 @@ test-suite spec time-manager, vault, wai >=3.2.2.1 && <3.3, - word8, - unliftio + word8 if flag(x509) build-depends: crypton-x509 @@ -306,7 +306,6 @@ benchmark parser streaming-commons, text, time-manager, - unliftio, vault, wai, word8 From 17ddfccae91596a4cc7fbf76e930c300ea93f05c Mon Sep 17 00:00:00 2001 From: Kazu Yamamoto Date: Fri, 1 Nov 2024 13:40:02 +0900 Subject: [PATCH 5/6] removing unnecessary import --- warp-tls/Network/Wai/Handler/WarpTLS.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/warp-tls/Network/Wai/Handler/WarpTLS.hs b/warp-tls/Network/Wai/Handler/WarpTLS.hs index 418d8f4a8..6f70d1e32 100644 --- a/warp-tls/Network/Wai/Handler/WarpTLS.hs +++ b/warp-tls/Network/Wai/Handler/WarpTLS.hs @@ -56,7 +56,6 @@ module Network.Wai.Handler.WarpTLS ( ) where import Control.Applicative ((<|>)) -import Control.Concurrent (newEmptyMVar, putMVar, takeMVar, forkIOWithUnmask) import Control.Exception ( Exception, IOException, From e991c3fc0cb8e8eb030b830007b56251761755e9 Mon Sep 17 00:00:00 2001 From: Kazu Yamamoto Date: Thu, 7 Nov 2024 10:25:05 +0900 Subject: [PATCH 6/6] using criterion instead of gauge and fixing bench --- warp/bench/Parser.hs | 15 +++++---------- warp/warp.cabal | 2 +- 2 files changed, 6 insertions(+), 11 deletions(-) diff --git a/warp/bench/Parser.hs b/warp/bench/Parser.hs index 2d33dbdbf..4ad265ebf 100644 --- a/warp/bench/Parser.hs +++ b/warp/bench/Parser.hs @@ -1,10 +1,10 @@ {-# LANGUAGE BangPatterns #-} -{-# LANGUAGE CPP #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} module Main where +import Control.Exception (throw, throwIO) import Control.Monad import qualified Data.ByteString as S import qualified Data.ByteString.Char8 as B (pack, unpack) @@ -16,17 +16,12 @@ import Foreign.ForeignPtr import Foreign.Ptr import Foreign.Storable import qualified Network.HTTP.Types as H -import Control.Exception (impureThrow, throwIO) import Prelude hiding (lines) import Network.Wai.Handler.Warp.Request (FirstRequest (..), headerLines) import Network.Wai.Handler.Warp.Types -#if MIN_VERSION_gauge(0, 2, 0) -import Gauge -#else -import Gauge.Main -#endif +import Criterion.Main -- $setup -- >>> :set -XOverloadedStrings @@ -86,15 +81,15 @@ parseRequestLine3 requestLine = ret where (!method, !rest) = S.break (== _space) requestLine (!pathQuery, !httpVer') - | rest == "" = impureThrow badmsg + | rest == "" = throw badmsg | otherwise = S.break (== _space) (S.drop 1 rest) (!path, !query) = S.break (== _question) pathQuery !httpVer = S.drop 1 httpVer' (!http, !ver) - | httpVer == "" = impureThrow badmsg + | httpVer == "" = throw badmsg | otherwise = S.break (== _slash) httpVer !hv - | http /= "HTTP" = impureThrow NonHttp + | http /= "HTTP" = throw NonHttp | ver == "/1.1" = H.http11 | otherwise = H.http10 !ret = (method, path, query, hv) diff --git a/warp/warp.cabal b/warp/warp.cabal index ee6d59b6b..f97df5003 100644 --- a/warp/warp.cabal +++ b/warp/warp.cabal @@ -295,7 +295,7 @@ benchmark parser bytestring, case-insensitive, containers, - gauge, + criterion, ghc-prim, hashable, http-date,