1{-# LANGUAGE CPP #-}
2{-# LANGUAGE OverloadedStrings #-}
3{-# LANGUAGE BangPatterns #-}
4
5module Network.Wai.Handler.Warp.File (
6    RspFileInfo(..)
7  , conditionalRequest
8  , addContentHeadersForFilePart
9  , H.parseByteRanges
10  ) where
11
12import Data.Array ((!))
13import qualified Data.ByteString.Char8 as C8 (pack)
14import Network.HTTP.Date
15import qualified Network.HTTP.Types as H
16import qualified Network.HTTP.Types.Header as H
17import Network.Wai
18
19import qualified Network.Wai.Handler.Warp.FileInfoCache as I
20import Network.Wai.Handler.Warp.Header
21import Network.Wai.Handler.Warp.Imports
22import Network.Wai.Handler.Warp.PackInt
23
24
25-- $setup
26-- >>> import Test.QuickCheck
27
28----------------------------------------------------------------
29
30data RspFileInfo = WithoutBody H.Status
31                 | WithBody H.Status H.ResponseHeaders Integer Integer
32                 deriving (Eq,Show)
33
34----------------------------------------------------------------
35
36conditionalRequest :: I.FileInfo
37                   -> H.ResponseHeaders
38                   -> IndexedHeader -- ^ Response
39                   -> IndexedHeader -- ^ Request
40                   -> RspFileInfo
41conditionalRequest finfo hs0 rspidx reqidx = case condition of
42    nobody@(WithoutBody _) -> nobody
43    WithBody s _ off len   -> let !hs1 = addContentHeaders hs0 off len size
44                                  !hasLM = isJust $ rspidx ! fromEnum ResLastModified
45                                  !hs = [ (H.hLastModified,date) | not hasLM ] ++ hs1
46                              in WithBody s hs off len
47  where
48    !mtime = I.fileInfoTime finfo
49    !size  = I.fileInfoSize finfo
50    !date  = I.fileInfoDate finfo
51    !mcondition = ifmodified    reqidx size mtime
52              <|> ifunmodified  reqidx size mtime
53              <|> ifrange       reqidx size mtime
54    !condition = fromMaybe (unconditional reqidx size) mcondition
55
56----------------------------------------------------------------
57
58ifModifiedSince :: IndexedHeader -> Maybe HTTPDate
59ifModifiedSince reqidx = reqidx ! fromEnum ReqIfModifiedSince >>= parseHTTPDate
60
61ifUnmodifiedSince :: IndexedHeader -> Maybe HTTPDate
62ifUnmodifiedSince reqidx = reqidx ! fromEnum ReqIfUnmodifiedSince >>= parseHTTPDate
63
64ifRange :: IndexedHeader -> Maybe HTTPDate
65ifRange reqidx = reqidx ! fromEnum ReqIfRange >>= parseHTTPDate
66
67----------------------------------------------------------------
68
69ifmodified :: IndexedHeader -> Integer -> HTTPDate -> Maybe RspFileInfo
70ifmodified reqidx size mtime = do
71    date <- ifModifiedSince reqidx
72    return $ if date /= mtime
73             then unconditional reqidx size
74             else WithoutBody H.notModified304
75
76ifunmodified :: IndexedHeader -> Integer -> HTTPDate -> Maybe RspFileInfo
77ifunmodified reqidx size mtime = do
78    date <- ifUnmodifiedSince reqidx
79    return $ if date == mtime
80             then unconditional reqidx size
81             else WithoutBody H.preconditionFailed412
82
83ifrange :: IndexedHeader -> Integer -> HTTPDate -> Maybe RspFileInfo
84ifrange reqidx size mtime = do
85    date <- ifRange reqidx
86    rng  <- reqidx ! fromEnum ReqRange
87    return $ if date == mtime
88             then parseRange rng size
89             else WithBody H.ok200 [] 0 size
90
91unconditional :: IndexedHeader -> Integer -> RspFileInfo
92unconditional reqidx size = case reqidx ! fromEnum ReqRange of
93    Nothing  -> WithBody H.ok200 [] 0 size
94    Just rng -> parseRange rng size
95
96----------------------------------------------------------------
97
98parseRange :: ByteString -> Integer -> RspFileInfo
99parseRange rng size = case H.parseByteRanges rng of
100    Nothing    -> WithoutBody H.requestedRangeNotSatisfiable416
101    Just []    -> WithoutBody H.requestedRangeNotSatisfiable416
102    Just (r:_) -> let (!beg, !end) = checkRange r size
103                      !len = end - beg + 1
104                      s = if beg == 0 && end == size - 1 then
105                              H.ok200
106                            else
107                              H.partialContent206
108                  in WithBody s [] beg len
109
110checkRange :: H.ByteRange -> Integer -> (Integer, Integer)
111checkRange (H.ByteRangeFrom   beg)     size = (beg, size - 1)
112checkRange (H.ByteRangeFromTo beg end) size = (beg,  min (size - 1) end)
113checkRange (H.ByteRangeSuffix count)   size = (max 0 (size - count), size - 1)
114
115----------------------------------------------------------------
116
117-- | @contentRangeHeader beg end total@ constructs a Content-Range 'H.Header'
118-- for the range specified.
119contentRangeHeader :: Integer -> Integer -> Integer -> H.Header
120contentRangeHeader beg end total = (H.hContentRange, range)
121  where
122    range = C8.pack
123      -- building with ShowS
124      $ 'b' : 'y': 't' : 'e' : 's' : ' '
125      : (if beg > end then ('*':) else
126          showInt beg
127          . ('-' :)
128          . showInt end)
129      ( '/'
130      : showInt total "")
131
132addContentHeaders :: H.ResponseHeaders -> Integer -> Integer -> Integer -> H.ResponseHeaders
133addContentHeaders hs off len size
134  | len == size = hs'
135  | otherwise   = let !ctrng = contentRangeHeader off (off + len - 1) size
136                  in ctrng:hs'
137  where
138    !lengthBS = packIntegral len
139    !hs' = (H.hContentLength, lengthBS) : (H.hAcceptRanges,"bytes") : hs
140
141-- |
142--
143-- >>> addContentHeadersForFilePart [] (FilePart 2 10 16)
144-- [("Content-Range","bytes 2-11/16"),("Content-Length","10"),("Accept-Ranges","bytes")]
145-- >>> addContentHeadersForFilePart [] (FilePart 0 16 16)
146-- [("Content-Length","16"),("Accept-Ranges","bytes")]
147addContentHeadersForFilePart :: H.ResponseHeaders -> FilePart -> H.ResponseHeaders
148addContentHeadersForFilePart hs part = addContentHeaders hs off len size
149  where
150    off = filePartOffset part
151    len = filePartByteCount part
152    size = filePartFileSize part
153