2 GeneralizedNewtypeDeriving
8 {-# OPTIONS_HADDOCK prune #-}
9 -- |This is the Resource Monad; monadic actions to define the behavior
10 -- of each resources. The 'Resource' Monad is a kind of 'Prelude.IO'
11 -- Monad thus it implements 'Control.Monad.Trans.MonadIO' class. It is
12 -- also a state machine.
14 -- Request Processing Flow:
16 -- 1. A client issues an HTTP request.
18 -- 2. If the URI of it matches to any resource, the corresponding
19 -- 'Resource' Monad starts running on a newly spawned thread.
21 -- 3. The 'Resource' Monad looks at the request header, find (or not
22 -- find) an entity, receive the request body (if any), decide the
23 -- response header, and decide the response body. This process
24 -- will be discussed later.
26 -- 4. The 'Resource' Monad and its thread stops running. The client
27 -- may or may not be sending us the next request at this point.
29 -- 'Resource' Monad takes the following states. The initial state is
30 -- /Examining Request/ and the final state is /Done/.
32 -- [/Examining Request/] In this state, a 'Resource' looks at the
33 -- request header and thinks about an entity for it. If there is a
34 -- suitable entity, the 'Resource' tells the system an entity tag
35 -- and its last modification time ('foundEntity'). If it found no
36 -- entity, it tells the system so ('foundNoEntity'). In case it is
37 -- impossible to decide the existence of entity, which is a typical
38 -- case for POST requests, 'Resource' does nothing in this state.
40 -- [/Getting Body/] A 'Resource' asks the system to receive a
41 -- request body from client. Before actually reading from the
42 -- socket, the system sends \"100 Continue\" to the client if need
43 -- be. When a 'Resource' transits to the next state without
44 -- receiving all or part of request body, the system still reads it
45 -- and just throws it away.
47 -- [/Deciding Header/] A 'Resource' makes a decision of status code
48 -- and response header. When it transits to the next state, the
49 -- system checks the validness of response header and then write
50 -- them to the socket.
52 -- [/Deciding Body/] In this state, a 'Resource' asks the system to
53 -- write some response body to the socket. When it transits to the
54 -- next state without writing any response body, the system
55 -- completes it depending on the status code.
57 -- [/Done/] Everything is over. A 'Resource' can do nothing for the
58 -- HTTP interaction anymore.
60 -- Note that the state transition is one-way: for instance, it is an
61 -- error to try to read a request body after writing some
62 -- response. This limitation is for efficiency. We don't want to read
63 -- the entire request before starting 'Resource', nor we don't want to
64 -- postpone writing the entire response till the end of 'Resource'
67 module Network.HTTP.Lucu.Resource
76 -- ** Getting request header
78 -- |These actions can be computed regardless of the current state,
79 -- and they don't change the state.
84 , getRemoteCertificate
95 , isEncodingAcceptable
99 -- ** Finding an entity
101 -- |These actions can be computed only in the /Examining Request/
102 -- state. After the computation, the 'Resource' transits to
103 -- /Getting Body/ state.
109 -- ** Getting a request body
111 -- |Computation of these actions changes the state to /Getting
118 -- ** Setting response headers
120 -- |Computation of these actions changes the state to /Deciding
130 -- ** Writing a response body
132 -- |Computation of these actions changes the state to /Deciding
140 import Blaze.ByteString.Builder (Builder)
141 import qualified Blaze.ByteString.Builder.ByteString as BB
142 import Control.Applicative
143 import Control.Concurrent.STM
144 import Control.Monad.Reader
145 import Control.Monad.Unicode
146 import Data.Ascii (Ascii, CIAscii)
147 import qualified Data.Ascii as A
148 import qualified Data.Attoparsec.Char8 as P
149 import qualified Data.Attoparsec.Lazy as LP
150 import Data.ByteString (ByteString)
151 import qualified Data.ByteString as Strict
152 import qualified Data.ByteString.Lazy as Lazy
153 import Data.Foldable (toList)
155 import qualified Data.Map as M
157 import Data.Monoid.Unicode
158 import Data.Sequence (Seq)
159 import Data.Text (Text)
160 import qualified Data.Text as T
161 import qualified Data.Text.Encoding as T
163 import qualified Data.Time.HTTP as HTTP
164 import Network.HTTP.Lucu.Abortion
165 import Network.HTTP.Lucu.Authorization
166 import Network.HTTP.Lucu.Config
167 import Network.HTTP.Lucu.ContentCoding
168 import Network.HTTP.Lucu.ETag
169 import qualified Network.HTTP.Lucu.Headers as H
170 import Network.HTTP.Lucu.HttpVersion
171 import Network.HTTP.Lucu.Interaction
172 import Network.HTTP.Lucu.MultipartForm
173 import Network.HTTP.Lucu.Postprocess
174 import Network.HTTP.Lucu.Request
175 import Network.HTTP.Lucu.Response
176 import Network.HTTP.Lucu.MIMEType
177 import Network.HTTP.Lucu.Utils
178 import Network.Socket hiding (accept)
179 import Network.URI hiding (path)
181 import Prelude.Unicode
183 -- |The 'Resource' monad. This monad implements 'MonadIO' so it can do
187 unRes ∷ ReaderT Interaction IO a
189 deriving (Applicative, Functor, Monad, MonadIO)
191 runRes ∷ Resource a → Interaction → IO a
193 = runReaderT (unRes r) itr
195 getInteraction ∷ Resource Interaction
196 getInteraction = Resource ask
198 -- |Get the 'Config' value which is used for the httpd.
199 getConfig ∷ Resource Config
200 getConfig = itrConfig <$> getInteraction
202 -- |Get the 'SockAddr' of the remote host. If you want a string
203 -- representation instead of 'SockAddr', use 'getRemoteAddr''.
204 getRemoteAddr ∷ Resource SockAddr
205 getRemoteAddr = itrRemoteAddr <$> getInteraction
207 -- |Get the string representation of the address of remote host. If
208 -- you want a 'SockAddr' instead of 'String', use 'getRemoteAddr'.
209 getRemoteAddr' ∷ Resource HostName
211 = do sa ← getRemoteAddr
212 (Just a, _) ← liftIO $ getNameInfo [NI_NUMERICHOST] True False sa
215 -- |Resolve an address to the remote host.
216 getRemoteHost ∷ Resource (Maybe HostName)
218 = do sa ← getRemoteAddr
219 fst <$> (liftIO $ getNameInfo [] True False sa)
221 -- | Return the X.509 certificate of the client, or 'Nothing' if:
223 -- * This request didn't came through an SSL stream.
225 -- * The client didn't send us its certificate.
227 -- * The 'OpenSSL.Session.VerificationMode' of
228 -- 'OpenSSL.Session.SSLContext' in 'SSLConfig' has not been set to
229 -- 'OpenSSL.Session.VerifyPeer'.
230 getRemoteCertificate ∷ Resource (Maybe X509)
231 getRemoteCertificate = itrRemoteCert <$> getInteraction
233 -- |Get the 'Request' value which represents the request header. In
234 -- general you don't have to use this action.
235 getRequest ∷ Resource Request
236 getRequest = (fromJust ∘ itrRequest) <$> getInteraction
238 -- |Get the 'Method' value of the request.
239 getMethod ∷ Resource Method
240 getMethod = reqMethod <$> getRequest
242 -- |Get the URI of the request.
243 getRequestURI ∷ Resource URI
244 getRequestURI = reqURI <$> getRequest
246 -- |Get the HTTP version of the request.
247 getRequestVersion ∷ Resource HttpVersion
248 getRequestVersion = reqVersion <$> getRequest
250 -- |Get the path of this 'Resource' (to be exact,
251 -- 'Network.HTTP.Lucu.Resource.Tree.ResourceDef') in the
252 -- 'Network.HTTP.Lucu.Resource.Tree.ResTree'. The result of this
253 -- action is the exact path in the tree even when the
254 -- 'Network.HTTP.Lucu.Resource.Tree.ResourceDef' is greedy.
258 -- > main = let tree = mkResTree [ (["foo"], resFoo) ]
259 -- > in runHttpd defaultConfig tree
261 -- > resFoo = ResourceDef {
262 -- > resIsGreedy = True
263 -- > , resGet = Just $ do requestURI <- getRequestURI
264 -- > resourcePath <- getResourcePath
265 -- > pathInfo <- getPathInfo
266 -- > -- uriPath requestURI == "/foo/bar/baz"
267 -- > -- resourcePath == ["foo"]
268 -- > -- pathInfo == ["bar", "baz"]
272 getResourcePath ∷ Resource [Text]
273 getResourcePath = (fromJust ∘ itrResourcePath) <$> getInteraction
275 -- |This is an analogy of CGI PATH_INFO. The result is
276 -- URI-unescaped. It is always @[]@ if the
277 -- 'Network.HTTP.Lucu.Resource.Tree.ResourceDef' is not greedy. See
278 -- 'getResourcePath'.
280 -- Note that the returned path is URI-decoded and then UTF-8 decoded.
281 getPathInfo ∷ Resource [Text]
282 getPathInfo = do rsrcPath ← getResourcePath
283 reqPath ← splitPathInfo <$> getRequestURI
284 -- rsrcPath と reqPath の共通する先頭部分を reqPath か
285 -- ら全部取り除くと、それは PATH_INFO のやうなものにな
286 -- る。rsrcPath は全部一致してゐるに決まってゐる(でな
287 -- ければこの Resource が撰ばれた筈が無い)ので、
288 -- rsrcPath の長さの分だけ削除すれば良い。
289 return $ drop (length rsrcPath) reqPath
291 -- |Assume the query part of request URI as
292 -- application\/x-www-form-urlencoded, and parse it to pairs of
293 -- @(name, formData)@. This action doesn't parse the request body. See
294 -- 'inputForm'. Field names are decoded in UTF-8.
295 getQueryForm ∷ Resource [(Text, FormData)]
296 getQueryForm = parse' <$> getRequestURI
298 parse' = map toPairWithFormData ∘
299 parseWWWFormURLEncoded ∘
305 toPairWithFormData ∷ (ByteString, ByteString) → (Text, FormData)
306 toPairWithFormData (name, value)
307 = let fd = FormData {
309 , fdContent = Lazy.fromChunks [value]
311 in (T.decodeUtf8 name, fd)
313 -- |Get a value of given request header. Comparison of header name is
314 -- case-insensitive. Note that this action is not intended to be used
315 -- so frequently: there should be actions like 'getContentType' for
316 -- every common headers.
317 getHeader ∷ CIAscii → Resource (Maybe Ascii)
319 = H.getHeader name <$> getRequest
321 -- |Get a list of 'MIMEType' enumerated on header \"Accept\".
322 getAccept ∷ Resource [MIMEType]
324 = do acceptM ← getHeader "Accept"
329 → case P.parseOnly p (A.toByteString accept) of
331 Left _ → abort BadRequest []
332 (Just $ "Unparsable Accept: " ⊕ A.toText accept)
334 p = do xs ← mimeTypeListP
338 -- |Get a list of @(contentCoding, qvalue)@ enumerated on header
339 -- \"Accept-Encoding\". The list is sorted in descending order by
341 getAcceptEncoding ∷ Resource [(CIAscii, Maybe Double)]
343 = do accEncM ← getHeader "Accept-Encoding"
346 -- HTTP/1.0 には Accept-Encoding が無い場合の規定が無い
347 -- ので安全の爲 identity が指定された事にする。HTTP/1.1
348 -- の場合は何でも受け入れて良い事になってゐるので "*" が
350 → do ver ← getRequestVersion
352 HttpVersion 1 0 → return [("identity", Nothing)]
353 HttpVersion 1 1 → return [("*" , Nothing)]
354 _ → abort InternalServerError []
355 (Just "getAcceptEncoding: unknown HTTP version")
359 return [("identity", Nothing)]
361 case P.parseOnly p (A.toByteString ae) of
362 Right xs → return $ map toTuple $ reverse $ sort xs
363 Left _ → abort BadRequest []
364 (Just $ "Unparsable Accept-Encoding: " ⊕ A.toText ae)
366 p = do xs ← acceptEncodingListP
370 toTuple (AcceptEncoding {..})
371 = (aeEncoding, aeQValue)
373 -- |Check whether a given content-coding is acceptable.
374 isEncodingAcceptable ∷ CIAscii → Resource Bool
375 isEncodingAcceptable encoding = any f <$> getAcceptEncoding
378 = (e ≡ "*" ∨ e ≡ encoding) ∧ q ≢ Just 0
380 -- |Get the header \"Content-Type\" as 'MIMEType'.
381 getContentType ∷ Resource (Maybe MIMEType)
383 = do cTypeM ← getHeader "Content-Type"
388 → case P.parseOnly p (A.toByteString cType) of
389 Right t → return $ Just t
390 Left _ → abort BadRequest []
391 (Just $ "Unparsable Content-Type: " ⊕ A.toText cType)
397 -- |Get the header \"Authorization\" as 'AuthCredential'.
398 getAuthorization ∷ Resource (Maybe AuthCredential)
400 = do authM ← getHeader "Authorization"
405 → case P.parseOnly p (A.toByteString auth) of
406 Right ac → return $ Just ac
407 Left _ → return Nothing
409 p = do ac ← authCredentialP
416 -- |Tell the system that the 'Resource' found an entity for the
417 -- request URI. If this is a GET or HEAD request, a found entity means
418 -- a datum to be replied. If this is a PUT or DELETE request, it means
419 -- a datum which was stored for the URI until now. It is an error to
420 -- compute 'foundEntity' if this is a POST request.
422 -- Computation of 'foundEntity' performs \"If-Match\" test or
423 -- \"If-None-Match\" test if possible. When those tests fail, the
424 -- computation of 'Resource' immediately aborts with status \"412
425 -- Precondition Failed\" or \"304 Not Modified\" depending on the
428 -- If this is a GET or HEAD request, 'foundEntity' automatically puts
429 -- \"ETag\" and \"Last-Modified\" headers into the response.
430 foundEntity ∷ ETag → UTCTime → Resource ()
431 foundEntity tag timeStamp
432 = do driftTo ExaminingRequest
435 when (method ≡ GET ∨ method ≡ HEAD)
436 $ setHeader' "Last-Modified" (HTTP.toAscii timeStamp)
438 $ abort InternalServerError []
439 (Just "Illegal computation of foundEntity for a POST request.")
444 -- |Tell the system that the 'Resource' found an entity for the
445 -- request URI. The only difference from 'foundEntity' is that
446 -- 'foundETag' doesn't (and can't) put \"Last-Modified\" header into
449 -- This action is not preferred. You should use 'foundEntity' whenever
451 foundETag ∷ ETag → Resource ()
453 = do driftTo ExaminingRequest
456 when (method ≡ GET ∨ method ≡ HEAD)
461 $ abort InternalServerError []
462 (Just "Illegal computation of foundETag for POST request.")
464 -- If-Match があればそれを見る。
465 ifMatch ← getHeader "If-Match"
468 Just value → if value ≡ "*" then
471 case P.parseOnly p (A.toByteString value) of
473 -- tags の中に一致するものが無ければ
474 -- PreconditionFailed で終了。
475 → when ((¬) (any (≡ tag) tags))
476 $ abort PreconditionFailed []
477 (Just $ "The entity tag doesn't match: " ⊕ A.toText value)
479 → abort BadRequest [] (Just $ "Unparsable If-Match: " ⊕ A.toText value)
481 let statusForNoneMatch
482 = if method ≡ GET ∨ method ≡ HEAD then
487 -- If-None-Match があればそれを見る。
488 ifNoneMatch ← getHeader "If-None-Match"
491 Just value → if value ≡ "*" then
492 abort statusForNoneMatch [] (Just "The entity tag matches: *")
494 case P.parseOnly p (A.toByteString value) of
496 → when (any (≡ tag) tags)
497 $ abort statusForNoneMatch []
498 (Just $ "The entity tag matches: " ⊕ A.toText value)
500 → abort BadRequest []
501 (Just $ "Unparsable If-None-Match: " ⊕ A.toText value)
505 p = do xs ← eTagListP
509 -- |Tell the system that the 'Resource' found an entity for the
510 -- request URI. The only difference from 'foundEntity' is that
511 -- 'foundTimeStamp' performs \"If-Modified-Since\" test or
512 -- \"If-Unmodified-Since\" test instead of \"If-Match\" test or
513 -- \"If-None-Match\" test. Be aware that any tests based on last
514 -- modification time are unsafe because it is possible to mess up such
515 -- tests by modifying the entity twice in a second.
517 -- This action is not preferred. You should use 'foundEntity' whenever
519 foundTimeStamp ∷ UTCTime → Resource ()
520 foundTimeStamp timeStamp
521 = do driftTo ExaminingRequest
524 when (method ≡ GET ∨ method ≡ HEAD)
525 $ setHeader' "Last-Modified" (HTTP.toAscii timeStamp)
527 $ abort InternalServerError []
528 (Just "Illegal computation of foundTimeStamp for POST request.")
530 let statusForIfModSince
531 = if method ≡ GET ∨ method ≡ HEAD then
536 -- If-Modified-Since があればそれを見る。
537 ifModSince ← getHeader "If-Modified-Since"
539 Just str → case HTTP.fromAscii str of
541 → when (timeStamp ≤ lastTime)
542 $ abort statusForIfModSince []
543 (Just $ "The entity has not been modified since " ⊕ A.toText str)
545 → return () -- 不正な時刻は無視
548 -- If-Unmodified-Since があればそれを見る。
549 ifUnmodSince ← getHeader "If-Unmodified-Since"
551 Just str → case HTTP.fromAscii str of
553 → when (timeStamp > lastTime)
554 $ abort PreconditionFailed []
555 (Just $ "The entity has not been modified since " ⊕ A.toText str)
557 → return () -- 不正な時刻は無視
562 -- | Computation of @'foundNoEntity' mStr@ tells the system that the
563 -- 'Resource' found no entity for the request URI. @mStr@ is an
564 -- optional error message to be replied to the client.
566 -- If this is a PUT request, 'foundNoEntity' performs \"If-Match\"
567 -- test and aborts with status \"412 Precondition Failed\" when it
568 -- failed. If this is a GET, HEAD, POST or DELETE request,
569 -- 'foundNoEntity' always aborts with status \"404 Not Found\".
570 foundNoEntity ∷ Maybe Text → Resource ()
572 = do driftTo ExaminingRequest
576 $ abort NotFound [] msgM
578 -- エンティティが存在しないと云ふ事は、"*" も含めたどのやうな
579 -- If-Match: 條件も滿たさない。
580 ifMatch ← getHeader "If-Match"
581 when (ifMatch ≢ Nothing)
582 $ abort PreconditionFailed [] msgM
587 -- Getting a request body
589 -- | Computation of @'input' limit@ attempts to read the request body
590 -- up to @limit@ bytes, and then make the 'Resource' transit to
591 -- /Deciding Header/ state. When the actual size of body is larger
592 -- than @limit@ bytes, computation of 'Resource' immediately aborts
593 -- with status \"413 Request Entity Too Large\". When the request has
594 -- no body, 'input' returns an empty string.
596 -- @limit@ may be less than or equal to zero. In this case, the
597 -- default limitation value ('cnfMaxEntityLength') is used. See
600 -- 'input' returns a 'Lazy.ByteString' but it's not really lazy:
601 -- reading from the socket just happens at the computation of 'input',
602 -- not at the evaluation of the 'Lazy.ByteString'. The same goes for
604 input ∷ Int → Resource Lazy.ByteString
606 = do driftTo GettingBody
608 chunk ← if reqMustHaveBody $ fromJust $ itrRequest itr then
611 do driftTo DecidingHeader
615 askForInput ∷ Interaction → Resource Lazy.ByteString
616 askForInput (Interaction {..})
617 = do let confLimit = cnfMaxEntityLength itrConfig
618 actualLimit = if limit ≤ 0 then
622 when (actualLimit ≤ 0)
623 $ fail ("inputLBS: limit must be positive: " ⧺ show actualLimit)
626 $ writeTVar itrReqBodyWanted actualLimit
627 -- 應答を待つ。トランザクションを分けなければ當然デッドロックする。
628 chunk ← liftIO $ atomically
629 $ do chunkLen ← readTVar itrReceivedBodyLen
630 chunkIsOver ← readTVar itrReqChunkIsOver
631 if chunkLen < actualLimit then
632 -- 要求された量に滿たなくて、まだ殘りが
637 -- 制限値一杯まで讀むやうに指示したのに
638 -- まだ殘ってゐるなら、それは多過ぎる。
640 $ tooLarge actualLimit
641 -- 成功。itr 内にチャンクを置いたままにする
643 chunk ← seqToLBS <$> readTVar itrReceivedBody
644 writeTVar itrReceivedBody (∅)
645 writeTVar itrReceivedBodyLen 0
648 driftTo DecidingHeader
651 tooLarge ∷ Int → STM ()
652 tooLarge lim = abortSTM RequestEntityTooLarge []
653 (Just $ "Request body must be smaller than "
654 ⊕ T.pack (show lim) ⊕ " bytes.")
656 seqToLBS ∷ Seq ByteString → Lazy.ByteString
657 {-# INLINE seqToLBS #-}
658 seqToLBS = Lazy.fromChunks ∘ toList
660 -- | Computation of @'inputChunk' limit@ attempts to read a part of
661 -- request body up to @limit@ bytes. You can read any large request by
662 -- repeating computation of this action. When you've read all the
663 -- request body, 'inputChunk' returns an empty string and then make
664 -- the 'Resource' transit to /Deciding Header/ state.
666 -- @limit@ may be less than or equal to zero. In this case, the
667 -- default limitation value ('cnfMaxEntityLength') is used. See
670 -- Note that 'inputChunkLBS' is more efficient than 'inputChunk' so you
671 -- should use it whenever possible.
672 inputChunk ∷ Int → Resource Lazy.ByteString
674 = do driftTo GettingBody
676 chunk ← if reqMustHaveBody $ fromJust $ itrRequest itr then
679 do driftTo DecidingHeader
683 askForInput ∷ Interaction → Resource Lazy.ByteString
684 askForInput (Interaction {..})
685 = do let confLimit = cnfMaxEntityLength itrConfig
686 actualLimit = if limit < 0 then
690 when (actualLimit ≤ 0)
691 $ fail ("inputChunkLBS: limit must be positive: " ++ show actualLimit)
694 $ writeTVar itrReqBodyWanted actualLimit
695 -- 應答を待つ。トランザクションを分けなければ當然デッドロック。
696 chunk ← liftIO $ atomically
697 $ do chunkLen ← readTVar itrReceivedBodyLen
698 -- 要求された量に滿たなくて、まだ殘りがある
700 when (chunkLen < actualLimit)
701 $ do chunkIsOver ← readTVar itrReqChunkIsOver
705 chunk ← seqToLBS <$> readTVar itrReceivedBody
706 writeTVar itrReceivedBody (∅)
707 writeTVar itrReceivedBodyLen 0
709 when (Lazy.null chunk)
710 $ driftTo DecidingHeader
713 -- | Computation of @'inputForm' limit@ attempts to read the request
714 -- body with 'input' and parse it as
715 -- @application\/x-www-form-urlencoded@ or @multipart\/form-data@. If
716 -- the request header \"Content-Type\" is neither of them, 'inputForm'
717 -- makes 'Resource' abort with status \"415 Unsupported Media
718 -- Type\". If the request has no \"Content-Type\", it aborts with
719 -- \"400 Bad Request\".
721 -- Field names in @multipart\/form-data@ will be precisely decoded in
722 -- accordance with RFC 2231. On the other hand,
723 -- @application\/x-www-form-urlencoded@ says nothing about the
724 -- encoding of field names, so they'll always be decoded in UTF-8.
725 inputForm ∷ Int → Resource [(Text, FormData)]
727 = do cTypeM ← getContentType
730 → abort BadRequest [] (Just "Missing Content-Type")
731 Just (MIMEType "application" "x-www-form-urlencoded" _)
732 → readWWWFormURLEncoded
733 Just (MIMEType "multipart" "form-data" params)
734 → readMultipartFormData params
736 → abort UnsupportedMediaType []
740 $ A.toAsciiBuilder "Unsupported media type: "
741 ⊕ printMIMEType cType
743 readWWWFormURLEncoded
744 = (map toPairWithFormData ∘ parseWWWFormURLEncoded)
746 (bsToAscii =≪ input limit)
749 = case A.fromByteString (Strict.concat (Lazy.toChunks bs)) of
751 Nothing → abort BadRequest [] (Just "Malformed x-www-form-urlencoded")
753 readMultipartFormData params
754 = do case M.lookup "boundary" params of
756 → abort BadRequest [] (Just "Missing boundary of multipart/form-data")
758 → do src ← input limit
759 b ← case A.fromText boundary of
761 Nothing → abort BadRequest []
762 (Just $ "Malformed boundary: " ⊕ boundary)
763 case LP.parse (p b) src of
766 _ → abort BadRequest [] (Just "Unparsable multipart/form-data")
768 p b = do xs ← multipartFormP b
772 -- | This is just a constant @-1@. It's better to say @'input'
773 -- 'defaultLimit'@ than to say @'input' (-1)@ but these are exactly
779 -- Setting response headers
781 -- | Set the response status code. If you omit to compute this action,
782 -- the status code will be defaulted to \"200 OK\".
783 setStatus ∷ StatusCode → Resource ()
785 = do driftTo DecidingHeader
789 $ setResponseStatus itr sc
791 -- | Set a value of given resource header. Comparison of header name
792 -- is case-insensitive. Note that this action is not intended to be
793 -- used so frequently: there should be actions like 'setContentType'
794 -- for every common headers.
796 -- Some important headers (especially \"Content-Length\" and
797 -- \"Transfer-Encoding\") may be silently dropped or overwritten by
798 -- the system not to corrupt the interaction with client at the
799 -- viewpoint of HTTP protocol layer. For instance, if we are keeping
800 -- the connection alive, without this process it causes a catastrophe
801 -- to send a header \"Content-Length: 10\" and actually send a body of
802 -- 20 bytes long. In this case the client shall only accept the first
803 -- 10 bytes of response body and thinks that the residual 10 bytes is
804 -- a part of header of the next response.
805 setHeader ∷ CIAscii → Ascii → Resource ()
807 = driftTo DecidingHeader ≫ setHeader' name value
809 setHeader' ∷ CIAscii → Ascii → Resource ()
810 setHeader' name value
811 = do itr ← getInteraction
813 $ do res ← readTVar $ itrResponse itr
814 let res' = H.setHeader name value res
815 writeTVar (itrResponse itr) res'
816 when (name ≡ "Content-Type")
817 $ writeTVar (itrResponseHasCType itr) True
819 -- | Computation of @'redirect' code uri@ sets the response status to
820 -- @code@ and \"Location\" header to @uri@. The @code@ must satisfy
821 -- 'isRedirection' or it causes an error.
822 redirect ∷ StatusCode → URI → Resource ()
824 = do when (code ≡ NotModified ∨ not (isRedirection code))
825 $ abort InternalServerError []
829 $ A.toAsciiBuilder "Attempted to redirect with status "
830 ⊕ printStatusCode code
834 -- | Computation of @'setContentType' mType@ sets the response header
835 -- \"Content-Type\" to @mType@.
836 setContentType ∷ MIMEType → Resource ()
837 {-# INLINE setContentType #-}
838 setContentType = setHeader "Content-Type" ∘ A.fromAsciiBuilder ∘ printMIMEType
840 -- | Computation of @'setLocation' uri@ sets the response header
841 -- \"Location\" to @uri@.
842 setLocation ∷ URI → Resource ()
844 = case A.fromChars uriStr of
845 Just a → setHeader "Location" a
846 Nothing → abort InternalServerError []
847 (Just $ "Malformed URI: " ⊕ T.pack uriStr)
849 uriStr = uriToString id uri ""
851 -- |Computation of @'setContentEncoding' codings@ sets the response
852 -- header \"Content-Encoding\" to @codings@.
853 setContentEncoding ∷ [CIAscii] → Resource ()
854 setContentEncoding codings
855 = do ver ← getRequestVersion
857 HttpVersion 1 0 → return (toAB ∘ unnormalizeCoding)
858 HttpVersion 1 1 → return toAB
859 _ → abort InternalServerError []
860 (Just "setContentEncoding: Unknown HTTP version")
861 setHeader "Content-Encoding"
862 (A.fromAsciiBuilder $ joinWith ", " $ map tr codings)
864 toAB = A.toAsciiBuilder ∘ A.fromCIAscii
866 -- |Computation of @'setWWWAuthenticate' challenge@ sets the response
867 -- header \"WWW-Authenticate\" to @challenge@.
868 setWWWAuthenticate ∷ AuthChallenge → Resource ()
869 setWWWAuthenticate challenge
870 = setHeader "WWW-Authenticate" (printAuthChallenge challenge)
873 -- Writing a response body
875 -- | Write a chunk in 'Lazy.ByteString' to the response body. It is
876 -- safe to apply this function to an infinitely long
877 -- 'Lazy.ByteString'.
879 -- Note that you must first set the response header \"Content-Type\"
880 -- before applying this function. See: 'setContentType'
881 putChunk ∷ Lazy.ByteString → Resource ()
882 {-# INLINE putChunk #-}
883 putChunk = putBuilder ∘ BB.fromLazyByteString
885 -- | Run a 'Builder' to construct a chunk, and write it to the
886 -- response body. It is safe to apply this function to a 'Builder'
887 -- producing an infinitely long stream of octets.
889 -- Note that you must first set the response header \"Content-Type\"
890 -- before applying this function. See: 'setContentType'
891 putBuilder ∷ Builder → Resource ()
893 = do itr ← getInteraction
895 $ do driftTo' itr DecidingBody
896 hasCType ← readTVar $ itrResponseHasCType itr
898 $ abortSTM InternalServerError []
899 $ Just "putBuilder: Content-Type has not been set."
900 putTMVar (itrBodyToSend itr) b
905 driftTo ∷ InteractionState → Resource ()
907 = do itr ← getInteraction
908 liftIO $ atomically $ driftTo' itr newState
910 driftTo' ∷ Interaction → InteractionState → STM ()
911 driftTo' itr@(Interaction {..}) newState
912 = do oldState ← readTVar itrState
913 if newState < oldState then
914 throwStateError oldState newState
916 do let a = [oldState .. newState]
919 mapM_ (uncurry drift) c
920 writeTVar itrState newState
922 throwStateError ∷ Monad m ⇒ InteractionState → InteractionState → m a
923 throwStateError Done DecidingBody
924 = fail "It makes no sense to output something after finishing outputs."
925 throwStateError old new
926 = fail ("state error: " ⧺ show old ⧺ " ==> " ⧺ show new)
928 drift ∷ InteractionState → InteractionState → STM ()
930 = writeTVar itrReqBodyWasteAll True
931 drift DecidingHeader _