git.iko.soy/typeable/wai
on master help sign in
settingsBeforeMainLoop
ff97fe5Michael Snoyman
warp/Network/Wai/Handler/Warp.hs+1
compare with master
unifiedsplit
@@ -33,6 +33,7 @@ module Network.Wai.Handler.Warp (
33 , settingsManager
33 , settingsManager
34 , settingsFdCacheDuration
34 , settingsFdCacheDuration
35 , settingsResourceTPerRequest
35 , settingsResourceTPerRequest
36+ , settingsBeforeMainLoop
36 -- ** Data types
37 -- ** Data types
37 , HostPreference (..)
38 , HostPreference (..)
38 -- * Connection
39 -- * Connection
warp/Network/Wai/Handler/Warp/Run.hs+1
@@ -134,6 +134,7 @@ runSettingsConnectionMaker set getConn app = do
134 0 -> return Nothing
134 0 -> return Nothing
135 _ -> Just <$> F.initialize (duration * 1000000)
135 _ -> Just <$> F.initialize (duration * 1000000)
136#endif
136#endif
137+ settingsBeforeMainLoop set
137 mask $ \restore -> forever $ do
138 mask $ \restore -> forever $ do
138 allowInterrupt
139 allowInterrupt
139 (mkConn, addr) <- getConnLoop
140 (mkConn, addr) <- getConnLoop
warp/Network/Wai/Handler/Warp/Settings.hs+9
@@ -31,6 +31,14 @@ data Settings = Settings
31 -- @ResourceT@. This provides more intuitive behavior for dynamic code,
31 -- @ResourceT@. This provides more intuitive behavior for dynamic code,
32 -- but can hinder performance in high-throughput cases. File servers can
32 -- but can hinder performance in high-throughput cases. File servers can
33 -- safely set to @False@ for increased performance. Default is @True@.
33 -- safely set to @False@ for increased performance. Default is @True@.
34+ , settingsBeforeMainLoop :: IO ()
35+ -- ^ Code to run after the listening socket is ready but before entering
36+ -- the main event loop. Useful for signaling to tests that they can start
37+ -- running, or to drop permissions after binding to a restricted port.
38+ --
39+ -- Default: do nothing.
40+ --
41+ -- Since 1.3.6
34 }
42 }
35
43
36-- | The default settings for the Warp server. See the individual settings for
44-- | The default settings for the Warp server. See the individual settings for
@@ -52,6 +60,7 @@ defaultSettings = Settings
52 , settingsManager = Nothing
60 , settingsManager = Nothing
53 , settingsFdCacheDuration = 10
61 , settingsFdCacheDuration = 10
54 , settingsResourceTPerRequest = True
62 , settingsResourceTPerRequest = True
63+ , settingsBeforeMainLoop = return ()
55 }
64 }
56 where
65 where
57 go :: InvalidRequest -> IO ()
66 go :: InvalidRequest -> IO ()
warp/test/RunSpec.hs+146−153
@@ -18,6 +18,8 @@ import Network.Wai.Handler.Warp
18import System.IO (hFlush, hClose)
18import System.IO (hFlush, hClose)
19import System.IO.Unsafe (unsafePerformIO)
19import System.IO.Unsafe (unsafePerformIO)
20import Test.Hspec
20import Test.Hspec
21+import Control.Concurrent.MVar (newEmptyMVar, takeMVar, putMVar)
22+import Control.Exception (bracket)
21
23
22main :: IO ()
24main :: IO ()
23main = hspec spec
25main = hspec spec
@@ -68,24 +70,33 @@ nextPort = unsafePerformIO $ I.newIORef 5000
68getPort :: IO Int
70getPort :: IO Int
69getPort = I.atomicModifyIORef nextPort $ \p -> (p + 1, p)
71getPort = I.atomicModifyIORef nextPort $ \p -> (p + 1, p)
70
72
73+withApp :: Settings -> Application -> (Int -> IO a) -> IO a
74+withApp settings app f = do
75+ port <- getPort
76+ baton <- newEmptyMVar
77+ bracket
78+ (forkIO $ runSettings settings
79+ { settingsPort = port
80+ , settingsBeforeMainLoop = putMVar baton ()
81+ } app)
82+ killThread
83+ (const $ takeMVar baton >> f port)
84+
71runTest :: Int -- ^ expected number of requests
85runTest :: Int -- ^ expected number of requests
72 -> CounterApplication
86 -> CounterApplication
73 -> [ByteString] -- ^ chunks to send
87 -> [ByteString] -- ^ chunks to send
74 -> IO ()
88 -> IO ()
75runTest expected app chunks = do
89runTest expected app chunks = do
76− port <- getPort
77 ref <- I.newIORef (Right 0)
90 ref <- I.newIORef (Right 0)
78− tid <- forkIO $ run port $ app ref
91+ withApp defaultSettings (app ref) $ \port -> do
79− threadDelay 1000
80− handle <- connectTo "127.0.0.1" $ PortNumber $ fromIntegral port
92+ handle <- connectTo "127.0.0.1" $ PortNumber $ fromIntegral port
81− forM_ chunks $ \chunk -> hPutStr handle chunk >> hFlush handle
93+ forM_ chunks $ \chunk -> hPutStr handle chunk >> hFlush handle
82− _ <- hGetSome handle 4096
94+ _ <- hGetSome handle 4096
83− threadDelay 1000
95+ threadDelay 1000
84− killThread tid
85− res <- I.readIORef ref
96+ res <- I.readIORef ref
86− case res of
97+ case res of
87− Left s -> error s
98+ Left s -> error s
88− Right i -> i `shouldBe` expected
99+ Right i -> i `shouldBe` expected
89
100
90dummyApp :: Application
101dummyApp :: Application
91dummyApp _ = return $ responseLBS status200 [] "foo"
102dummyApp _ = return $ responseLBS status200 [] "foo"
@@ -94,21 +105,17 @@ runTerminateTest :: InvalidRequest
94 -> ByteString
105 -> ByteString
95 -> IO ()
106 -> IO ()
96runTerminateTest expected input = do
107runTerminateTest expected input = do
97− port <- getPort
98 ref <- I.newIORef Nothing
108 ref <- I.newIORef Nothing
99− tid <- forkIO $ runSettings defaultSettings
109+ withApp defaultSettings
100− { settingsOnException = \e -> I.writeIORef ref $ Just e
110+ { settingsOnException = \e -> I.writeIORef ref $ Just e
101− , settingsPort = port
102− } dummyApp
111+ } dummyApp $ \port -> do
103− threadDelay 1000
104− handle <- connectTo "127.0.0.1" $ PortNumber $ fromIntegral port
112+ handle <- connectTo "127.0.0.1" $ PortNumber $ fromIntegral port
105− hPutStr handle input
113+ hPutStr handle input
106− hFlush handle
114+ hFlush handle
107− hClose handle
115+ hClose handle
108− threadDelay 1000
116+ threadDelay 1000
109− killThread tid
110− res <- I.readIORef ref
117+ res <- I.readIORef ref
111− show res `shouldBe` show (Just expected)
118+ show res `shouldBe` show (Just expected)
112
119
113singleGet :: ByteString
120singleGet :: ByteString
114singleGet = "GET / HTTP/1.1\r\nHost: localhost\r\n\r\n"
121singleGet = "GET / HTTP/1.1\r\nHost: localhost\r\n\r\n"
@@ -151,149 +158,135 @@ spec = do
151 describe "special input" $ do
158 describe "special input" $ do
152 it "multiline headers" $ do
159 it "multiline headers" $ do
153 iheaders <- I.newIORef []
160 iheaders <- I.newIORef []
154− port <- getPort
161+ let app req = do
155− tid <- forkIO $ run port $ \req -> do
156− liftIO $ I.writeIORef iheaders $ requestHeaders req
162+ liftIO $ I.writeIORef iheaders $ requestHeaders req
157− return $ responseLBS status200 [] ""
163+ return $ responseLBS status200 [] ""
158− threadDelay 1000
164+ withApp defaultSettings app $ \port -> do
159− handle <- connectTo "127.0.0.1" $ PortNumber $ fromIntegral port
165+ handle <- connectTo "127.0.0.1" $ PortNumber $ fromIntegral port
160− let input = S.concat
166+ let input = S.concat
161− [ "GET / HTTP/1.1\r\nfoo: bar\r\n baz\r\n\tbin\r\n\r\n"
167+ [ "GET / HTTP/1.1\r\nfoo: bar\r\n baz\r\n\tbin\r\n\r\n"
168+ ]
169+ hPutStr handle input
170+ hFlush handle
171+ hClose handle
172+ threadDelay 1000
173+ headers <- I.readIORef iheaders
174+ headers `shouldBe`
175+ [ ("foo", "bar baz\tbin")
162 ]
176 ]
163− hPutStr handle input
164− hFlush handle
165− hClose handle
166− threadDelay 1000
167− killThread tid
168− headers <- I.readIORef iheaders
169− headers `shouldBe`
170− [ ("foo", "bar baz\tbin")
171− ]
172 it "no space between colon and value" $ do
177 it "no space between colon and value" $ do
173 iheaders <- I.newIORef []
178 iheaders <- I.newIORef []
174− port <- getPort
179+ let app req = do
175− tid <- forkIO $ run port $ \req -> do
176− liftIO $ I.writeIORef iheaders $ requestHeaders req
180+ liftIO $ I.writeIORef iheaders $ requestHeaders req
177− return $ responseLBS status200 [] ""
181+ return $ responseLBS status200 [] ""
178− threadDelay 1000
182+ withApp defaultSettings app $ \port -> do
179− handle <- connectTo "127.0.0.1" $ PortNumber $ fromIntegral port
183+ handle <- connectTo "127.0.0.1" $ PortNumber $ fromIntegral port
180− let input = S.concat
184+ let input = S.concat
181− [ "GET / HTTP/1.1\r\nfoo:bar\r\n\r\n"
185+ [ "GET / HTTP/1.1\r\nfoo:bar\r\n\r\n"
186+ ]
187+ hPutStr handle input
188+ hFlush handle
189+ hClose handle
190+ threadDelay 1000
191+ headers <- I.readIORef iheaders
192+ headers `shouldBe`
193+ [ ("foo", "bar")
182 ]
194 ]
183− hPutStr handle input
184− hFlush handle
185− hClose handle
186− threadDelay 1000
187− killThread tid
188− headers <- I.readIORef iheaders
189− headers `shouldBe`
190− [ ("foo", "bar")
191− ]
192 it "extra spaces in first line" $ do
195 it "extra spaces in first line" $ do
193 iheaders <- I.newIORef []
196 iheaders <- I.newIORef []
194− port <- getPort
197+ let app req = do
195− tid <- forkIO $ run port $ \req -> do
196− liftIO $ I.writeIORef iheaders $ requestHeaders req
198+ liftIO $ I.writeIORef iheaders $ requestHeaders req
197− return $ responseLBS status200 [] ""
199+ return $ responseLBS status200 [] ""
198− threadDelay 1000
200+ withApp defaultSettings app $ \port -> do
199− handle <- connectTo "127.0.0.1" $ PortNumber $ fromIntegral port
201+ handle <- connectTo "127.0.0.1" $ PortNumber $ fromIntegral port
200− let input = S.concat
202+ let input = S.concat
201− [ "GET / HTTP/1.1\r\nfoo: bar\r\n\r\n"
203+ [ "GET / HTTP/1.1\r\nfoo: bar\r\n\r\n"
204+ ]
205+ hPutStr handle input
206+ hFlush handle
207+ hClose handle
208+ threadDelay 1000
209+ headers <- I.readIORef iheaders
210+ headers `shouldBe`
211+ [ ("foo", "bar")
202 ]
212 ]
203− hPutStr handle input
204− hFlush handle
205− hClose handle
206− threadDelay 1000
207− killThread tid
208− headers <- I.readIORef iheaders
209− headers `shouldBe`
210− [ ("foo", "bar")
211− ]
212 it "spaces in http version" $ do
213 it "spaces in http version" $ do
213 iversion <- I.newIORef $ error "Version not parsed"
214 iversion <- I.newIORef $ error "Version not parsed"
214− port <- getPort
215+ let app req = do
215− tid <- forkIO $ run port $ \req -> do
216− liftIO $ I.writeIORef iversion $ httpVersion req
216+ liftIO $ I.writeIORef iversion $ httpVersion req
217− return $ responseLBS status200 [] ""
217+ return $ responseLBS status200 [] ""
218− threadDelay 1000
218+ withApp defaultSettings app $ \port -> do
219− handle <- connectTo "127.0.0.1" $ PortNumber $ fromIntegral port
219+ handle <- connectTo "127.0.0.1" $ PortNumber $ fromIntegral port
220− let input = S.concat
220+ let input = S.concat
221− [ "GET / HTTP\t/ 1 . 1 \r\nfoo: bar\r\n\r\n"
221+ [ "GET / HTTP\t/ 1 . 1 \r\nfoo: bar\r\n\r\n"
222− ]
222+ ]
223− hPutStr handle input
223+ hPutStr handle input
224− hFlush handle
224+ hFlush handle
225− hClose handle
225+ hClose handle
226− threadDelay 1000
226+ threadDelay 1000
227− killThread tid
228− version <- I.readIORef iversion
227+ version <- I.readIORef iversion
229− version `shouldBe` http11
228+ version `shouldBe` http11
230
229
231 describe "chunked bodies" $ do
230 describe "chunked bodies" $ do
232 it "works" $ do
231 it "works" $ do
233 ifront <- I.newIORef id
232 ifront <- I.newIORef id
234− port <- getPort
233+ let app req = do
235− tid <- forkIO $ run port $ \req -> do
236− bss <- requestBody req $$ Data.Conduit.List.consume
234+ bss <- requestBody req $$ Data.Conduit.List.consume
237− liftIO $ I.atomicModifyIORef ifront $ \front -> (front . (S.concat bss:), ())
235+ liftIO $ I.atomicModifyIORef ifront $ \front -> (front . (S.concat bss:), ())
238− return $ responseLBS status200 [] ""
236+ return $ responseLBS status200 [] ""
239− threadDelay 1000
237+ withApp defaultSettings app $ \port -> do
240− handle <- connectTo "127.0.0.1" $ PortNumber $ fromIntegral port
238+ handle <- connectTo "127.0.0.1" $ PortNumber $ fromIntegral port
241− let input = S.concat
239+ let input = S.concat
242− [ "POST / HTTP/1.1\r\nTransfer-Encoding: Chunked\r\n\r\n"
240+ [ "POST / HTTP/1.1\r\nTransfer-Encoding: Chunked\r\n\r\n"
243− , "c\r\nHello World\n\r\n3\r\nBye\r\n0\r\n\r\n"
241+ , "c\r\nHello World\n\r\n3\r\nBye\r\n0\r\n\r\n"
244− , "POST / HTTP/1.1\r\nTransfer-Encoding: Chunked\r\n\r\n"
242+ , "POST / HTTP/1.1\r\nTransfer-Encoding: Chunked\r\n\r\n"
245− , "b\r\nHello World\r\n0\r\n\r\n"
243+ , "b\r\nHello World\r\n0\r\n\r\n"
244+ ]
245+ hPutStr handle input
246+ hFlush handle
247+ hClose handle
248+ threadDelay 1000
249+ front <- I.readIORef ifront
250+ front [] `shouldBe`
251+ [ "Hello World\nBye"
252+ , "Hello World"
246 ]
253 ]
247− hPutStr handle input
248− hFlush handle
249− hClose handle
250− threadDelay 1000
251− killThread tid
252− front <- I.readIORef ifront
253− front [] `shouldBe`
254− [ "Hello World\nBye"
255− , "Hello World"
256− ]
257 it "lots of chunks" $ do
254 it "lots of chunks" $ do
258 ifront <- I.newIORef id
255 ifront <- I.newIORef id
259− port <- getPort
256+ let app req = do
260− tid <- forkIO $ run port $ \req -> do
261− bss <- requestBody req $$ Data.Conduit.List.consume
257+ bss <- requestBody req $$ Data.Conduit.List.consume
262− liftIO $ I.atomicModifyIORef ifront $ \front -> (front . (S.concat bss:), ())
258+ liftIO $ I.atomicModifyIORef ifront $ \front -> (front . (S.concat bss:), ())
263− return $ responseLBS status200 [] ""
259+ return $ responseLBS status200 [] ""
264− threadDelay 1000
260+ withApp defaultSettings app $ \port -> do
265− handle <- connectTo "127.0.0.1" $ PortNumber $ fromIntegral port
261+ handle <- connectTo "127.0.0.1" $ PortNumber $ fromIntegral port
266− let input = concat $ replicate 2 $
262+ let input = concat $ replicate 2 $
267− ["POST / HTTP/1.1\r\nTransfer-Encoding: Chunked\r\n\r\n"] ++
263+ ["POST / HTTP/1.1\r\nTransfer-Encoding: Chunked\r\n\r\n"] ++
268− (replicate 50 "5\r\n12345\r\n") ++
264+ (replicate 50 "5\r\n12345\r\n") ++
269− ["0\r\n\r\n"]
265+ ["0\r\n\r\n"]
270− mapM_ (\bs -> hPutStr handle bs >> hFlush handle) input
266+ mapM_ (\bs -> hPutStr handle bs >> hFlush handle) input
271− hClose handle
267+ hClose handle
272− threadDelay 1000
268+ threadDelay 1000
273− killThread tid
274− front <- I.readIORef ifront
269+ front <- I.readIORef ifront
275− front [] `shouldBe` replicate 2 (S.concat $ replicate 50 "12345")
270+ front [] `shouldBe` replicate 2 (S.concat $ replicate 50 "12345")
276 it "in chunks" $ do
271 it "in chunks" $ do
277 ifront <- I.newIORef id
272 ifront <- I.newIORef id
278− port <- getPort
273+ let app req = do
279− tid <- forkIO $ run port $ \req -> do
280− bss <- requestBody req $$ Data.Conduit.List.consume
274+ bss <- requestBody req $$ Data.Conduit.List.consume
281− liftIO $ I.atomicModifyIORef ifront $ \front -> (front . (S.concat bss:), ())
275+ liftIO $ I.atomicModifyIORef ifront $ \front -> (front . (S.concat bss:), ())
282− return $ responseLBS status200 [] ""
276+ return $ responseLBS status200 [] ""
283− threadDelay 1000
277+ withApp defaultSettings app $ \port -> do
284− handle <- connectTo "127.0.0.1" $ PortNumber $ fromIntegral port
278+ handle <- connectTo "127.0.0.1" $ PortNumber $ fromIntegral port
285− let input = S.concat
279+ let input = S.concat
286− [ "POST / HTTP/1.1\r\nTransfer-Encoding: Chunked\r\n\r\n"
280+ [ "POST / HTTP/1.1\r\nTransfer-Encoding: Chunked\r\n\r\n"
287− , "c\r\nHello World\n\r\n3\r\nBye\r\n0\r\n"
281+ , "c\r\nHello World\n\r\n3\r\nBye\r\n0\r\n"
288− , "POST / HTTP/1.1\r\nTransfer-Encoding: Chunked\r\n\r\n"
282+ , "POST / HTTP/1.1\r\nTransfer-Encoding: Chunked\r\n\r\n"
289− , "b\r\nHello World\r\n0\r\n\r\n"
283+ , "b\r\nHello World\r\n0\r\n\r\n"
284+ ]
285+ mapM_ (\bs -> hPutStr handle bs >> hFlush handle) $ map S.singleton $ S.unpack input
286+ hClose handle
287+ threadDelay 1000
288+ front <- I.readIORef ifront
289+ front [] `shouldBe`
290+ [ "Hello World\nBye"
291+ , "Hello World"
290 ]
292 ]
291− mapM_ (\bs -> hPutStr handle bs >> hFlush handle) $ map S.singleton $ S.unpack input
292− hClose handle
293− threadDelay 1000
294− killThread tid
295− front <- I.readIORef ifront
296− front [] `shouldBe`
297− [ "Hello World\nBye"
298− , "Hello World"
299− ]
warp/warp.cabal+1−1
@@ -1,5 +1,5 @@
1Name: warp
1Name: warp
2−Version: 1.3.5.1
2+Version: 1.3.6
3Synopsis: A fast, light-weight web server for WAI applications.
3Synopsis: A fast, light-weight web server for WAI applications.
4License: MIT
4License: MIT
5License-file: LICENSE
5License-file: LICENSE