{-# LANGUAGE CPP #-}
{-# LANGUAGE ImpredicativeTypes #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE UnboxedTuples #-}
{-# LANGUAGE ViewPatterns #-}
module Network.Wai.Handler.Warp.Settings where
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 Data.Version (showVersion)
import GHC.IO (IO (IO), unsafeUnmask)
import GHC.IO.Exception (AsyncException (ThreadKilled), IOErrorType (..))
import GHC.Prim (fork#)
import qualified Network.HTTP.Types as H
import Network.Socket (SockAddr, Socket, accept)
import Network.Wai
import qualified Paths_warp
import System.IO (stderr)
import System.IO.Error (ioeGetErrorType)
import System.TimeManager
import UnliftIO (SomeException, fromException)
import Network.Wai.Handler.Warp.Imports
import Network.Wai.Handler.Warp.Types
#if WINDOWS
import Network.Wai.Handler.Warp.Windows (windowsThreadBlockHack)
#endif
data Settings = Settings
{ Settings -> Int
settingsPort :: Port
, Settings -> HostPreference
settingsHost :: HostPreference
, Settings -> Maybe Request -> SomeException -> IO ()
settingsOnException :: Maybe Request -> SomeException -> IO ()
, Settings -> SomeException -> Response
settingsOnExceptionResponse :: SomeException -> Response
, Settings -> SockAddr -> IO Bool
settingsOnOpen :: SockAddr -> IO Bool
, Settings -> SockAddr -> IO ()
settingsOnClose :: SockAddr -> IO ()
, Settings -> Int
settingsTimeout :: Int
, Settings -> Maybe Manager
settingsManager :: Maybe Manager
, Settings -> Int
settingsFdCacheDuration :: Int
, Settings -> Int
settingsFileInfoCacheDuration :: Int
, Settings -> IO ()
settingsBeforeMainLoop :: IO ()
, Settings -> ((forall a. IO a -> IO a) -> IO ()) -> IO ()
settingsFork :: ((forall a. IO a -> IO a) -> IO ()) -> IO ()
, Settings -> Socket -> IO (Socket, SockAddr)
settingsAccept :: Socket -> IO (Socket, SockAddr)
, Settings -> Bool
settingsNoParsePath :: Bool
, Settings -> IO () -> IO ()
settingsInstallShutdownHandler :: IO () -> IO ()
, Settings -> ByteString
settingsServerName :: ByteString
, Settings -> Maybe Int
settingsMaximumBodyFlush :: Maybe Int
, Settings -> ProxyProtocol
settingsProxyProtocol :: ProxyProtocol
, Settings -> Int
settingsSlowlorisSize :: Int
, Settings -> Bool
settingsHTTP2Enabled :: Bool
, Settings -> Request -> Status -> Maybe Integer -> IO ()
settingsLogger :: Request -> H.Status -> Maybe Integer -> IO ()
, Settings -> Request -> ByteString -> Integer -> IO ()
settingsServerPushLogger :: Request -> ByteString -> Integer -> IO ()
, Settings -> Maybe Int
settingsGracefulShutdownTimeout :: Maybe Int
, Settings -> Int
settingsGracefulCloseTimeout1 :: Int
, Settings -> Int
settingsGracefulCloseTimeout2 :: Int
, :: Int
, Settings -> Maybe ByteString
settingsAltSvc :: Maybe ByteString
, Settings -> Int
settingsMaxBuilderResponseBufferSize :: Int
}
data ProxyProtocol
=
ProxyProtocolNone
|
ProxyProtocolRequired
|
ProxyProtocolOptional
defaultSettings :: Settings
defaultSettings :: Settings
defaultSettings =
Settings
{ settingsPort :: Int
settingsPort = Int
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 a. a -> IO a
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 a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
, settingsTimeout :: Int
settingsTimeout = Int
30
, settingsManager :: Maybe Manager
settingsManager = Maybe Manager
forall a. Maybe a
Nothing
, settingsFdCacheDuration :: Int
settingsFdCacheDuration = Int
0
, settingsFileInfoCacheDuration :: Int
settingsFileInfoCacheDuration = Int
0
, settingsBeforeMainLoop :: IO ()
settingsBeforeMainLoop = () -> IO ()
forall a. a -> IO a
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 a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
, settingsServerName :: ByteString
settingsServerName = [Char] -> ByteString
C8.pack ([Char] -> ByteString) -> [Char] -> ByteString
forall a b. (a -> b) -> a -> b
$ [Char]
"Warp/" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Version -> [Char]
showVersion Version
Paths_warp.version
, settingsMaximumBodyFlush :: Maybe Int
settingsMaximumBodyFlush = Int -> Maybe Int
forall a. a -> Maybe a
Just Int
8192
, settingsProxyProtocol :: ProxyProtocol
settingsProxyProtocol = ProxyProtocol
ProxyProtocolNone
, settingsSlowlorisSize :: Int
settingsSlowlorisSize = Int
2048
, settingsHTTP2Enabled :: Bool
settingsHTTP2Enabled = Bool
True
, settingsLogger :: Request -> Status -> Maybe Integer -> IO ()
settingsLogger = \Request
_ Status
_ Maybe Integer
_ -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
, settingsServerPushLogger :: Request -> ByteString -> Integer -> IO ()
settingsServerPushLogger = \Request
_ ByteString
_ Integer
_ -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
, settingsGracefulShutdownTimeout :: Maybe Int
settingsGracefulShutdownTimeout = Maybe Int
forall a. Maybe a
Nothing
, settingsGracefulCloseTimeout1 :: Int
settingsGracefulCloseTimeout1 = Int
0
, settingsGracefulCloseTimeout2 :: Int
settingsGracefulCloseTimeout2 = Int
2000
, settingsMaxTotalHeaderLength :: Int
settingsMaxTotalHeaderLength = Int
50 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
1024
, settingsAltSvc :: Maybe ByteString
settingsAltSvc = Maybe ByteString
forall a. Maybe a
Nothing
, settingsMaxBuilderResponseBufferSize :: Int
settingsMaxBuilderResponseBufferSize = Int
1049000000
}
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
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
$
[Char] -> Text
T.pack ([Char] -> Text) -> [Char] -> Text
forall a b. (a -> b) -> a -> b
$
SomeException -> [Char]
forall a. Show a => a -> [Char]
show SomeException
e
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"
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
<> [Char] -> Builder
Builder.stringUtf8 (SomeException -> [Char]
forall a. Show a => a -> [Char]
show SomeException
e)
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 =
(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 ->
#if __GLASGOW_HASKELL__ >= 904
case (forall a. IO a -> IO a) -> IO ()
io IO a -> IO a
forall a. IO a -> IO a
unsafeUnmask of
IO State# RealWorld -> (# State# RealWorld, () #)
io' ->
case (State# RealWorld -> (# State# RealWorld, () #))
-> State# RealWorld -> (# State# RealWorld, ThreadId# #)
forall a.
(State# RealWorld -> (# State# RealWorld, a #))
-> State# RealWorld -> (# State# RealWorld, ThreadId# #)
fork# State# RealWorld -> (# State# RealWorld, () #)
io' State# RealWorld
s0 of
(# State# RealWorld
s1, ThreadId#
_tid #) -> (# State# RealWorld
s1, () #)
#else
case fork# (io unsafeUnmask) s0 of
(# s1, _tid #) -> (# s1, () #)
#endif
defaultAccept :: Socket -> IO (Socket, SockAddr)
defaultAccept :: Socket -> IO (Socket, SockAddr)
defaultAccept =
#if WINDOWS
windowsThreadBlockHack . accept
#else
Socket -> IO (Socket, SockAddr)
accept
#endif