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