fe2032a · typeable/wai

git.iko.soy/typeable/wai

Pass around an InternalState instead of living in ResourceT

commitfe2032ad4c7435709ed79683acac3b91110bba04 authorMichael Snoyman <michael@snoyman.com> dateMon 22 Jul 2013, 15:14 (13 years ago) parent671720e

10 files changed+77−66

compare with master

unifiedsplit

wai/Network/Wai.hs+22−10 wai/wai.cabal+2−1 warp/Network/Wai/Handler/Warp/Conduit.hs+3−3 warp/Network/Wai/Handler/Warp/Request.hs+18−20 warp/Network/Wai/Handler/Warp/Response.hs+3−3 warp/Network/Wai/Handler/Warp/Run.hs+14−15 warp/Network/Wai/Handler/Warp/Settings.hs+1−1 warp/test/ConduitSpec.hs+6−7 warp/test/RequestSpec.hs+4−4 warp/warp.cabal+4−2

wai/Network/Wai.hs+22−10

@@ -63,6 +63,7 @@ import Data.ByteString.Lazy.Char8 () -- makes it easier to use responseLBS

6363import Blaze.ByteString.Builder (fromByteString)

6464import Data.Vault (Vault)

6565import Data.Word (Word64)

66+import qualified Control.Monad.Trans.Resource as Res

6667

6768-- | Information on the request sent by the client. This abstracts away the

6869-- details of the underlying implementation.

@@ -102,13 +103,18 @@ data Request = Request

102103 , pathInfo :: [Text]

103104 -- | Parsed query string information

104105 , queryString :: H.Query

105− , requestBody :: C.Source (C.ResourceT IO) B.ByteString

106+ , requestBody :: C.Source IO B.ByteString

106107 -- | A location for arbitrary data to be shared by applications and middleware.

107108 , vault :: Vault

108109 -- | The size of the request body. In the case of a chunked request body, this may be unknown.

109110 --

110111 -- Since 1.4.0

111112 , requestBodyLength :: RequestBodyLength

113+ -- | The internal @ResourceT@ state, used for allocating scarce resources

114+ -- will in an application.

115+ --

116+ -- Since 1.5.0

117+ , resourceInternalState :: Res.InternalState

112118 }

113119 deriving (Typeable)

114120

@@ -138,7 +144,7 @@ data Request = Request

138144data Response

139145 = ResponseFile H.Status H.ResponseHeaders FilePath (Maybe FilePart)

140146 | ResponseBuilder H.Status H.ResponseHeaders Builder

141− | ResponseSource H.Status H.ResponseHeaders (C.Source (C.ResourceT IO) (C.Flush Builder))

147+ | ResponseSource H.Status H.ResponseHeaders (C.Source IO (C.Flush Builder))

142148 deriving Typeable

143149

144150responseStatus :: Response -> H.Status

@@ -153,13 +159,19 @@ data FilePart = FilePart

153159 , filePartByteCount :: Integer

154160 } deriving Show

155161

156−responseSource :: Response -> (H.Status, H.ResponseHeaders, C.Source (C.ResourceT IO) (C.Flush Builder))

157−responseSource (ResponseSource s h b) = (s, h, b)

158−responseSource (ResponseFile s h fp (Just part)) =

159− (s, h, sourceFilePart part fp C.$= CL.map (C.Chunk . fromByteString))

160−responseSource (ResponseFile s h fp Nothing) =

161− (s, h, CB.sourceFile fp C.$= CL.map (C.Chunk . fromByteString))

162−responseSource (ResponseBuilder s h b) =

162+responseSource :: Request

163+ -> Response

164+ -> (H.Status, H.ResponseHeaders, C.Source IO (C.Flush Builder))

165+responseSource _ (ResponseSource s h b) = (s, h, b)

166+responseSource req (ResponseFile s h fp (Just part)) =

167+ (s, h, transRes (sourceFilePart part fp) C.$= CL.map (C.Chunk . fromByteString))

168+ where

169+ transRes = C.transPipe (flip Res.runInternalState (resourceInternalState req))

170+responseSource req (ResponseFile s h fp Nothing) =

171+ (s, h, transRes (CB.sourceFile fp) C.$= CL.map (C.Chunk . fromByteString))

172+ where

173+ transRes = C.transPipe (flip Res.runInternalState (resourceInternalState req))

174+responseSource _ (ResponseBuilder s h b) =

163175 (s, h, CL.sourceList [C.Chunk b])

164176

165177sourceFilePart :: C.MonadResource m => FilePart -> FilePath -> C.Source m B.ByteString

@@ -169,7 +181,7 @@ sourceFilePart (FilePart offset count) fp =

169181responseLBS :: H.Status -> H.ResponseHeaders -> L.ByteString -> Response

170182responseLBS s h = ResponseBuilder s h . fromLazyByteString

171183

172−type Application = Request -> C.ResourceT IO Response

184+type Application = Request -> IO Response

173185

174186-- | Middleware is a component that sits between the server and application. It

175187-- can do such tasks as GZIP encoding or response caching. What follows is the

wai/wai.cabal+2−1

@@ -1,5 +1,5 @@

11Name: wai

2−Version: 1.4.0.1

2+Version: 1.5.0

33Synopsis: Web Application Interface.

44Description: Provides a common protocol for communication between web applications and web servers.

55License: MIT

@@ -26,5 +26,6 @@ Library

2626 , text >= 0.7

2727 , transformers >= 0.2.2

2828 , vault >= 0.1 && < 0.3

29+ , resourcet >= 0.4.7

2930 Exposed-modules: Network.Wai

3031 ghc-options: -Wall

warp/Network/Wai/Handler/Warp/Conduit.hs+3−3

@@ -20,13 +20,13 @@ import Network.Wai.Handler.Warp.Types

2020----------------------------------------------------------------

2121

2222-- | Contains a @Source@ and a byte count that is still to be read in.

23−newtype IsolatedBSSource = IsolatedBSSource (I.IORef (Int, ResumableSource (ResourceT IO) ByteString))

23+newtype IsolatedBSSource = IsolatedBSSource (I.IORef (Int, ResumableSource IO ByteString))

2424

2525-- | Given an @IsolatedBSSource@ provide a @Source@ that only allows up to the

2626-- specified number of bytes to be passed downstream. All leftovers should be

2727-- retained within the @Source@. If there are not enough bytes available,

2828-- throws a @ConnectionClosedByPeer@ exception.

29−ibsIsolate :: IsolatedBSSource -> Source (ResourceT IO) ByteString

29+ibsIsolate :: IsolatedBSSource -> Source IO ByteString

3030ibsIsolate ibs@(IsolatedBSSource ref) = do

3131 (count, src) <- liftIO $ I.readIORef ref

3232 unless (count == 0) $ do

@@ -70,7 +70,7 @@ ibsIsolate ibs@(IsolatedBSSource ref) = do

7070

7171-- | Extract the underlying @Source@ from an @IsolatedBSSource@, which will not

7272-- perform any more isolation.

73−ibsDone :: IsolatedBSSource -> IO (ResumableSource (ResourceT IO) ByteString)

73+ibsDone :: IsolatedBSSource -> IO (ResumableSource IO ByteString)

7474ibsDone (IsolatedBSSource ref) = snd <$> I.readIORef ref

7575

7676----------------------------------------------------------------

warp/Network/Wai/Handler/Warp/Request.hs+18−20

@@ -26,26 +26,22 @@ import Network.Wai.Handler.Warp.ReadInt

2626import Network.Wai.Handler.Warp.Types

2727import Prelude hiding (lines)

2828import qualified Network.Wai.Handler.Warp.Timeout as Timeout

29+import qualified Control.Monad.Trans.Resource as Res

2930

3031-- FIXME come up with good values here

3132maxTotalHeaderLength :: Int

3233maxTotalHeaderLength = 50 * 1024

3334

34−parseRequest :: Connection

35− -> Port -> SockAddr

36− -> Source (ResourceT IO) ByteString

37− -> ResourceT IO (Request, IO (ResumableSource (ResourceT IO) ByteString))

38−parseRequest conn = parseRequestInternal conn Timeout.dummyHandle

39−

40−parseRequestInternal

35+parseRequest

4136 :: Connection

4237 -> Timeout.Handle

38+ -> Res.InternalState

4339 -> Port -> SockAddr

44− -> Source (ResourceT IO) ByteString

45− -> ResourceT IO (Request, IO (ResumableSource (ResourceT IO) ByteString))

46−parseRequestInternal conn timeoutHandle port remoteHost' src1 = do

40+ -> Source IO ByteString

41+ -> IO (Request, IO (ResumableSource IO ByteString))

42+parseRequest conn timeoutHandle internalState port remoteHost' src1 = do

4743 (src2, headers') <- src1 $$+ takeHeaders

48− parseRequest' conn timeoutHandle port headers' remoteHost' src2

44+ parseRequest' conn timeoutHandle internalState port headers' remoteHost' src2

4945

5046handleExpect :: Connection

5147 -> H.HttpVersion

@@ -64,13 +60,14 @@ handleExpect conn hv front (x:xs) = handleExpect conn hv (front . (x:)) xs

6460-- | Parse a set of header lines and body into a 'Request'.

6561parseRequest' :: Connection

6662 -> Timeout.Handle

63+ -> Res.InternalState

6764 -> Port

6865 -> [ByteString]

6966 -> SockAddr

70− -> ResumableSource (ResourceT IO) ByteString -- FIXME was buffered

71− -> ResourceT IO (Request, IO (ResumableSource (ResourceT IO) ByteString))

72−parseRequest' _ _ _ [] _ _ = throwIO $ NotEnoughLines []

73−parseRequest' conn timeoutHandle port (firstLine:otherLines) remoteHost' src = do

67+ -> ResumableSource IO ByteString -- FIXME was buffered

68+ -> IO (Request, IO (ResumableSource IO ByteString))

69+parseRequest' _ _ _ _ [] _ _ = throwIO $ NotEnoughLines []

70+parseRequest' conn timeoutHandle internalState port (firstLine:otherLines) remoteHost' src = do

7471 (method, rpath', gets, httpversion) <- parseFirst firstLine

7572 let (host',rpath)

7673 | S.null rpath' = ("", "/")

@@ -87,7 +84,7 @@ parseRequest' conn timeoutHandle port (firstLine:otherLines) remoteHost' src = d

8784 let serverName' = takeUntil 58 host -- ':'

8885 let chunked = maybe False ((== "chunked") . CI.foldCase)

8986 $ lookup hTransferEncoding heads

90− (rbody, getSource) <- liftIO $

87+ (rbody, getSource) <-

9188 if chunked

9289 then do

9390 ref <- I.newIORef (src, NeedLen)

@@ -125,6 +122,7 @@ parseRequest' conn timeoutHandle port (firstLine:otherLines) remoteHost' src = d

125122 then ChunkedBody

126123 else KnownLength $ fromIntegral len0

127124#endif

125+ , resourceInternalState = internalState

128126 }, getSource)

129127

130128{-# INLINE takeUntil #-}

@@ -136,7 +134,7 @@ takeUntil c bs =

136134

137135{-# INLINE parseFirst #-} -- FIXME is this inline necessary? the function is only called from one place and not exported

138136parseFirst :: ByteString

139− -> ResourceT IO (ByteString, ByteString, ByteString, H.HttpVersion)

137+ -> IO (ByteString, ByteString, ByteString, H.HttpVersion)

140138parseFirst s =

141139 case filter (not . S.null) $ S.splitWith (\c -> c == 32 || c == 9) s of -- ' '

142140 (method:query:http'') -> do

@@ -167,14 +165,14 @@ data THStatus = THStatus

167165 BSEndo -- bytestrings to be prepended

168166

169167{-# INLINE takeHeaders #-}

170−takeHeaders :: Sink ByteString (ResourceT IO) [ByteString]

168+takeHeaders :: Sink ByteString IO [ByteString]

171169takeHeaders =

172170 await >>= maybe (throwIO ConnectionClosedByPeer) (push (THStatus 0 id id))

173171

174−close :: Sink ByteString (ResourceT IO) a

172+close :: Sink ByteString IO a

175173close = throwIO IncompleteHeaders

176174

177−push :: THStatus -> ByteString -> Sink ByteString (ResourceT IO) [ByteString]

175+push :: THStatus -> ByteString -> Sink ByteString IO [ByteString]

178176push (THStatus len lines prepend) bs

179177 -- Too many bytes

180178 | len > maxTotalHeaderLength = throwIO OverLargeHeader

warp/Network/Wai/Handler/Warp/Response.hs+3−3

@@ -35,7 +35,7 @@ import Numeric (showInt)

3535

3636sendResponse :: Settings

3737 -> Cleaner -> Request -> Connection -> Response

38− -> ResourceT IO Bool

38+ -> IO Bool

3939

4040----------------------------------------------------------------

4141

@@ -143,7 +143,7 @@ sendResponse settings cleaner req conn (ResponseSource s hs bodyFlush)

143143 cbody = if needsChunked then body $= chunk else body

144144 -- FIXME perhaps alloca a buffer per thread and reuse that in all

145145 -- functions below. Should lessen greatly the GC burden (I hope)

146− chunk :: Conduit Builder (ResourceT IO) Builder

146+ chunk :: Conduit Builder IO Builder

147147 chunk = await >>= maybe (yield chunkedTransferTerminator) (\x -> yield (chunkedTransferEncoding x) >> chunk)

148148 version = httpVersion req

149149 reqinfo@(isPersist,_) = infoFromRequest req

@@ -153,7 +153,7 @@ sendResponse settings cleaner req conn (ResponseSource s hs bodyFlush)

153153----------------------------------------------------------------

154154

155155-- | Use 'connSendAll' to send this data while respecting timeout rules.

156−connSink :: Connection -> T.Handle -> Sink ByteString (ResourceT IO) ()

156+connSink :: Connection -> T.Handle -> Sink ByteString IO ()

157157connSink Connection { connSendAll = send } th =

158158 sink

159159 where

warp/Network/Wai/Handler/Warp/Run.hs+14−15

@@ -7,7 +7,7 @@ import Control.Concurrent (threadDelay, forkIOWithUnmask)

77import Control.Exception

88import Control.Monad (forever, when, unless, void)

99import Control.Monad.IO.Class (MonadIO, liftIO)

10−import Control.Monad.Trans.Class (lift)

10+import qualified Control.Monad.Trans.Resource as Res

1111import Data.ByteString (ByteString)

1212import qualified Data.ByteString as S

1313import Data.Conduit

@@ -233,39 +233,38 @@ serveConnection :: T.Handle

233233 -> Cleaner

234234 -> Port -> Application -> Connection -> SockAddr-> IO ()

235235serveConnection timeoutHandle settings cleaner port app conn remoteHost' =

236− runResourceT serveConnection'

236+ runResourceT $ Res.withInternalState $ serveConnection'' $ connSource conn th

237237 where

238− innerRunResourceT

239− | settingsResourceTPerRequest settings = lift . runResourceT

240− | otherwise = id

238+ innerRunResourceT env f

239+ | settingsResourceTPerRequest settings = runResourceT $ Res.withInternalState $ \is' -> f env

240+ { resourceInternalState = is'

241+ }

242+ | otherwise = f env

241243 th = threadHandle cleaner

242244

243− serveConnection' :: ResourceT IO ()

244− serveConnection' = serveConnection'' $ connSource conn th

245−

246− serveConnection'' fromClient = do

247− (env, getSource) <- parseRequestInternal conn timeoutHandle port remoteHost' fromClient

245+ serveConnection'' fromClient internalState = do

246+ (env, getSource) <- parseRequest conn timeoutHandle internalState port remoteHost' fromClient

248247 case settingsIntercept settings env of

249248 Nothing -> do

250249 -- Let the application run for as long as it wants

251250 liftIO $ T.pause th

252− keepAlive <- innerRunResourceT $ do

253− res <- app env

251+ keepAlive <- innerRunResourceT env $ \env' -> do

252+ res <- app env'

254253

255254 liftIO $ T.resume th

256− sendResponse settings cleaner env conn res

255+ sendResponse settings cleaner env' conn res

257256

258257 -- flush the rest of the request body

259258 requestBody env $$ CL.sinkNull

260259 ResumableSource fromClient' _ <- liftIO getSource

261260

262− when keepAlive $ serveConnection'' fromClient'

261+ when keepAlive $ serveConnection'' fromClient' internalState

263262 Just intercept -> do

264263 liftIO $ T.pause th

265264 ResumableSource fromClient' _ <- liftIO getSource

266265 intercept fromClient' conn

267266

268−connSource :: Connection -> T.Handle -> Source (ResourceT IO) ByteString

267+connSource :: Connection -> T.Handle -> Source IO ByteString

269268connSource Connection { connRecv = recv } th = src

270269 where

271270 src = do

warp/Network/Wai/Handler/Warp/Settings.hs+1−1

@@ -25,7 +25,7 @@ data Settings = Settings

2525 , settingsOnOpen :: IO () -- ^ What to do when a connection is open. Default: do nothing.

2626 , settingsOnClose :: IO () -- ^ What to do when a connection is close. Default: do nothing.

2727 , settingsTimeout :: Int -- ^ Timeout value in seconds. Default value: 30

28− , settingsIntercept :: Request -> Maybe (Source (ResourceT IO) S.ByteString -> Connection -> ResourceT IO ())

28+ , settingsIntercept :: Request -> Maybe (Source IO S.ByteString -> Connection -> IO ())

2929 , settingsManager :: Maybe Manager -- ^ Use an existing timeout manager instead of spawning a new one. If used, 'settingsTimeout' is ignored. Default is 'Nothing'

3030 , settingsFdCacheDuration :: Int -- ^ Cache duratoin time of file descriptors in seconds. 0 means that the cache mechanism is not used. Default value: 10

3131 , settingsResourceTPerRequest :: Bool

warp/test/ConduitSpec.hs+6−7

@@ -7,25 +7,24 @@ import qualified Data.Conduit.List as CL

77import Test.Hspec

88import qualified Data.IORef as I

99import qualified Data.ByteString as S

10−import Control.Monad.Trans.Class (lift)

1110

1211main :: IO ()

1312main = hspec spec

1413

1514spec :: Spec

1615spec = describe "conduit" $ do

17− it "IsolatedBSSource" $ runResourceT $ do

16+ it "IsolatedBSSource" $ do

1817 (rsrc, ()) <- mapM_ yield (map S.singleton [1..50]) $$+ return ()

19− ibs <- lift $ fmap IsolatedBSSource $ I.newIORef (40, rsrc)

18+ ibs <- fmap IsolatedBSSource $ I.newIORef (40, rsrc)

2019 x <- ibsIsolate ibs $$ CL.take 20

21− lift $ S.concat x `shouldBe` S.pack [1..20]

20+ S.concat x `shouldBe` S.pack [1..20]

2221

2322 y <- ibsIsolate ibs $$ CL.consume

24− lift $ S.concat y `shouldBe` S.pack [21..40]

23+ S.concat y `shouldBe` S.pack [21..40]

2524

26− rsrc' <- lift $ ibsDone ibs

25+ rsrc' <- ibsDone ibs

2726 z <- rsrc' $$+- CL.consume

28− lift $ S.concat z `shouldBe` S.pack [41..50]

27+ S.concat z `shouldBe` S.pack [41..50]

2928 it "chunkedSource" $ do

3029 (rsrc, ()) <- yield "5\r\n12345\r\n3\r\n678\r\n0\r\nBLAH" $$+ return ()

3130 ref <- I.newIORef (rsrc, NeedLen)

warp/test/RequestSpec.hs+4−4

@@ -22,10 +22,10 @@ spec = describe "takeHeaders" $ do

2222 it "throws OverLargeHeader when too large" $

2323 tooLarge `shouldThrow` overLargeHeader

2424 where

25− blankSafe = runResourceT $ (sourceList ["f", "oo\n", "bar\nbaz\n\r\n"]) $$ takeHeaders

26− whiteSafe = runResourceT $ (sourceList ["foo\r\nbar\r\nbaz\r\n\r\n hi there"]) $$ takeHeaders

27− tooMany = runResourceT $ (sourceList $ repeat "f\n") $$ takeHeaders

28− tooLarge = runResourceT $ (sourceList $ repeat "f") $$ takeHeaders

25+ blankSafe = (sourceList ["f", "oo\n", "bar\nbaz\n\r\n"]) $$ takeHeaders

26+ whiteSafe = (sourceList ["foo\r\nbar\r\nbaz\r\n\r\n hi there"]) $$ takeHeaders

27+ tooMany = (sourceList $ repeat "f\n") $$ takeHeaders

28+ tooLarge = (sourceList $ repeat "f") $$ takeHeaders

2929

3030overLargeHeader :: Selector InvalidRequest

3131overLargeHeader e = e == OverLargeHeader

warp/warp.cabal+4−2

@@ -1,5 +1,5 @@

11Name: warp

2−Version: 1.3.9

2+Version: 1.5.0

33Synopsis: A fast, light-weight web server for WAI applications.

44License: MIT

55License-file: LICENSE

@@ -42,8 +42,9 @@ Library

4242 , transformers >= 0.2.2 && < 0.4

4343 , unix-compat >= 0.2

4444 , void

45− , wai >= 1.3 && < 1.5

45+ , wai >= 1.5 && < 1.6

4646 , http-attoparsec

47+ , resourcet

4748 if flag(network-bytestring)

4849 Build-Depends: network >= 2.2.1.5 && < 2.2.3

4950 , network-bytestring >= 0.1.3 && < 0.1.4

@@ -97,6 +98,7 @@ Test-Suite spec

9798 , HUnit

9899 , QuickCheck

99100 , hspec >= 1.3

101+ , resourcet

100102

101103 -- Yes, this means that the test suite will no longer work on Windows.

102104 -- Unfortunately there is a bug in older versions of cabal, and this conditional