1{-# LANGUAGE OverloadedStrings, ScopedTypeVariables, ViewPatterns #-}
2{-# LANGUAGE PatternGuards, RankNTypes #-}
3{-# LANGUAGE ImpredicativeTypes, CPP #-}
4{-# LANGUAGE MagicHash, UnboxedTuples #-}
5
6module Network.Wai.Handler.Warp.Settings where
7
8import GHC.IO (unsafeUnmask, IO (IO))
9import GHC.Prim (fork#)
10import UnliftIO (SomeException, fromException)
11import qualified Data.ByteString.Char8 as C8
12import qualified Data.ByteString.Builder as Builder
13import Data.ByteString.Lazy (fromStrict)
14import Data.Streaming.Network (HostPreference)
15import qualified Data.Text as T
16import qualified Data.Text.IO as TIO
17import Data.Version (showVersion)
18import GHC.IO.Exception (IOErrorType(..), AsyncException (ThreadKilled))
19import qualified Network.HTTP.Types as H
20import Network.HTTP2.Frame (HTTP2Error (..), ErrorCodeId (..))
21import Network.Socket (SockAddr)
22import Network.Wai
23import qualified Paths_warp
24import System.IO (stderr)
25import System.IO.Error (ioeGetErrorType)
26import System.TimeManager
27
28import Network.Wai.Handler.Warp.Imports
29import Network.Wai.Handler.Warp.Types
30
31-- | Various Warp server settings. This is purposely kept as an abstract data
32-- type so that new settings can be added without breaking backwards
33-- compatibility. In order to create a 'Settings' value, use 'defaultSettings'
34-- and the various \'set\' functions to modify individual fields. For example:
35--
36-- > setTimeout 20 defaultSettings
37data Settings = Settings
38    { settingsPort :: Port -- ^ Port to listen on. Default value: 3000
39    , settingsHost :: HostPreference -- ^ Default value: HostIPv4
40    , 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.
41    , settingsOnExceptionResponse :: SomeException -> Response
42      -- ^ A function to create `Response` when an exception occurs.
43      --
44      -- Default: 500, text/plain, \"Something went wrong\"
45      --
46      -- Since 2.0.3
47    , 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'.
48    , settingsOnClose :: SockAddr -> IO ()  -- ^ What to do when a connection is close. Default: do nothing.
49    , settingsTimeout :: Int -- ^ Timeout value in seconds. Default value: 30
50    , settingsManager :: Maybe Manager -- ^ Use an existing timeout manager instead of spawning a new one. If used, 'settingsTimeout' is ignored. Default is 'Nothing'
51    , settingsFdCacheDuration :: Int -- ^ Cache duration time of file descriptors in seconds. 0 means that the cache mechanism is not used. Default value: 0
52    , settingsFileInfoCacheDuration :: Int -- ^ Cache duration time of file information in seconds. 0 means that the cache mechanism is not used. Default value: 0
53    , settingsBeforeMainLoop :: IO ()
54      -- ^ Code to run after the listening socket is ready but before entering
55      -- the main event loop. Useful for signaling to tests that they can start
56      -- running, or to drop permissions after binding to a restricted port.
57      --
58      -- Default: do nothing.
59      --
60      -- Since 1.3.6
61
62    , settingsFork :: ((forall a. IO a -> IO a) -> IO ()) -> IO ()
63      -- ^ Code to fork a new thread to accept a connection.
64      --
65      -- This may be useful if you need OS bound threads, or if
66      -- you wish to develop an alternative threading model.
67      --
68      -- Default: 'defaultFork'
69      --
70      -- Since 3.0.4
71
72    , settingsNoParsePath :: Bool
73      -- ^ Perform no parsing on the rawPathInfo.
74      --
75      -- This is useful for writing HTTP proxies.
76      --
77      -- Default: False
78      --
79      -- Since 2.0.3
80    , settingsInstallShutdownHandler :: IO () -> IO ()
81      -- ^ An action to install a handler (e.g. Unix signal handler)
82      -- to close a listen socket.
83      -- The first argument is an action to close the listen socket.
84      --
85      -- Default: no action
86      --
87      -- Since 3.0.1
88    , settingsServerName :: ByteString
89      -- ^ Default server name if application does not set one.
90      --
91      -- Since 3.0.2
92    , settingsMaximumBodyFlush :: Maybe Int
93      -- ^ See @setMaximumBodyFlush@.
94      --
95      -- Since 3.0.3
96    , settingsProxyProtocol :: ProxyProtocol
97      -- ^ Specify usage of the PROXY protocol.
98      --
99      -- Since 3.0.5
100    , settingsSlowlorisSize :: Int
101      -- ^ Size of bytes read to prevent Slowloris protection. Default value: 2048
102      --
103      -- Since 3.1.2
104    , settingsHTTP2Enabled :: Bool
105      -- ^ Whether to enable HTTP2 ALPN/upgrades. Default: True
106      --
107      -- Since 3.1.7
108    , settingsLogger :: Request -> H.Status -> Maybe Integer -> IO ()
109      -- ^ A log function. Default: no action.
110      --
111      -- Since 3.1.10
112    , settingsServerPushLogger :: Request -> ByteString -> Integer -> IO ()
113      -- ^ A HTTP/2 server push log function. Default: no action.
114      --
115      -- Since 3.2.7
116    , settingsGracefulShutdownTimeout :: Maybe Int
117      -- ^ An optional timeout to limit the time (in seconds) waiting for
118      -- a graceful shutdown of the web server.
119      --
120      -- Since 3.2.8
121    , settingsGracefulCloseTimeout1 :: Int
122      -- ^ A timeout to limit the time (in milliseconds) waiting for
123      -- FIN for HTTP/1.x. 0 means uses immediate close.
124      -- Default: 0.
125      --
126      -- Since 3.3.5
127    , settingsGracefulCloseTimeout2 :: Int
128      -- ^ A timeout to limit the time (in milliseconds) waiting for
129      -- FIN for HTTP/2. 0 means uses immediate close.
130      -- Default: 2000.
131      --
132      -- Since 3.3.5
133    , settingsMaxTotalHeaderLength :: Int
134      -- ^ Determines the maximum header size that Warp will tolerate when using HTTP/1.x.
135      --
136      -- Since 3.3.8
137    , settingsAltSvc :: Maybe ByteString
138      -- ^ Specify the header value of Alternative Services (AltSvc:).
139      --
140      -- Default: Nothing
141      --
142      -- Since 3.3.11
143    }
144
145-- | Specify usage of the PROXY protocol.
146data ProxyProtocol = ProxyProtocolNone
147                     -- ^ See @setProxyProtocolNone@.
148                   | ProxyProtocolRequired
149                     -- ^ See @setProxyProtocolRequired@.
150                   | ProxyProtocolOptional
151                     -- ^ See @setProxyProtocolOptional@.
152
153-- | The default settings for the Warp server. See the individual settings for
154-- the default value.
155defaultSettings :: Settings
156defaultSettings = Settings
157    { settingsPort = 3000
158    , settingsHost = "*4"
159    , settingsOnException = defaultOnException
160    , settingsOnExceptionResponse = defaultOnExceptionResponse
161    , settingsOnOpen = const $ return True
162    , settingsOnClose = const $ return ()
163    , settingsTimeout = 30
164    , settingsManager = Nothing
165    , settingsFdCacheDuration = 0
166    , settingsFileInfoCacheDuration = 0
167    , settingsBeforeMainLoop = return ()
168    , settingsFork = defaultFork
169    , settingsNoParsePath = False
170    , settingsInstallShutdownHandler = const $ return ()
171    , settingsServerName = C8.pack $ "Warp/" ++ showVersion Paths_warp.version
172    , settingsMaximumBodyFlush = Just 8192
173    , settingsProxyProtocol = ProxyProtocolNone
174    , settingsSlowlorisSize = 2048
175    , settingsHTTP2Enabled = True
176    , settingsLogger = \_ _ _ -> return ()
177    , settingsServerPushLogger = \_ _ _ -> return ()
178    , settingsGracefulShutdownTimeout = Nothing
179    , settingsGracefulCloseTimeout1 = 0
180    , settingsGracefulCloseTimeout2 = 2000
181    , settingsMaxTotalHeaderLength = 50 * 1024
182    , settingsAltSvc = Nothing
183    }
184
185-- | Apply the logic provided by 'defaultOnException' to determine if an
186-- exception should be shown or not. The goal is to hide exceptions which occur
187-- under the normal course of the web server running.
188--
189-- Since 2.1.3
190defaultShouldDisplayException :: SomeException -> Bool
191defaultShouldDisplayException se
192    | Just ThreadKilled <- fromException se = False
193    | Just (_ :: InvalidRequest) <- fromException se = False
194    | Just (ioeGetErrorType -> et) <- fromException se
195        , et == ResourceVanished || et == InvalidArgument = False
196    | Just TimeoutThread <- fromException se = False
197    | otherwise = True
198
199-- | Printing an exception to standard error
200--   if `defaultShouldDisplayException` returns `True`.
201--
202-- Since: 3.1.0
203defaultOnException :: Maybe Request -> SomeException -> IO ()
204defaultOnException _ e =
205    when (defaultShouldDisplayException e)
206        $ TIO.hPutStrLn stderr $ T.pack $ show e
207
208-- | Sending 400 for bad requests.
209--   Sending 500 for internal server errors.
210-- Since: 3.1.0
211--   Sending 413 for too large payload.
212--   Sending 431 for too large headers.
213-- Since 3.2.27
214defaultOnExceptionResponse :: SomeException -> Response
215defaultOnExceptionResponse e
216  | Just (_ :: InvalidRequest) <-
217    fromException e = responseLBS H.badRequest400
218                                [(H.hContentType, "text/plain; charset=utf-8")]
219                                 "Bad Request"
220  | Just (ConnectionError (UnknownErrorCode 413) t) <-
221    fromException e = responseLBS H.status413
222                                [(H.hContentType, "text/plain; charset=utf-8")]
223                                 (fromStrict t)
224  | Just (ConnectionError (UnknownErrorCode 431) t) <-
225    fromException e = responseLBS H.status431
226                                [(H.hContentType, "text/plain; charset=utf-8")]
227                                 (fromStrict t)
228  | otherwise       = responseLBS H.internalServerError500
229                                [(H.hContentType, "text/plain; charset=utf-8")]
230                                 "Something went wrong"
231
232-- | Exception handler for the debugging purpose.
233--   500, text/plain, a showed exception.
234--
235-- Since: 2.0.3.2
236exceptionResponseForDebug :: SomeException -> Response
237exceptionResponseForDebug e =
238    responseBuilder H.internalServerError500
239                    [(H.hContentType, "text/plain; charset=utf-8")]
240                    $ "Exception: " <> Builder.stringUtf8 (show e)
241
242-- | Similar to @forkIOWithUnmask@, but does not set up the default exception handler.
243--
244-- Since Warp will always install its own exception handler in forked threads, this provides
245-- a minor optimization.
246--
247-- For inspiration of this function, see @rawForkIO@ in the @async@ package.
248--
249-- @since 3.3.17
250defaultFork :: ((forall a. IO a -> IO a) -> IO ()) -> IO ()
251defaultFork io =
252  IO $ \s0 ->
253    case (fork# (io unsafeUnmask) s0) of
254      (# s1, _tid #) ->
255        (# s1, () #)
256