{-# LANGUAGE OverloadedStrings, ScopedTypeVariables, ViewPatterns #-}
{-# LANGUAGE PatternGuards, RankNTypes #-}
{-# LANGUAGE ImpredicativeTypes, CPP #-}
{-# LANGUAGE MagicHash, UnboxedTuples #-}

module Network.Wai.Handler.Warp.Settings where

import GHC.IO (unsafeUnmask, IO (IO))
import GHC.Prim (fork#)
import UnliftIO (SomeException, fromException)
import qualified Data.ByteString.Char8 as C8
import qualified Data.ByteString.Builder as Builder
import Data.Streaming.Network (HostPreference)
import qualified Data.Text as T
import qualified Data.Text.IO as TIO
import Data.Version (showVersion)
import GHC.IO.Exception (IOErrorType(..), AsyncException (ThreadKilled))
import qualified Network.HTTP.Types as H
import Network.Socket (Socket, SockAddr, accept)
import Network.Wai
import qualified Paths_warp
import System.IO (stderr)
import System.IO.Error (ioeGetErrorType)
import System.TimeManager

import Network.Wai.Handler.Warp.Imports
import Network.Wai.Handler.Warp.Types
import Network.Wai.Handler.Warp.Windows (windowsThreadBlockHack)

-- | Various Warp server settings. This is purposely kept as an abstract data
-- type so that new settings can be added without breaking backwards
-- compatibility. In order to create a 'Settings' value, use 'defaultSettings'
-- and the various \'set\' functions to modify individual fields. For example:
--
-- > setTimeout 20 defaultSettings
data Settings = Settings
    { Settings -> Port
settingsPort :: Port -- ^ Port to listen on. Default value: 3000
    , Settings -> HostPreference
settingsHost :: HostPreference -- ^ Default value: HostIPv4
    , Settings -> Maybe Request -> SomeException -> IO ()
settingsOnException :: Maybe Request -> SomeException -> IO () -- ^ What to do with exceptions thrown by either the application or server. Default: ignore server-generated exceptions (see 'InvalidRequest') and print application-generated applications to stderr.
    , Settings -> SomeException -> Response
settingsOnExceptionResponse :: SomeException -> Response
      -- ^ A function to create `Response` when an exception occurs.
      --
      -- Default: 500, text/plain, \"Something went wrong\"
      --
      -- Since 2.0.3
    , Settings -> SockAddr -> IO Bool
settingsOnOpen :: SockAddr -> IO Bool -- ^ What to do when a connection is open. When 'False' is returned, the connection is closed immediately. Otherwise, the connection is going on. Default: always returns 'True'.
    , Settings -> SockAddr -> IO ()
settingsOnClose :: SockAddr -> IO ()  -- ^ What to do when a connection is close. Default: do nothing.
    , Settings -> Port
settingsTimeout :: Int -- ^ Timeout value in seconds. Default value: 30
    , Settings -> Maybe Manager
settingsManager :: Maybe Manager -- ^ Use an existing timeout manager instead of spawning a new one. If used, 'settingsTimeout' is ignored. Default is 'Nothing'
    , Settings -> Port
settingsFdCacheDuration :: Int -- ^ Cache duration time of file descriptors in seconds. 0 means that the cache mechanism is not used. Default value: 0
    , Settings -> Port
settingsFileInfoCacheDuration :: Int -- ^ Cache duration time of file information in seconds. 0 means that the cache mechanism is not used. Default value: 0
    , Settings -> IO ()
settingsBeforeMainLoop :: IO ()
      -- ^ Code to run after the listening socket is ready but before entering
      -- the main event loop. Useful for signaling to tests that they can start
      -- running, or to drop permissions after binding to a restricted port.
      --
      -- Default: do nothing.
      --
      -- Since 1.3.6

    , Settings -> ((forall a. IO a -> IO a) -> IO ()) -> IO ()
settingsFork :: ((forall a. IO a -> IO a) -> IO ()) -> IO ()
      -- ^ Code to fork a new thread to accept a connection.
      --
      -- This may be useful if you need OS bound threads, or if
      -- you wish to develop an alternative threading model.
      --
      -- Default: 'defaultFork'
      --
      -- Since 3.0.4

    , Settings -> Socket -> IO (Socket, SockAddr)
settingsAccept :: Socket -> IO (Socket, SockAddr)
      -- ^ Code to accept a new connection.
      --
      -- Useful if you need to provide connected sockets from something other
      -- than a standard accept call.
      --
      -- Default: 'defaultAccept'
      --
      -- Since 3.3.24

    , Settings -> Bool
settingsNoParsePath :: Bool
      -- ^ Perform no parsing on the rawPathInfo.
      --
      -- This is useful for writing HTTP proxies.
      --
      -- Default: False
      --
      -- Since 2.0.3
    , Settings -> IO () -> IO ()
settingsInstallShutdownHandler :: IO () -> IO ()
      -- ^ An action to install a handler (e.g. Unix signal handler)
      -- to close a listen socket.
      -- The first argument is an action to close the listen socket.
      --
      -- Default: no action
      --
      -- Since 3.0.1
    , Settings -> ByteString
settingsServerName :: ByteString
      -- ^ Default server name if application does not set one.
      --
      -- Since 3.0.2
    , Settings -> Maybe Port
settingsMaximumBodyFlush :: Maybe Int
      -- ^ See @setMaximumBodyFlush@.
      --
      -- Since 3.0.3
    , Settings -> ProxyProtocol
settingsProxyProtocol :: ProxyProtocol
      -- ^ Specify usage of the PROXY protocol.
      --
      -- Since 3.0.5
    , Settings -> Port
settingsSlowlorisSize :: Int
      -- ^ Size of bytes read to prevent Slowloris protection. Default value: 2048
      --
      -- Since 3.1.2
    , Settings -> Bool
settingsHTTP2Enabled :: Bool
      -- ^ Whether to enable HTTP2 ALPN/upgrades. Default: True
      --
      -- Since 3.1.7
    , Settings -> Request -> Status -> Maybe Integer -> IO ()
settingsLogger :: Request -> H.Status -> Maybe Integer -> IO ()
      -- ^ A log function. Default: no action.
      --
      -- Since 3.1.10
    , Settings -> Request -> ByteString -> Integer -> IO ()
settingsServerPushLogger :: Request -> ByteString -> Integer -> IO ()
      -- ^ A HTTP/2 server push log function. Default: no action.
      --
      -- Since 3.2.7
    , Settings -> Maybe Port
settingsGracefulShutdownTimeout :: Maybe Int
      -- ^ An optional timeout to limit the time (in seconds) waiting for
      -- a graceful shutdown of the web server.
      --
      -- Since 3.2.8
    , Settings -> Port
settingsGracefulCloseTimeout1 :: Int
      -- ^ A timeout to limit the time (in milliseconds) waiting for
      -- FIN for HTTP/1.x. 0 means uses immediate close.
      -- Default: 0.
      --
      -- Since 3.3.5
    , Settings -> Port
settingsGracefulCloseTimeout2 :: Int
      -- ^ A timeout to limit the time (in milliseconds) waiting for
      -- FIN for HTTP/2. 0 means uses immediate close.
      -- Default: 2000.
      --
      -- Since 3.3.5
    , Settings -> Port
settingsMaxTotalHeaderLength :: Int
      -- ^ Determines the maximum header size that Warp will tolerate when using HTTP/1.x.
      --
      -- Since 3.3.8
    , Settings -> Maybe ByteString
settingsAltSvc :: Maybe ByteString
      -- ^ Specify the header value of Alternative Services (AltSvc:).
      --
      -- Default: Nothing
      --
      -- Since 3.3.11
    , Settings -> Port
settingsMaxBuilderResponseBufferSize :: Int
      -- ^ Determines the maxium buffer size when sending `Builder` responses
      -- (See `responseBuilder`).
      --
      -- When sending a builder response warp uses a 16 KiB buffer to write the
      -- builder to. When that buffer is too small to fit the builder warp will
      -- free it and create a new one that will fit the builder.
      --
      -- To protect against allocating too large a buffer warp will error if the
      -- builder requires more than this maximum.
      --
      -- Default: 1049_000_000 = 1 MiB.
      --
      -- Since 3.3.22
    }

-- | Specify usage of the PROXY protocol.
data ProxyProtocol = ProxyProtocolNone
                     -- ^ See @setProxyProtocolNone@.
                   | ProxyProtocolRequired
                     -- ^ See @setProxyProtocolRequired@.
                   | ProxyProtocolOptional
                     -- ^ See @setProxyProtocolOptional@.

-- | The default settings for the Warp server. See the individual settings for
-- the default value.
defaultSettings :: Settings
defaultSettings :: Settings
defaultSettings = Settings :: Port
-> HostPreference
-> (Maybe Request -> SomeException -> IO ())
-> (SomeException -> Response)
-> (SockAddr -> IO Bool)
-> (SockAddr -> IO ())
-> Port
-> Maybe Manager
-> Port
-> Port
-> IO ()
-> (((forall a. IO a -> IO a) -> IO ()) -> IO ())
-> (Socket -> IO (Socket, SockAddr))
-> Bool
-> (IO () -> IO ())
-> ByteString
-> Maybe Port
-> ProxyProtocol
-> Port
-> Bool
-> (Request -> Status -> Maybe Integer -> IO ())
-> (Request -> ByteString -> Integer -> IO ())
-> Maybe Port
-> Port
-> Port
-> Port
-> Maybe ByteString
-> Port
-> Settings
Settings
    { settingsPort :: Port
settingsPort = Port
3000
    , settingsHost :: HostPreference
settingsHost = HostPreference
"*4"
    , settingsOnException :: Maybe Request -> SomeException -> IO ()
settingsOnException = Maybe Request -> SomeException -> IO ()
defaultOnException
    , settingsOnExceptionResponse :: SomeException -> Response
settingsOnExceptionResponse = SomeException -> Response
defaultOnExceptionResponse
    , settingsOnOpen :: SockAddr -> IO Bool
settingsOnOpen = IO Bool -> SockAddr -> IO Bool
forall a b. a -> b -> a
const (IO Bool -> SockAddr -> IO Bool) -> IO Bool -> SockAddr -> IO Bool
forall a b. (a -> b) -> a -> b
$ Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
    , settingsOnClose :: SockAddr -> IO ()
settingsOnClose = IO () -> SockAddr -> IO ()
forall a b. a -> b -> a
const (IO () -> SockAddr -> IO ()) -> IO () -> SockAddr -> IO ()
forall a b. (a -> b) -> a -> b
$ () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    , settingsTimeout :: Port
settingsTimeout = Port
30
    , settingsManager :: Maybe Manager
settingsManager = Maybe Manager
forall a. Maybe a
Nothing
    , settingsFdCacheDuration :: Port
settingsFdCacheDuration = Port
0
    , settingsFileInfoCacheDuration :: Port
settingsFileInfoCacheDuration = Port
0
    , settingsBeforeMainLoop :: IO ()
settingsBeforeMainLoop = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    , settingsFork :: ((forall a. IO a -> IO a) -> IO ()) -> IO ()
settingsFork = ((forall a. IO a -> IO a) -> IO ()) -> IO ()
defaultFork
    , settingsAccept :: Socket -> IO (Socket, SockAddr)
settingsAccept = Socket -> IO (Socket, SockAddr)
defaultAccept
    , settingsNoParsePath :: Bool
settingsNoParsePath = Bool
False
    , settingsInstallShutdownHandler :: IO () -> IO ()
settingsInstallShutdownHandler = IO () -> IO () -> IO ()
forall a b. a -> b -> a
const (IO () -> IO () -> IO ()) -> IO () -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    , settingsServerName :: ByteString
settingsServerName = String -> ByteString
C8.pack (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ String
"Warp/" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Version -> String
showVersion Version
Paths_warp.version
    , settingsMaximumBodyFlush :: Maybe Port
settingsMaximumBodyFlush = Port -> Maybe Port
forall a. a -> Maybe a
Just Port
8192
    , settingsProxyProtocol :: ProxyProtocol
settingsProxyProtocol = ProxyProtocol
ProxyProtocolNone
    , settingsSlowlorisSize :: Port
settingsSlowlorisSize = Port
2048
    , settingsHTTP2Enabled :: Bool
settingsHTTP2Enabled = Bool
True
    , settingsLogger :: Request -> Status -> Maybe Integer -> IO ()
settingsLogger = \Request
_ Status
_ Maybe Integer
_ -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    , settingsServerPushLogger :: Request -> ByteString -> Integer -> IO ()
settingsServerPushLogger = \Request
_ ByteString
_ Integer
_ -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    , settingsGracefulShutdownTimeout :: Maybe Port
settingsGracefulShutdownTimeout = Maybe Port
forall a. Maybe a
Nothing
    , settingsGracefulCloseTimeout1 :: Port
settingsGracefulCloseTimeout1 = Port
0
    , settingsGracefulCloseTimeout2 :: Port
settingsGracefulCloseTimeout2 = Port
2000
    , settingsMaxTotalHeaderLength :: Port
settingsMaxTotalHeaderLength = Port
50 Port -> Port -> Port
forall a. Num a => a -> a -> a
* Port
1024
    , settingsAltSvc :: Maybe ByteString
settingsAltSvc = Maybe ByteString
forall a. Maybe a
Nothing
    , settingsMaxBuilderResponseBufferSize :: Port
settingsMaxBuilderResponseBufferSize = Port
1049000000
    }

-- | Apply the logic provided by 'defaultOnException' to determine if an
-- exception should be shown or not. The goal is to hide exceptions which occur
-- under the normal course of the web server running.
--
-- Since 2.1.3
defaultShouldDisplayException :: SomeException -> Bool
defaultShouldDisplayException :: SomeException -> Bool
defaultShouldDisplayException SomeException
se
    | Just AsyncException
ThreadKilled <- SomeException -> Maybe AsyncException
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
se = Bool
False
    | Just (InvalidRequest
_ :: InvalidRequest) <- SomeException -> Maybe InvalidRequest
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
se = Bool
False
    | Just (IOError -> IOErrorType
ioeGetErrorType -> IOErrorType
et) <- SomeException -> Maybe IOError
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
se
        , IOErrorType
et IOErrorType -> IOErrorType -> Bool
forall a. Eq a => a -> a -> Bool
== IOErrorType
ResourceVanished Bool -> Bool -> Bool
|| IOErrorType
et IOErrorType -> IOErrorType -> Bool
forall a. Eq a => a -> a -> Bool
== IOErrorType
InvalidArgument = Bool
False
    | Just TimeoutThread
TimeoutThread <- SomeException -> Maybe TimeoutThread
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
se = Bool
False
    | Bool
otherwise = Bool
True

-- | Printing an exception to standard error
--   if `defaultShouldDisplayException` returns `True`.
--
-- Since: 3.1.0
defaultOnException :: Maybe Request -> SomeException -> IO ()
defaultOnException :: Maybe Request -> SomeException -> IO ()
defaultOnException Maybe Request
_ SomeException
e =
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (SomeException -> Bool
defaultShouldDisplayException SomeException
e)
        (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Handle -> Text -> IO ()
TIO.hPutStrLn Handle
stderr (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ SomeException -> String
forall a. Show a => a -> String
show SomeException
e

-- | Sending 400 for bad requests.
--   Sending 500 for internal server errors.
-- Since: 3.1.0
--   Sending 413 for too large payload.
--   Sending 431 for too large headers.
-- Since 3.2.27
defaultOnExceptionResponse :: SomeException -> Response
defaultOnExceptionResponse :: SomeException -> Response
defaultOnExceptionResponse SomeException
e
  | Just InvalidRequest
PayloadTooLarge <-
    SomeException -> Maybe InvalidRequest
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
e = Status -> ResponseHeaders -> ByteString -> Response
responseLBS Status
H.status413
                                 [(HeaderName
H.hContentType, ByteString
"text/plain; charset=utf-8")]
                                  ByteString
"Payload too large"
  | Just InvalidRequest
RequestHeaderFieldsTooLarge <-
    SomeException -> Maybe InvalidRequest
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
e = Status -> ResponseHeaders -> ByteString -> Response
responseLBS Status
H.status431
                                [(HeaderName
H.hContentType, ByteString
"text/plain; charset=utf-8")]
                                 ByteString
"Request header fields too large"
  | Just (InvalidRequest
_ :: InvalidRequest) <-
    SomeException -> Maybe InvalidRequest
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
e = Status -> ResponseHeaders -> ByteString -> Response
responseLBS Status
H.badRequest400
                                [(HeaderName
H.hContentType, ByteString
"text/plain; charset=utf-8")]
                                 ByteString
"Bad Request"
  | Bool
otherwise       = Status -> ResponseHeaders -> ByteString -> Response
responseLBS Status
H.internalServerError500
                                [(HeaderName
H.hContentType, ByteString
"text/plain; charset=utf-8")]
                                 ByteString
"Something went wrong"

-- | Exception handler for the debugging purpose.
--   500, text/plain, a showed exception.
--
-- Since: 2.0.3.2
exceptionResponseForDebug :: SomeException -> Response
exceptionResponseForDebug :: SomeException -> Response
exceptionResponseForDebug SomeException
e =
    Status -> ResponseHeaders -> Builder -> Response
responseBuilder Status
H.internalServerError500
                    [(HeaderName
H.hContentType, ByteString
"text/plain; charset=utf-8")]
                    (Builder -> Response) -> Builder -> Response
forall a b. (a -> b) -> a -> b
$ Builder
"Exception: " Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> String -> Builder
Builder.stringUtf8 (SomeException -> String
forall a. Show a => a -> String
show SomeException
e)

-- | Similar to @forkIOWithUnmask@, but does not set up the default exception handler.
--
-- Since Warp will always install its own exception handler in forked threads, this provides
-- a minor optimization.
--
-- For inspiration of this function, see @rawForkIO@ in the @async@ package.
--
-- @since 3.3.17
defaultFork :: ((forall a. IO a -> IO a) -> IO ()) -> IO ()
defaultFork :: ((forall a. IO a -> IO a) -> IO ()) -> IO ()
defaultFork (forall a. IO a -> IO a) -> IO ()
io =
#if __GLASGOW_HASKELL__ >= 904
  IO $ \s0 ->
    case io unsafeUnmask of
      IO io' ->
        case (fork# io' s0) of
          (# s1, _tid #) ->
            (# s1, () #)
#else
  (State# RealWorld -> (# State# RealWorld, () #)) -> IO ()
forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
IO ((State# RealWorld -> (# State# RealWorld, () #)) -> IO ())
-> (State# RealWorld -> (# State# RealWorld, () #)) -> IO ()
forall a b. (a -> b) -> a -> b
$ \State# RealWorld
s0 ->
    case (IO () -> State# RealWorld -> (# State# RealWorld, ThreadId# #)
forall a.
a -> State# RealWorld -> (# State# RealWorld, ThreadId# #)
fork# ((forall a. IO a -> IO a) -> IO ()
io forall a. IO a -> IO a
unsafeUnmask) State# RealWorld
s0) of
      (# State# RealWorld
s1, ThreadId#
_tid #) ->
        (# State# RealWorld
s1, () #)
#endif

-- | Standard "accept" call for a listening socket.
--
-- @since 3.3.24
defaultAccept :: Socket -> IO (Socket, SockAddr)
defaultAccept :: Socket -> IO (Socket, SockAddr)
defaultAccept =
#if WINDOWS
    windowsThreadBlockHack . accept
#else
    Socket -> IO (Socket, SockAddr)
accept
#endif