Merge pull request #1012 from kazu-yamamoto/removing-unliftio

Removing unliftio

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.

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

warp-tls/Network/Wai/Handler/WarpTLS.hs

@@ -56,6 +56,19 @@ module Network.Wai.Handler.WarpTLS (
 ) where
 
 import Control.Applicative ((<|>))
+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 +86,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 +96,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)
 
 ----------------------------------------------------------------
 
@@ -323,12 +321,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
@@ -366,7 +360,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 ()

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

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

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

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)
 

warp/Network/Wai/Handler/Warp/FileInfoCache.hs

@@ -7,14 +7,14 @@ 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
 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)

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

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

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