{-# 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)
import GHC.IO.Exception (IOException(..), IOErrorType(..))
import Network.Socket (Socket, close, withSocketsDo, SockAddr, setSocketOption, SocketOption(..), getSocketName)
#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 <- forall a. a -> IO (IORef a)
newIORef WriteBuffer
writeBuffer
    IORef Bool
isH2 <- forall a. a -> IO (IORef a)
newIORef Bool
False -- HTTP/1.x
    SockAddr
mysa <- Socket -> IO SockAddr
getSocketName Socket
s
    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 <- 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 forall a. Eq a => a -> a -> Bool
== Int
0 then
                Socket -> IO ()
close Socket
s
              else
                Socket -> Int -> IO ()
gracefulClose Socket
s Int
tm forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> (SomeException -> m a) -> m a
`UnliftIO.catchAny` \(UnliftIO.SomeException e
_) -> 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
_ -> 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 = forall (m :: * -> *) a.
MonadUnliftIO m =>
(IOException -> m a) -> m a -> m a
UnliftIO.handleIO IOException -> Recv
handler 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 forall a. Eq a => a -> a -> Bool
== IOErrorType
InvalidArgument = forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
""
          | Bool
otherwise                            = 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 <- 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 = 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 forall a. Eq a => a -> a -> Bool
== IOErrorType
ResourceVanished
        then forall a. a -> Maybe a
Just InvalidRequest
ConnectionClosedByPeer
        else forall a. Maybe a
Nothing)
      forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
UnliftIO.throwIO
      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 [Char]
mp <- [Char] -> IO (Maybe [Char])
lookupEnv [Char]
"PORT"

    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 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])]
_ -> forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail forall a b. (a -> b) -> a -> b
$ [Char]
"Invalid value in $PORT: " 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 = forall a. IO a -> IO a
withSocketsDo forall a b. (a -> b) -> a -> b
$
    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 forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> (SomeException -> m a) -> m a
`UnliftIO.catchAny` \(UnliftIO.SomeException e
_) -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
        Connection
conn <- Settings -> Socket -> IO Connection
socketConnection Settings
set Socket
s
        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
      forall (m :: * -> *) a. Monad m => a -> m a
return (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 (forall {a} {d}. (IO a, d) -> (IO (a, Transport), d)
toTCP 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 = forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first ((, Transport
TCP) 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
    forall a. Settings -> (InternalInfo -> IO a) -> IO a
withII Settings
set 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 =
    forall {c}. (Manager -> IO c) -> IO c
withTimeoutManager forall a b. (a -> b) -> a -> b
$ \Manager
tm ->
    forall a. (Recv -> IO a) -> IO a
D.withDateCache forall a b. (a -> b) -> a -> b
$ \Recv
dc ->
    forall a. Int -> (([Char] -> IO (Maybe Fd, IO ())) -> IO a) -> IO a
F.withFdCache Int
fdCacheDurationInSeconds forall a b. (a -> b) -> a -> b
$ \[Char] -> IO (Maybe Fd, IO ())
fdc ->
    forall a. Int -> (([Char] -> IO FileInfo) -> IO a) -> IO a
I.withFileInfoCache Int
fdFileInfoDurationInSeconds 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 forall a. Num a => a -> a -> a
* Int
1000000
    !fdFileInfoDurationInSeconds :: Int
fdFileInfoDurationInSeconds = Settings -> Int
settingsFileInfoCacheDuration Settings
set forall a. Num a => a -> a -> a
* Int
1000000
    !timeoutInSeconds :: Int
timeoutInSeconds = Settings -> Int
settingsTimeout Settings
set 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 -> 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.
    forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ 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             -> 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 <- 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 -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ 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 forall a. Eq a => a -> a -> Bool
== 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 forall a. Maybe a
Nothing forall a b. (a -> b) -> a -> b
$ forall e. Exception e => e -> SomeException
toException IOException
e
                        forall (m :: * -> *) a. Monad m => a -> m a
return 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 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
    forall e a. Exception e => (e -> IO a) -> IO a -> IO a
Control.Exception.handle (Settings -> Maybe Request -> SomeException -> IO ()
settingsOnException Settings
set forall a. Maybe a
Nothing) 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.
        forall (m :: * -> *) a b c.
MonadUnliftIO m =>
m a -> (a -> m b) -> (a -> m c) -> m c
UnliftIO.bracket IO (Connection, Transport)
mkConn forall {b}. (Connection, b) -> IO ()
cleanUp (forall {c}. (IO () -> IO c) -> (Connection, Transport) -> IO c
serve forall a. IO a -> IO a
unmask)
  where
    cleanUp :: (Connection, b) -> IO ()
cleanUp (Connection
conn, b
_) = Connection -> IO ()
connClose Connection
conn forall (m :: * -> *) a b. MonadUnliftIO m => m a -> m b -> m a
`UnliftIO.finally` do
                          WriteBuffer
writeBuffer <- forall a. IORef a -> IO a
readIORef 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) = 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 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
.
            -- Call the user-supplied code for connection open and
            -- close events
           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) (forall {p}. SockAddr -> p -> IO ()
onClose SockAddr
addr) forall a b. (a -> b) -> a -> b
$ \Bool
goingon ->
           -- Actually serve this connection.  bracket with closeConn
           -- above ensures the connection is closed.
           forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
goingon 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 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 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
                   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 forall a. Ord a => a -> a -> Bool
>= Int
4 Bool -> Bool -> Bool
&& ByteString
"PRI " ByteString -> ByteString -> Bool
`S.isPrefixOf` ByteString
bs0 then
                       forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
True, ByteString
bs0)
                     else
                       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 forall a b. (a -> b) -> a -> b
$ 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) ->
            forall (f :: * -> *) a. Functor f => f a -> f ()
void (forall a. Int -> IO a -> IO (Maybe a)
timeout (Int
seconds forall a. Num a => a -> a -> a
* Int
microsPerSecond) (Counter -> IO ()
waitForZero Counter
counter))
            where microsPerSecond :: Int
microsPerSecond = Int
1000000