]> gitweb @ CieloNegro.org - Lucu.git/blob - Network/HTTP/Lucu/Resource.hs
Make sure RequestReader tells the writer to stop when the reader stops.
[Lucu.git] / Network / HTTP / Lucu / Resource.hs
1 {-# LANGUAGE
2     CPP
3   , BangPatterns
4   , GeneralizedNewtypeDeriving
5   , DoAndIfThenElse
6   , OverloadedStrings
7   , QuasiQuotes
8   , RecordWildCards
9   , UnicodeSyntax
10   #-}
11 -- |This is the Resource Monad; monadic actions to define a behavior
12 -- of resource. The 'Resource' Monad is a kind of 'IO' Monad thus it
13 -- implements 'MonadIO' class, and it is a state machine as well.
14 -- 
15 -- Request Processing Flow:
16 --
17 --   1. A client issues an HTTP request.
18 --
19 --   2. If the URI of it matches to any resource, the corresponding
20 --      'Resource' Monad starts running on a newly spawned thread.
21 --
22 --   3. The 'Resource' Monad looks at request headers, find (or not
23 --      find) an entity, receive the request body (if any), send
24 --      response headers, and then send a response body. This process
25 --      will be discussed later.
26 --
27 --   4. The 'Resource' Monad and its thread stops running. The client
28 --      may or may not be sending us the next request at this point.
29 --
30 -- 'Resource' Monad takes the following states. The initial state is
31 -- /Examining Request/ and the final state is /Done/.
32 --
33 --   [/Examining Request/] In this state, a 'Resource' looks at the
34 --   request header fields and thinks about the corresponding entity
35 --   for it. If there is a suitable entity, the 'Resource' tells the
36 --   system an entity tag and its last modification time
37 --   ('foundEntity'). If it found no entity, it tells the system so
38 --   ('foundNoEntity'). In case it is impossible to decide the
39 --   existence of entity, which is a typical case for POST requests,
40 --   'Resource' does nothing in this state.
41 --
42 --   [/Receiving Body/] A 'Resource' asks the system to receive a
43 --   request body from the client. Before actually reading from the
44 --   socket, the system sends \"100 Continue\" to the client if need
45 --   be. When a 'Resource' transits to the next state without
46 --   receiving all or part of a request body, the system automatically
47 --   discards it.
48 --
49 --   [/Deciding Header/] A 'Resource' makes a decision of response
50 --   status code and header fields. When it transits to the next
51 --   state, the system validates and completes the header fields and
52 --   then sends them to the client.
53 --
54 --   [/Sending Body/] In this state, a 'Resource' asks the system to
55 --   write some response body to the socket. When it transits to the
56 --   next state without writing any response body, the system
57 --   automatically completes it depending on the status code. (To be
58 --   exact, such completion only occurs when the 'Resource' transits
59 --   to this state without even declaring the \"Content-Type\" header
60 --   field. See: 'setContentType')
61 --
62 --   [/Done/] Everything is over. A 'Resource' can do nothing for the
63 --   HTTP interaction anymore.
64 --
65 -- Note that the state transition is one-way: for instance, it is an
66 -- error to try to read a request body after writing some
67 -- response. This limitation is for efficiency. We don't want to read
68 -- the entire request before starting 'Resource', nor we don't want to
69 -- postpone writing the entire response till the end of 'Resource'
70 -- computation.
71 module Network.HTTP.Lucu.Resource
72     (
73     -- * Types
74       Resource
75     , ResourceDef(..)
76     , emptyResource
77     , FormData(..)
78
79     -- * Getting request header
80     -- |These functions can be called regardless of the current state,
81     -- and they don't change the state of 'Resource'.
82     , getConfig
83     , getRemoteAddr
84     , getRemoteAddr'
85     , getRemoteHost
86 #if defined(HAVE_SSL)
87     , getRemoteCertificate
88 #endif
89     , getRequest
90     , getMethod
91     , getRequestURI
92     , getRequestVersion
93     , getResourcePath
94     , getPathInfo
95     , getQueryForm
96     , getHeader
97     , getAccept
98     , getAcceptEncoding
99     , isEncodingAcceptable
100     , getContentType
101     , getAuthorization
102
103     -- * Finding an entity
104     -- |These functions can be called only in the /Examining Request/
105     -- state. They make the 'Resource' transit to the /Receiving Body/
106     -- state.
107     , foundEntity
108     , foundETag
109     , foundTimeStamp
110     , foundNoEntity
111     , foundNoEntity'
112
113     -- * Receiving a request body
114     -- |These functions make the 'Resource' transit to the /Receiving
115     -- Body/ state.
116     , getChunk
117     , getChunks
118     , getForm
119
120     -- * Declaring response status and header fields
121     -- |These functions can be called at any time before transiting to
122     -- the /Sending Body/ state, but they themselves never causes any
123     -- state transitions.
124     , setStatus
125     , redirect
126     , setContentType
127     , setContentEncoding
128     , setWWWAuthenticate
129
130     -- ** Less frequently used functions
131     , setLocation
132     , setHeader
133     , deleteHeader
134
135     -- * Sending a response body
136
137     -- |These functions make the 'Resource' transit to the
138     -- /Sending Body/ state.
139     , putChunk
140     , putChunks
141     , putBuilder
142     )
143     where
144 import Blaze.ByteString.Builder (Builder)
145 import qualified Blaze.ByteString.Builder as BB
146 import qualified Blaze.ByteString.Builder.Internal as BB
147 import Control.Applicative
148 import Control.Arrow
149 import Control.Monad
150 import Control.Monad.IO.Class
151 import Control.Monad.Unicode
152 import Data.Ascii (Ascii, CIAscii)
153 import qualified Data.Ascii as A
154 import qualified Data.Attoparsec.Char8 as P
155 import Data.ByteString (ByteString)
156 import qualified Data.ByteString as Strict
157 import qualified Data.ByteString.Lazy as Lazy
158 import Data.Collections
159 import Data.List (intersperse, sort)
160 import Data.Maybe
161 import Data.Monoid
162 import Data.Monoid.Unicode
163 import Data.Text (Text)
164 import qualified Data.Text as T
165 import Data.Time
166 import qualified Data.Time.HTTP as HTTP
167 import Network.HTTP.Lucu.Abortion
168 import Network.HTTP.Lucu.Authentication
169 import Network.HTTP.Lucu.Config
170 import Network.HTTP.Lucu.ContentCoding
171 import Network.HTTP.Lucu.ETag
172 import qualified Network.HTTP.Lucu.Headers as H
173 import Network.HTTP.Lucu.HttpVersion
174 import Network.HTTP.Lucu.Interaction
175 import Network.HTTP.Lucu.MultipartForm
176 import Network.HTTP.Lucu.Parser
177 import Network.HTTP.Lucu.Request
178 import Network.HTTP.Lucu.Resource.Internal
179 import Network.HTTP.Lucu.Response
180 import Network.HTTP.Lucu.MIMEType (MIMEType(..))
181 import qualified Network.HTTP.Lucu.MIMEType as MT
182 import Network.HTTP.Lucu.MIMEType.TH
183 import Network.HTTP.Lucu.Utils
184 import Network.Socket hiding (accept)
185 import Network.URI hiding (path)
186 import Prelude hiding (any, drop, lookup, reverse)
187 import Prelude.Unicode
188
189 -- |Get the string representation of the address of remote host. If
190 -- you want a 'SockAddr' instead of 'HostName', use 'getRemoteAddr'.
191 getRemoteAddr' ∷ Resource HostName
192 getRemoteAddr' = liftIO ∘ toNM =≪ getRemoteAddr
193     where
194       toNM ∷ SockAddr → IO HostName
195       toNM = (fromJust ∘ fst <$>) ∘ getNameInfo [NI_NUMERICHOST] True False
196
197 -- |Resolve an address to the remote host.
198 getRemoteHost ∷ Resource (Maybe HostName)
199 getRemoteHost = liftIO ∘ getHN =≪ getRemoteAddr
200     where
201       getHN ∷ SockAddr → IO (Maybe HostName)
202       getHN = (fst <$>) ∘ getNameInfo [] True False
203
204 -- |Get the 'Method' value of the request.
205 getMethod ∷ Resource Method
206 getMethod = reqMethod <$> getRequest
207
208 -- |Get the URI of the request.
209 getRequestURI ∷ Resource URI
210 getRequestURI = reqURI <$> getRequest
211
212 -- |Get the HTTP version of the request.
213 getRequestVersion ∷ Resource HttpVersion
214 getRequestVersion = reqVersion <$> getRequest
215
216 -- |This is an analogy of CGI PATH_INFO. 'getPathInfo' always returns
217 -- @[]@ if the corresponding
218 -- 'Network.HTTP.Lucu.Resource.Tree.ResourceDef' is not greedy. See:
219 -- 'getResourcePath'
220 --
221 -- Note that the returned path components are URI-decoded.
222 getPathInfo ∷ Resource [Strict.ByteString]
223 getPathInfo = do rsrcPath ← getResourcePath
224                  reqPath  ← splitPathInfo <$> getRequestURI
225                  return $ drop (length rsrcPath) reqPath
226
227 -- |Assume the query part of request URI as
228 -- application\/x-www-form-urlencoded, and parse it into pairs of
229 -- @(name, formData)@. This function doesn't read the request
230 -- body.
231 getQueryForm ∷ Resource [(Strict.ByteString, FormData)]
232 getQueryForm = parse' <$> getRequestURI
233     where
234       parse' = map toPairWithFormData ∘
235                parseWWWFormURLEncoded ∘
236                fromJust ∘
237                A.fromChars ∘
238                drop 1 ∘
239                uriQuery
240
241 toPairWithFormData ∷ (ByteString, ByteString) → (Strict.ByteString, FormData)
242 toPairWithFormData (name, value)
243     = let fd = FormData {
244                  fdFileName = Nothing
245                , fdMIMEType = [mimeType| text/plain |]
246                , fdContent  = Lazy.fromChunks [value]
247                }
248       in (name, fd)
249
250 -- |@'getHeader' name@ returns the value of the request header field
251 -- @name@. Comparison of header name is case-insensitive. Note that
252 -- this function is not intended to be used so frequently: there
253 -- should be functions like 'getContentType' for every common headers.
254 getHeader ∷ CIAscii → Resource (Maybe Ascii)
255 getHeader name
256     = H.getHeader name <$> getRequest
257
258 -- |Return the list of 'MIMEType' enumerated on the value of request
259 -- header \"Accept\", or @[]@ if absent.
260 getAccept ∷ Resource [MIMEType]
261 getAccept
262     = do acceptM ← getHeader "Accept"
263          case acceptM of
264            Nothing
265                → return []
266            Just accept
267                → case P.parseOnly (finishOff MT.mimeTypeList) (A.toByteString accept) of
268                     Right xs → return xs
269                     Left  _  → abort $ mkAbortion' BadRequest
270                                      $ "Unparsable Accept: " ⊕ A.toText accept
271
272 -- |Return the list of @(contentCoding, qvalue)@ enumerated on the
273 -- value of request header \"Accept-Encoding\". The list is sorted in
274 -- descending order by qvalue.
275 getAcceptEncoding ∷ Resource [(CIAscii, Maybe Double)]
276 getAcceptEncoding
277     = do accEncM ← getHeader "Accept-Encoding"
278          case accEncM of
279            Nothing
280                -- HTTP/1.0 には Accept-Encoding が無い場合の規定が無い
281                -- ので安全の爲 identity が指定された事にする。HTTP/1.1
282                -- の場合は何でも受け入れて良い事になってゐるので "*" が
283                -- 指定された事にする。
284                → do ver ← getRequestVersion
285                     case ver of
286                       HttpVersion 1 0 → return [("identity", Nothing)]
287                       HttpVersion 1 1 → return [("*"       , Nothing)]
288                       _               → abort $ mkAbortion' InternalServerError
289                                                 "getAcceptEncoding: unknown HTTP version"
290            Just ae
291                → if ae ≡ "" then
292                       -- identity のみが許される。
293                       return [("identity", Nothing)]
294                  else
295                      case P.parseOnly (finishOff acceptEncodingList) (A.toByteString ae) of
296                        Right xs → return $ map toTuple $ reverse $ sort xs
297                        Left  _  → abort $ mkAbortion' BadRequest
298                                         $ "Unparsable Accept-Encoding: " ⊕ A.toText ae
299     where
300       toTuple (AcceptEncoding {..})
301           = (aeEncoding, aeQValue)
302
303 -- |Return 'True' iff a given content-coding is acceptable by the
304 -- client.
305 isEncodingAcceptable ∷ CIAscii → Resource Bool
306 isEncodingAcceptable encoding = any doesMatch <$> getAcceptEncoding
307     where
308       doesMatch ∷ (CIAscii, Maybe Double) → Bool
309       doesMatch (e, q) = (e ≡ "*" ∨ e ≡ encoding) ∧ q ≢ Just 0
310
311 -- |Return the value of request header \"Content-Type\" as 'MIMEType'.
312 getContentType ∷ Resource (Maybe MIMEType)
313 getContentType
314     = do cTypeM ← getHeader "Content-Type"
315          case cTypeM of
316            Nothing
317                → return Nothing
318            Just cType
319                → case P.parseOnly (finishOff MT.mimeType) (A.toByteString cType) of
320                     Right t → return $ Just t
321                     Left  _ → abort $ mkAbortion' BadRequest
322                                     $ "Unparsable Content-Type: " ⊕ A.toText cType
323
324 -- |Return the value of request header \"Authorization\" as
325 -- 'AuthCredential'.
326 getAuthorization ∷ Resource (Maybe AuthCredential)
327 getAuthorization
328     = do authM ← getHeader "Authorization"
329          case authM of
330            Nothing
331                → return Nothing
332            Just auth
333                → case P.parseOnly (finishOff authCredential) (A.toByteString auth) of
334                     Right ac → return $ Just ac
335                     Left  _  → return Nothing
336
337 -- |Tell the system that the 'Resource' found an entity for the
338 -- request URI. If this is a GET or HEAD request, a found entity means
339 -- a datum to be replied. If this is a PUT or DELETE request, it means
340 -- a datum which was stored for the URI until now. For POST requests
341 -- it raises an error.
342 --
343 -- 'foundEntity' performs \"If-Match\" test or \"If-None-Match\" test
344 -- whenever possible, and if those tests fail, it immediately aborts
345 -- with status \"412 Precondition Failed\" or \"304 Not Modified\"
346 -- depending on the situation.
347 --
348 -- If the request method is either GET or HEAD, 'foundEntity'
349 -- automatically puts \"ETag\" and \"Last-Modified\" headers into the
350 -- response.
351 foundEntity ∷ ETag → UTCTime → Resource ()
352 foundEntity tag timeStamp
353     = do driftTo ExaminingRequest
354
355          method ← getMethod
356          when (method ≡ GET ∨ method ≡ HEAD)
357              $ setHeader "Last-Modified" (HTTP.toAscii timeStamp)
358          when (method ≡ POST)
359              $ abort
360              $ mkAbortion' InternalServerError
361                "foundEntity: this is a POST request."
362          foundETag tag
363
364          driftTo ReceivingBody
365
366 -- |Tell the system that the 'Resource' found an entity for the
367 -- request URI. The only difference from 'foundEntity' is that
368 -- 'foundETag' doesn't (nor can't) put \"Last-Modified\" header into
369 -- the response.
370 --
371 -- Using this function is discouraged. You should use 'foundEntity'
372 -- whenever possible.
373 foundETag ∷ ETag → Resource ()
374 foundETag tag
375     = do driftTo ExaminingRequest
376       
377          method ← getMethod
378          when (method ≡ GET ∨ method ≡ HEAD)
379              $ setHeader "ETag"
380              $ A.fromAsciiBuilder
381              $ printETag tag
382          when (method ≡ POST)
383              $ abort
384              $ mkAbortion' InternalServerError
385                "Illegal computation of foundETag for POST request."
386
387          -- If-Match があればそれを見る。
388          ifMatch ← getHeader "If-Match"
389          case ifMatch of
390            Nothing
391                → return ()
392            Just value
393                → if value ≡ "*" then
394                       return ()
395                   else
396                       case P.parseOnly (finishOff eTagList) (A.toByteString value) of
397                         Right tags
398                             -- tags の中に一致するものが無ければ
399                             -- PreconditionFailed で終了。
400                             → when ((¬) (any (≡ tag) tags))
401                                   $ abort
402                                   $ mkAbortion' PreconditionFailed
403                                   $ "The entity tag doesn't match: " ⊕ A.toText value
404                         Left _
405                             → abort $ mkAbortion' BadRequest
406                                     $ "Unparsable If-Match: " ⊕ A.toText value
407
408          let statusForNoneMatch
409                  = if method ≡ GET ∨ method ≡ HEAD then
410                        fromStatusCode NotModified
411                    else
412                        fromStatusCode PreconditionFailed
413
414          -- If-None-Match があればそれを見る。
415          ifNoneMatch ← getHeader "If-None-Match"
416          case ifNoneMatch of
417            Nothing
418                → return ()
419            Just value
420                → if value ≡ "*" then
421                       abort $ mkAbortion' statusForNoneMatch
422                             $ "The entity tag matches: *"
423                   else
424                       case P.parseOnly (finishOff eTagList) (A.toByteString value) of
425                         Right tags
426                             → when (any (≡ tag) tags)
427                                   $ abort
428                                   $ mkAbortion' statusForNoneMatch
429                                   $ "The entity tag matches: " ⊕ A.toText value
430                         Left _
431                             → abort $ mkAbortion' BadRequest
432                                     $ "Unparsable If-None-Match: " ⊕ A.toText value
433
434          driftTo ReceivingBody
435
436 -- |Tell the system that the 'Resource' found an entity for the
437 -- request URI. The only difference from 'foundEntity' is that
438 -- 'foundTimeStamp' performs \"If-Modified-Since\" test or
439 -- \"If-Unmodified-Since\" test instead of \"If-Match\" test or
440 -- \"If-None-Match\" test. Be aware that any tests based on a last
441 -- modification time are unsafe because it is possible to mess up such
442 -- tests by modifying the entity twice in a second.
443 --
444 -- Using this function is discouraged. You should use 'foundEntity'
445 -- whenever possible.
446 foundTimeStamp ∷ UTCTime → Resource ()
447 foundTimeStamp timeStamp
448     = do driftTo ExaminingRequest
449
450          method ← getMethod
451          when (method ≡ GET ∨ method ≡ HEAD)
452              $ setHeader "Last-Modified" (HTTP.toAscii timeStamp)
453          when (method ≡ POST)
454              $ abort
455              $ mkAbortion' InternalServerError
456                "Illegal call of foundTimeStamp for POST request."
457
458          let statusForIfModSince
459                  = if method ≡ GET ∨ method ≡ HEAD then
460                        fromStatusCode NotModified
461                    else
462                        fromStatusCode PreconditionFailed
463
464          ifModSince ← getHeader "If-Modified-Since"
465          case ifModSince of
466            Just str → case HTTP.fromAscii str of
467                          Right lastTime
468                              → when (timeStamp ≤ lastTime)
469                                $ abort
470                                $ mkAbortion' statusForIfModSince
471                                $ "The entity has not been modified since " ⊕ A.toText str
472                          Left e
473                              → abort $ mkAbortion' BadRequest
474                                      $ "Malformed If-Modified-Since: " ⊕ T.pack e
475            Nothing  → return ()
476
477          ifUnmodSince ← getHeader "If-Unmodified-Since"
478          case ifUnmodSince of
479            Just str → case HTTP.fromAscii str of
480                          Right lastTime
481                              → when (timeStamp > lastTime)
482                                $ abort
483                                $ mkAbortion' PreconditionFailed
484                                $ "The entity has not been modified since " ⊕ A.toText str
485                          Left e
486                              → abort $ mkAbortion' BadRequest
487                                      $ "Malformed If-Unmodified-Since: " ⊕ T.pack e
488            Nothing  → return ()
489
490          driftTo ReceivingBody
491
492 -- |@'foundNoEntity' mStr@ tells the system that the 'Resource' found
493 -- no entity for the request URI. @mStr@ is an optional error message
494 -- to be replied to the client.
495 --
496 -- If the request method is PUT, 'foundNoEntity' performs \"If-Match\"
497 -- test and when that fails it aborts with status \"412 Precondition
498 -- Failed\". If the request method is GET, HEAD, POST or DELETE,
499 -- 'foundNoEntity' always aborts with status \"404 Not Found\".
500 foundNoEntity ∷ Maybe Text → Resource ()
501 foundNoEntity msgM
502     = do driftTo ExaminingRequest
503
504          method ← getMethod
505          when (method ≢ PUT)
506              $ abort
507              $ mkAbortion NotFound [] msgM
508
509          -- エンティティが存在しないと云ふ事は、"*" も含めたどのやうな
510          -- If-Match: 條件も滿たさない。
511          ifMatch ← getHeader "If-Match"
512          when (ifMatch ≢ Nothing)
513              $ abort
514              $ mkAbortion PreconditionFailed [] msgM
515
516          driftTo ReceivingBody
517
518 -- |'foundNoEntity'' is the same as @'foundNoEntity' 'Nothing'@.
519 foundNoEntity' ∷ Resource ()
520 {-# INLINE foundNoEntity' #-}
521 foundNoEntity' = foundNoEntity Nothing
522
523 -- |@'getChunks' limit@ attemts to read the entire request body up to
524 -- @limit@ bytes, and then make the 'Resource' transit to the
525 -- /Deciding Header/ state. When the actual size of the body is larger
526 -- than @limit@ bytes, 'getChunks' immediately aborts with status
527 -- \"413 Request Entity Too Large\". When the request has no body, it
528 -- returns an empty string.
529 --
530 -- When the @limit@ is 'Nothing', 'getChunks' uses the default
531 -- limitation value ('cnfMaxEntityLength') instead.
532 --
533 -- 'getChunks' returns a lazy 'Lazy.ByteString' but it's not really
534 -- lazy: reading from the socket just happens at the computation of
535 -- 'getChunks', not at the evaluation of the 'Lazy.ByteString'.
536 getChunks ∷ Maybe Int → Resource Lazy.ByteString
537 getChunks (Just n)
538     | n < 0     = fail ("getChunks: limit must not be negative: " ⧺ show n)
539     | n ≡ 0     = return (∅)
540     | otherwise = getChunks' n
541 getChunks Nothing
542     = getConfig ≫= getChunks ∘ Just ∘ cnfMaxEntityLength
543
544 getChunks' ∷ Int → Resource Lazy.ByteString
545 getChunks' limit = go limit (∅)
546     where
547       go ∷ Int → Builder → Resource Lazy.ByteString
548       go  0  _ = do chunk ← getChunk 1
549                     if Strict.null chunk then
550                         return (∅)
551                     else
552                         abort $ mkAbortion' RequestEntityTooLarge
553                               $ "Request body must be smaller than "
554                               ⊕ T.pack (show limit)
555                               ⊕ " bytes."
556       go !n !b = do c ← getChunk $ min n BB.defaultBufferSize
557                     if Strict.null c then
558                         -- Got EOF
559                         return $ BB.toLazyByteString b
560                     else
561                         do let n'  = n - Strict.length c
562                                xs' = b ⊕ BB.fromByteString c
563                            go n' xs'
564
565 -- |@'getForm' limit@ attempts to read the request body with
566 -- 'getChunks' and parse it as @application\/x-www-form-urlencoded@ or
567 -- @multipart\/form-data@. If the request header \"Content-Type\" is
568 -- neither of them, 'getForm' aborts with status \"415 Unsupported
569 -- Media Type\". If the request has no \"Content-Type\", it aborts
570 -- with \"400 Bad Request\".
571 --
572 -- Note that there are currently a few limitations on parsing
573 -- @multipart/form-data@. See: 'parseMultipartFormData'
574 getForm ∷ Maybe Int → Resource [(Strict.ByteString, FormData)]
575 getForm limit
576     = do cTypeM ← getContentType
577          case cTypeM of
578            Nothing
579                → abort $ mkAbortion' BadRequest "Missing Content-Type"
580            Just (MIMEType "application" "x-www-form-urlencoded" _)
581                → readWWWFormURLEncoded
582            Just (MIMEType "multipart" "form-data" params)
583                → readMultipartFormData params
584            Just cType
585                → abort $ mkAbortion' UnsupportedMediaType
586                        $ A.toText
587                        $ A.fromAsciiBuilder
588                        $ A.toAsciiBuilder "Unsupported media type: "
589                        ⊕ MT.printMIMEType cType
590     where
591       readWWWFormURLEncoded
592           = (map toPairWithFormData ∘ parseWWWFormURLEncoded)
593             <$>
594             (bsToAscii =≪ getChunks limit)
595
596       bsToAscii bs
597           = case A.fromByteString (Strict.concat (Lazy.toChunks bs)) of
598               Just a  → return a
599               Nothing → abort $ mkAbortion' BadRequest "Malformed x-www-form-urlencoded"
600
601       readMultipartFormData m
602           = case lookup "boundary" m of
603               Nothing
604                   → abort $ mkAbortion' BadRequest "Missing boundary of multipart/form-data"
605               Just boundary
606                   → do src ← getChunks limit
607                        b   ← case A.fromText boundary of
608                                 Just b  → return b
609                                 Nothing → abort $ mkAbortion' BadRequest
610                                                 $ "Malformed boundary: " ⊕ boundary
611                        case parseMultipartFormData b src of
612                          Right xs → return $ map (first A.toByteString) xs
613                          Left err → abort $ mkAbortion' BadRequest $ T.pack err
614
615 -- |@'redirect' code uri@ declares the response status as @code@ and
616 -- \"Location\" header field as @uri@. The @code@ must satisfy
617 -- 'isRedirection' or it raises an error.
618 redirect ∷ StatusCode sc ⇒ sc → URI → Resource ()
619 redirect sc uri
620     = do when (sc ≈ NotModified ∨ (¬) (isRedirection sc))
621              $ abort
622              $ mkAbortion' InternalServerError
623              $ A.toText
624              $ A.fromAsciiBuilder
625              $ A.toAsciiBuilder "Attempted to redirect with status "
626              ⊕ printStatusCode sc
627          setStatus sc
628          setLocation uri
629
630 -- |@'setContentType' mType@ declares the response header
631 -- \"Content-Type\" as @mType@. Declaring \"Content-Type\" is
632 -- mandatory for sending a response body.
633 setContentType ∷ MIMEType → Resource ()
634 setContentType
635     = setHeader "Content-Type" ∘ A.fromAsciiBuilder ∘ MT.printMIMEType
636
637 -- |@'setLocation' uri@ declares the response header \"Location\" as
638 -- @uri@. You usually don't need to call this function directly.
639 setLocation ∷ URI → Resource ()
640 setLocation uri
641     = case A.fromChars uriStr of
642         Just a  → setHeader "Location" a
643         Nothing → abort $ mkAbortion' InternalServerError
644                         $ "Malformed URI: " ⊕ T.pack uriStr
645     where
646       uriStr = uriToString id uri ""
647
648 -- |@'setContentEncoding' codings@ declares the response header
649 -- \"Content-Encoding\" as @codings@.
650 setContentEncoding ∷ [CIAscii] → Resource ()
651 setContentEncoding codings
652     = do ver ← getRequestVersion
653          tr  ← case ver of
654                   HttpVersion 1 0 → return (toAB ∘ unnormalizeCoding)
655                   HttpVersion 1 1 → return toAB
656                   _               → abort $ mkAbortion' InternalServerError
657                                             "setContentEncoding: Unknown HTTP version"
658          setHeader "Content-Encoding"
659              $ A.fromAsciiBuilder
660              $ mconcat
661              $ intersperse (A.toAsciiBuilder ", ")
662              $ map tr codings
663     where
664       toAB = A.toAsciiBuilder ∘ A.fromCIAscii
665
666 -- |@'setWWWAuthenticate' challenge@ declares the response header
667 -- \"WWW-Authenticate\" as @challenge@.
668 setWWWAuthenticate ∷ AuthChallenge → Resource ()
669 setWWWAuthenticate = setHeader "WWW-Authenticate" ∘ printAuthChallenge
670
671 -- |Write a chunk in 'Strict.ByteString' to the response body. You
672 -- must first declare the response header \"Content-Type\" before
673 -- applying this function. See: 'setContentType'
674 putChunk ∷ Strict.ByteString → Resource ()
675 putChunk = putBuilder ∘ BB.fromByteString
676
677 -- |Write a chunk in lazy 'Lazy.ByteString' to the response body. It
678 -- can be safely applied to an infinitely long 'Lazy.ByteString'.
679 --
680 -- Note that you must first declare the response header
681 -- \"Content-Type\" before applying this function. See:
682 -- 'setContentType'
683 putChunks ∷ Lazy.ByteString → Resource ()
684 putChunks = putBuilder ∘ BB.fromLazyByteString