@@ -1,47 +1,171 @@
11{-# LANGUAGE OverloadedStrings #-}
2−{-# LANGUAGE ScopedTypeVariables #-}
3−{-# LANGUAGE TupleSections #-}
4−{-# LANGUAGE RankNTypes #-}
5−{-# LANGUAGE CPP #-}
2+{-# LANGUAGE BangPatterns #-}
63
7−module Network.Wai.Handler.Warp.File where
4+module Network.Wai.Handler.Warp.File (
5+ RspFileInfo(..)
6+ , conditionalRequest
7+ , addContentHeadersForFilePart
8+ ) where
89
9−#if __GLASGOW_HASKELL__ < 709
10−import Control.Applicative
11−#endif
12−import Control.Exception
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
1317import Data.Maybe
18+import Network.HTTP.Date
1419import qualified Network.HTTP.Types as H
20+import qualified Network.HTTP.Types.Header as H
1521import Network.Wai
1622import qualified Network.Wai.Handler.Warp.FileInfoCache as I
17−import Network.Wai.Handler.Warp.Types
18−import Network.Wai.Internal
23+import Network.Wai.Handler.Warp.Header
24+import Numeric (showInt)
1925
2026----------------------------------------------------------------
2127
22−fileRange :: H.Status -> H.ResponseHeaders -> FilePath
23− -> Maybe FilePart -> Maybe HeaderValue
24− -> (FilePath -> IO I.FileInfo)
25− -> IO (Either IOException
26− (H.Status, H.ResponseHeaders, Integer, Integer))
27−fileRange s0 hs0 path Nothing mRange get = do
28− efinfo <- try (get path)
29− case efinfo of
30− Left e -> return $ Left e
31− Right finfo -> do
32− let ret = fileRangeSized s0 hs0 Nothing mRange $ I.fileInfoSize finfo
33− return $ Right ret
34−fileRange s0 hs0 _ mPart@(Just part) mRange _ =
35− return . Right $ fileRangeSized s0 hs0 mPart mRange size
28+data RspFileInfo = WithoutBody H.Status
29+ | WithBody H.Status H.ResponseHeaders Integer Integer
30+ deriving (Eq,Show)
31+
32+----------------------------------------------------------------
33+
34+conditionalRequest :: I.FileInfo
35+ -> H.ResponseHeaders -> IndexedHeader
36+ -> RspFileInfo
37+conditionalRequest finfo hs0 reqidx = case fromJust mx of
38+ nobody@(WithoutBody _) -> nobody
39+ WithBody s _ off len -> let hs = addContentHeaders hs0 off len size
40+ in WithBody s hs off len
3641 where
37− size = filePartFileSize part
42+ mtime = I.fileInfoTime finfo
43+ size = I.fileInfoSize finfo
44+ mx = ifmodified reqidx size mtime
45+ <|> ifunmodified reqidx size mtime
46+ <|> ifrange reqidx size mtime
47+ <|> unconditional reqidx size mtime
48+
49+----------------------------------------------------------------
50+
51+ifModifiedSince :: IndexedHeader -> Maybe HTTPDate
52+ifModifiedSince reqidx = reqidx ! idxIfModifiedSince >>= parseHTTPDate
53+
54+ifUnmodifiedSince :: IndexedHeader -> Maybe HTTPDate
55+ifUnmodifiedSince reqidx = reqidx ! idxIfUnmodifiedSince >>= parseHTTPDate
56+
57+ifRange :: IndexedHeader -> Maybe HTTPDate
58+ifRange reqidx = reqidx ! idxIfRange >>= parseHTTPDate
59+
60+----------------------------------------------------------------
61+
62+ifmodified :: IndexedHeader -> Integer -> HTTPDate -> Maybe RspFileInfo
63+ifmodified reqidx size mtime = do
64+ date <- ifModifiedSince reqidx
65+ if date /= mtime
66+ then unconditional reqidx size mtime
67+ else Just $ WithoutBody H.notModified304
68+
69+ifunmodified :: IndexedHeader -> Integer -> HTTPDate -> Maybe RspFileInfo
70+ifunmodified reqidx size mtime = do
71+ date <- ifUnmodifiedSince reqidx
72+ if date == mtime
73+ then unconditional reqidx size mtime
74+ else Just $ WithoutBody H.preconditionFailed412
75+
76+ifrange :: IndexedHeader -> Integer -> HTTPDate -> Maybe RspFileInfo
77+ifrange reqidx size mtime = do
78+ date <- ifRange reqidx
79+ rng <- reqidx ! idxRange
80+ if date == mtime
81+ then parseRange rng size
82+ else Just $ WithBody H.ok200 [] 0 size
83+
84+unconditional :: IndexedHeader -> Integer -> HTTPDate -> Maybe RspFileInfo
85+unconditional reqidx size _ = case reqidx ! idxRange of
86+ Nothing -> Just $ WithBody H.ok200 [] 0 size
87+ Just rng -> parseRange rng size
3888
39−fileRangeSized :: H.Status -> H.ResponseHeaders
40− -> Maybe FilePart -> Maybe HeaderValue -> Integer
41− -> (H.Status, H.ResponseHeaders, Integer, Integer)
42−fileRangeSized s0 hs0 mPart mRange fileSize = (s, hs, beg, len)
89+----------------------------------------------------------------
90+
91+parseRange :: ByteString -> Integer -> Maybe RspFileInfo
92+parseRange rng size = case parseByteRanges rng of
93+ Nothing -> Just $ WithoutBody H.requestedRangeNotSatisfiable416
94+ Just [] -> Just $ WithoutBody H.requestedRangeNotSatisfiable416
95+ Just (r:_) -> let (!beg, !end) = checkRange r size
96+ !len = end - beg + 1
97+ s = if beg == 0 && end == size - 1 then
98+ H.ok200
99+ else
100+ H.partialContent206
101+ in Just $ WithBody s [] beg len
102+
103+checkRange :: H.ByteRange -> Integer -> (Integer, Integer)
104+checkRange (H.ByteRangeFrom beg) size = (beg, size - 1)
105+checkRange (H.ByteRangeFromTo beg end) size = (beg, min (size - 1) end)
106+checkRange (H.ByteRangeSuffix count) size = (max 0 (size - count), size - 1)
107+
108+-- | Parse the value of a Range header into a 'H.ByteRanges'.
109+parseByteRanges :: B.ByteString -> Maybe H.ByteRanges
110+parseByteRanges bs1 = do
111+ bs2 <- stripPrefix "bytes=" bs1
112+ (r, bs3) <- range bs2
113+ ranges (r:) bs3
114+ where
115+ range bs2 = do
116+ (i, bs3) <- B.readInteger bs2
117+ if i < 0 -- has prefix "-" ("-0" is not valid, but here treated as "0-")
118+ then Just (H.ByteRangeSuffix (negate i), bs3)
119+ else do
120+ bs4 <- stripPrefix "-" bs3
121+ case B.readInteger bs4 of
122+ Just (j, bs5) | j >= i -> Just (H.ByteRangeFromTo i j, bs5)
123+ _ -> Just (H.ByteRangeFrom i, bs4)
124+ ranges front bs3
125+ | B.null bs3 = Just (front [])
126+ | otherwise = do
127+ bs4 <- stripPrefix "," bs3
128+ (r, bs5) <- range bs4
129+ ranges (front . (r:)) bs5
130+
131+ stripPrefix x y
132+ | x `B.isPrefixOf` y = Just (B.drop (B.length x) y)
133+ | otherwise = Nothing
134+
135+----------------------------------------------------------------
136+
137+-- | @contentRangeHeader beg end total@ constructs a Content-Range 'H.Header'
138+-- for the range specified.
139+contentRangeHeader :: Integer -> Integer -> Integer -> H.Header
140+contentRangeHeader beg end total = (H.hContentRange, range)
141+ where
142+ range = B.pack
143+ -- building with ShowS
144+ $ 'b' : 'y': 't' : 'e' : 's' : ' '
145+ : (if beg > end then ('*':) else
146+ showInt beg
147+ . ('-' :)
148+ . showInt end)
149+ ( '/'
150+ : showInt total "")
151+
152+addContentHeaders :: H.ResponseHeaders -> Integer -> Integer -> Integer -> H.ResponseHeaders
153+addContentHeaders hs off len size = hs''
43154 where
44− part = fromMaybe (chooseFilePart fileSize mRange) mPart
45− beg = filePartOffset part
155+ contentRange = contentRangeHeader off (off + len - 1) size
156+ lengthBS = L.toStrict $ B.toLazyByteString $ B.integerDec len
157+ hs' = (H.hContentLength, lengthBS):(H.hAcceptRanges, "bytes"):hs
158+ hs'' = if len == size then hs' else contentRange:hs'
159+
160+-- |
161+--
162+-- >>> addContentHeadersForFilePart [] (FilePart 2 10 16)
163+-- [("Content-Range","bytes 2-11/16"),("Content-Length","10"),("Accept-Ranges","bytes")]
164+-- >>> addContentHeadersForFilePart [] (FilePart 0 16 16)
165+-- [("Content-Length","16"),("Accept-Ranges","bytes")]
166+addContentHeadersForFilePart :: H.ResponseHeaders -> FilePart -> H.ResponseHeaders
167+addContentHeadersForFilePart hs part = addContentHeaders hs off len size
168+ where
169+ off = filePartOffset part
46170 len = filePartByteCount part
47− (s, hs) = adjustForFilePart s0 hs0 $ FilePart beg len fileSize
171+ size = filePartFileSize part