git.iko.soy/typeable/wai
on master help sign in
Merge pull request #477 from yesodweb/conditional-requests
ed7072dMichael Snoyman
warp/Network/Wai/Handler/Warp/File.hsnew file+174
compare with master
unifiedsplit
@@ -0,0 +1,174 @@
1+{-# LANGUAGE OverloadedStrings #-}
2+{-# LANGUAGE BangPatterns #-}
3+
4+module Network.Wai.Handler.Warp.File (
5+ RspFileInfo(..)
6+ , conditionalRequest
7+ , addContentHeadersForFilePart
8+ ) where
9+
10+import Control.Applicative ((<|>))
11+import Data.Array ((!))
12+import Data.ByteString (ByteString)
13+import qualified Data.ByteString as B hiding (pack)
14+import qualified Data.ByteString.Builder as B
15+import qualified Data.ByteString.Char8 as B (pack, readInteger)
16+import qualified Data.ByteString.Lazy as L
17+import Network.HTTP.Date
18+import qualified Network.HTTP.Types as H
19+import qualified Network.HTTP.Types.Header as H
20+import Network.Wai
21+import qualified Network.Wai.Handler.Warp.FileInfoCache as I
22+import Network.Wai.Handler.Warp.Header
23+import Numeric (showInt)
24+
25+----------------------------------------------------------------
26+
27+data RspFileInfo = WithoutBody H.Status
28+ | WithBody H.Status H.ResponseHeaders Integer Integer
29+ deriving (Eq,Show)
30+
31+----------------------------------------------------------------
32+
33+conditionalRequest :: I.FileInfo
34+ -> H.ResponseHeaders -> IndexedHeader
35+ -> RspFileInfo
36+conditionalRequest finfo hs0 reqidx = case condition of
37+ nobody@(WithoutBody _) -> nobody
38+ WithBody s _ off len -> let hs = (H.hLastModified,date) :
39+ addContentHeaders hs0 off len size
40+ in WithBody s hs off len
41+ where
42+ mtime = I.fileInfoTime finfo
43+ size = I.fileInfoSize finfo
44+ date = I.fileInfoDate finfo
45+ mcondition = ifmodified reqidx size mtime
46+ <|> ifunmodified reqidx size mtime
47+ <|> ifrange reqidx size mtime
48+ condition = case mcondition of
49+ Nothing -> unconditional reqidx size
50+ Just x -> x
51+
52+----------------------------------------------------------------
53+
54+ifModifiedSince :: IndexedHeader -> Maybe HTTPDate
55+ifModifiedSince reqidx = reqidx ! fromEnum ReqIfModifiedSince >>= parseHTTPDate
56+
57+ifUnmodifiedSince :: IndexedHeader -> Maybe HTTPDate
58+ifUnmodifiedSince reqidx = reqidx ! fromEnum ReqIfUnmodifiedSince >>= parseHTTPDate
59+
60+ifRange :: IndexedHeader -> Maybe HTTPDate
61+ifRange reqidx = reqidx ! fromEnum ReqIfRange >>= parseHTTPDate
62+
63+----------------------------------------------------------------
64+
65+ifmodified :: IndexedHeader -> Integer -> HTTPDate -> Maybe RspFileInfo
66+ifmodified reqidx size mtime = do
67+ date <- ifModifiedSince reqidx
68+ return $ if date /= mtime
69+ then unconditional reqidx size
70+ else WithoutBody H.notModified304
71+
72+ifunmodified :: IndexedHeader -> Integer -> HTTPDate -> Maybe RspFileInfo
73+ifunmodified reqidx size mtime = do
74+ date <- ifUnmodifiedSince reqidx
75+ return $ if date == mtime
76+ then unconditional reqidx size
77+ else WithoutBody H.preconditionFailed412
78+
79+ifrange :: IndexedHeader -> Integer -> HTTPDate -> Maybe RspFileInfo
80+ifrange reqidx size mtime = do
81+ date <- ifRange reqidx
82+ rng <- reqidx ! fromEnum ReqRange
83+ return $ if date == mtime
84+ then parseRange rng size
85+ else WithBody H.ok200 [] 0 size
86+
87+unconditional :: IndexedHeader -> Integer -> RspFileInfo
88+unconditional reqidx size = case reqidx ! fromEnum ReqRange of
89+ Nothing -> WithBody H.ok200 [] 0 size
90+ Just rng -> parseRange rng size
91+
92+----------------------------------------------------------------
93+
94+parseRange :: ByteString -> Integer -> RspFileInfo
95+parseRange rng size = case parseByteRanges rng of
96+ Nothing -> WithoutBody H.requestedRangeNotSatisfiable416
97+ Just [] -> WithoutBody H.requestedRangeNotSatisfiable416
98+ Just (r:_) -> let (!beg, !end) = checkRange r size
99+ !len = end - beg + 1
100+ s = if beg == 0 && end == size - 1 then
101+ H.ok200
102+ else
103+ H.partialContent206
104+ in WithBody s [] beg len
105+
106+checkRange :: H.ByteRange -> Integer -> (Integer, Integer)
107+checkRange (H.ByteRangeFrom beg) size = (beg, size - 1)
108+checkRange (H.ByteRangeFromTo beg end) size = (beg, min (size - 1) end)
109+checkRange (H.ByteRangeSuffix count) size = (max 0 (size - count), size - 1)
110+
111+-- | Parse the value of a Range header into a 'H.ByteRanges'.
112+parseByteRanges :: B.ByteString -> Maybe H.ByteRanges
113+parseByteRanges bs1 = do
114+ bs2 <- stripPrefix "bytes=" bs1
115+ (r, bs3) <- range bs2
116+ ranges (r:) bs3
117+ where
118+ range bs2 = do
119+ (i, bs3) <- B.readInteger bs2
120+ if i < 0 -- has prefix "-" ("-0" is not valid, but here treated as "0-")
121+ then Just (H.ByteRangeSuffix (negate i), bs3)
122+ else do
123+ bs4 <- stripPrefix "-" bs3
124+ case B.readInteger bs4 of
125+ Just (j, bs5) | j >= i -> Just (H.ByteRangeFromTo i j, bs5)
126+ _ -> Just (H.ByteRangeFrom i, bs4)
127+ ranges front bs3
128+ | B.null bs3 = Just (front [])
129+ | otherwise = do
130+ bs4 <- stripPrefix "," bs3
131+ (r, bs5) <- range bs4
132+ ranges (front . (r:)) bs5
133+
134+ stripPrefix x y
135+ | x `B.isPrefixOf` y = Just (B.drop (B.length x) y)
136+ | otherwise = Nothing
137+
138+----------------------------------------------------------------
139+
140+-- | @contentRangeHeader beg end total@ constructs a Content-Range 'H.Header'
141+-- for the range specified.
142+contentRangeHeader :: Integer -> Integer -> Integer -> H.Header
143+contentRangeHeader beg end total = (H.hContentRange, range)
144+ where
145+ range = B.pack
146+ -- building with ShowS
147+ $ 'b' : 'y': 't' : 'e' : 's' : ' '
148+ : (if beg > end then ('*':) else
149+ showInt beg
150+ . ('-' :)
151+ . showInt end)
152+ ( '/'
153+ : showInt total "")
154+
155+addContentHeaders :: H.ResponseHeaders -> Integer -> Integer -> Integer -> H.ResponseHeaders
156+addContentHeaders hs off len size = hs''
157+ where
158+ contentRange = contentRangeHeader off (off + len - 1) size
159+ lengthBS = L.toStrict $ B.toLazyByteString $ B.integerDec len
160+ hs' = (H.hContentLength, lengthBS):(H.hAcceptRanges, "bytes"):hs
161+ hs'' = if len == size then hs' else contentRange:hs'
162+
163+-- |
164+--
165+-- >>> addContentHeadersForFilePart [] (FilePart 2 10 16)
166+-- [("Content-Range","bytes 2-11/16"),("Content-Length","10"),("Accept-Ranges","bytes")]
167+-- >>> addContentHeadersForFilePart [] (FilePart 0 16 16)
168+-- [("Content-Length","16"),("Accept-Ranges","bytes")]
169+addContentHeadersForFilePart :: H.ResponseHeaders -> FilePart -> H.ResponseHeaders
170+addContentHeadersForFilePart hs part = addContentHeaders hs off len size
171+ where
172+ off = filePartOffset part
173+ len = filePartByteCount part
174+ size = filePartFileSize part
warp/Network/Wai/Handler/Warp/Header.hs+31−25
@@ -17,29 +17,35 @@ type IndexedHeader = Array Int (Maybe HeaderValue)
17indexRequestHeader :: RequestHeaders -> IndexedHeader
17indexRequestHeader :: RequestHeaders -> IndexedHeader
18indexRequestHeader hdr = traverseHeader hdr requestMaxIndex requestKeyIndex
18indexRequestHeader hdr = traverseHeader hdr requestMaxIndex requestKeyIndex
19
19
20−idxContentLength,idxTransferEncoding,idxExpect :: Int
20+data RequestHeaderIndex = ReqContentLength
21−idxConnection,idxRange,idxHost :: Int
21+ | ReqTransferEncoding
22−idxContentLength = 0
22+ | ReqExpect
23−idxTransferEncoding = 1
23+ | ReqConnection
24−idxExpect = 2
24+ | ReqRange
25−idxConnection = 3
25+ | ReqHost
26−idxRange = 4
26+ | ReqIfModifiedSince
27−idxHost = 5
27+ | ReqIfUnmodifiedSince
28+ | ReqIfRange
29+ deriving (Enum,Bounded)
28
30
29-- | The size for 'IndexedHeader' for HTTP Request.
31-- | The size for 'IndexedHeader' for HTTP Request.
30-- From 0 to this corresponds to \"Content-Length\", \"Transfer-Encoding\",
32-- From 0 to this corresponds to \"Content-Length\", \"Transfer-Encoding\",
31−-- \"Expect\", \"Connection\", \"Range\", and \"Host\".
33+-- \"Expect\", \"Connection\", \"Range\", \"Host\",
34+-- \"If-Modified-Since\", \"If-Unmodified-Since\" and \"If-Range\".
32requestMaxIndex :: Int
35requestMaxIndex :: Int
33−requestMaxIndex = 5
36+requestMaxIndex = fromEnum (maxBound :: RequestHeaderIndex)
34
37
35requestKeyIndex :: HeaderName -> Int
38requestKeyIndex :: HeaderName -> Int
36−requestKeyIndex "content-length" = idxContentLength
39+requestKeyIndex "content-length" = fromEnum ReqContentLength
37−requestKeyIndex "transfer-encoding" = idxTransferEncoding
40+requestKeyIndex "transfer-encoding" = fromEnum ReqTransferEncoding
38−requestKeyIndex "expect" = idxExpect
41+requestKeyIndex "expect" = fromEnum ReqExpect
39−requestKeyIndex "connection" = idxConnection
42+requestKeyIndex "connection" = fromEnum ReqConnection
40−requestKeyIndex "range" = idxRange
43+requestKeyIndex "range" = fromEnum ReqRange
41−requestKeyIndex "host" = idxHost
44+requestKeyIndex "host" = fromEnum ReqHost
45+requestKeyIndex "if-modified-since" = fromEnum ReqIfModifiedSince
46+requestKeyIndex "if-unmodified-since" = fromEnum ReqIfUnmodifiedSince
47+requestKeyIndex "if-range" = fromEnum ReqIfRange
42−requestKeyIndex _ = -1
48+requestKeyIndex _ = -1
43
49
44defaultIndexRequestHeader :: IndexedHeader
50defaultIndexRequestHeader :: IndexedHeader
45defaultIndexRequestHeader = array (0,requestMaxIndex) [(i,Nothing)|i<-[0..requestMaxIndex]]
51defaultIndexRequestHeader = array (0,requestMaxIndex) [(i,Nothing)|i<-[0..requestMaxIndex]]
@@ -49,19 +55,19 @@ defaultIndexRequestHeader = array (0,requestMaxIndex) [(i,Nothing)|i<-[0..reques
49indexResponseHeader :: ResponseHeaders -> IndexedHeader
55indexResponseHeader :: ResponseHeaders -> IndexedHeader
50indexResponseHeader hdr = traverseHeader hdr responseMaxIndex responseKeyIndex
56indexResponseHeader hdr = traverseHeader hdr responseMaxIndex responseKeyIndex
51
57
52−idxServer, idxDate :: Int
58+data ResponseHeaderIndex = ResContentLength
53−--idxContentLength = 0
59+ | ResServer
54−idxServer = 1
60+ | ResDate
55−idxDate = 2
61+ deriving (Enum,Bounded)
56
62
57-- | The size for 'IndexedHeader' for HTTP Response.
63-- | The size for 'IndexedHeader' for HTTP Response.
58responseMaxIndex :: Int
64responseMaxIndex :: Int
59−responseMaxIndex = 2
65+responseMaxIndex = fromEnum (maxBound :: ResponseHeaderIndex)
60
66
61responseKeyIndex :: HeaderName -> Int
67responseKeyIndex :: HeaderName -> Int
62−responseKeyIndex "content-length" = idxContentLength
68+responseKeyIndex "content-length" = fromEnum ResContentLength
63−responseKeyIndex "server" = idxServer
69+responseKeyIndex "server" = fromEnum ResServer
64−responseKeyIndex "date" = idxDate
70+responseKeyIndex "date" = fromEnum ResDate
65responseKeyIndex _ = -1
71responseKeyIndex _ = -1
66
72
67----------------------------------------------------------------
73----------------------------------------------------------------
warp/Network/Wai/Handler/Warp/Request.hs+5−5
@@ -63,9 +63,9 @@ recvRequest settings conn ii addr src = do
63 hdrlines <- headerLines src
63 hdrlines <- headerLines src
64 (method, unparsedPath, path, query, httpversion, hdr) <- parseHeaderLines hdrlines
64 (method, unparsedPath, path, query, httpversion, hdr) <- parseHeaderLines hdrlines
65 let idxhdr = indexRequestHeader hdr
65 let idxhdr = indexRequestHeader hdr
66− expect = idxhdr ! idxExpect
66+ expect = idxhdr ! fromEnum ReqExpect
67− cl = idxhdr ! idxContentLength
67+ cl = idxhdr ! fromEnum ReqContentLength
68− te = idxhdr ! idxTransferEncoding
68+ te = idxhdr ! fromEnum ReqTransferEncoding
69 handle100Continue = handleExpect conn httpversion expect
69 handle100Continue = handleExpect conn httpversion expect
70 (rbody, remainingRef, bodyLength) <- bodyAndSource src cl te
70 (rbody, remainingRef, bodyLength) <- bodyAndSource src cl te
71 -- body producing function which will produce '100-continue', if needed
71 -- body producing function which will produce '100-continue', if needed
@@ -85,8 +85,8 @@ recvRequest settings conn ii addr src = do
85 , requestBody = rbody'
85 , requestBody = rbody'
86 , vault = vaultValue
86 , vault = vaultValue
87 , requestBodyLength = bodyLength
87 , requestBodyLength = bodyLength
88− , requestHeaderHost = idxhdr ! idxHost
88+ , requestHeaderHost = idxhdr ! fromEnum ReqHost
89− , requestHeaderRange = idxhdr ! idxRange
89+ , requestHeaderRange = idxhdr ! fromEnum ReqRange
90 }
90 }
91 return (req, remainingRef, idxhdr, rbodyFlush)
91 return (req, remainingRef, idxhdr, rbodyFlush)
92 where
92 where
warp/Network/Wai/Handler/Warp/Response.hs+102−98
@@ -7,7 +7,6 @@
7module Network.Wai.Handler.Warp.Response (
7module Network.Wai.Handler.Warp.Response (
8 sendResponse
8 sendResponse
9 , sanitizeHeaderValue -- for testing
9 , sanitizeHeaderValue -- for testing
10− , fileRange -- for testing
11 , warpVersion
10 , warpVersion
12 , addDate
11 , addDate
13 , addServer
12 , addServer
@@ -26,7 +25,7 @@ import Blaze.ByteString.Builder.HTTP (chunkedTransferEncoding, chunkedTransferTe
26#if __GLASGOW_HASKELL__ < 709
25#if __GLASGOW_HASKELL__ < 709
27import Control.Applicative
26import Control.Applicative
28#endif
27#endif
29−import Control.Exception
28+import qualified Control.Exception as E
30import Control.Monad (unless, when)
29import Control.Monad (unless, when)
31import Data.Array ((!))
30import Data.Array ((!))
32import Data.ByteString (ByteString)
31import Data.ByteString (ByteString)
@@ -57,7 +56,7 @@ import Network.Wai
57import Network.Wai.Handler.Warp.Buffer (toBuilderBuffer)
56import Network.Wai.Handler.Warp.Buffer (toBuilderBuffer)
58import qualified Network.Wai.Handler.Warp.Date as D
57import qualified Network.Wai.Handler.Warp.Date as D
59import qualified Network.Wai.Handler.Warp.FdCache as F
58import qualified Network.Wai.Handler.Warp.FdCache as F
60−import qualified Network.Wai.Handler.Warp.FileInfoCache as I
59+import Network.Wai.Handler.Warp.File
61import Network.Wai.Handler.Warp.Header
60import Network.Wai.Handler.Warp.Header
62import Network.Wai.Handler.Warp.IO (toBufIOWith)
61import Network.Wai.Handler.Warp.IO (toBufIOWith)
63import Network.Wai.Handler.Warp.ResponseHeader
62import Network.Wai.Handler.Warp.ResponseHeader
@@ -77,42 +76,14 @@ import qualified Paths_warp
77
76
78----------------------------------------------------------------
77----------------------------------------------------------------
79
78
80−fileRange :: H.Status -> H.ResponseHeaders -> FilePath
81− -> Maybe FilePart -> Maybe HeaderValue
82− -> (FilePath -> IO I.FileInfo)
83− -> IO (Either IOException
84− (H.Status, H.ResponseHeaders, Integer, Integer))
85−fileRange s0 hs0 path Nothing mRange get = do
86− efinfo <- try (get path)
87− case efinfo of
88− Left e -> return $ Left e
89− Right finfo -> do
90− let ret = fileRangeSized s0 hs0 Nothing mRange $ I.fileInfoSize finfo
91− return $ Right ret
92−fileRange s0 hs0 _ mPart@(Just part) mRange _ =
93− return . Right $ fileRangeSized s0 hs0 mPart mRange size
94− where
95− size = filePartFileSize part
96−
97−fileRangeSized :: H.Status -> H.ResponseHeaders
98− -> Maybe FilePart -> Maybe HeaderValue -> Integer
99− -> (H.Status, H.ResponseHeaders, Integer, Integer)
100−fileRangeSized s0 hs0 mPart mRange fileSize = (s, hs, beg, len)
101− where
102− part = fromMaybe (chooseFilePart fileSize mRange) mPart
103− beg = filePartOffset part
104− len = filePartByteCount part
105− (s, hs) = adjustForFilePart s0 hs0 $ FilePart beg len fileSize
106−
107−----------------------------------------------------------------
108−
109-- | Sending a HTTP response to 'Connection' according to 'Response'.
79-- | Sending a HTTP response to 'Connection' according to 'Response'.
110--
80--
111−-- Applications/middlewares MUST specify a proper 'H.ResponseHeaders'.
81+-- Applications/middlewares MUST provide a proper 'H.ResponseHeaders'.
112-- so that inconsistency does not happen.
82-- so that inconsistency does not happen.
113-- No header is deleted by this function.
83-- No header is deleted by this function.
114--
84--
115−-- Especially, Applications/middlewares MUST take care of
85+-- Especially, Applications/middlewares MUST provide a proper
86+-- Content-Type. They MUST NOT provide
116-- Content-Length, Content-Range, and Transfer-Encoding
87-- Content-Length, Content-Range, and Transfer-Encoding
117-- because they are inserted, when necessary,
88-- because they are inserted, when necessary,
118-- regardless they already exist.
89-- regardless they already exist.
@@ -124,22 +95,6 @@ fileRangeSized s0 hs0 mPart mRange fileSize = (s, hs, beg, len)
124--
95--
125-- There are three basic APIs to create 'Response':
96-- There are three basic APIs to create 'Response':
126--
97--
127−-- ['responseFile' :: 'H.Status' -> 'H.ResponseHeaders' -> 'FilePath' -> 'Maybe' 'FilePart' -> 'Response']
128−-- HTTP response body is sent by sendfile() for GET method.
129−-- HTTP response body is not sent by HEAD method.
130−-- Applications are categorized into simple and sophisticated.
131−-- Simple applications should specify 'Nothing' to
132−-- 'Maybe' 'FilePart'. The size of the specified file is obtained
133−-- by disk access. Then Range is handled.
134−-- Sophisticated applications should specify 'Just' to
135−-- 'Maybe' 'FilePart'. They should treat Range (and If-Range) by
136−-- themselves. In both cases,
137−-- Content-Length and Content-Range (if necessary) are automatically
138−-- added into the HTTP response header.
139−-- If Content-Length and Content-Range exist in the HTTP response header,
140−-- they would cause inconsistency.
141−-- Status is also changed to 206 (Partial Content) if necessary.
142−--
143-- ['responseBuilder' :: 'H.Status' -> 'H.ResponseHeaders' -> 'Builder' -> 'Response']
98-- ['responseBuilder' :: 'H.Status' -> 'H.ResponseHeaders' -> 'Builder' -> 'Response']
144-- HTTP response body is created from 'Builder'.
99-- HTTP response body is created from 'Builder'.
145-- Transfer-Encoding: chunked is used in HTTP/1.1.
100-- Transfer-Encoding: chunked is used in HTTP/1.1.
@@ -150,6 +105,27 @@ fileRangeSized s0 hs0 mPart mRange fileSize = (s, hs, beg, len)
150--
105--
151-- ['responseRaw' :: ('IO' 'ByteString' -> ('ByteString' -> 'IO' ()) -> 'IO' ()) -> 'Response' -> 'Response']
106-- ['responseRaw' :: ('IO' 'ByteString' -> ('ByteString' -> 'IO' ()) -> 'IO' ()) -> 'Response' -> 'Response']
152-- No header is added and no Transfer-Encoding: is applied.
107-- No header is added and no Transfer-Encoding: is applied.
108+--
109+-- ['responseFile' :: 'H.Status' -> 'H.ResponseHeaders' -> 'FilePath' -> 'Maybe' 'FilePart' -> 'Response']
110+-- HTTP response body is sent (by sendfile(), if possible) for GET method.
111+-- HTTP response body is not sent by HEAD method.
112+-- Content-Length and Content-Range are automatically
113+-- added into the HTTP response header if necessary.
114+-- If Content-Length and Content-Range exist in the HTTP response header,
115+-- they would cause inconsistency.
116+-- \"Accept-Ranges: bytes\" is also inserted.
117+--
118+-- Applications are categorized into simple and sophisticated.
119+-- Sophisticated applications should specify 'Just' to
120+-- 'Maybe' 'FilePart'. They should treat the conditional request
121+-- by themselves. A proper 'Status' (200 or 206) must be provided.
122+--
123+-- Simple applications should specify 'Nothing' to
124+-- 'Maybe' 'FilePart'. The size of the specified file is obtained
125+-- by disk access or from the file infor cache.
126+-- If-Modified-Since, If-Unmodified-Since, If-Range and Range
127+-- are processed. Since a proper status is chosen, 'Status' is
128+-- ignored. Last-Modified is inserted.
153
129
154sendResponse :: Settings
130sendResponse :: Settings
155 -> Connection
131 -> Connection
@@ -189,13 +165,12 @@ sendResponse settings conn ii req reqidxhdr src response = do
189 th = threadHandle ii
165 th = threadHandle ii
190 dc = dateCacher ii
166 dc = dateCacher ii
191 addServerAndDate = addDate dc rspidxhdr . addServer defServer rspidxhdr
167 addServerAndDate = addDate dc rspidxhdr . addServer defServer rspidxhdr
192− mRange = reqidxhdr ! idxRange
193 (isPersist,isChunked0) = infoFromRequest req reqidxhdr
168 (isPersist,isChunked0) = infoFromRequest req reqidxhdr
194 isChunked = not isHead && isChunked0
169 isChunked = not isHead && isChunked0
195 (isKeepAlive, needsChunked) = infoFromResponse rspidxhdr (isPersist,isChunked)
170 (isKeepAlive, needsChunked) = infoFromResponse rspidxhdr (isPersist,isChunked)
196 isHead = requestMethod req == H.methodHead
171 isHead = requestMethod req == H.methodHead
197 rsp = case response of
172 rsp = case response of
198− ResponseFile _ _ path mPart -> RspFile path mPart mRange isHead (T.tickle th)
173+ ResponseFile _ _ path mPart -> RspFile path mPart reqidxhdr isHead (T.tickle th)
199 ResponseBuilder _ _ b
174 ResponseBuilder _ _ b
200 | isHead -> RspNoBody
175 | isHead -> RspNoBody
201 | otherwise -> RspBuilder b needsChunked
176 | otherwise -> RspBuilder b needsChunked
@@ -237,7 +212,7 @@ sanitizeHeaderValue v = case S8.lines $ S.filter (/= _cr) v of
237----------------------------------------------------------------
212----------------------------------------------------------------
238
213
239data Rsp = RspNoBody
214data Rsp = RspNoBody
240− | RspFile FilePath (Maybe FilePart) (Maybe HeaderValue) Bool (IO ())
215+ | RspFile FilePath (Maybe FilePart) IndexedHeader Bool (IO ())
241 | RspBuilder Builder Bool
216 | RspBuilder Builder Bool
242 | RspStream StreamingBody Bool T.Handle
217 | RspStream StreamingBody Bool T.Handle
243 | RspRaw (IO ByteString -> (ByteString -> IO ()) -> IO ()) (IO ByteString) (IO ())
218 | RspRaw (IO ByteString -> (ByteString -> IO ()) -> IO ()) (IO ByteString) (IO ())
@@ -262,47 +237,6 @@ sendRsp conn _ ver s hs RspNoBody = do
262
237
263----------------------------------------------------------------
238----------------------------------------------------------------
264
239
265−sendRsp conn ii ver s0 hs0 (RspFile path mPart mRange isHead hook) = do
266− ex <- fileRange s0 hs0 path mPart mRange get
267− case ex of
268− Left _ex ->
269−#ifdef WARP_DEBUG
270− print _ex >>
271−#endif
272− sendRsp conn ii ver s2 hs2 (RspBuilder body True)
273− Right (s, hs, beg, len)
274− | len >= 0 ->
275− if isHead then
276− sendRsp conn ii ver s hs RspNoBody
277− else do
278− lheader <- composeHeader ver s hs
279−#ifdef WINDOWS
280− let fid = FileId path Nothing
281− hook' = hook
282−#else
283− (mfd, hook') <- case mfdc of
284− -- settingsFdCacheDuration is 0
285− Nothing -> return (Nothing, hook)
286− Just fdc -> do
287− (fd, fresher) <- F.getFd fdc path
288− return (Just fd, hook >> fresher)
289− let fid = FileId path mfd
290−#endif
291− connSendFile conn fid beg len hook' [lheader]
292− return (Just s, Just len)
293− | otherwise -> do
294− sendRsp conn ii ver H.requestedRangeNotSatisfiable416
295− (filter (\(k, _) -> k /= "content-length") hs)
296− (RspBuilder mempty True)
297− where
298− s2 = H.notFound404
299− hs2 = replaceHeader H.hContentType "text/plain; charset=utf-8" hs0
300− body = byteString "File not found"
301− mfdc = fdCacher ii
302− get = fileInfo ii
303−
304−----------------------------------------------------------------
305−
306sendRsp conn _ ver s hs (RspBuilder body needsChunked) = do
240sendRsp conn _ ver s hs (RspBuilder body needsChunked) = do
307 header <- composeHeaderBuilder ver s hs needsChunked
241 header <- composeHeaderBuilder ver s hs needsChunked
308 let hdrBdy
242 let hdrBdy
@@ -350,6 +284,76 @@ sendRsp conn _ _ _ _ (RspRaw withApp src tickle) = do
350 return bs
284 return bs
351 send bs = connSendAll conn bs >> tickle
285 send bs = connSendAll conn bs >> tickle
352
286
287+----------------------------------------------------------------
288+
289+-- Sophisticated WAI applications.
290+-- We respect s0. s0 MUST be a proper value.
291+sendRsp conn ii ver s0 hs0 (RspFile path (Just part) _ isHead hook) =
292+ sendRspFile2XX conn ii ver s0 hs path beg len isHead hook
293+ where
294+ beg = filePartOffset part
295+ len = filePartByteCount part
296+ hs = addContentHeadersForFilePart hs0 part
297+
298+----------------------------------------------------------------
299+
300+-- Simple WAI applications.
301+-- Status is ignored
302+sendRsp conn ii ver _ hs0 (RspFile path Nothing idxhdr isHead hook) = do
303+ efinfo <- E.try $ fileInfo ii path
304+ case efinfo of
305+ Left (_ex :: E.IOException) ->
306+#ifdef WARP_DEBUG
307+ print _ex >>
308+#endif
309+ sendRspFile404 conn ii ver hs0
310+ Right finfo -> case conditionalRequest finfo hs0 idxhdr of
311+ WithoutBody s -> sendRsp conn ii ver s hs0 RspNoBody
312+ WithBody s hs beg len -> sendRspFile2XX conn ii ver s hs path beg len isHead hook
313+
314+----------------------------------------------------------------
315+
316+sendRspFile2XX :: Connection
317+ -> InternalInfo
318+ -> H.HttpVersion
319+ -> H.Status
320+ -> H.ResponseHeaders
321+ -> FilePath
322+ -> Integer
323+ -> Integer
324+ -> Bool
325+ -> IO ()
326+ -> IO (Maybe H.Status, Maybe Integer)
327+sendRspFile2XX conn ii ver s hs path beg len isHead hook
328+ | isHead = sendRsp conn ii ver s hs RspNoBody
329+ | otherwise = do
330+ lheader <- composeHeader ver s hs
331+#ifdef WINDOWS
332+ let fid = FileId path Nothing
333+ hook' = hook
334+#else
335+ (mfd, hook') <- case fdCacher ii of
336+ -- settingsFdCacheDuration is 0
337+ Nothing -> return (Nothing, hook)
338+ Just fdc -> do
339+ (fd, fresher) <- F.getFd fdc path
340+ return (Just fd, hook >> fresher)
341+ let fid = FileId path mfd
342+#endif
343+ connSendFile conn fid beg len hook' [lheader]
344+ return (Just s, Just len)
345+
346+sendRspFile404 :: Connection
347+ -> InternalInfo
348+ -> H.HttpVersion
349+ -> H.ResponseHeaders
350+ -> IO (Maybe H.Status, Maybe Integer)
351+sendRspFile404 conn ii ver hs0 = sendRsp conn ii ver s hs (RspBuilder body True)
352+ where
353+ s = H.notFound404
354+ hs = replaceHeader H.hContentType "text/plain; charset=utf-8" hs0
355+ body = byteString "File not found"
356+
353----------------------------------------------------------------
357----------------------------------------------------------------
354----------------------------------------------------------------
358----------------------------------------------------------------
355
359
@@ -376,7 +380,7 @@ checkPersist req reqidxhdr
376 | otherwise = checkPersist10 conn
380 | otherwise = checkPersist10 conn
377 where
381 where
378 ver = httpVersion req
382 ver = httpVersion req
379− conn = reqidxhdr ! idxConnection
383+ conn = reqidxhdr ! fromEnum ReqConnection
380 checkPersist11 (Just x)
384 checkPersist11 (Just x)
381 | CI.foldCase x == "close" = False
385 | CI.foldCase x == "close" = False
382 checkPersist11 _ = True
386 checkPersist11 _ = True
@@ -401,7 +405,7 @@ infoFromResponse rspidxhdr (isPersist,isChunked) = (isKeepAlive, needsChunked)
401 where
405 where
402 needsChunked = isChunked && not hasLength
406 needsChunked = isChunked && not hasLength
403 isKeepAlive = isPersist && (isChunked || hasLength)
407 isKeepAlive = isPersist && (isChunked || hasLength)
404− hasLength = isJust $ rspidxhdr ! idxContentLength
408+ hasLength = isJust $ rspidxhdr ! fromEnum ResContentLength
405
409
406----------------------------------------------------------------
410----------------------------------------------------------------
407
411
@@ -422,7 +426,7 @@ addTransferEncoding hdrs = ("transfer-encoding", "chunked") : hdrs
422#endif
426#endif
423
427
424addDate :: D.DateCache -> IndexedHeader -> H.ResponseHeaders -> IO H.ResponseHeaders
428addDate :: D.DateCache -> IndexedHeader -> H.ResponseHeaders -> IO H.ResponseHeaders
425−addDate dc rspidxhdr hdrs = case rspidxhdr ! idxDate of
429+addDate dc rspidxhdr hdrs = case rspidxhdr ! fromEnum ResDate of
426 Nothing -> do
430 Nothing -> do
427 gmtdate <- D.getDate dc
431 gmtdate <- D.getDate dc
428 return $ (H.hDate, gmtdate) : hdrs
432 return $ (H.hDate, gmtdate) : hdrs
@@ -435,7 +439,7 @@ warpVersion :: String
435warpVersion = showVersion Paths_warp.version
439warpVersion = showVersion Paths_warp.version
436
440
437addServer :: HeaderValue -> IndexedHeader -> H.ResponseHeaders -> H.ResponseHeaders
441addServer :: HeaderValue -> IndexedHeader -> H.ResponseHeaders -> H.ResponseHeaders
438−addServer serverName rspidxhdr hdrs = case rspidxhdr ! idxServer of
442+addServer serverName rspidxhdr hdrs = case rspidxhdr ! fromEnum ResServer of
439 Nothing -> (H.hServer, serverName) : hdrs
443 Nothing -> (H.hServer, serverName) : hdrs
440 _ -> hdrs
444 _ -> hdrs
441
445
warp/test/FileSpec.hsnew file+45
@@ -0,0 +1,45 @@
1+{-# LANGUAGE OverloadedStrings #-}
2+
3+module FileSpec (main, spec) where
4+
5+import Network.HTTP.Types
6+import Network.Wai.Handler.Warp.File
7+import Network.Wai.Handler.Warp.FileInfoCache
8+import Network.Wai.Handler.Warp.Header
9+
10+import Test.Hspec
11+
12+main :: IO ()
13+main = hspec spec
14+
15+testFileRange :: String
16+ -> RequestHeaders -> FilePath
17+ -> RspFileInfo
18+ -> Spec
19+testFileRange desc reqhs file ans = it desc $ do
20+ finfo <- getInfo file
21+ let WithBody s hs off len = ans
22+ hs' = ("Last-Modified",fileInfoDate finfo) : hs
23+ ans' = WithBody s hs' off len
24+ conditionalRequest finfo [] (indexRequestHeader reqhs) `shouldBe` ans'
25+
26+spec :: Spec
27+spec = do
28+ describe "conditionalRequest" $ do
29+ testFileRange
30+ "gets a file size from file system"
31+ [] "attic/hex"
32+ $ WithBody ok200 [("Content-Length","16"),("Accept-Ranges","bytes")] 0 16
33+ testFileRange
34+ "gets a file size from file system and handles Range and returns Partical Content"
35+ [("Range","bytes=2-14")] "attic/hex"
36+ $ WithBody status206 [("Content-Range","bytes 2-14/16"),("Content-Length","13"),("Accept-Ranges","bytes")] 2 13
37+ testFileRange
38+ "truncates end point of range to file size"
39+ [("Range","bytes=10-20")] "attic/hex"
40+ $ WithBody status206 [("Content-Range","bytes 10-15/16"),("Content-Length","6"),("Accept-Ranges","bytes")] 10 6
41+ testFileRange
42+ "gets a file size from file system and handles Range and returns OK if Range means the entire"
43+ [("Range:","bytes=0-15")] "attic/hex"
44+ $ WithBody status200 [("Content-Length","16"),("Accept-Ranges","bytes")] 0 16
45+
warp/test/ResponseSpec.hs+1−47
@@ -1,4 +1,5 @@
1{-# LANGUAGE OverloadedStrings #-}
1{-# LANGUAGE OverloadedStrings #-}
2+
2module ResponseSpec (main, spec) where
3module ResponseSpec (main, spec) where
3
4
4import Control.Concurrent (threadDelay)
5import Control.Concurrent (threadDelay)
@@ -9,7 +10,6 @@ import Network (connectTo, PortID (PortNumber))
9import Network.HTTP.Types
10import Network.HTTP.Types
10import Network.Wai
11import Network.Wai
11import Network.Wai.Handler.Warp
12import Network.Wai.Handler.Warp
12−import Network.Wai.Handler.Warp.FileInfoCache
13import Network.Wai.Handler.Warp.Response
13import Network.Wai.Handler.Warp.Response
14import RunSpec (withApp)
14import RunSpec (withApp)
15import System.IO (hClose, hFlush)
15import System.IO (hClose, hFlush)
@@ -71,18 +71,6 @@ testPartial size offset count out = it title $ withApp defaultSettings app $ \po
71 _ -> Nothing
71 _ -> Nothing
72 range = "bytes " ++ show offset ++ "-" ++ show (offset + count - 1) ++ "/" ++ show size
72 range = "bytes " ++ show offset ++ "-" ++ show (offset + count - 1) ++ "/" ++ show size
73
73
74−testFileRange :: String
75− -> Status -> ResponseHeaders -> FilePath
76− -> Maybe FilePart -> Maybe HeaderValue
77− -> Either String (Status, ResponseHeaders, Integer, Integer)
78− -> Spec
79−testFileRange desc s rsphdr file mPart mRange ans = it desc $ do
80− eres <- fileRange s rsphdr file mPart mRange getInfo
81− let res = case eres of
82− Left e -> Left $ show e
83− Right r -> Right r
84− res `shouldBe` ans
85−
86spec :: Spec
74spec :: Spec
87spec = do
75spec = do
88 describe "preventing response splitting attack" $ do
76 describe "preventing response splitting attack" $ do
@@ -125,37 +113,3 @@ spec = do
125 testPartial 16 2 2 "23"
113 testPartial 16 2 2 "23"
126 testPartial 16 0 2 "01"
114 testPartial 16 0 2 "01"
127 testPartial 16 3 8 "3456789a"
115 testPartial 16 3 8 "3456789a"
128−
129− describe "fileRange" $ do
130− testFileRange
131− "gets a file size from file system"
132− status200 [] "attic/hex" Nothing Nothing
133− $ Right (status200,[("Content-Length","16"), ("Accept-Ranges","bytes")],0,16)
134− testFileRange
135− "gets an error if a file does not exist"
136− status200 [] "attic/nonexist" Nothing Nothing
137− $ Left "attic/nonexist: getFileStatus: does not exist (No such file or directory)"
138− testFileRange
139− "changes status if FileParts is specified"
140− status200 [] "attic/hex" (Just (FilePart 2 10 16)) Nothing
141− $ Right (status206,[("Content-Range", "bytes 2-11/16"),("Content-Length","10"),("Accept-Ranges","bytes")],2,10)
142− testFileRange
143− "does not change status and does not add Content-Range if FileParts means the entire"
144− status200 [] "attic/hex" (Just (FilePart 0 16 16)) Nothing
145− $ Right (status200,[("Content-Length","16"), ("Accept-Ranges","bytes")],0,16)
146− testFileRange
147− "gets a file size from file system and handles Range and returns Partical Content"
148− status200 [] "attic/hex" Nothing (Just "bytes=2-14")
149− $ Right (status206,[("Content-Range","bytes 2-14/16"),("Content-Length","13"),("Accept-Ranges","bytes")],2,13)
150− testFileRange
151− "truncates end point of range to file size"
152− status200 [] "attic/hex" Nothing (Just "bytes=10-20")
153− $ Right (status206,[("Content-Range","bytes 10-15/16"),("Content-Length","6"),("Accept-Ranges","bytes")],10,6)
154− testFileRange
155− "gets a file size from file system and handles Range and returns OK if Range means the entire"
156− status200 [] "attic/hex" Nothing (Just "bytes=0-15")
157− $ Right (status200,[("Content-Length","16"),("Accept-Ranges","bytes")],0,16)
158− testFileRange
159− "igores Range if FilePart is specified"
160− status200 [] "attic/hex" (Just (FilePart 2 10 16)) (Just "bytes=8-9")
161− $ Right (status206,[("Content-Range", "bytes 2-11/16"),("Content-Length","10"),("Accept-Ranges","bytes")],2,10)
warp/warp.cabal+2
@@ -66,6 +66,7 @@ Library
66 Network.Wai.Handler.Warp.Counter
66 Network.Wai.Handler.Warp.Counter
67 Network.Wai.Handler.Warp.Date
67 Network.Wai.Handler.Warp.Date
68 Network.Wai.Handler.Warp.FdCache
68 Network.Wai.Handler.Warp.FdCache
69+ Network.Wai.Handler.Warp.File
69 Network.Wai.Handler.Warp.FileInfoCache
70 Network.Wai.Handler.Warp.FileInfoCache
70 Network.Wai.Handler.Warp.HTTP2
71 Network.Wai.Handler.Warp.HTTP2
71 Network.Wai.Handler.Warp.HTTP2.EncodeFrame
72 Network.Wai.Handler.Warp.HTTP2.EncodeFrame
@@ -120,6 +121,7 @@ Test-Suite spec
120 ConduitSpec
121 ConduitSpec
121 ExceptionSpec
122 ExceptionSpec
122 FdCacheSpec
123 FdCacheSpec
124+ FileSpec
123 MultiMapSpec
125 MultiMapSpec
124 ReadIntSpec
126 ReadIntSpec
125 RequestSpec
127 RequestSpec