on 1932ddd help sign in
7 files changed+31−83
since splitsnapshots
unifiedsplit
wai-extra/ChangeLog.md−4 wai-extra/Network/Wai/Test.hs+14−22 wai-extra/test/Network/Wai/TestSpec.hs+11−41 wai-extra/wai-extra.cabal+1−1 wai-websockets/server.lhs−6 warp-tls/Network/Wai/Handler/WarpTLS.hs+2−2 warp/Network/Wai/Handler/Warp/Run.hs+3−7
wai-extra/ChangeLog.md−4
@@ -1,9 +1,5 @@
11# Changelog for wai-extra
22
3−## 3.0.29.1
4−
5−* Fix `Network.Wai.Test.request` always sending an empty request body [#794](https://github.com/yesodweb/wai/pull/794)
6−
73## 3.0.29
84
95* Export `Network.Wai.EventSource.eventStreamAppRaw` [#786](https://github.com/yesodweb/wai/pull/786)
wai-extra/Network/Wai/Test.hs+14−22
@@ -99,10 +99,6 @@ runSession session app = ST.evalStateT (runReaderT session app) initState
9999data SRequest = SRequest
100100 { simpleRequest :: Request
101101 , simpleRequestBody :: L.ByteString
102− -- ^ Request body that will override the one set in 'simpleRequest'.
103− --
104− -- This is usually simpler than setting the body as a stateful IO-action
105− -- in 'simpleRequest'.
106102 }
107103data SResponse = SResponse
108104 { simpleStatus :: H.Status
@@ -110,16 +106,8 @@ data SResponse = SResponse
110106 , simpleBody :: L.ByteString
111107 }
112108 deriving (Show, Eq)
113−
114109request :: Request -> Session SResponse
115−request req = do
116− app <- ask
117− req' <- addCookiesToRequest req
118− response <- liftIO $ do
119− ref <- newIORef $ error "runResponse gave no result"
120− ResponseReceived <- app req' (runResponse ref)
121− readIORef ref
122− extractSetCookieFromSResponse response
110+request = srequest . flip SRequest L.empty
123111
124112-- | Set whole path (request path + query string).
125113setPath :: Request -> S8.ByteString -> Request
@@ -178,18 +166,22 @@ extractSetCookieFromSResponse response = do
178166 (Map.fromList [(Cookie.setCookieName c, c) | c <- newClientCookies ]))
179167 return response
180168
181−-- | Similar to 'request', but allows setting the request body as a plain
182−-- 'L.ByteString'.
183169srequest :: SRequest -> Session SResponse
184170srequest (SRequest req bod) = do
171+ app <- ask
185172 refChunks <- liftIO $ newIORef $ L.toChunks bod
186− request $
187− req
188− { requestBody = atomicModifyIORef refChunks $ \bss ->
189− case bss of
190− [] -> ([], S.empty)
191− x:y -> (y, x)
192− }
173+ let req' = req
174+ { requestBody = atomicModifyIORef refChunks $ \bss ->
175+ case bss of
176+ [] -> ([], S.empty)
177+ x:y -> (y, x)
178+ }
179+ req'' <- addCookiesToRequest req'
180+ response <- liftIO $ do
181+ ref <- newIORef $ error "runResponse gave no result"
182+ ResponseReceived <- app req'' (runResponse ref)
183+ readIORef ref
184+ extractSetCookieFromSResponse response
193185
194186runResponse :: IORef SResponse -> Response -> IO ResponseReceived
195187runResponse ref res = do
wai-extra/test/Network/Wai/TestSpec.hs+11−41
@@ -3,8 +3,6 @@ module Network.Wai.TestSpec (main, spec) where
33
44import Control.Monad (void)
55
6−import qualified Data.IORef as IORef
7−
86import qualified Data.Text.Encoding as TE
97
108import Data.Time.Calendar (fromGregorian)
@@ -55,53 +53,25 @@ spec = do
5553 it "sets rawQueryString to empty string" $ do
5654 rawQueryString (setPath defaultRequest "/foo/bar/baz") `shouldBe` ""
5755
58− describe "srequest" $ do
59−
60− let echoApp req respond = do
61− reqBody <- L8.fromStrict <$> getRequestBodyChunk req
62− let reqHeaders = requestHeaders req
63− respond $
64− responseLBS
65− status200
66− reqHeaders
67− reqBody
68−
69− it "returns the response body of an echo app" $ do
70− sresp <- flip runSession echoApp $
71− srequest $ SRequest defaultRequest "request body"
72− simpleBody sresp `shouldBe` "request body"
73−
7456 describe "request" $ do
7557
76− let echoApp req respond = do
77− reqBody <- L8.fromStrict <$> getRequestBodyChunk req
78− let reqHeaders = requestHeaders req
58+ let simpleApp _req respond =
7959 respond $
8060 responseLBS
8161 status200
82− reqHeaders
83− reqBody
62+ [("foo", "bar")]
63+ "simple"
8464
85− it "returns the status code of an echo app on default request" $ do
86− sresp <- runSession (request defaultRequest) echoApp
65+ it "returns the status code of a simple app on default request" $ do
66+ sresp <- runSession (request defaultRequest) simpleApp
8767 simpleStatus sresp `shouldBe` status200
8868
89− it "returns the response body of an echo app" $ do
90− bodyRef <- IORef.newIORef "request body"
91− let getBodyChunk = IORef.atomicModifyIORef bodyRef $ \leftover -> ("", leftover)
92− sresp <- flip runSession echoApp $
93− request $
94− defaultRequest
95− { requestBody = getBodyChunk
96− }
97− simpleBody sresp `shouldBe` "request body"
98−
99− it "returns the response headers of an echo app" $ do
100− sresp <- flip runSession echoApp $
101− request $
102− defaultRequest
103− { requestHeaders = [("foo", "bar")]
104− }
69+ it "returns the response body of a simple app on default request" $ do
70+ sresp <- runSession (request defaultRequest) simpleApp
71+ simpleBody sresp `shouldBe` "simple"
72+
73+ it "returns the response headers of a simple app on default request" $ do
74+ sresp <- runSession (request defaultRequest) simpleApp
10575 simpleHeaders sresp `shouldBe` [("foo", "bar")]
10676
10777 let cookieApp req respond =
wai-extra/wai-extra.cabal+1−1
@@ -1,5 +1,5 @@
11Name: wai-extra
2−Version: 3.0.29.1
2+Version: 3.0.29
33Synopsis: Provides some basic WAI handlers and middleware.
44description:
55 Provides basic WAI handler and middleware functionality:
wai-websockets/server.lhs−6
@@ -8,8 +8,6 @@ this example, keep the [reference](http://jaspervdj.be/websockets/reference)
88nearby to check out the functions we use.
99
1010> {-# LANGUAGE OverloadedStrings, TemplateHaskell #-}
11−> {-# LANGUAGE CPP #-}
12−> {-# OPTIONS_GHC -Wno-unused-top-binds #-} -- for numClients
1311> import Data.Char (isPunctuation, isSpace)
1412> import Data.Monoid (mappend)
1513> import Data.Text (Text)
@@ -101,11 +99,7 @@ stays alive on some browsers.
10199
102100> application state pending = do
103101> conn <- WS.acceptRequest pending
104−#if __GLASGOW_HASKELL__ >= 806
105102> WS.withPingThread conn 30 (return ()) $ do
106−#else
107−> WS.forkPingThread conn 30
108−#endif
109103
110104When a client is successfully connected, we read the first message. This should
111105be in the format of "Hi! I am Jasper", where Jasper is the requested username.
warp-tls/Network/Wai/Handler/WarpTLS.hs+2−2
@@ -483,9 +483,9 @@ tryIO = try
483483----------------------------------------------------------------
484484
485485plainHTTP :: TLSSettings -> Settings -> Socket -> S.ByteString -> IO (Connection, Transport)
486−plainHTTP TLSSettings{..} set s bs0 = case onInsecure of
486+plainHTTP TLSSettings{..} _ s bs0 = case onInsecure of
487487 AllowInsecure -> do
488− conn' <- socketConnection set s
488+ conn' <- socketConnection s
489489 cachedRef <- I.newIORef bs0
490490 let conn'' = conn'
491491 { connRecv = recvPlain cachedRef (connRecv conn')
warp/Network/Wai/Handler/Warp/Run.hs+3−7
@@ -58,12 +58,8 @@ import Network.Socket (fdSocket)
5858#endif
5959
6060-- | Creating 'Connection' for plain HTTP based on a given socket.
61−socketConnection :: Settings -> Socket -> IO Connection
62−#if MIN_VERSION_network(3,1,1)
63−socketConnection set s = do
64−#else
65−socketConnection _ s = do
66−#endif
61+socketConnection :: Socket -> IO Connection
62+socketConnection s = do
6763 bufferPool <- newBufferPool
6864 writeBuf <- allocateBuffer bufferSize
6965 let sendall = Sock.sendAll s
@@ -151,7 +147,7 @@ runSettingsSocket set socket app = do
151147 setSocketCloseOnExec s
152148 -- NoDelay causes an error for AF_UNIX.
153149 setSocketOption s NoDelay 1 `E.catch` \(E.SomeException _) -> return ()
154− conn <- socketConnection set s
150+ conn <- socketConnection s
155151 return (conn, sa)
156152
157153 closeListenSocket = close socket