@@ -34,6 +34,49 @@ import Numeric (showInt)
3434import qualified System.PosixCompat.Files as P
3535
3636----------------------------------------------------------------
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+
3780----------------------------------------------------------------
3881
3982sendResponse :: Connection
@@ -47,45 +90,11 @@ sendResponse :: Connection
4790----------------------------------------------------------------
4891
4992sendResponse conn ii restore req reqidxhdr (ResponseFile s0 hs0 path mpart0) =
50− restore $ headerAndLength >>= sendResponse'
93+ restore $ fileRange reqidxhdr s0 hs path mpart0 >>= sendResponseEither
5194 where
52− hs = addAccept hs0
95+ hs = addAcceptRanges hs0
5396 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))
8998 | hasBody s req = liftIO $ do
9099 lheader <- composeHeader version s lengthyHeaders
91100 connSendFile conn path beg len (T.tickle th) [lheader]
@@ -99,7 +108,7 @@ sendResponse conn ii restore req reqidxhdr (ResponseFile s0 hs0 path mpart0) =
99108 version = httpVersion req
100109 (isPersist,_) = infoFromRequest req reqidxhdr
101110
102− sendResponse' (Left (_ :: SomeException)) =
111+ sendResponseEither (Left (SomeException _)) =
103112 sendResponse conn ii restore req reqidxhdr notFound
104113 where
105114 notFound = responseLBS H.status404 [(H.hContentType, "text/plain")] "File not found"
@@ -222,20 +231,32 @@ hasBody s req = sc /= 204
222231
223232----------------------------------------------------------------
224233
225−addLength :: Integer -> H.ResponseHeaders -> H.ResponseHeaders
226−addLength cl hdrs = (H.hContentLength, B.pack $ show cl) : hdrs
234+addContentLength :: Integer -> H.ResponseHeaders -> H.ResponseHeaders
235+addContentLength cl hdrs = (H.hContentLength, B.pack $ show cl) : hdrs
227236
228−addAccept :: H.ResponseHeaders -> H.ResponseHeaders
229−addAccept hdrs = (hAcceptRanges, "bytes") : hdrs
237+addAcceptRanges :: H.ResponseHeaders -> H.ResponseHeaders
238+addAcceptRanges hdrs = (hAcceptRanges, "bytes") : hdrs
230239
231−addEncodingHeader :: H.ResponseHeaders -> H.ResponseHeaders
232−addEncodingHeader hdrs = (hTransferEncoding, "chunked") : hdrs
240+addTransferEncoding :: H.ResponseHeaders -> H.ResponseHeaders
241+addTransferEncoding hdrs = (hTransferEncoding, "chunked") : hdrs
233242
234−addServerHeader :: H.ResponseHeaders -> H.ResponseHeaders
235−addServerHeader hdrs = case lookup hServer hdrs of
243+addServer :: H.ResponseHeaders -> H.ResponseHeaders
244+addServer hdrs = case lookup hServer hdrs of
236245 Nothing -> (hServer, defaultServerValue) : hdrs
237246 Just _ -> hdrs
238247
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+
239260----------------------------------------------------------------
240261
241262composeHeader :: H.HttpVersion
@@ -243,10 +264,10 @@ composeHeader :: H.HttpVersion
243264 -> H.ResponseHeaders
244265 -> IO ByteString
245266composeHeader version s hs =
246− RH.composeHeader version s $ addServerHeader hs
267+ RH.composeHeader version s $ addServer hs
247268
248269composeHeaderBuilder :: H.HttpVersion -> H.Status -> H.ResponseHeaders -> Bool -> IO Builder
249270composeHeaderBuilder ver s hs True =
250− fromByteString <$> composeHeader ver s (addEncodingHeader hs)
271+ fromByteString <$> composeHeader ver s (addTransferEncoding hs)
251272composeHeaderBuilder ver s hs False =
252273 fromByteString <$> composeHeader ver s hs