-
Notifications
You must be signed in to change notification settings - Fork 259
/
File.hs
200 lines (177 loc) · 7.02 KB
/
File.hs
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
module Network.Wai.Handler.Warp.File (
RspFileInfo (..),
conditionalRequest,
addContentHeadersForFilePart,
H.parseByteRanges,
) where
import Data.Array ((!))
import qualified Data.ByteString.Char8 as C8 (pack)
import Network.HTTP.Date
import qualified Network.HTTP.Types as H
import qualified Network.HTTP.Types.Header as H
import Network.Wai
import qualified Network.Wai.Handler.Warp.FileInfoCache as I
import Network.Wai.Handler.Warp.Header
import Network.Wai.Handler.Warp.Imports
import Network.Wai.Handler.Warp.PackInt
----------------------------------------------------------------
data RspFileInfo
= WithoutBody H.Status
| WithBody H.Status H.ResponseHeaders Integer Integer
deriving (Eq, Show)
----------------------------------------------------------------
conditionalRequest
:: I.FileInfo
-> H.ResponseHeaders
-> H.Method
-> IndexedHeader
-- ^ Response
-> IndexedHeader
-- ^ Request
-> RspFileInfo
conditionalRequest finfo hs0 method rspidx reqidx = case condition of
nobody@(WithoutBody _) -> nobody
WithBody s _ off len ->
let !hs1 = addContentHeaders hs0 off len size
!hs = case rspidx ! fromEnum ResLastModified of
Just _ -> hs1
Nothing -> (H.hLastModified, date) : hs1
in WithBody s hs off len
where
!mtime = I.fileInfoTime finfo
!size = I.fileInfoSize finfo
!date = I.fileInfoDate finfo
-- According to RFC 9110:
-- "A recipient cache or origin server MUST evaluate the request
-- preconditions defined by this specification in the following order:
-- - If-Match
-- - If-Unmodified-Since
-- - If-None-Match
-- - If-Modified-Since
-- - If-Range
--
-- We don't actually implement the If-(None-)Match logic, but
-- we also don't want to block middleware or applications from
-- using ETags. And sending If-(None-)Match headers in a request
-- to a server that doesn't use them is requester's problem.
!mcondition =
ifunmodified reqidx mtime
<|> ifmodified reqidx mtime method
<|> ifrange reqidx mtime method size
!condition = fromMaybe (unconditional reqidx size) mcondition
----------------------------------------------------------------
ifModifiedSince :: IndexedHeader -> Maybe HTTPDate
ifModifiedSince reqidx = reqidx ! fromEnum ReqIfModifiedSince >>= parseHTTPDate
ifUnmodifiedSince :: IndexedHeader -> Maybe HTTPDate
ifUnmodifiedSince reqidx = reqidx ! fromEnum ReqIfUnmodifiedSince >>= parseHTTPDate
ifRange :: IndexedHeader -> Maybe HTTPDate
ifRange reqidx = reqidx ! fromEnum ReqIfRange >>= parseHTTPDate
----------------------------------------------------------------
ifmodified :: IndexedHeader -> HTTPDate -> H.Method -> Maybe RspFileInfo
ifmodified reqidx mtime method = do
date <- ifModifiedSince reqidx
-- According to RFC 9110:
-- "A recipient MUST ignore If-Modified-Since if the request
-- contains an If-None-Match header field; [...]"
guard . isNothing $ reqidx ! fromEnum ReqIfNoneMatch
-- "A recipient MUST ignore the If-Modified-Since header field
-- if [...] the request method is neither GET nor HEAD."
guard $ method == H.methodGet || method == H.methodHead
guard $ date == mtime || date > mtime
Just $ WithoutBody H.notModified304
ifunmodified :: IndexedHeader -> HTTPDate -> Maybe RspFileInfo
ifunmodified reqidx mtime = do
date <- ifUnmodifiedSince reqidx
-- According to RFC 9110:
-- "A recipient MUST ignore If-Unmodified-Since if the request
-- contains an If-Match header field; [...]"
guard . isNothing $ reqidx ! fromEnum ReqIfMatch
guard $ date /= mtime && date < mtime
Just $ WithoutBody H.preconditionFailed412
-- TODO: Should technically also strongly match on ETags.
ifrange :: IndexedHeader -> HTTPDate -> H.Method -> Integer -> Maybe RspFileInfo
ifrange reqidx mtime method size = do
-- According to RFC 9110:
-- "When the method is GET and both Range and If-Range are
-- present, evaluate the If-Range precondition:"
date <- ifRange reqidx
rng <- reqidx ! fromEnum ReqRange
guard $ method == H.methodGet
return $
if date == mtime
then parseRange rng size
else WithBody H.ok200 [] 0 size
unconditional :: IndexedHeader -> Integer -> RspFileInfo
unconditional reqidx =
case reqidx ! fromEnum ReqRange of
Nothing -> WithBody H.ok200 [] 0
Just rng -> parseRange rng
----------------------------------------------------------------
parseRange :: ByteString -> Integer -> RspFileInfo
parseRange rng size = case H.parseByteRanges rng of
Nothing -> WithoutBody H.requestedRangeNotSatisfiable416
Just [] -> WithoutBody H.requestedRangeNotSatisfiable416
Just (r : _) ->
let (!beg, !end) = checkRange r size
!len = end - beg + 1
s =
if beg == 0 && end == size - 1
then H.ok200
else H.partialContent206
in WithBody s [] beg len
checkRange :: H.ByteRange -> Integer -> (Integer, Integer)
checkRange (H.ByteRangeFrom beg) size = (beg, size - 1)
checkRange (H.ByteRangeFromTo beg end) size = (beg, min (size - 1) end)
checkRange (H.ByteRangeSuffix count) size = (max 0 (size - count), size - 1)
----------------------------------------------------------------
-- | @contentRangeHeader beg end total@ constructs a Content-Range 'H.Header'
-- for the range specified.
contentRangeHeader :: Integer -> Integer -> Integer -> H.Header
contentRangeHeader beg end total = (H.hContentRange, range)
where
range =
C8.pack
-- building with ShowS
$
'b'
: 'y'
: 't'
: 'e'
: 's'
: ' '
: ( if beg > end
then ('*' :)
else
showInt beg
. ('-' :)
. showInt end
)
( '/'
: showInt total ""
)
addContentHeaders
:: H.ResponseHeaders -> Integer -> Integer -> Integer -> H.ResponseHeaders
addContentHeaders hs off len size
| len == size = hs'
| otherwise =
let !ctrng = contentRangeHeader off (off + len - 1) size
in ctrng : hs'
where
!lengthBS = packIntegral len
!hs' = (H.hContentLength, lengthBS) : (H.hAcceptRanges, "bytes") : hs
-- |
--
-- >>> addContentHeadersForFilePart [] (FilePart 2 10 16)
-- [("Content-Range","bytes 2-11/16"),("Content-Length","10"),("Accept-Ranges","bytes")]
-- >>> addContentHeadersForFilePart [] (FilePart 0 16 16)
-- [("Content-Length","16"),("Accept-Ranges","bytes")]
addContentHeadersForFilePart
:: H.ResponseHeaders -> FilePart -> H.ResponseHeaders
addContentHeadersForFilePart hs part = addContentHeaders hs off len size
where
off = filePartOffset part
len = filePartByteCount part
size = filePartFileSize part