{-# 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 Control.Exception (allowInterrupt)
import qualified Control.Exception
import qualified Data.ByteString as S
import Data.IORef (newIORef, readIORef)
import Data.Streaming.Network (bindPortTCP)
import Foreign.C.Error (Errno (..), eCONNABORTED)
import GHC.IO.Exception (IOErrorType (..), IOException (..))
import Network.Socket (
    SockAddr,
    Socket,
    SocketOption (..),
    close,
#if !WINDOWS
    fdSocket,
#endif
    getSocketName,
    setSocketOption,
    withSocketsDo,
 )
#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 UnliftIO (toException)
import qualified UnliftIO

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
#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
    SockAddr
mysa <- Socket -> IO SockAddr
getSocketName Socket
s
    Connection -> IO Connection
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return
        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 a. a -> IO a
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 a. a -> IO a
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
            , connMySockAddr :: SockAddr
connMySockAddr = SockAddr
mysa
            }
  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 a. a -> IO a
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 = 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 [Char]
mp <- [Char] -> IO (Maybe [Char])
lookupEnv [Char]
"PORT"

    IO () -> ([Char] -> IO ()) -> Maybe [Char] -> IO ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Int -> Application -> IO ()
run Int
p Application
app) [Char] -> IO ()
runReadPort Maybe [Char]
mp
  where
    runReadPort :: String -> IO ()
    runReadPort :: [Char] -> IO ()
runReadPort [Char]
sp = case ReadS Int
forall a. Read a => ReadS a
reads [Char]
sp of
        ((Int
p', [Char]
_) : [(Int, [Char])]
_) -> Int -> Application -> IO ()
run Int
p' Application
app
        [(Int, [Char])]
_ -> [Char] -> IO ()
forall a. [Char] -> IO a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"Invalid value in $PORT: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
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 a. a -> IO a
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 a. a -> IO a
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 a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Connection -> IO Connection
forall a. a -> IO a
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 {a} {d}. (IO a, d) -> (IO (a, 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 a, d) -> (IO (a, Transport), d)
toTCP = (IO a -> IO (a, Transport)) -> (IO a, d) -> (IO (a, Transport), d)
forall b c d. (b -> c) -> (b, d) -> (c, d)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first ((,Transport
TCP) (a -> (a, Transport)) -> IO a -> IO (a, 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 :: forall a. 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 -> (([Char] -> IO (Maybe Fd, IO ())) -> IO a) -> IO a
forall a. Int -> (([Char] -> IO (Maybe Fd, IO ())) -> IO a) -> IO a
F.withFdCache Int
fdCacheDurationInSeconds ((([Char] -> IO (Maybe Fd, IO ())) -> IO a) -> IO a)
-> (([Char] -> IO (Maybe Fd, IO ())) -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \[Char] -> IO (Maybe Fd, IO ())
fdc ->
                Int -> (([Char] -> IO FileInfo) -> IO a) -> IO a
forall a. Int -> (([Char] -> IO FileInfo) -> IO a) -> IO a
I.withFileInfoCache Int
fdFileInfoDurationInSeconds ((([Char] -> IO FileInfo) -> IO a) -> IO a)
-> (([Char] -> IO FileInfo) -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \[Char] -> IO FileInfo
fic -> do
                    let ii :: InternalInfo
ii = Manager
-> Recv
-> ([Char] -> IO (Maybe Fd, IO ()))
-> ([Char] -> IO FileInfo)
-> InternalInfo
InternalInfo Manager
tm Recv
dc [Char] -> IO (Maybe Fd, IO ())
fdc [Char] -> 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 a. a -> IO a
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 a. a -> IO a
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 eConnAborted :: CInt
eConnAborted = Errno -> CInt
getErrno Errno
eCONNABORTED
                    getErrno :: Errno -> CInt
getErrno (Errno CInt
cInt) = CInt
cInt
                if IOException -> Maybe CInt
ioe_errno IOException
e Maybe CInt -> Maybe CInt -> Bool
forall a. Eq a => a -> a -> Bool
== CInt -> Maybe CInt
forall a. a -> Maybe a
Just CInt
eConnAborted
                    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 a. a -> IO a
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 a b. IO a -> IO b -> IO b
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 a b. IO a -> IO b -> IO b
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 a. a -> IO a
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 a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
True, ByteString
bs0)
                    else (Bool, ByteString) -> IO (Bool, ByteString)
forall a. a -> IO a
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