{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PackageImports #-}
{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE ViewPatterns #-}
{-# OPTIONS_GHC -fno-warn-deprecations #-}

module Network.Wai.Handler.Warp.Run where

import "iproute" Data.IP (toHostAddress, toHostAddress6)
import Control.Arrow (first)
import qualified Control.Concurrent as Conc (yield)
import Control.Exception as E
import qualified Data.ByteString as S
import Data.Char (chr)
import Data.IORef (IORef, newIORef, readIORef, writeIORef)
import Data.Streaming.Network (bindPortTCP)
import Foreign.C.Error (Errno(..), eCONNABORTED)
import GHC.IO.Exception (IOException(..), IOErrorType(..))
import qualified Network.HTTP2 as H2
import Network.Socket (Socket, close, accept, withSocketsDo, SockAddr(SockAddrInet, SockAddrInet6), setSocketOption, SocketOption(..))
#if MIN_VERSION_network(3,1,1)
import Network.Socket (gracefulClose)
#endif
import qualified Network.Socket.ByteString as Sock
import Network.Wai
import Network.Wai.Internal (ResponseReceived (ResponseReceived))
import System.Environment (lookupEnv)
import System.IO.Error (ioeGetErrorType)
import qualified System.TimeManager as T
import System.Timeout (timeout)

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.HTTP2 (http2)
import Network.Wai.Handler.Warp.HTTP2.Types (isHTTP2)
import Network.Wai.Handler.Warp.Header
import Network.Wai.Handler.Warp.Imports hiding (readInt)
import Network.Wai.Handler.Warp.ReadInt
import Network.Wai.Handler.Warp.Recv
import Network.Wai.Handler.Warp.Request
import Network.Wai.Handler.Warp.Response
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 set :: Settings
set s :: Socket
s = do
#else
socketConnection _ s = do
#endif
    BufferPool
bufferPool <- IO BufferPool
newBufferPool
    Buffer
writeBuf <- Int -> IO Buffer
allocateBuffer Int
bufferSize
    let sendall :: ByteString -> IO ()
sendall = Socket -> ByteString -> IO ()
sendAll' Socket
s
    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 $WConnection :: ([ByteString] -> IO ())
-> (ByteString -> IO ())
-> SendFile
-> IO ()
-> IO ()
-> Recv
-> RecvBuf
-> Buffer
-> Int
-> 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 = Socket -> Buffer -> Int -> (ByteString -> IO ()) -> SendFile
sendFile Socket
s Buffer
writeBuf Int
bufferSize ByteString -> IO ()
sendall
#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
== 0 then
                Socket -> IO ()
close Socket
s
              else
                Socket -> Int -> IO ()
gracefulClose Socket
s Int
tm IO () -> (SomeException -> IO ()) -> IO ()
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`E.catch` \(E.SomeException _) -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
#else
      , connClose = close s
#endif
      , connFree :: IO ()
connFree = Buffer -> IO ()
freeBuffer Buffer
writeBuf
      , connRecv :: Recv
connRecv = Socket -> BufferPool -> Recv
receive Socket
s BufferPool
bufferPool
      , connRecvBuf :: RecvBuf
connRecvBuf = Socket -> RecvBuf
receiveBuf Socket
s
      , connWriteBuffer :: Buffer
connWriteBuffer = Buffer
writeBuf
      , connBufferSize :: Int
connBufferSize = Int
bufferSize
      , connHTTP2 :: IORef Bool
connHTTP2 = IORef Bool
isH2
      }
  where
    sendAll' :: Socket -> ByteString -> IO ()
sendAll' sock :: Socket
sock bs :: ByteString
bs = (IOError -> Maybe InvalidRequest)
-> (InvalidRequest -> IO ()) -> IO () -> IO ()
forall e b a.
Exception e =>
(e -> Maybe b) -> (b -> IO a) -> IO a -> IO a
E.handleJust
      (\ e :: IOError
e -> if IOError -> IOErrorType
ioeGetErrorType IOError
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 e a. Exception e => e -> IO a
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 p :: 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 p :: Int
p app :: Application
app = do
    Maybe String
mp <- String -> IO (Maybe String)
lookupEnv "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 sp :: String
sp = case ReadS Int
forall a. Read a => ReadS a
reads String
sp of
        ((p' :: Int
p', _):_) -> Int -> Application -> IO ()
run Int
p' Application
app
        _ -> String -> IO ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ "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 set :: Settings
set app :: 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 a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket
        (Int -> HostPreference -> IO Socket
bindPortTCP (Settings -> Int
settingsPort Settings
set) (Settings -> HostPreference
settingsHost Settings
set))
        Socket -> IO ()
close
        (\socket :: 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 socket :: Socket
socket app :: 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
#if WINDOWS
        (s, sa) <- windowsThreadBlockHack $ accept socket
#else
        (s :: Socket
s, sa :: SockAddr
sa) <- Socket -> IO (Socket, SockAddr)
accept Socket
socket
#endif
        Socket -> IO ()
setSocketCloseOnExec Socket
s
        -- NoDelay causes an error for AF_UNIX.
        Socket -> SocketOption -> Int -> IO ()
setSocketOption Socket
s SocketOption
NoDelay 1 IO () -> (SomeException -> IO ()) -> IO ()
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`E.catch` \(E.SomeException _) -> () -> 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 set :: Settings
set getConn :: IO (Connection, SockAddr)
getConn app :: 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
      (conn :: Connection
conn, sa :: 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 x :: Settings
x y :: 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 set :: Settings
set getConnMaker :: IO (IO (Connection, Transport), SockAddr)
getConnMaker app :: 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 set :: Settings
set action :: 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
$ \tm :: 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
$ \dc :: 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
$ \fdc :: 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
$ \fic :: 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
* 1000000
    !fdFileInfoDurationInSeconds :: Int
fdFileInfoDurationInSeconds = Settings -> Int
settingsFileInfoCacheDuration Settings
set Int -> Int -> Int
forall a. Num a => a -> a -> a
* 1000000
    !timeoutInSeconds :: Int
timeoutInSeconds = Settings -> Int
settingsTimeout Settings
set Int -> Int -> Int
forall a. Num a => a -> a -> a
* 1000000
    withTimeoutManager :: (Manager -> IO c) -> IO c
withTimeoutManager f :: Manager -> IO c
f = case Settings -> Maybe Manager
settingsManager Settings
set of
        Just tm :: Manager
tm -> Manager -> IO c
f Manager
tm
        Nothing -> IO Manager -> (Manager -> IO ()) -> (Manager -> IO c) -> IO c
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
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 set :: Settings
set getConnMaker :: IO (IO (Connection, Transport), SockAddr)
getConnMaker app :: Application
app counter :: Counter
counter ii :: 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 listing 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 a. IO a -> IO a
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
            Nothing             -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
            Just (mkConn :: IO (Connection, Transport)
mkConn, addr :: 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 IOError (IO (Connection, Transport), SockAddr)
ex <- IO (IO (Connection, Transport), SockAddr)
-> IO (Either IOError (IO (Connection, Transport), SockAddr))
forall e a. Exception e => IO a -> IO (Either e a)
try IO (IO (Connection, Transport), SockAddr)
getConnMaker
        case Either IOError (IO (Connection, Transport), SockAddr)
ex of
            Right x :: (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 e :: IOError
e -> do
                let eConnAborted :: CInt
eConnAborted = Errno -> CInt
getErrno Errno
eCONNABORTED
                    getErrno :: Errno -> CInt
getErrno (Errno cInt :: CInt
cInt) = CInt
cInt
                if IOError -> Maybe CInt
ioe_errno IOError
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
$ IOError -> SomeException
forall e. Exception e => e -> SomeException
toException IOError
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 set :: Settings
set mkConn :: IO (Connection, Transport)
mkConn addr :: SockAddr
addr app :: Application
app counter :: Counter
counter ii :: 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
$ \unmask :: forall a. IO a -> IO a
unmask ->
    -- Call the user-supplied on exception code if any
    -- exceptions are thrown.
    (SomeException -> IO ()) -> IO () -> IO ()
forall e a. Exception e => (e -> IO a) -> IO a -> IO a
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 a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
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 (conn :: Connection
conn, _) = Connection -> IO ()
connClose Connection
conn IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO a
`finally` Connection -> IO ()
connFree Connection
conn

    -- 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 unmask :: IO () -> IO c
unmask (conn :: Connection
conn, transport :: Transport
transport) = IO Handle -> (Handle -> IO ()) -> (Handle -> IO c) -> IO c
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket IO Handle
register Handle -> IO ()
cancel ((Handle -> IO c) -> IO c) -> (Handle -> IO c) -> IO c
forall a b. (a -> b) -> a -> b
$ \th :: 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 a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
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
$ \goingon :: 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 adr :: 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 adr :: SockAddr
adr _ = 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 conn :: Connection
conn ii :: InternalInfo
ii th :: Handle
th origAddr :: SockAddr
origAddr transport :: Transport
transport settings :: Settings
settings app :: Application
app = do
    -- fixme: Upgrading to HTTP/2 should be supported.
    (h2 :: Bool
h2,bs :: 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, "")
                 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
>= 4 Bool -> Bool -> Bool
&& "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)
    IORef Bool
istatus <- Bool -> IO (IORef Bool)
forall a. a -> IO (IORef a)
newIORef Bool
False
    if Settings -> Bool
settingsHTTP2Enabled Settings
settings Bool -> Bool -> Bool
&& Bool
h2 then do
        Int -> Recv
rawRecvN <- ByteString -> Recv -> RecvBuf -> IO (Int -> Recv)
makeReceiveN ByteString
bs (Connection -> Recv
connRecv Connection
conn) (Connection -> RecvBuf
connRecvBuf Connection
conn)
        -- This thread becomes the sender in http2 library.
        -- In the case of event source, one request comes and one
        -- worker gets busy. But it is likely that the receiver does
        -- not receive any data at all while the sender is sending
        -- output data from the worker. It's not good enough to tickle
        -- the time handler in the receiver only. So, we should tickle
        -- the time handler in both the receiver and the sender.
        let recvN :: Int -> Recv
recvN = Handle -> IORef Bool -> Int -> (Int -> Recv) -> Int -> Recv
wrappedRecvN Handle
th IORef Bool
istatus (Settings -> Int
settingsSlowlorisSize Settings
settings) Int -> Recv
rawRecvN
            sendBS :: ByteString -> IO ()
sendBS x :: ByteString
x = Connection -> ByteString -> IO ()
connSendAll Connection
conn ByteString
x IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Handle -> IO ()
T.tickle Handle
th
        -- fixme: origAddr
        IO ()
checkTLS
        Connection -> Bool -> IO ()
setConnHTTP2 Connection
conn Bool
True
        Settings
-> InternalInfo
-> Connection
-> Transport
-> SockAddr
-> (Int -> Recv)
-> (ByteString -> IO ())
-> Application
-> IO ()
http2 Settings
settings InternalInfo
ii Connection
conn Transport
transport SockAddr
origAddr Int -> Recv
recvN ByteString -> IO ()
sendBS Application
app
      else do
        Source
src <- Recv -> IO Source
mkSource (Connection -> Handle -> IORef Bool -> Int -> Recv
wrappedRecv Connection
conn Handle
th IORef Bool
istatus (Settings -> Int
settingsSlowlorisSize Settings
settings))
        IORef Bool -> Bool -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef Bool
istatus Bool
True
        Source -> ByteString -> IO ()
leftoverSource Source
src ByteString
bs
        SockAddr
addr <- Source -> IO SockAddr
getProxyProtocolAddr Source
src
        Bool -> SockAddr -> IORef Bool -> Source -> IO ()
http1 Bool
True SockAddr
addr IORef Bool
istatus Source
src IO () -> (SomeException -> IO ()) -> IO ()
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`E.catch` \e :: SomeException
e ->
          case () of
            ()
             -- See comment below referencing
             -- https://github.com/yesodweb/wai/issues/618
             | Just NoKeepAliveRequest <- SomeException -> Maybe NoKeepAliveRequest
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
e -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
             -- No valid request
             | Just (BadFirstLine _)   <- SomeException -> Maybe InvalidRequest
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
e -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
             | Bool
otherwise -> do
               Bool
_ <- Request -> IORef Bool -> SomeException -> IO Bool
sendErrorResponse (SockAddr -> Request
dummyreq SockAddr
addr) IORef Bool
istatus SomeException
e
               SomeException -> IO ()
forall e a. Exception e => e -> IO a
throwIO SomeException
e

  where
    getProxyProtocolAddr :: Source -> IO SockAddr
getProxyProtocolAddr src :: Source
src =
        case Settings -> ProxyProtocol
settingsProxyProtocol Settings
settings of
            ProxyProtocolNone ->
                SockAddr -> IO SockAddr
forall (m :: * -> *) a. Monad m => a -> m a
return SockAddr
origAddr
            ProxyProtocolRequired -> do
                ByteString
seg <- Source -> Recv
readSource Source
src
                Source -> ByteString -> IO SockAddr
parseProxyProtocolHeader Source
src ByteString
seg
            ProxyProtocolOptional -> do
                ByteString
seg <- Source -> Recv
readSource Source
src
                if ByteString -> ByteString -> Bool
S.isPrefixOf "PROXY " ByteString
seg
                    then Source -> ByteString -> IO SockAddr
parseProxyProtocolHeader Source
src ByteString
seg
                    else do Source -> ByteString -> IO ()
leftoverSource Source
src ByteString
seg
                            SockAddr -> IO SockAddr
forall (m :: * -> *) a. Monad m => a -> m a
return SockAddr
origAddr

    parseProxyProtocolHeader :: Source -> ByteString -> IO SockAddr
parseProxyProtocolHeader src :: Source
src seg :: ByteString
seg = do
        let (header :: ByteString
header,seg' :: ByteString
seg') = (Word8 -> Bool) -> ByteString -> (ByteString, ByteString)
S.break (Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== 0x0d) ByteString
seg -- 0x0d == CR
            maybeAddr :: Maybe SockAddr
maybeAddr = case Word8 -> ByteString -> [ByteString]
S.split 0x20 ByteString
header of -- 0x20 == space
                ["PROXY","TCP4",clientAddr :: ByteString
clientAddr,_,clientPort :: ByteString
clientPort,_] ->
                    case [IPv4
x | (x :: IPv4
x, t :: String
t) <- ReadS IPv4
forall a. Read a => ReadS a
reads (ByteString -> String
decodeAscii ByteString
clientAddr), String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
t] of
                        [a :: IPv4
a] -> SockAddr -> Maybe SockAddr
forall a. a -> Maybe a
Just (PortNumber -> HostAddress -> SockAddr
SockAddrInet (ByteString -> PortNumber
forall a. Integral a => ByteString -> a
readInt ByteString
clientPort)
                                                       (IPv4 -> HostAddress
toHostAddress IPv4
a))
                        _ -> Maybe SockAddr
forall a. Maybe a
Nothing
                ["PROXY","TCP6",clientAddr :: ByteString
clientAddr,_,clientPort :: ByteString
clientPort,_] ->
                    case [IPv6
x | (x :: IPv6
x, t :: String
t) <- ReadS IPv6
forall a. Read a => ReadS a
reads (ByteString -> String
decodeAscii ByteString
clientAddr), String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
t] of
                        [a :: IPv6
a] -> SockAddr -> Maybe SockAddr
forall a. a -> Maybe a
Just (PortNumber
-> HostAddress -> HostAddress6 -> HostAddress -> SockAddr
SockAddrInet6 (ByteString -> PortNumber
forall a. Integral a => ByteString -> a
readInt ByteString
clientPort)
                                                        0
                                                        (IPv6 -> HostAddress6
toHostAddress6 IPv6
a)
                                                        0)
                        _ -> Maybe SockAddr
forall a. Maybe a
Nothing
                ("PROXY":"UNKNOWN":_) ->
                    SockAddr -> Maybe SockAddr
forall a. a -> Maybe a
Just SockAddr
origAddr
                _ ->
                    Maybe SockAddr
forall a. Maybe a
Nothing
        case Maybe SockAddr
maybeAddr of
            Nothing -> InvalidRequest -> IO SockAddr
forall e a. Exception e => e -> IO a
throwIO (String -> InvalidRequest
BadProxyHeader (ByteString -> String
decodeAscii ByteString
header))
            Just a :: SockAddr
a -> do Source -> ByteString -> IO ()
leftoverSource Source
src (Int -> ByteString -> ByteString
S.drop 2 ByteString
seg') -- drop CRLF
                         SockAddr -> IO SockAddr
forall (m :: * -> *) a. Monad m => a -> m a
return SockAddr
a

    decodeAscii :: ByteString -> String
decodeAscii = (Word8 -> Char) -> [Word8] -> String
forall a b. (a -> b) -> [a] -> [b]
map (Int -> Char
chr (Int -> Char) -> (Word8 -> Int) -> Word8 -> Char
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word8 -> Int
forall a. Enum a => a -> Int
fromEnum) ([Word8] -> String)
-> (ByteString -> [Word8]) -> ByteString -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [Word8]
S.unpack

    shouldSendErrorResponse :: SomeException -> Bool
shouldSendErrorResponse se :: SomeException
se
        | Just ConnectionClosedByPeer <- SomeException -> Maybe InvalidRequest
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
se = Bool
False
        | Bool
otherwise                                       = Bool
True

    sendErrorResponse :: Request -> IORef Bool -> SomeException -> IO Bool
sendErrorResponse req :: Request
req istatus :: IORef Bool
istatus e :: SomeException
e = do
        Bool
status <- IORef Bool -> IO Bool
forall a. IORef a -> IO a
readIORef IORef Bool
istatus
        if SomeException -> Bool
shouldSendErrorResponse SomeException
e Bool -> Bool -> Bool
&& Bool
status
            then do
                Settings
-> Connection
-> InternalInfo
-> Handle
-> Request
-> IndexedHeader
-> Recv
-> Response
-> IO Bool
sendResponse Settings
settings Connection
conn InternalInfo
ii Handle
th Request
req IndexedHeader
defaultIndexRequestHeader (ByteString -> Recv
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
S.empty) (SomeException -> Response
errorResponse SomeException
e)
            else Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False

    dummyreq :: SockAddr -> Request
dummyreq addr :: SockAddr
addr = Request
defaultRequest { remoteHost :: SockAddr
remoteHost = SockAddr
addr }

    errorResponse :: SomeException -> Response
errorResponse e :: SomeException
e = Settings -> SomeException -> Response
settingsOnExceptionResponse Settings
settings SomeException
e

    http1 :: Bool -> SockAddr -> IORef Bool -> Source -> IO ()
http1 firstRequest :: Bool
firstRequest addr :: SockAddr
addr istatus :: IORef Bool
istatus src :: Source
src = do
        (req :: Request
req, mremainingRef :: Maybe (IORef Int)
mremainingRef, idxhdr :: IndexedHeader
idxhdr, nextBodyFlush :: Recv
nextBodyFlush) <- Bool
-> Settings
-> Connection
-> InternalInfo
-> Handle
-> SockAddr
-> Source
-> Transport
-> IO (Request, Maybe (IORef Int), IndexedHeader, Recv)
recvRequest Bool
firstRequest Settings
settings Connection
conn InternalInfo
ii Handle
th SockAddr
addr Source
src Transport
transport
        Bool
keepAlive <- IORef Bool
-> Source
-> Request
-> Maybe (IORef Int)
-> IndexedHeader
-> Recv
-> IO Bool
processRequest IORef Bool
istatus Source
src Request
req Maybe (IORef Int)
mremainingRef IndexedHeader
idxhdr Recv
nextBodyFlush
            IO Bool -> (SomeException -> IO Bool) -> IO Bool
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`E.catch` \e :: SomeException
e -> do
                Settings -> Maybe Request -> SomeException -> IO ()
settingsOnException Settings
settings (Request -> Maybe Request
forall a. a -> Maybe a
Just Request
req) SomeException
e
                -- Don't throw the error again to prevent calling settingsOnException twice.
                Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False

        -- When doing a keep-alive connection, the other side may just
        -- close the connection. We don't want to treat that as an
        -- exceptional situation, so we pass in False to http1 (which
        -- in turn passes in False to recvRequest), indicating that
        -- this is not the first request. If, when trying to read the
        -- request headers, no data is available, recvRequest will
        -- throw a NoKeepAliveRequest exception, which we catch here
        -- and ignore. See: https://github.com/yesodweb/wai/issues/618
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
keepAlive (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Bool -> SockAddr -> IORef Bool -> Source -> IO ()
http1 Bool
False SockAddr
addr IORef Bool
istatus Source
src

    processRequest :: IORef Bool
-> Source
-> Request
-> Maybe (IORef Int)
-> IndexedHeader
-> Recv
-> IO Bool
processRequest istatus :: IORef Bool
istatus src :: Source
src req :: Request
req mremainingRef :: Maybe (IORef Int)
mremainingRef idxhdr :: IndexedHeader
idxhdr nextBodyFlush :: Recv
nextBodyFlush = do
        -- Let the application run for as long as it wants
        Handle -> IO ()
T.pause Handle
th

        -- In the event that some scarce resource was acquired during
        -- creating the request, we need to make sure that we don't get
        -- an async exception before calling the ResponseSource.
        IORef Bool
keepAliveRef <- Bool -> IO (IORef Bool)
forall a. a -> IO (IORef a)
newIORef (Bool -> IO (IORef Bool)) -> Bool -> IO (IORef Bool)
forall a b. (a -> b) -> a -> b
$ String -> Bool
forall a. HasCallStack => String -> a
error "keepAliveRef not filled"
        Either SomeException ResponseReceived
r <- IO ResponseReceived -> IO (Either SomeException ResponseReceived)
forall e a. Exception e => IO a -> IO (Either e a)
E.try (IO ResponseReceived -> IO (Either SomeException ResponseReceived))
-> IO ResponseReceived
-> IO (Either SomeException ResponseReceived)
forall a b. (a -> b) -> a -> b
$ Application
app Request
req ((Response -> IO ResponseReceived) -> IO ResponseReceived)
-> (Response -> IO ResponseReceived) -> IO ResponseReceived
forall a b. (a -> b) -> a -> b
$ \res :: Response
res -> do
            Handle -> IO ()
T.resume Handle
th
            -- FIXME consider forcing evaluation of the res here to
            -- send more meaningful error messages to the user.
            -- However, it may affect performance.
            IORef Bool -> Bool -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef Bool
istatus Bool
False
            Bool
keepAlive <- Settings
-> Connection
-> InternalInfo
-> Handle
-> Request
-> IndexedHeader
-> Recv
-> Response
-> IO Bool
sendResponse Settings
settings Connection
conn InternalInfo
ii Handle
th Request
req IndexedHeader
idxhdr (Source -> Recv
readSource Source
src) Response
res
            IORef Bool -> Bool -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef Bool
keepAliveRef Bool
keepAlive
            ResponseReceived -> IO ResponseReceived
forall (m :: * -> *) a. Monad m => a -> m a
return ResponseReceived
ResponseReceived
        case Either SomeException ResponseReceived
r of
            Right ResponseReceived -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
            Left e :: SomeException
e@(SomeException _)
              | Just (ExceptionInsideResponseBody e' :: SomeException
e') <- SomeException -> Maybe ExceptionInsideResponseBody
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
e -> SomeException -> IO ()
forall e a. Exception e => e -> IO a
throwIO SomeException
e'
              | Bool
otherwise -> do
                    Bool
keepAlive <- Request -> IORef Bool -> SomeException -> IO Bool
sendErrorResponse Request
req IORef Bool
istatus SomeException
e
                    Settings -> Maybe Request -> SomeException -> IO ()
settingsOnException Settings
settings (Request -> Maybe Request
forall a. a -> Maybe a
Just Request
req) SomeException
e
                    IORef Bool -> Bool -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef Bool
keepAliveRef Bool
keepAlive

        Bool
keepAlive <- IORef Bool -> IO Bool
forall a. IORef a -> IO a
readIORef IORef Bool
keepAliveRef

        -- We just send a Response and it takes a time to
        -- receive a Request again. If we immediately call recv,
        -- it is likely to fail and cause the IO manager to do some work.
        -- It is very costly, so we yield to another Haskell
        -- thread hoping that the next Request will arrive
        -- when this Haskell thread will be re-scheduled.
        -- This improves performance at least when
        -- the number of cores is small.
        IO ()
Conc.yield

        if Bool
keepAlive
          then
            -- If there is an unknown or large amount of data to still be read
            -- from the request body, simple drop this connection instead of
            -- reading it all in to satisfy a keep-alive request.
            case Settings -> Maybe Int
settingsMaximumBodyFlush Settings
settings of
                Nothing -> do
                    Recv -> IO ()
flushEntireBody Recv
nextBodyFlush
                    Handle -> IO ()
T.resume Handle
th
                    Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
                Just maxToRead :: Int
maxToRead -> do
                    let tryKeepAlive :: IO Bool
tryKeepAlive = do
                            -- flush the rest of the request body
                            Bool
isComplete <- Recv -> Int -> IO Bool
flushBody Recv
nextBodyFlush Int
maxToRead
                            if Bool
isComplete then do
                                Handle -> IO ()
T.resume Handle
th
                                Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
                              else
                                Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
                    case Maybe (IORef Int)
mremainingRef of
                        Just ref :: IORef Int
ref -> do
                            Int
remaining <- IORef Int -> IO Int
forall a. IORef a -> IO a
readIORef IORef Int
ref
                            if Int
remaining Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
maxToRead then
                                IO Bool
tryKeepAlive
                              else
                                Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
                        Nothing -> IO Bool
tryKeepAlive
          else
            Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False

    checkTLS :: IO ()
checkTLS = case Transport
transport of
        TCP -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return () -- direct
        tls :: Transport
tls -> Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Transport -> Bool
tls12orLater Transport
tls) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Connection -> ErrorCodeId -> ByteString -> IO ()
goaway Connection
conn ErrorCodeId
H2.InadequateSecurity "Weak TLS"
    tls12orLater :: Transport -> Bool
tls12orLater tls :: Transport
tls = Transport -> Int
tlsMajorVersion Transport
tls Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 3 Bool -> Bool -> Bool
&& Transport -> Int
tlsMinorVersion Transport
tls Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= 3

-- connClose must not be called here since Run:fork calls it
goaway :: Connection -> H2.ErrorCodeId -> ByteString -> IO ()
goaway :: Connection -> ErrorCodeId -> ByteString -> IO ()
goaway Connection{..} etype :: ErrorCodeId
etype debugmsg :: ByteString
debugmsg = ByteString -> IO ()
connSendAll ByteString
bytestream
  where
    einfo :: EncodeInfo
einfo = (Word8 -> Word8) -> Int -> EncodeInfo
H2.encodeInfo Word8 -> Word8
forall a. a -> a
id 0
    frame :: FramePayload
frame = Int -> ErrorCodeId -> ByteString -> FramePayload
H2.GoAwayFrame 0 ErrorCodeId
etype ByteString
debugmsg
    bytestream :: ByteString
bytestream = EncodeInfo -> FramePayload -> ByteString
H2.encodeFrame EncodeInfo
einfo FramePayload
frame

flushEntireBody :: IO ByteString -> IO ()
flushEntireBody :: Recv -> IO ()
flushEntireBody src :: Recv
src =
    IO ()
loop
  where
    loop :: IO ()
loop = do
        ByteString
bs <- Recv
src
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (ByteString -> Bool
S.null ByteString
bs) IO ()
loop

flushBody :: IO ByteString -- ^ get next chunk
          -> Int -- ^ maximum to flush
          -> IO Bool -- ^ True == flushed the entire body, False == we didn't
flushBody :: Recv -> Int -> IO Bool
flushBody src :: Recv
src =
    Int -> IO Bool
loop
  where
    loop :: Int -> IO Bool
loop toRead :: Int
toRead = do
        ByteString
bs <- Recv
src
        let toRead' :: Int
toRead' = Int
toRead Int -> Int -> Int
forall a. Num a => a -> a -> a
- ByteString -> Int
S.length ByteString
bs
        case () of
            ()
                | ByteString -> Bool
S.null ByteString
bs -> Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
                | Int
toRead' Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= 0 -> Int -> IO Bool
loop Int
toRead'
                | Bool
otherwise -> Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False

wrappedRecv :: Connection -> T.Handle -> IORef Bool -> Int -> IO ByteString
wrappedRecv :: Connection -> Handle -> IORef Bool -> Int -> Recv
wrappedRecv Connection { connRecv :: Connection -> Recv
connRecv = Recv
recv } th :: Handle
th istatus :: IORef Bool
istatus slowlorisSize :: Int
slowlorisSize = do
    ByteString
bs <- Recv
recv
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (ByteString -> Bool
S.null ByteString
bs) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        IORef Bool -> Bool -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef Bool
istatus Bool
True
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ByteString -> Int
S.length ByteString
bs Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
slowlorisSize) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Handle -> IO ()
T.tickle Handle
th
    ByteString -> Recv
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
bs

wrappedRecvN :: T.Handle -> IORef Bool -> Int -> (BufSize -> IO ByteString) -> (BufSize -> IO ByteString)
wrappedRecvN :: Handle -> IORef Bool -> Int -> (Int -> Recv) -> Int -> Recv
wrappedRecvN th :: Handle
th istatus :: IORef Bool
istatus slowlorisSize :: Int
slowlorisSize readN :: Int -> Recv
readN bufsize :: Int
bufsize = do
    ByteString
bs <- Int -> Recv
readN Int
bufsize
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (ByteString -> Bool
S.null ByteString
bs) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        IORef Bool -> Bool -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef Bool
istatus Bool
True
    -- TODO: think about the slowloris protection in HTTP2: current code
    -- might open a slow-loris attack vector. Rather than timing we should
    -- consider limiting the per-client connections assuming that in HTTP2
    -- we should allow only few connections per host (real-world
    -- deployments with large NATs may be trickier).
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ByteString -> Int
S.length ByteString
bs Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
slowlorisSize Bool -> Bool -> Bool
|| Int
bufsize Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
slowlorisSize) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Handle -> IO ()
T.tickle Handle
th
    ByteString -> Recv
forall (m :: * -> *) a. Monad m => a -> m a
return 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
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 set :: Settings
set counter :: Counter
counter =
    case Settings -> Maybe Int
settingsGracefulShutdownTimeout Settings
set of
        Nothing ->
            Counter -> IO ()
waitForZero Counter
counter
        (Just seconds :: 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 = 1000000