git.iko.soy/typeable/wai
on master help sign in
Merge pull request #317 from pparkkin/streamfile

WAI middleware that converts a ResponseFile into ResponseStream.

commitaa0cba90dd9f8c699d60ba940c452062dd7bfc11 authorMichael Snoyman <michael@snoyman.com> dateMon 5 Jan 2015, 10:55 (12 years ago) parent163005a6cdbc1b
3 files changed+67
compare with master
unifiedsplit
wai-extra/Network/Wai/Middleware/StreamFile.hs+39 wai-extra/test/WaiExtraSpec.hs+27 wai-extra/wai-extra.cabal+1
wai-extra/Network/Wai/Middleware/StreamFile.hsnew file+39
@@ -0,0 +1,39 @@
1+{-# LANGUAGE OverloadedStrings #-}
2+
3+module Network.Wai.Middleware.StreamFile
4+ (streamFile) where
5+
6+import Network.Wai (responseStream)
7+import Network.Wai.Internal
8+import Network.Wai (Middleware, responseToStream)
9+import qualified Data.ByteString.Char8 as S8
10+import System.Posix
11+
12+-- |Convert ResponseFile type responses into ResponseStream type
13+--
14+-- Checks the response type, and if it's a ResponseFile, converts it
15+-- into a ResponseStream. Other response types are passed through
16+-- unchanged.
17+--
18+-- Converted responses get a Content-Length header.
19+--
20+-- Streaming a file will bypass a sendfile system call, and may be
21+-- useful to work around systems without working sendfile
22+-- implementations.
23+streamFile :: Middleware
24+streamFile app env sendResponse = app env $ \res ->
25+ case res of
26+ ResponseFile _ _ fp _ -> withBody sendBody
27+ where
28+ (s, hs, withBody) = responseToStream res
29+ sendBody :: StreamingBody -> IO ResponseReceived
30+ sendBody body = do
31+ len <- getFileSize fp
32+ let hs' = ("Content-Length", (S8.pack (show len))) : hs
33+ sendResponse $ responseStream s hs' body
34+ _ -> sendResponse res
35+
36+getFileSize :: FilePath -> IO FileOffset
37+getFileSize path = do
38+ stat <- getFileStatus path
39+ return (fileSize stat)
wai-extra/test/WaiExtraSpec.hs+27
@@ -25,6 +25,7 @@ import Network.Wai.Middleware.MethodOverridePost
2525import Network.Wai.Middleware.AcceptOverride
2626import Network.Wai.Middleware.RequestLogger
2727import Codec.Compression.GZip (decompress)
28+import Network.Wai.Middleware.StreamFile
2829
2930import Control.Monad.IO.Class (liftIO)
3031import Data.Maybe (fromMaybe)
@@ -57,6 +58,8 @@ spec = do
5758 it "method override post" caseMethodOverridePost
5859 it "accept override" caseAcceptOverride
5960 it "debug request body" caseDebugRequestBody
61+ it "stream file" caseStreamFile
62+ it "stream LBS" caseStreamLBS
6063
6164toRequest :: S8.ByteString -> S8.ByteString -> SRequest
6265toRequest ctype content = SRequest defaultRequest
@@ -419,3 +422,27 @@ casesUrlMap = [pair1, pair2, pair3, pair4]
419422 pair4 = makePair "should 404 if none match" $ do
420423 res4 <- get "/api/v3"
421424 assertStatus 404 res4
425+
426+testFile :: FilePath
427+testFile = "test/WaiExtraSpec.hs"
428+
429+streamFileApp :: Application
430+streamFileApp = streamFile $ \_ f -> f $ responseFile status200 [] testFile Nothing
431+
432+caseStreamFile :: Assertion
433+caseStreamFile = flip runSession streamFileApp $ do
434+ sres <- request defaultRequest
435+ assertStatus 200 sres
436+ assertBodyContains "caseStreamFile" sres
437+ assertNoHeader "Transfer-Encoding" sres
438+
439+streamLBSApp :: Application
440+streamLBSApp = streamFile $ \_ f -> f $ responseLBS status200
441+ [("Content-Type", "text/plain")]
442+ "test"
443+
444+caseStreamLBS :: Assertion
445+caseStreamLBS = flip runSession streamLBSApp $ do
446+ sres <- request defaultRequest
447+ assertStatus 200 sres
448+ assertBody "test" sres
wai-extra/wai-extra.cabal+1
@@ -66,6 +66,7 @@ Library
6666 Network.Wai.Middleware.Rewrite
6767 Network.Wai.Middleware.Vhost
6868 Network.Wai.Middleware.HttpAuth
69+ Network.Wai.Middleware.StreamFile
6970 Network.Wai.Parse
7071 Network.Wai.UrlMap
7172 Network.Wai.Test