{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# OPTIONS_GHC -fno-warn-deprecations #-}

module Network.Wai.Handler.Warp.Run where

import Control.Arrow (first)
import qualified Control.Exception
import Control.Exception (allowInterrupt)
import qualified Data.ByteString as S
import Data.IORef (newIORef, readIORef)
import Data.Streaming.Network (bindPortTCP)
import Foreign.C.Error (Errno(..), eCONNABORTED, eMFILE)
import GHC.IO.Exception (IOException(..), IOErrorType(..))
import Network.Socket (Socket, close, withSocketsDo, SockAddr, setSocketOption, SocketOption(..))
#if MIN_VERSION_network(3,1,1)
import Network.Socket (gracefulClose)
#endif
import Network.Socket.BufferPool
import qualified Network.Socket.ByteString as Sock
import Network.Wai
import System.Environment (lookupEnv)
import System.IO.Error (ioeGetErrorType)
import qualified System.TimeManager as T
import System.Timeout (timeout)
import qualified UnliftIO
import UnliftIO (toException)

import Network.Wai.Handler.Warp.Buffer
import Network.Wai.Handler.Warp.Counter
import qualified Network.Wai.Handler.Warp.Date as D
import qualified Network.Wai.Handler.Warp.FdCache as F
import qualified Network.Wai.Handler.Warp.FileInfoCache as I
import Network.Wai.Handler.Warp.HTTP1 (http1)
import Network.Wai.Handler.Warp.HTTP2 (http2)
import Network.Wai.Handler.Warp.HTTP2.Types (isHTTP2)
import Network.Wai.Handler.Warp.Imports hiding (readInt)
import Network.Wai.Handler.Warp.SendFile
import Network.Wai.Handler.Warp.Settings
import Network.Wai.Handler.Warp.Types


#if WINDOWS
import Network.Wai.Handler.Warp.Windows
#else
import Network.Socket (fdSocket)
#endif

-- | Creating 'Connection' for plain HTTP based on a given socket.
socketConnection :: Settings -> Socket -> IO Connection
#if MIN_VERSION_network(3,1,1)
socketConnection :: Settings -> Socket -> IO Connection
socketConnection Settings
set Socket
s = do
#else
socketConnection _ s = do
#endif
    BufferPool
bufferPool <- Int -> Int -> IO BufferPool
newBufferPool Int
2048 Int
16384
    WriteBuffer
writeBuffer <- Int -> IO WriteBuffer
createWriteBuffer Int
16384
    IORef WriteBuffer
writeBufferRef <- WriteBuffer -> IO (IORef WriteBuffer)
forall a. a -> IO (IORef a)
newIORef WriteBuffer
writeBuffer
    IORef Bool
isH2 <- Bool -> IO (IORef Bool)
forall a. a -> IO (IORef a)
newIORef Bool
False -- HTTP/1.x
    Connection -> IO Connection
forall (m :: * -> *) a. Monad m => a -> m a
return Connection :: ([ByteString] -> IO ())
-> (ByteString -> IO ())
-> SendFile
-> IO ()
-> Recv
-> RecvBuf
-> IORef WriteBuffer
-> IORef Bool
-> Connection
Connection {
        connSendMany :: [ByteString] -> IO ()
connSendMany = Socket -> [ByteString] -> IO ()
Sock.sendMany Socket
s
      , connSendAll :: ByteString -> IO ()
connSendAll = ByteString -> IO ()
sendall
      , connSendFile :: SendFile
connSendFile = IORef WriteBuffer -> SendFile
sendfile IORef WriteBuffer
writeBufferRef
#if MIN_VERSION_network(3,1,1)
      , connClose :: IO ()
connClose = do
            Bool
h2 <- IORef Bool -> IO Bool
forall a. IORef a -> IO a
readIORef IORef Bool
isH2
            let tm :: Int
tm = if Bool
h2 then Settings -> Int
settingsGracefulCloseTimeout2 Settings
set
                           else Settings -> Int
settingsGracefulCloseTimeout1 Settings
set
            if Int
tm Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 then
                Socket -> IO ()
close Socket
s
              else
                Socket -> Int -> IO ()
gracefulClose Socket
s Int
tm IO () -> (SomeException -> IO ()) -> IO ()
forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> (SomeException -> m a) -> m a
`UnliftIO.catchAny` \(UnliftIO.SomeException e
_) -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
#else
      , connClose = close s
#endif
      , connRecv :: Recv
connRecv = Socket -> BufferPool -> Recv
receive' Socket
s BufferPool
bufferPool
      , connRecvBuf :: RecvBuf
connRecvBuf = \Buffer
_ Int
_ -> Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True -- obsoleted
      , connWriteBuffer :: IORef WriteBuffer
connWriteBuffer = IORef WriteBuffer
writeBufferRef
      , connHTTP2 :: IORef Bool
connHTTP2 = IORef Bool
isH2
      }
  where
    receive' :: Socket -> BufferPool -> Recv
receive' Socket
sock BufferPool
pool = (IOException -> Recv) -> Recv -> Recv
forall (m :: * -> *) a.
MonadUnliftIO m =>
(IOException -> m a) -> m a -> m a
UnliftIO.handleIO IOException -> Recv
handler (Recv -> Recv) -> Recv -> Recv
forall a b. (a -> b) -> a -> b
$ Socket -> BufferPool -> Recv
receive Socket
sock BufferPool
pool
      where
        handler :: UnliftIO.IOException -> IO ByteString
        handler :: IOException -> Recv
handler IOException
e
          | IOException -> IOErrorType
ioeGetErrorType IOException
e IOErrorType -> IOErrorType -> Bool
forall a. Eq a => a -> a -> Bool
== IOErrorType
InvalidArgument = ByteString -> Recv
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
""
          | Bool
otherwise                            = IOException -> Recv
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
UnliftIO.throwIO IOException
e

    sendfile :: IORef WriteBuffer -> SendFile
sendfile IORef WriteBuffer
writeBufferRef FileId
fid Integer
offset Integer
len IO ()
hook [ByteString]
headers = do
      WriteBuffer
writeBuffer <- IORef WriteBuffer -> IO WriteBuffer
forall a. IORef a -> IO a
readIORef IORef WriteBuffer
writeBufferRef
      Socket -> Buffer -> Int -> (ByteString -> IO ()) -> SendFile
sendFile Socket
s (WriteBuffer -> Buffer
bufBuffer WriteBuffer
writeBuffer) (WriteBuffer -> Int
bufSize WriteBuffer
writeBuffer) ByteString -> IO ()
sendall
        FileId
fid Integer
offset Integer
len IO ()
hook [ByteString]
headers

    sendall :: ByteString -> IO ()
sendall = Socket -> ByteString -> IO ()
sendAll' Socket
s

    sendAll' :: Socket -> ByteString -> IO ()
sendAll' Socket
sock ByteString
bs = (IOException -> Maybe InvalidRequest)
-> (InvalidRequest -> IO ()) -> IO () -> IO ()
forall (m :: * -> *) e b a.
(MonadUnliftIO m, Exception e) =>
(e -> Maybe b) -> (b -> m a) -> m a -> m a
UnliftIO.handleJust
      (\ IOException
e -> if IOException -> IOErrorType
ioeGetErrorType IOException
e IOErrorType -> IOErrorType -> Bool
forall a. Eq a => a -> a -> Bool
== IOErrorType
ResourceVanished
        then InvalidRequest -> Maybe InvalidRequest
forall a. a -> Maybe a
Just InvalidRequest
ConnectionClosedByPeer
        else Maybe InvalidRequest
forall a. Maybe a
Nothing)
      InvalidRequest -> IO ()
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
UnliftIO.throwIO
      (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Socket -> ByteString -> IO ()
Sock.sendAll Socket
sock ByteString
bs

-- | Run an 'Application' on the given port.
-- This calls 'runSettings' with 'defaultSettings'.
run :: Port -> Application -> IO ()
run :: Int -> Application -> IO ()
run Int
p = Settings -> Application -> IO ()
runSettings Settings
defaultSettings { settingsPort :: Int
settingsPort = Int
p }

-- | Run an 'Application' on the port present in the @PORT@
-- environment variable. Uses the 'Port' given when the variable is unset.
-- This calls 'runSettings' with 'defaultSettings'.
--
-- Since 3.0.9
runEnv :: Port -> Application -> IO ()
runEnv :: Int -> Application -> IO ()
runEnv Int
p Application
app = do
    Maybe String
mp <- String -> IO (Maybe String)
lookupEnv String
"PORT"

    IO () -> (String -> IO ()) -> Maybe String -> IO ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Int -> Application -> IO ()
run Int
p Application
app) String -> IO ()
runReadPort Maybe String
mp

  where
    runReadPort :: String -> IO ()
    runReadPort :: String -> IO ()
runReadPort String
sp = case ReadS Int
forall a. Read a => ReadS a
reads String
sp of
        ((Int
p', String
_):[(Int, String)]
_) -> Int -> Application -> IO ()
run Int
p' Application
app
        [(Int, String)]
_ -> String -> IO ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Invalid value in $PORT: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
sp

-- | Run an 'Application' with the given 'Settings'.
-- This opens a listen socket on the port defined in 'Settings' and
-- calls 'runSettingsSocket'.
runSettings :: Settings -> Application -> IO ()
runSettings :: Settings -> Application -> IO ()
runSettings Settings
set Application
app = IO () -> IO ()
forall a. IO a -> IO a
withSocketsDo (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
    IO Socket -> (Socket -> IO ()) -> (Socket -> IO ()) -> IO ()
forall (m :: * -> *) a b c.
MonadUnliftIO m =>
m a -> (a -> m b) -> (a -> m c) -> m c
UnliftIO.bracket
        (Int -> HostPreference -> IO Socket
bindPortTCP (Settings -> Int
settingsPort Settings
set) (Settings -> HostPreference
settingsHost Settings
set))
        Socket -> IO ()
close
        (\Socket
socket -> do
            Socket -> IO ()
setSocketCloseOnExec Socket
socket
            Settings -> Socket -> Application -> IO ()
runSettingsSocket Settings
set Socket
socket Application
app)

-- | This installs a shutdown handler for the given socket and
-- calls 'runSettingsConnection' with the default connection setup action
-- which handles plain (non-cipher) HTTP.
-- When the listen socket in the second argument is closed, all live
-- connections are gracefully shut down.
--
-- The supplied socket can be a Unix named socket, which
-- can be used when reverse HTTP proxying into your application.
--
-- Note that the 'settingsPort' will still be passed to 'Application's via the
-- 'serverPort' record.
runSettingsSocket :: Settings -> Socket -> Application -> IO ()
runSettingsSocket :: Settings -> Socket -> Application -> IO ()
runSettingsSocket set :: Settings
set@Settings{settingsAccept :: Settings -> Socket -> IO (Socket, SockAddr)
settingsAccept = Socket -> IO (Socket, SockAddr)
accept'} Socket
socket Application
app = do
    Settings -> IO () -> IO ()
settingsInstallShutdownHandler Settings
set IO ()
closeListenSocket
    Settings -> IO (Connection, SockAddr) -> Application -> IO ()
runSettingsConnection Settings
set IO (Connection, SockAddr)
getConn Application
app
  where
    getConn :: IO (Connection, SockAddr)
getConn = do
        (Socket
s, SockAddr
sa) <- Socket -> IO (Socket, SockAddr)
accept' Socket
socket
        Socket -> IO ()
setSocketCloseOnExec Socket
s
        -- NoDelay causes an error for AF_UNIX.
        Socket -> SocketOption -> Int -> IO ()
setSocketOption Socket
s SocketOption
NoDelay Int
1 IO () -> (SomeException -> IO ()) -> IO ()
forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> (SomeException -> m a) -> m a
`UnliftIO.catchAny` \(UnliftIO.SomeException e
_) -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        Connection
conn <- Settings -> Socket -> IO Connection
socketConnection Settings
set Socket
s
        (Connection, SockAddr) -> IO (Connection, SockAddr)
forall (m :: * -> *) a. Monad m => a -> m a
return (Connection
conn, SockAddr
sa)

    closeListenSocket :: IO ()
closeListenSocket = Socket -> IO ()
close Socket
socket

-- | The connection setup action would be expensive. A good example
-- is initialization of TLS.
-- So, this converts the connection setup action to the connection maker
-- which will be executed after forking a new worker thread.
-- Then this calls 'runSettingsConnectionMaker' with the connection maker.
-- This allows the expensive computations to be performed
-- in a separate worker thread instead of the main server loop.
--
-- Since 1.3.5
runSettingsConnection :: Settings -> IO (Connection, SockAddr) -> Application -> IO ()
runSettingsConnection :: Settings -> IO (Connection, SockAddr) -> Application -> IO ()
runSettingsConnection Settings
set IO (Connection, SockAddr)
getConn Application
app = Settings -> IO (IO Connection, SockAddr) -> Application -> IO ()
runSettingsConnectionMaker Settings
set IO (IO Connection, SockAddr)
getConnMaker Application
app
  where
    getConnMaker :: IO (IO Connection, SockAddr)
getConnMaker = do
      (Connection
conn, SockAddr
sa) <- IO (Connection, SockAddr)
getConn
      (IO Connection, SockAddr) -> IO (IO Connection, SockAddr)
forall (m :: * -> *) a. Monad m => a -> m a
return (Connection -> IO Connection
forall (m :: * -> *) a. Monad m => a -> m a
return Connection
conn, SockAddr
sa)

-- | This modifies the connection maker so that it returns 'TCP' for 'Transport'
-- (i.e. plain HTTP) then calls 'runSettingsConnectionMakerSecure'.
runSettingsConnectionMaker :: Settings -> IO (IO Connection, SockAddr) -> Application -> IO ()
runSettingsConnectionMaker :: Settings -> IO (IO Connection, SockAddr) -> Application -> IO ()
runSettingsConnectionMaker Settings
x IO (IO Connection, SockAddr)
y =
    Settings
-> IO (IO (Connection, Transport), SockAddr)
-> Application
-> IO ()
runSettingsConnectionMakerSecure Settings
x ((IO Connection, SockAddr) -> (IO (Connection, Transport), SockAddr)
forall t d. (IO t, d) -> (IO (t, Transport), d)
toTCP ((IO Connection, SockAddr)
 -> (IO (Connection, Transport), SockAddr))
-> IO (IO Connection, SockAddr)
-> IO (IO (Connection, Transport), SockAddr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO (IO Connection, SockAddr)
y)
  where
    toTCP :: (IO t, d) -> (IO (t, Transport), d)
toTCP = (IO t -> IO (t, Transport)) -> (IO t, d) -> (IO (t, Transport), d)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first ((, Transport
TCP) (t -> (t, Transport)) -> IO t -> IO (t, Transport)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>)

----------------------------------------------------------------

-- | The core run function which takes 'Settings',
-- a connection maker and 'Application'.
-- The connection maker can return a connection of either plain HTTP
-- or HTTP over TLS.
--
-- Since 2.1.4
runSettingsConnectionMakerSecure :: Settings -> IO (IO (Connection, Transport), SockAddr) -> Application -> IO ()
runSettingsConnectionMakerSecure :: Settings
-> IO (IO (Connection, Transport), SockAddr)
-> Application
-> IO ()
runSettingsConnectionMakerSecure Settings
set IO (IO (Connection, Transport), SockAddr)
getConnMaker Application
app = do
    Settings -> IO ()
settingsBeforeMainLoop Settings
set
    Counter
counter <- IO Counter
newCounter
    Settings -> (InternalInfo -> IO ()) -> IO ()
forall a. Settings -> (InternalInfo -> IO a) -> IO a
withII Settings
set ((InternalInfo -> IO ()) -> IO ())
-> (InternalInfo -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ Settings
-> IO (IO (Connection, Transport), SockAddr)
-> Application
-> Counter
-> InternalInfo
-> IO ()
acceptConnection Settings
set IO (IO (Connection, Transport), SockAddr)
getConnMaker Application
app Counter
counter

-- | Running an action with internal info.
--
-- Since 3.3.11
withII :: Settings -> (InternalInfo -> IO a) -> IO a
withII :: Settings -> (InternalInfo -> IO a) -> IO a
withII Settings
set InternalInfo -> IO a
action =
    (Manager -> IO a) -> IO a
forall c. (Manager -> IO c) -> IO c
withTimeoutManager ((Manager -> IO a) -> IO a) -> (Manager -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \Manager
tm ->
    (Recv -> IO a) -> IO a
forall a. (Recv -> IO a) -> IO a
D.withDateCache ((Recv -> IO a) -> IO a) -> (Recv -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \Recv
dc ->
    Int -> ((String -> IO (Maybe Fd, IO ())) -> IO a) -> IO a
forall a. Int -> ((String -> IO (Maybe Fd, IO ())) -> IO a) -> IO a
F.withFdCache Int
fdCacheDurationInSeconds (((String -> IO (Maybe Fd, IO ())) -> IO a) -> IO a)
-> ((String -> IO (Maybe Fd, IO ())) -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \String -> IO (Maybe Fd, IO ())
fdc ->
    Int -> ((String -> IO FileInfo) -> IO a) -> IO a
forall a. Int -> ((String -> IO FileInfo) -> IO a) -> IO a
I.withFileInfoCache Int
fdFileInfoDurationInSeconds (((String -> IO FileInfo) -> IO a) -> IO a)
-> ((String -> IO FileInfo) -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \String -> IO FileInfo
fic -> do
        let ii :: InternalInfo
ii = Manager
-> Recv
-> (String -> IO (Maybe Fd, IO ()))
-> (String -> IO FileInfo)
-> InternalInfo
InternalInfo Manager
tm Recv
dc String -> IO (Maybe Fd, IO ())
fdc String -> IO FileInfo
fic
        InternalInfo -> IO a
action InternalInfo
ii
  where
    !fdCacheDurationInSeconds :: Int
fdCacheDurationInSeconds = Settings -> Int
settingsFdCacheDuration Settings
set Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
1000000
    !fdFileInfoDurationInSeconds :: Int
fdFileInfoDurationInSeconds = Settings -> Int
settingsFileInfoCacheDuration Settings
set Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
1000000
    !timeoutInSeconds :: Int
timeoutInSeconds = Settings -> Int
settingsTimeout Settings
set Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
1000000
    withTimeoutManager :: (Manager -> IO c) -> IO c
withTimeoutManager Manager -> IO c
f = case Settings -> Maybe Manager
settingsManager Settings
set of
        Just Manager
tm -> Manager -> IO c
f Manager
tm
        Maybe Manager
Nothing -> IO Manager -> (Manager -> IO ()) -> (Manager -> IO c) -> IO c
forall (m :: * -> *) a b c.
MonadUnliftIO m =>
m a -> (a -> m b) -> (a -> m c) -> m c
UnliftIO.bracket
                   (Int -> IO Manager
T.initialize Int
timeoutInSeconds)
                   Manager -> IO ()
T.stopManager
                   Manager -> IO c
f

-- Note that there is a thorough discussion of the exception safety of the
-- following code at: https://github.com/yesodweb/wai/issues/146
--
-- We need to make sure of two things:
--
-- 1. Asynchronous exceptions are not blocked entirely in the main loop.
--    Doing so would make it impossible to kill the Warp thread.
--
-- 2. Once a connection maker is received via acceptNewConnection, the
--    connection is guaranteed to be closed, even in the presence of
--    async exceptions.
--
-- Our approach is explained in the comments below.
acceptConnection :: Settings
                 -> IO (IO (Connection, Transport), SockAddr)
                 -> Application
                 -> Counter
                 -> InternalInfo
                 -> IO ()
acceptConnection :: Settings
-> IO (IO (Connection, Transport), SockAddr)
-> Application
-> Counter
-> InternalInfo
-> IO ()
acceptConnection Settings
set IO (IO (Connection, Transport), SockAddr)
getConnMaker Application
app Counter
counter InternalInfo
ii = do
    -- First mask all exceptions in acceptLoop. This is necessary to
    -- ensure that no async exception is throw between the call to
    -- acceptNewConnection and the registering of connClose.
    --
    -- acceptLoop can be broken by closing the listening socket.
    IO () -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ IO () -> IO ()
forall (m :: * -> *) a. MonadUnliftIO m => m a -> m a
UnliftIO.mask_ IO ()
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.
    Settings -> Counter -> IO ()
gracefulShutdown Settings
set Counter
counter
  where
    acceptLoop :: IO ()
acceptLoop = do
        -- Allow async exceptions before receiving the next connection maker.
        IO ()
allowInterrupt

        -- acceptNewConnection will try to receive the next incoming
        -- request. It returns a /connection maker/, not a connection,
        -- since in some circumstances creating a working connection
        -- from a raw socket may be an expensive operation, and this
        -- expensive work should not be performed in the main event
        -- loop. An example of something expensive would be TLS
        -- negotiation.
        Maybe (IO (Connection, Transport), SockAddr)
mx <- IO (Maybe (IO (Connection, Transport), SockAddr))
acceptNewConnection
        case Maybe (IO (Connection, Transport), SockAddr)
mx of
            Maybe (IO (Connection, Transport), SockAddr)
Nothing             -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
            Just (IO (Connection, Transport)
mkConn, SockAddr
addr) -> do
                Settings
-> IO (Connection, Transport)
-> SockAddr
-> Application
-> Counter
-> InternalInfo
-> IO ()
fork Settings
set IO (Connection, Transport)
mkConn SockAddr
addr Application
app Counter
counter InternalInfo
ii
                IO ()
acceptLoop

    acceptNewConnection :: IO (Maybe (IO (Connection, Transport), SockAddr))
acceptNewConnection = do
        Either IOException (IO (Connection, Transport), SockAddr)
ex <- IO (IO (Connection, Transport), SockAddr)
-> IO (Either IOException (IO (Connection, Transport), SockAddr))
forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> m (Either IOException a)
UnliftIO.tryIO IO (IO (Connection, Transport), SockAddr)
getConnMaker
        case Either IOException (IO (Connection, Transport), SockAddr)
ex of
            Right (IO (Connection, Transport), SockAddr)
x -> Maybe (IO (Connection, Transport), SockAddr)
-> IO (Maybe (IO (Connection, Transport), SockAddr))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (IO (Connection, Transport), SockAddr)
 -> IO (Maybe (IO (Connection, Transport), SockAddr)))
-> Maybe (IO (Connection, Transport), SockAddr)
-> IO (Maybe (IO (Connection, Transport), SockAddr))
forall a b. (a -> b) -> a -> b
$ (IO (Connection, Transport), SockAddr)
-> Maybe (IO (Connection, Transport), SockAddr)
forall a. a -> Maybe a
Just (IO (Connection, Transport), SockAddr)
x
            Left IOException
e -> do
                let getErrno :: Errno -> CInt
getErrno (Errno CInt
cInt) = CInt
cInt
                    eConnAborted :: CInt
eConnAborted = Errno -> CInt
getErrno Errno
eCONNABORTED
                    eMfile :: CInt
eMfile = Errno -> CInt
getErrno Errno
eMFILE
                    merrno :: Maybe CInt
merrno = IOException -> Maybe CInt
ioe_errno IOException
e
                if Maybe CInt
merrno Maybe CInt -> Maybe CInt -> Bool
forall a. Eq a => a -> a -> Bool
== CInt -> Maybe CInt
forall a. a -> Maybe a
Just CInt
eConnAborted Bool -> Bool -> Bool
|| Maybe CInt
merrno Maybe CInt -> Maybe CInt -> Bool
forall a. Eq a => a -> a -> Bool
== CInt -> Maybe CInt
forall a. a -> Maybe a
Just CInt
eMfile
                    then IO (Maybe (IO (Connection, Transport), SockAddr))
acceptNewConnection
                    else do
                        Settings -> Maybe Request -> SomeException -> IO ()
settingsOnException Settings
set Maybe Request
forall a. Maybe a
Nothing (SomeException -> IO ()) -> SomeException -> IO ()
forall a b. (a -> b) -> a -> b
$ IOException -> SomeException
forall e. Exception e => e -> SomeException
toException IOException
e
                        Maybe (IO (Connection, Transport), SockAddr)
-> IO (Maybe (IO (Connection, Transport), SockAddr))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (IO (Connection, Transport), SockAddr)
forall a. Maybe a
Nothing

-- Fork a new worker thread for this connection maker, and ask for a
-- function to unmask (i.e., allow async exceptions to be thrown).
fork :: Settings
     -> IO (Connection, Transport)
     -> SockAddr
     -> Application
     -> Counter
     -> InternalInfo
     -> IO ()
fork :: Settings
-> IO (Connection, Transport)
-> SockAddr
-> Application
-> Counter
-> InternalInfo
-> IO ()
fork Settings
set IO (Connection, Transport)
mkConn SockAddr
addr Application
app Counter
counter InternalInfo
ii = Settings -> ((forall a. IO a -> IO a) -> IO ()) -> IO ()
settingsFork Settings
set (((forall a. IO a -> IO a) -> IO ()) -> IO ())
-> ((forall a. IO a -> IO a) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \forall a. IO a -> IO a
unmask ->
    -- Call the user-supplied on exception code if any
    -- exceptions are thrown.
    --
    -- Intentionally using Control.Exception.handle, since we want to
    -- catch all exceptions and avoid them from propagating, even
    -- async exceptions. See:
    -- https://github.com/yesodweb/wai/issues/850
    (SomeException -> IO ()) -> IO () -> IO ()
forall e a. Exception e => (e -> IO a) -> IO a -> IO a
Control.Exception.handle (Settings -> Maybe Request -> SomeException -> IO ()
settingsOnException Settings
set Maybe Request
forall a. Maybe a
Nothing) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
        -- 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
        -- vulnerable to attacks (e.g., Slowloris), we do nothing to
        -- protect the server. It is therefore vital that mkConn is well
        -- vetted.
        --
        -- 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.
        IO (Connection, Transport)
-> ((Connection, Transport) -> IO ())
-> ((Connection, Transport) -> IO ())
-> IO ()
forall (m :: * -> *) a b c.
MonadUnliftIO m =>
m a -> (a -> m b) -> (a -> m c) -> m c
UnliftIO.bracket IO (Connection, Transport)
mkConn (Connection, Transport) -> IO ()
forall b. (Connection, b) -> IO ()
cleanUp ((IO () -> IO ()) -> (Connection, Transport) -> IO ()
forall c. (IO () -> IO c) -> (Connection, Transport) -> IO c
serve IO () -> IO ()
forall a. IO a -> IO a
unmask)
  where
    cleanUp :: (Connection, b) -> IO ()
cleanUp (Connection
conn, b
_) = Connection -> IO ()
connClose Connection
conn IO () -> IO () -> IO ()
forall (m :: * -> *) a b. MonadUnliftIO m => m a -> m b -> m a
`UnliftIO.finally` do
                          WriteBuffer
writeBuffer <- IORef WriteBuffer -> IO WriteBuffer
forall a. IORef a -> IO a
readIORef (IORef WriteBuffer -> IO WriteBuffer)
-> IORef WriteBuffer -> IO WriteBuffer
forall a b. (a -> b) -> a -> b
$ Connection -> IORef WriteBuffer
connWriteBuffer Connection
conn
                          WriteBuffer -> IO ()
bufFree WriteBuffer
writeBuffer

    -- We need to register a timeout handler for this thread, and
    -- cancel that handler as soon as we exit.
    serve :: (IO () -> IO c) -> (Connection, Transport) -> IO c
serve IO () -> IO c
unmask (Connection
conn, Transport
transport) = IO Handle -> (Handle -> IO ()) -> (Handle -> IO c) -> IO c
forall (m :: * -> *) a b c.
MonadUnliftIO m =>
m a -> (a -> m b) -> (a -> m c) -> m c
UnliftIO.bracket IO Handle
register Handle -> IO ()
cancel ((Handle -> IO c) -> IO c) -> (Handle -> IO c) -> IO c
forall a b. (a -> b) -> a -> b
$ \Handle
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.
        IO () -> IO c
unmask (IO () -> IO c)
-> ((Bool -> IO ()) -> IO ()) -> (Bool -> IO ()) -> IO c
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
            -- Call the user-supplied code for connection open and
            -- close events
           IO Bool -> (Bool -> IO ()) -> (Bool -> IO ()) -> IO ()
forall (m :: * -> *) a b c.
MonadUnliftIO m =>
m a -> (a -> m b) -> (a -> m c) -> m c
UnliftIO.bracket (SockAddr -> IO Bool
onOpen SockAddr
addr) (SockAddr -> Bool -> IO ()
forall p. SockAddr -> p -> IO ()
onClose SockAddr
addr) ((Bool -> IO ()) -> IO c) -> (Bool -> IO ()) -> IO c
forall a b. (a -> b) -> a -> b
$ \Bool
goingon ->
           -- Actually serve this connection.  bracket with closeConn
           -- above ensures the connection is closed.
           Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
goingon (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Connection
-> InternalInfo
-> Handle
-> SockAddr
-> Transport
-> Settings
-> Application
-> IO ()
serveConnection Connection
conn InternalInfo
ii Handle
th SockAddr
addr Transport
transport Settings
set Application
app
      where
        register :: IO Handle
register = Manager -> IO () -> IO Handle
T.registerKillThread (InternalInfo -> Manager
timeoutManager InternalInfo
ii) (Connection -> IO ()
connClose Connection
conn)
        cancel :: Handle -> IO ()
cancel   = Handle -> IO ()
T.cancel

    onOpen :: SockAddr -> IO Bool
onOpen SockAddr
adr    = Counter -> IO ()
increase Counter
counter IO () -> IO Bool -> IO Bool
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Settings -> SockAddr -> IO Bool
settingsOnOpen  Settings
set SockAddr
adr
    onClose :: SockAddr -> p -> IO ()
onClose SockAddr
adr p
_ = Counter -> IO ()
decrease Counter
counter IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Settings -> SockAddr -> IO ()
settingsOnClose Settings
set SockAddr
adr

serveConnection :: Connection
                -> InternalInfo
                -> T.Handle
                -> SockAddr
                -> Transport
                -> Settings
                -> Application
                -> IO ()
serveConnection :: Connection
-> InternalInfo
-> Handle
-> SockAddr
-> Transport
-> Settings
-> Application
-> IO ()
serveConnection Connection
conn InternalInfo
ii Handle
th SockAddr
origAddr Transport
transport Settings
settings Application
app = do
    -- fixme: Upgrading to HTTP/2 should be supported.
    (Bool
h2,ByteString
bs) <- if Transport -> Bool
isHTTP2 Transport
transport then
                   (Bool, ByteString) -> IO (Bool, ByteString)
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
True, ByteString
"")
                 else do
                   ByteString
bs0 <- Connection -> Recv
connRecv Connection
conn
                   if ByteString -> Int
S.length ByteString
bs0 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
4 Bool -> Bool -> Bool
&& ByteString
"PRI " ByteString -> ByteString -> Bool
`S.isPrefixOf` ByteString
bs0 then
                       (Bool, ByteString) -> IO (Bool, ByteString)
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
True, ByteString
bs0)
                     else
                       (Bool, ByteString) -> IO (Bool, ByteString)
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
False, ByteString
bs0)
    if Settings -> Bool
settingsHTTP2Enabled Settings
settings Bool -> Bool -> Bool
&& Bool
h2 then do
        Settings
-> InternalInfo
-> Connection
-> Transport
-> Application
-> SockAddr
-> Handle
-> ByteString
-> IO ()
http2 Settings
settings InternalInfo
ii Connection
conn Transport
transport Application
app SockAddr
origAddr Handle
th ByteString
bs
      else do
        Settings
-> InternalInfo
-> Connection
-> Transport
-> Application
-> SockAddr
-> Handle
-> ByteString
-> IO ()
http1 Settings
settings InternalInfo
ii Connection
conn Transport
transport Application
app SockAddr
origAddr Handle
th ByteString
bs

-- | Set flag FileCloseOnExec flag on a socket (on Unix)
--
-- Copied from: https://github.com/mzero/plush/blob/master/src/Plush/Server/Warp.hs
--
-- @since 3.2.17
setSocketCloseOnExec :: Socket -> IO ()
#if WINDOWS
setSocketCloseOnExec _ = return ()
#else
setSocketCloseOnExec :: Socket -> IO ()
setSocketCloseOnExec Socket
socket = do
#if MIN_VERSION_network(3,0,0)
    CInt
fd <- Socket -> IO CInt
fdSocket Socket
socket
#else
    let fd = fdSocket socket
#endif
    Fd -> IO ()
F.setFileCloseOnExec (Fd -> IO ()) -> Fd -> IO ()
forall a b. (a -> b) -> a -> b
$ CInt -> Fd
forall a b. (Integral a, Num b) => a -> b
fromIntegral CInt
fd
#endif

gracefulShutdown :: Settings -> Counter -> IO ()
gracefulShutdown :: Settings -> Counter -> IO ()
gracefulShutdown Settings
set Counter
counter =
    case Settings -> Maybe Int
settingsGracefulShutdownTimeout Settings
set of
        Maybe Int
Nothing ->
            Counter -> IO ()
waitForZero Counter
counter
        (Just Int
seconds) ->
            IO (Maybe ()) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Int -> IO () -> IO (Maybe ())
forall a. Int -> IO a -> IO (Maybe a)
timeout (Int
seconds Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
microsPerSecond) (Counter -> IO ()
waitForZero Counter
counter))
            where microsPerSecond :: Int
microsPerSecond = Int
1000000