{-# LANGUAGE CPP #-}
{-# LANGUAGE ImpredicativeTypes #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE UnboxedTuples #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE LiberalTypeSynonyms #-}
{-# LANGUAGE LambdaCase #-}

module Network.Wai.Handler.Warp.Settings where

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

import Network.Wai.Handler.Warp.Imports
import Network.Wai.Handler.Warp.Types
#if WINDOWS
import Network.Wai.Handler.Warp.Windows (windowsThreadBlockHack)
#endif

#ifdef INCLUDE_WARP_VERSION
import Data.Version (showVersion)
import qualified Paths_warpZ
#endif

-- | 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
    { settingsPort :: Port
    -- ^ Port to listen on. Default value: 3000
    , settingsHost :: HostPreference
    -- ^ Default value: HostIPv4
    , 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.
    , settingsOnExceptionResponse :: SomeException -> Response
    -- ^ A function to create `Response` when an exception occurs.
    --
    -- Default: 500, text/plain, \"Something went wrong\"
    --
    -- Since 2.0.3
    , 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'.
    , settingsOnClose :: SockAddr -> IO ()
    -- ^ What to do when a connection is close. Default: do nothing.
    , settingsTimeout :: Int
    -- ^ Timeout value in seconds. Default value: 30
    , settingsManager :: Maybe Manager
    -- ^ Use an existing timeout manager instead of spawning a new one. If used, 'settingsTimeout' is ignored. Default is 'Nothing'
    , settingsFdCacheDuration :: Int
    -- ^ Cache duration time of file descriptors in seconds. 0 means that the cache mechanism is not used. Default value: 0
    , settingsFileInfoCacheDuration :: Int
    -- ^ Cache duration time of file information in seconds. 0 means that the cache mechanism is not used. Default value: 0
    , 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
    , 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
    , 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
    , settingsNoParsePath :: Bool
    -- ^ Perform no parsing on the rawPathInfo.
    --
    -- This is useful for writing HTTP proxies.
    --
    -- Default: False
    --
    -- Since 2.0.3
    , 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
    , settingsServerName :: ByteString
    -- ^ Default server name if application does not set one.
    --
    -- Since 3.0.2
    , settingsMaximumBodyFlush :: Maybe Int
    -- ^ See @setMaximumBodyFlush@.
    --
    -- Since 3.0.3
    , settingsProxyProtocol :: ProxyProtocol
    -- ^ Specify usage of the PROXY protocol.
    --
    -- Since 3.0.5
    , settingsSlowlorisSize :: Int
    -- ^ Size of bytes read to prevent Slowloris protection. Default value: 2048
    --
    -- Since 3.1.2
    , settingsHTTP2Enabled :: Bool
    -- ^ Whether to enable HTTP2 ALPN/upgrades. Default: True
    --
    -- Since 3.1.7
    , settingsLogger :: Request -> H.Status -> Maybe Integer -> IO ()
    -- ^ A log function. Default: no action.
    --
    -- Since 3.1.10
    , settingsServerPushLogger :: Request -> ByteString -> Integer -> IO ()
    -- ^ A HTTP/2 server push log function. Default: no action.
    --
    -- Since 3.2.7
    , 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
    , 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
    , 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
    , settingsMaxTotalHeaderLength :: Int
    -- ^ Determines the maximum header size that Warp will tolerate when using HTTP/1.x.
    --
    -- Since 3.3.8
    , settingsAltSvc :: Maybe ByteString
    -- ^ Specify the header value of Alternative Services (AltSvc:).
    --
    -- Default: Nothing
    --
    -- Since 3.3.11
    , 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
    }

class HasSettings a where
    settings :: Lens' a Settings
    port :: Lens' a Port
    port  = settings . port
    host :: Lens' a HostPreference
    host = settings . host
    onException :: Lens' a (Maybe Request -> SomeException -> IO ())
    onException = settings . onException
    onExceptionResponse :: Lens' a (SomeException -> Response)
    onExceptionResponse = settings . onExceptionResponse
    onOpen :: Lens' a (SockAddr -> IO Bool)
    onOpen = settings . onOpen
    onClose :: Lens' a (SockAddr -> IO ())
    onClose = settings . onClose
    timeoutL :: Lens' a Int
    timeoutL = settings . timeoutL
    manager :: Lens' a (Maybe Manager)
    manager = settings . manager
    fdCacheDuration :: Lens' a Int
    fdCacheDuration = settings . fdCacheDuration
    fileInfoCacheDuration :: Lens' a Int
    fileInfoCacheDuration = settings . fileInfoCacheDuration
    beforeMainLoop :: Lens' a (IO ())
    beforeMainLoop = settings . beforeMainLoop
    forkL :: Lens' a (((forall x. IO x -> IO x) -> IO ()) -> IO ())
    forkL = settings . forkL
    acceptL :: Lens' a (Socket -> IO (Socket, SockAddr))
    acceptL = settings . acceptL
    noParsePath :: Lens' a Bool
    noParsePath = settings . noParsePath
    installShutdownHandler :: Lens' a (IO () -> IO ())
    installShutdownHandler = settings . installShutdownHandler
    serverName :: Lens' a ByteString
    serverName = settings . serverName
    maximumBodyFlush :: Lens' a (Maybe Int)
    maximumBodyFlush = settings . maximumBodyFlush
    slowlorisSize :: Lens' a Int
    slowlorisSize = settings . slowlorisSize
    http2Enabled :: Lens' a Bool
    http2Enabled = settings . http2Enabled
    logger :: Lens' a (Request -> H.Status -> Maybe Integer -> IO ())
    logger = settings . logger
    serverPushLogger :: Lens' a (Request -> ByteString -> Integer -> IO ())
    serverPushLogger = settings . serverPushLogger
    gracefulShutdownTimeout :: Lens' a (Maybe Int)
    gracefulShutdownTimeout = settings . gracefulShutdownTimeout
    gracefulCloseTimeout1 :: Lens' a Int
    gracefulCloseTimeout1 = settings . gracefulCloseTimeout1
    gracefulCloseTimeout2 :: Lens' a Int
    gracefulCloseTimeout2 = settings . gracefulCloseTimeout2
    maxTotalHeaderLength :: Lens' a Int
    maxTotalHeaderLength = settings . maxTotalHeaderLength
    altSvc :: Lens' a (Maybe ByteString)
    altSvc = settings . altSvc
    maxBuilderResponseBufferSize :: Lens' a Int
    maxBuilderResponseBufferSize = settings . maxBuilderResponseBufferSize

instance HasSettings Settings where
    settings = id
    port f s = fmap (\x -> s { settingsPort = x }) (f (settingsPort s))
    host f s = fmap (\x -> s { settingsHost = x }) (f (settingsHost s))
    onException f s = fmap (\x -> s { settingsOnException = x }) (f (settingsOnException s))
    onExceptionResponse f s = fmap (\x -> s { settingsOnExceptionResponse = x }) (f (settingsOnExceptionResponse s))
    onOpen f s = fmap (\x -> s { settingsOnOpen = x }) (f (settingsOnOpen s))
    onClose f s = fmap (\x -> s { settingsOnClose = x }) (f (settingsOnClose s))
    timeoutL f s = fmap (\x -> s { settingsTimeout = x }) (f (settingsTimeout s))
    manager f s = fmap (\x -> s { settingsManager = x }) (f (settingsManager s))
    fdCacheDuration f s = fmap (\x -> s { settingsFdCacheDuration = x }) (f (settingsFdCacheDuration s))
    fileInfoCacheDuration f s = fmap (\x -> s { settingsFileInfoCacheDuration = x }) (f (settingsFileInfoCacheDuration s))
    beforeMainLoop f s = fmap (\x -> s { settingsBeforeMainLoop = x }) (f (settingsBeforeMainLoop s))
    forkL f s = fmap (\x -> s { settingsFork = x }) (f (settingsFork s))
    acceptL f s = fmap (\x -> s { settingsAccept = x }) (f (settingsAccept s))
    noParsePath f s = fmap (\x -> s { settingsNoParsePath = x }) (f (settingsNoParsePath s))
    installShutdownHandler f s = fmap (\x -> s { settingsInstallShutdownHandler = x }) (f (settingsInstallShutdownHandler s))
    serverName f s = fmap (\x -> s { settingsServerName = x }) (f (settingsServerName s))
    maximumBodyFlush f s = fmap (\x -> s { settingsMaximumBodyFlush = x }) (f (settingsMaximumBodyFlush s))
    slowlorisSize f s = fmap (\x -> s { settingsSlowlorisSize = x }) (f (settingsSlowlorisSize s))
    http2Enabled f s = fmap (\x -> s { settingsHTTP2Enabled = x }) (f (settingsHTTP2Enabled s))
    logger f s = fmap (\x -> s { settingsLogger = x }) (f (settingsLogger s))
    serverPushLogger f s = fmap (\x -> s { settingsServerPushLogger = x }) (f (settingsServerPushLogger s))
    gracefulShutdownTimeout f s = fmap (\x -> s { settingsGracefulShutdownTimeout = x }) (f (settingsGracefulShutdownTimeout s))
    gracefulCloseTimeout1 f s = fmap (\x -> s { settingsGracefulCloseTimeout1 = x }) (f (settingsGracefulCloseTimeout1 s))
    gracefulCloseTimeout2 f s = fmap (\x -> s { settingsGracefulCloseTimeout2 = x }) (f (settingsGracefulCloseTimeout2 s))
    maxTotalHeaderLength f s = fmap (\x -> s { settingsMaxTotalHeaderLength = x }) (f (settingsMaxTotalHeaderLength s))
    altSvc f s = fmap (\x -> s { settingsAltSvc = x }) (f (settingsAltSvc s))
    maxBuilderResponseBufferSize f s = fmap (\x -> s { settingsMaxBuilderResponseBufferSize = x }) (f (settingsMaxBuilderResponseBufferSize s))

class AsSettings a where
    _Settings :: Prism' a Settings

instance AsSettings Settings where
    _Settings = id

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

class HasProxyProtocol a where
    proxyProtocol :: Lens' a ProxyProtocol

instance HasProxyProtocol ProxyProtocol where
    proxyProtocol = id

instance HasProxyProtocol Settings where
    proxyProtocol f s = fmap (\x -> s { settingsProxyProtocol = x }) (f (settingsProxyProtocol s))

class AsProxyProtocol a where
    _ProxyProtocol :: Prism' a ProxyProtocol
    _ProxyProtocolNone :: Prism' a ()
    _ProxyProtocolNone = _ProxyProtocol . _ProxyProtocolNone
    _ProxyProtocolRequired :: Prism' a ()
    _ProxyProtocolRequired = _ProxyProtocol . _ProxyProtocolRequired
    _ProxyProtocolOptional :: Prism' a ()
    _ProxyProtocolOptional = _ProxyProtocol . _ProxyProtocolOptional

instance AsProxyProtocol ProxyProtocol where
    _ProxyProtocol = id
    _ProxyProtocolNone =
        prism'
            (\() -> ProxyProtocolNone)
            (\case
                ProxyProtocolNone -> Just ()
                _ -> Nothing)
    _ProxyProtocolRequired =
        prism'
            (\() -> ProxyProtocolRequired)
            (\case
                ProxyProtocolRequired -> Just ()
                _ -> Nothing)
    _ProxyProtocolOptional =
        prism'
            (\() -> ProxyProtocolOptional)
            (\case
                ProxyProtocolOptional -> Just ()
                _ -> Nothing)

-- | The default settings for the Warp server. See the individual settings for
-- the default value.
defaultSettings :: Settings
defaultSettings =
    Settings
        { settingsPort = 3000
        , settingsHost = "*4"
        , settingsOnException = defaultOnException
        , settingsOnExceptionResponse = defaultOnExceptionResponse
        , settingsOnOpen = const $ return True
        , settingsOnClose = const $ return ()
        , settingsTimeout = 30
        , settingsManager = Nothing
        , settingsFdCacheDuration = 0
        , settingsFileInfoCacheDuration = 0
        , settingsBeforeMainLoop = return ()
        , settingsFork = defaultFork
        , settingsAccept = defaultAccept
        , settingsNoParsePath = False
        , settingsInstallShutdownHandler = const $ return ()
        , settingsServerName = C8.pack $ "Warp/" ++ warpVersion
        , settingsMaximumBodyFlush = Just 8192
        , settingsProxyProtocol = ProxyProtocolNone
        , settingsSlowlorisSize = 2048
        , settingsHTTP2Enabled = True
        , settingsLogger = \_ _ _ -> return ()
        , settingsServerPushLogger = \_ _ _ -> return ()
        , settingsGracefulShutdownTimeout = Nothing
        , settingsGracefulCloseTimeout1 = 0
        , settingsGracefulCloseTimeout2 = 2000
        , settingsMaxTotalHeaderLength = 50 * 1024
        , settingsAltSvc = Nothing
        , settingsMaxBuilderResponseBufferSize = 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 se
    | Just (_ :: InvalidRequest) <- fromException se = False
    | Just (ioeGetErrorType -> et) <- fromException se
    , et == ResourceVanished || et == InvalidArgument =
        False
    | isAsyncException se = False
    | otherwise = True

-- | Printing an exception to standard error
--   if `defaultShouldDisplayException` returns `True`.
--
-- Since: 3.1.0
defaultOnException :: Maybe Request -> SomeException -> IO ()
defaultOnException _ e =
    when (defaultShouldDisplayException e) $
        TIO.hPutStrLn stderr $
            T.pack $
                show 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 e
    | isAsyncException e = throw e
    | Just PayloadTooLarge <- fromException e =
        responseLBS
            H.status413
            [(H.hContentType, "text/plain; charset=utf-8")]
            "Payload too large"
    | Just RequestHeaderFieldsTooLarge <- fromException e =
        responseLBS
            H.status431
            [(H.hContentType, "text/plain; charset=utf-8")]
            "Request header fields too large"
    | Just (_ :: InvalidRequest) <- fromException e =
        responseLBS
            H.badRequest400
            [(H.hContentType, "text/plain; charset=utf-8")]
            "Bad Request"
    | otherwise =
        responseLBS
            H.internalServerError500
            [(H.hContentType, "text/plain; charset=utf-8")]
            "Something went wrong"

-- | Exception handler for the debugging purpose.
--   500, text/plain, a showed exception.
--
-- Since: 2.0.3.2
exceptionResponseForDebug :: SomeException -> Response
exceptionResponseForDebug e =
    responseBuilder
        H.internalServerError500
        [(H.hContentType, "text/plain; charset=utf-8")]
        $ "Exception: " <> Builder.stringUtf8 (show 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 io =
    IO $ \s0 ->
#if __GLASGOW_HASKELL__ >= 904
        case io unsafeUnmask of
            IO io' ->
                case fork# io' s0 of
                    (# s1, _tid #) -> (# s1, () #)
#else
        case fork# (io unsafeUnmask) s0 of
            (# s1, _tid #) -> (# s1, () #)
#endif

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

-- | The version of Warp.
warpVersion :: String
warpVersion =
#ifdef INCLUDE_WARP_VERSION
  showVersion Paths_warpZ.version
#else
  "unknown"
#endif