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