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