git.iko.soy/typeable/wai
on master help sign in
extracting fileRange to make sendResponse simpler.
59beab1Kazu Yamamoto
warp/Network/Wai/Handler/Warp/Response.hs+69−48
compare with master
unifiedsplit
@@ -34,6 +34,49 @@ import Numeric (showInt)
34import qualified System.PosixCompat.Files as P
34import qualified System.PosixCompat.Files as P
35
35
36----------------------------------------------------------------
36----------------------------------------------------------------
37+
38+fileRange :: IndexedHeader
39+ -> H.Status -> H.ResponseHeaders
40+ -> FilePath -> Maybe FilePart
41+ -> IO (Either SomeException
42+ (H.Status, H.ResponseHeaders, Integer, Integer))
43+fileRange reqidxhdr s0 hs0 path mpart0 = liftIO . try $ do
44+ -- If mpart0 is not Nothing, Content-Range must exist.
45+ (hadLength, total) <- handleLength
46+ let (s, addRangeFunc, beg, len) = handleRange total
47+ hs1 | hadLength = hs0
48+ | otherwise = addContentLength len hs0
49+ hs2 = addRangeFunc hs1
50+ return (s, hs2, beg, len)
51+ where
52+ -- 1) If Content-Length does not exist in HTTP response header,
53+ -- we need to add it.
54+ -- 2) Total length is necessary, anyway.
55+ handleLength = case checkLength hs0 of
56+ Just cl -> return (True, readInt cl)
57+ Nothing -> case mpart0 of
58+ Just part -> return (False, fromIntegral $ filePartByteCount part)
59+ Nothing -> do
60+ size <- fromIntegral . P.fileSize <$> P.getFileStatus path
61+ return (False, size)
62+ -- 1) Status. We should return 206 if partial.
63+ -- 2) A function to add Content-Range.
64+ -- 3) Offset.
65+ -- 4) Length.
66+ handleRange total = case mpart0 of
67+ Just part -> (s0, id, filePartOffset part, filePartByteCount part)
68+ Nothing -> case reqidxhdr ! idxRange >>= parseByteRanges >>= listToMaybe of
69+ Just range | s0 == H.status200 -> case range of
70+ H.ByteRangeFrom from -> fromRange total from (total - 1)
71+ H.ByteRangeFromTo from to -> fromRange total from to
72+ H.ByteRangeSuffix count -> fromRange total (total - count) (total - 1)
73+ _ -> (s0, id, 0, total)
74+
75+ fromRange total from to = (H.status206
76+ ,addContentRange total from to
77+ ,from
78+ ,to - from + 1)
79+
37----------------------------------------------------------------
80----------------------------------------------------------------
38
81
39sendResponse :: Connection
82sendResponse :: Connection
@@ -47,45 +90,11 @@ sendResponse :: Connection
47----------------------------------------------------------------
90----------------------------------------------------------------
48
91
49sendResponse conn ii restore req reqidxhdr (ResponseFile s0 hs0 path mpart0) =
92sendResponse conn ii restore req reqidxhdr (ResponseFile s0 hs0 path mpart0) =
50− restore $ headerAndLength >>= sendResponse'
93+ restore $ fileRange reqidxhdr s0 hs path mpart0 >>= sendResponseEither
51 where
94 where
52− hs = addAccept hs0
95+ hs = addAcceptRanges hs0
53 th = threadHandle ii
96 th = threadHandle ii
54− headerAndLength = liftIO . try $ do
55− (hadLength, cl) <-
56− case readInt <$> checkLength hs of
57− Just cl -> return (True, cl)
58− Nothing ->
59− case mpart0 of
60− Just part -> return (False, fromIntegral $ filePartByteCount part)
61− Nothing -> (False, ) . fromIntegral . P.fileSize
62− <$> P.getFileStatus path
63− let (s, addRange, beg, len) =
64− case mpart0 of
65− Just part -> (s0, id, filePartOffset part, filePartByteCount part)
66− Nothing -> case reqidxhdr ! idxRange >>= parseByteRanges >>= listToMaybe of
67− Just range | s0 == H.status200 ->
68− case range of
69− H.ByteRangeFrom from -> rangeRes cl from (cl - 1)
70− H.ByteRangeFromTo from to -> rangeRes cl from to
71− H.ByteRangeSuffix count -> rangeRes cl (cl - count) (cl - 1)
72− _ -> (s0, id, 0, cl)
73− hs'
74− | hadLength = hs
75− | otherwise = addLength len hs
76− return (s, addRange hs', beg, len)
77−
78− rangeRes cl from to = (H.status206, ((hContentRange, rangeHeader cl from to):), from, to - from + 1)
79−
80− rangeHeader total from to = B.pack
81− $ 'b' : 'y': 't' : 'e' : 's' : ' '
82− : showInt from
83− ( '-'
84− : showInt to
85− ( '/'
86− : showInt total ""))
87−
88− sendResponse' (Right (s, lengthyHeaders, beg, len))
97+ sendResponseEither (Right (s, lengthyHeaders, beg, len))
89 | hasBody s req = liftIO $ do
98 | hasBody s req = liftIO $ do
90 lheader <- composeHeader version s lengthyHeaders
99 lheader <- composeHeader version s lengthyHeaders
91 connSendFile conn path beg len (T.tickle th) [lheader]
100 connSendFile conn path beg len (T.tickle th) [lheader]
@@ -99,7 +108,7 @@ sendResponse conn ii restore req reqidxhdr (ResponseFile s0 hs0 path mpart0) =
99 version = httpVersion req
108 version = httpVersion req
100 (isPersist,_) = infoFromRequest req reqidxhdr
109 (isPersist,_) = infoFromRequest req reqidxhdr
101
110
102− sendResponse' (Left (_ :: SomeException)) =
111+ sendResponseEither (Left (SomeException _)) =
103 sendResponse conn ii restore req reqidxhdr notFound
112 sendResponse conn ii restore req reqidxhdr notFound
104 where
113 where
105 notFound = responseLBS H.status404 [(H.hContentType, "text/plain")] "File not found"
114 notFound = responseLBS H.status404 [(H.hContentType, "text/plain")] "File not found"
@@ -222,20 +231,32 @@ hasBody s req = sc /= 204
222
231
223----------------------------------------------------------------
232----------------------------------------------------------------
224
233
225−addLength :: Integer -> H.ResponseHeaders -> H.ResponseHeaders
234+addContentLength :: Integer -> H.ResponseHeaders -> H.ResponseHeaders
226−addLength cl hdrs = (H.hContentLength, B.pack $ show cl) : hdrs
235+addContentLength cl hdrs = (H.hContentLength, B.pack $ show cl) : hdrs
227
236
228−addAccept :: H.ResponseHeaders -> H.ResponseHeaders
237+addAcceptRanges :: H.ResponseHeaders -> H.ResponseHeaders
229−addAccept hdrs = (hAcceptRanges, "bytes") : hdrs
238+addAcceptRanges hdrs = (hAcceptRanges, "bytes") : hdrs
230
239
231−addEncodingHeader :: H.ResponseHeaders -> H.ResponseHeaders
240+addTransferEncoding :: H.ResponseHeaders -> H.ResponseHeaders
232−addEncodingHeader hdrs = (hTransferEncoding, "chunked") : hdrs
241+addTransferEncoding hdrs = (hTransferEncoding, "chunked") : hdrs
233
242
234−addServerHeader :: H.ResponseHeaders -> H.ResponseHeaders
243+addServer :: H.ResponseHeaders -> H.ResponseHeaders
235−addServerHeader hdrs = case lookup hServer hdrs of
244+addServer hdrs = case lookup hServer hdrs of
236 Nothing -> (hServer, defaultServerValue) : hdrs
245 Nothing -> (hServer, defaultServerValue) : hdrs
237 Just _ -> hdrs
246 Just _ -> hdrs
238
247
248+addContentRange :: Integer -> Integer -> Integer -> H.ResponseHeaders -> H.ResponseHeaders
249+addContentRange total from to hdrs = (hContentRange, range) : hdrs
250+ where
251+ range = B.pack
252+ -- building with ShowS
253+ $ 'b' : 'y': 't' : 'e' : 's' : ' '
254+ : showInt from
255+ ( '-'
256+ : showInt to
257+ ( '/'
258+ : showInt total ""))
259+
239----------------------------------------------------------------
260----------------------------------------------------------------
240
261
241composeHeader :: H.HttpVersion
262composeHeader :: H.HttpVersion
@@ -243,10 +264,10 @@ composeHeader :: H.HttpVersion
243 -> H.ResponseHeaders
264 -> H.ResponseHeaders
244 -> IO ByteString
265 -> IO ByteString
245composeHeader version s hs =
266composeHeader version s hs =
246− RH.composeHeader version s $ addServerHeader hs
267+ RH.composeHeader version s $ addServer hs
247
268
248composeHeaderBuilder :: H.HttpVersion -> H.Status -> H.ResponseHeaders -> Bool -> IO Builder
269composeHeaderBuilder :: H.HttpVersion -> H.Status -> H.ResponseHeaders -> Bool -> IO Builder
249composeHeaderBuilder ver s hs True =
270composeHeaderBuilder ver s hs True =
250− fromByteString <$> composeHeader ver s (addEncodingHeader hs)
271+ fromByteString <$> composeHeader ver s (addTransferEncoding hs)
251composeHeaderBuilder ver s hs False =
272composeHeaderBuilder ver s hs False =
252 fromByteString <$> composeHeader ver s hs
273 fromByteString <$> composeHeader ver s hs