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 qualified Blaze.ByteString.Builder.ByteString as BB
141 import Control.Applicative
142 import Control.Concurrent.STM
143 import Control.Monad.Reader
144 import Control.Monad.Unicode
145 import Data.Ascii (Ascii, CIAscii)
146 import qualified Data.Ascii as A
147 import qualified Data.Attoparsec.Char8 as P
148 import qualified Data.Attoparsec.Lazy as LP
149 import Data.ByteString (ByteString)
150 import qualified Data.ByteString as Strict
151 import qualified Data.ByteString.Lazy as Lazy
152 import Data.Foldable (toList)
154 import qualified Data.Map as M
156 import Data.Monoid.Unicode
157 import Data.Sequence (Seq)
158 import Data.Text (Text)
159 import qualified Data.Text as T
160 import qualified Data.Text.Encoding as T
162 import qualified Data.Time.HTTP as HTTP
163 import Network.HTTP.Lucu.Abortion
164 import Network.HTTP.Lucu.Authorization
165 import Network.HTTP.Lucu.Config
166 import Network.HTTP.Lucu.ContentCoding
167 import Network.HTTP.Lucu.ETag
168 import qualified Network.HTTP.Lucu.Headers as H
169 import Network.HTTP.Lucu.HttpVersion
170 import Network.HTTP.Lucu.Interaction
171 import Network.HTTP.Lucu.MultipartForm
172 import Network.HTTP.Lucu.Postprocess
173 import Network.HTTP.Lucu.Request
174 import Network.HTTP.Lucu.Response
175 import Network.HTTP.Lucu.MIMEType
176 import Network.HTTP.Lucu.Utils
177 import Network.Socket hiding (accept)
178 import Network.URI hiding (path)
180 import Prelude.Unicode
182 -- |The 'Resource' monad. This monad implements 'MonadIO' so it can do
186 unRes ∷ ReaderT Interaction IO a
188 deriving (Applicative, Functor, Monad, MonadIO)
190 runRes ∷ Resource a → Interaction → IO a
192 = runReaderT (unRes r) itr
194 getInteraction ∷ Resource Interaction
195 getInteraction = Resource ask
197 -- |Get the 'Config' value which is used for the httpd.
198 getConfig ∷ Resource Config
199 getConfig = itrConfig <$> getInteraction
201 -- |Get the 'SockAddr' of the remote host. If you want a string
202 -- representation instead of 'SockAddr', use 'getRemoteAddr''.
203 getRemoteAddr ∷ Resource SockAddr
204 getRemoteAddr = itrRemoteAddr <$> getInteraction
206 -- |Get the string representation of the address of remote host. If
207 -- you want a 'SockAddr' instead of 'String', use 'getRemoteAddr'.
208 getRemoteAddr' ∷ Resource HostName
210 = do sa ← getRemoteAddr
211 (Just a, _) ← liftIO $ getNameInfo [NI_NUMERICHOST] True False sa
214 -- |Resolve an address to the remote host.
215 getRemoteHost ∷ Resource (Maybe HostName)
217 = do sa ← getRemoteAddr
218 fst <$> (liftIO $ getNameInfo [] True False sa)
220 -- | Return the X.509 certificate of the client, or 'Nothing' if:
222 -- * This request didn't came through an SSL stream.
224 -- * The client didn't send us its certificate.
226 -- * The 'OpenSSL.Session.VerificationMode' of
227 -- 'OpenSSL.Session.SSLContext' in 'SSLConfig' has not been set to
228 -- 'OpenSSL.Session.VerifyPeer'.
229 getRemoteCertificate ∷ Resource (Maybe X509)
230 getRemoteCertificate = itrRemoteCert <$> getInteraction
232 -- |Get the 'Request' value which represents the request header. In
233 -- general you don't have to use this action.
234 getRequest ∷ Resource Request
235 getRequest = (fromJust ∘ itrRequest) <$> getInteraction
237 -- |Get the 'Method' value of the request.
238 getMethod ∷ Resource Method
239 getMethod = reqMethod <$> getRequest
241 -- |Get the URI of the request.
242 getRequestURI ∷ Resource URI
243 getRequestURI = reqURI <$> getRequest
245 -- |Get the HTTP version of the request.
246 getRequestVersion ∷ Resource HttpVersion
247 getRequestVersion = reqVersion <$> getRequest
249 -- |Get the path of this 'Resource' (to be exact,
250 -- 'Network.HTTP.Lucu.Resource.Tree.ResourceDef') in the
251 -- 'Network.HTTP.Lucu.Resource.Tree.ResTree'. The result of this
252 -- action is the exact path in the tree even when the
253 -- 'Network.HTTP.Lucu.Resource.Tree.ResourceDef' is greedy.
257 -- > main = let tree = mkResTree [ (["foo"], resFoo) ]
258 -- > in runHttpd defaultConfig tree
260 -- > resFoo = ResourceDef {
261 -- > resIsGreedy = True
262 -- > , resGet = Just $ do requestURI <- getRequestURI
263 -- > resourcePath <- getResourcePath
264 -- > pathInfo <- getPathInfo
265 -- > -- uriPath requestURI == "/foo/bar/baz"
266 -- > -- resourcePath == ["foo"]
267 -- > -- pathInfo == ["bar", "baz"]
271 getResourcePath ∷ Resource [Text]
272 getResourcePath = (fromJust ∘ itrResourcePath) <$> getInteraction
274 -- |This is an analogy of CGI PATH_INFO. The result is
275 -- URI-unescaped. It is always @[]@ if the
276 -- 'Network.HTTP.Lucu.Resource.Tree.ResourceDef' is not greedy. See
277 -- 'getResourcePath'.
279 -- Note that the returned path is URI-decoded and then UTF-8 decoded.
280 getPathInfo ∷ Resource [Text]
281 getPathInfo = do rsrcPath ← getResourcePath
282 reqPath ← splitPathInfo <$> getRequestURI
283 -- rsrcPath と reqPath の共通する先頭部分を reqPath か
284 -- ら全部取り除くと、それは PATH_INFO のやうなものにな
285 -- る。rsrcPath は全部一致してゐるに決まってゐる(でな
286 -- ければこの Resource が撰ばれた筈が無い)ので、
287 -- rsrcPath の長さの分だけ削除すれば良い。
288 return $ drop (length rsrcPath) reqPath
290 -- |Assume the query part of request URI as
291 -- application\/x-www-form-urlencoded, and parse it to pairs of
292 -- @(name, formData)@. This action doesn't parse the request body. See
293 -- 'inputForm'. Field names are decoded in UTF-8.
294 getQueryForm ∷ Resource [(Text, FormData)]
295 getQueryForm = parse' <$> getRequestURI
297 parse' = map toPairWithFormData ∘
298 parseWWWFormURLEncoded ∘
304 toPairWithFormData ∷ (ByteString, ByteString) → (Text, FormData)
305 toPairWithFormData (name, value)
306 = let fd = FormData {
308 , fdContent = Lazy.fromChunks [value]
310 in (T.decodeUtf8 name, fd)
312 -- |Get a value of given request header. Comparison of header name is
313 -- case-insensitive. Note that this action is not intended to be used
314 -- so frequently: there should be actions like 'getContentType' for
315 -- every common headers.
316 getHeader ∷ CIAscii → Resource (Maybe Ascii)
318 = H.getHeader name <$> getRequest
320 -- |Get a list of 'MIMEType' enumerated on header \"Accept\".
321 getAccept ∷ Resource [MIMEType]
323 = do acceptM ← getHeader "Accept"
328 → case P.parseOnly p (A.toByteString accept) of
330 Left _ → abort BadRequest []
331 (Just $ "Unparsable Accept: " ⊕ A.toText accept)
333 p = do xs ← mimeTypeListP
337 -- |Get a list of @(contentCoding, qvalue)@ enumerated on header
338 -- \"Accept-Encoding\". The list is sorted in descending order by
340 getAcceptEncoding ∷ Resource [(CIAscii, Maybe Double)]
342 = do accEncM ← getHeader "Accept-Encoding"
345 -- HTTP/1.0 には Accept-Encoding が無い場合の規定が無い
346 -- ので安全の爲 identity が指定された事にする。HTTP/1.1
347 -- の場合は何でも受け入れて良い事になってゐるので "*" が
349 → do ver ← getRequestVersion
351 HttpVersion 1 0 → return [("identity", Nothing)]
352 HttpVersion 1 1 → return [("*" , Nothing)]
353 _ → abort InternalServerError []
354 (Just "getAcceptEncoding: unknown HTTP version")
358 return [("identity", Nothing)]
360 case P.parseOnly p (A.toByteString ae) of
361 Right xs → return $ map toTuple $ reverse $ sort xs
362 Left _ → abort BadRequest []
363 (Just $ "Unparsable Accept-Encoding: " ⊕ A.toText ae)
365 p = do xs ← acceptEncodingListP
369 toTuple (AcceptEncoding {..})
370 = (aeEncoding, aeQValue)
372 -- |Check whether a given content-coding is acceptable.
373 isEncodingAcceptable ∷ CIAscii → Resource Bool
374 isEncodingAcceptable encoding = any f <$> getAcceptEncoding
377 = (e ≡ "*" ∨ e ≡ encoding) ∧ q ≢ Just 0
379 -- |Get the header \"Content-Type\" as 'MIMEType'.
380 getContentType ∷ Resource (Maybe MIMEType)
382 = do cTypeM ← getHeader "Content-Type"
387 → case P.parseOnly p (A.toByteString cType) of
388 Right t → return $ Just t
389 Left _ → abort BadRequest []
390 (Just $ "Unparsable Content-Type: " ⊕ A.toText cType)
396 -- |Get the header \"Authorization\" as 'AuthCredential'.
397 getAuthorization ∷ Resource (Maybe AuthCredential)
399 = do authM ← getHeader "Authorization"
404 → case P.parseOnly p (A.toByteString auth) of
405 Right ac → return $ Just ac
406 Left _ → return Nothing
408 p = do ac ← authCredentialP
413 {- ExaminingRequest 時に使用するアクション群 -}
415 -- |Tell the system that the 'Resource' found an entity for the
416 -- request URI. If this is a GET or HEAD request, a found entity means
417 -- a datum to be replied. If this is a PUT or DELETE request, it means
418 -- a datum which was stored for the URI until now. It is an error to
419 -- compute 'foundEntity' if this is a POST request.
421 -- Computation of 'foundEntity' performs \"If-Match\" test or
422 -- \"If-None-Match\" test if possible. When those tests fail, the
423 -- computation of 'Resource' immediately aborts with status \"412
424 -- Precondition Failed\" or \"304 Not Modified\" depending on the
427 -- If this is a GET or HEAD request, 'foundEntity' automatically puts
428 -- \"ETag\" and \"Last-Modified\" headers into the response.
429 foundEntity ∷ ETag → UTCTime → Resource ()
430 foundEntity tag timeStamp
431 = do driftTo ExaminingRequest
434 when (method ≡ GET ∨ method ≡ HEAD)
435 $ setHeader' "Last-Modified" (HTTP.toAscii timeStamp)
437 $ abort InternalServerError []
438 (Just "Illegal computation of foundEntity for a POST request.")
443 -- |Tell the system that the 'Resource' found an entity for the
444 -- request URI. The only difference from 'foundEntity' is that
445 -- 'foundETag' doesn't (and can't) put \"Last-Modified\" header into
448 -- This action is not preferred. You should use 'foundEntity' whenever
450 foundETag ∷ ETag → Resource ()
452 = do driftTo ExaminingRequest
455 when (method ≡ GET ∨ method ≡ HEAD)
460 $ abort InternalServerError []
461 (Just "Illegal computation of foundETag for POST request.")
463 -- If-Match があればそれを見る。
464 ifMatch ← getHeader "If-Match"
467 Just value → if value ≡ "*" then
470 case P.parseOnly p (A.toByteString value) of
472 -- tags の中に一致するものが無ければ
473 -- PreconditionFailed で終了。
474 → when ((¬) (any (≡ tag) tags))
475 $ abort PreconditionFailed []
476 (Just $ "The entity tag doesn't match: " ⊕ A.toText value)
478 → abort BadRequest [] (Just $ "Unparsable If-Match: " ⊕ A.toText value)
480 let statusForNoneMatch
481 = if method ≡ GET ∨ method ≡ HEAD then
486 -- If-None-Match があればそれを見る。
487 ifNoneMatch ← getHeader "If-None-Match"
490 Just value → if value ≡ "*" then
491 abort statusForNoneMatch [] (Just "The entity tag matches: *")
493 case P.parseOnly p (A.toByteString value) of
495 → when (any (≡ tag) tags)
496 $ abort statusForNoneMatch []
497 (Just $ "The entity tag matches: " ⊕ A.toText value)
499 → abort BadRequest []
500 (Just $ "Unparsable If-None-Match: " ⊕ A.toText value)
504 p = do xs ← eTagListP
508 -- |Tell the system that the 'Resource' found an entity for the
509 -- request URI. The only difference from 'foundEntity' is that
510 -- 'foundTimeStamp' performs \"If-Modified-Since\" test or
511 -- \"If-Unmodified-Since\" test instead of \"If-Match\" test or
512 -- \"If-None-Match\" test. Be aware that any tests based on last
513 -- modification time are unsafe because it is possible to mess up such
514 -- tests by modifying the entity twice in a second.
516 -- This action is not preferred. You should use 'foundEntity' whenever
518 foundTimeStamp ∷ UTCTime → Resource ()
519 foundTimeStamp timeStamp
520 = do driftTo ExaminingRequest
523 when (method ≡ GET ∨ method ≡ HEAD)
524 $ setHeader' "Last-Modified" (HTTP.toAscii timeStamp)
526 $ abort InternalServerError []
527 (Just "Illegal computation of foundTimeStamp for POST request.")
529 let statusForIfModSince
530 = if method ≡ GET ∨ method ≡ HEAD then
535 -- If-Modified-Since があればそれを見る。
536 ifModSince ← getHeader "If-Modified-Since"
538 Just str → case HTTP.fromAscii str of
540 → when (timeStamp ≤ lastTime)
541 $ abort statusForIfModSince []
542 (Just $ "The entity has not been modified since " ⊕ A.toText str)
544 → return () -- 不正な時刻は無視
547 -- If-Unmodified-Since があればそれを見る。
548 ifUnmodSince ← getHeader "If-Unmodified-Since"
550 Just str → case HTTP.fromAscii str of
552 → when (timeStamp > lastTime)
553 $ abort PreconditionFailed []
554 (Just $ "The entity has not been modified since " ⊕ A.toText str)
556 → return () -- 不正な時刻は無視
561 -- | Computation of @'foundNoEntity' mStr@ tells the system that the
562 -- 'Resource' found no entity for the request URI. @mStr@ is an
563 -- optional error message to be replied to the client.
565 -- If this is a PUT request, 'foundNoEntity' performs \"If-Match\"
566 -- test and aborts with status \"412 Precondition Failed\" when it
567 -- failed. If this is a GET, HEAD, POST or DELETE request,
568 -- 'foundNoEntity' always aborts with status \"404 Not Found\".
569 foundNoEntity ∷ Maybe Text → Resource ()
571 = do driftTo ExaminingRequest
575 $ abort NotFound [] msgM
577 -- エンティティが存在しないと云ふ事は、"*" も含めたどのやうな
578 -- If-Match: 條件も滿たさない。
579 ifMatch ← getHeader "If-Match"
580 when (ifMatch ≢ Nothing)
581 $ abort PreconditionFailed [] msgM
586 {- GettingBody 時に使用するアクション群 -}
588 -- | Computation of @'input' limit@ attempts to read the request body
589 -- up to @limit@ bytes, and then make the 'Resource' transit to
590 -- /Deciding Header/ state. When the actual size of body is larger
591 -- than @limit@ bytes, computation of 'Resource' immediately aborts
592 -- with status \"413 Request Entity Too Large\". When the request has
593 -- no body, 'input' returns an empty string.
595 -- @limit@ may be less than or equal to zero. In this case, the
596 -- default limitation value ('cnfMaxEntityLength') is used. See
599 -- 'input' returns a 'Lazy.ByteString' but it's not really lazy:
600 -- reading from the socket just happens at the computation of 'input',
601 -- not at the evaluation of the 'Lazy.ByteString'. The same goes for
603 input ∷ Int → Resource Lazy.ByteString
605 = do driftTo GettingBody
607 chunk ← if reqMustHaveBody $ fromJust $ itrRequest itr then
610 do driftTo DecidingHeader
614 askForInput ∷ Interaction → Resource Lazy.ByteString
615 askForInput (Interaction {..})
616 = do let confLimit = cnfMaxEntityLength itrConfig
617 actualLimit = if limit ≤ 0 then
621 when (actualLimit ≤ 0)
622 $ fail ("inputLBS: limit must be positive: " ⧺ show actualLimit)
625 $ writeTVar itrReqBodyWanted actualLimit
626 -- 應答を待つ。トランザクションを分けなければ當然デッドロックする。
627 chunk ← liftIO $ atomically
628 $ do chunkLen ← readTVar itrReceivedBodyLen
629 chunkIsOver ← readTVar itrReqChunkIsOver
630 if chunkLen < actualLimit then
631 -- 要求された量に滿たなくて、まだ殘りが
636 -- 制限値一杯まで讀むやうに指示したのに
637 -- まだ殘ってゐるなら、それは多過ぎる。
639 $ tooLarge actualLimit
640 -- 成功。itr 内にチャンクを置いたままにする
642 chunk ← seqToLBS <$> readTVar itrReceivedBody
643 writeTVar itrReceivedBody (∅)
644 writeTVar itrReceivedBodyLen 0
647 driftTo DecidingHeader
650 tooLarge ∷ Int → STM ()
651 tooLarge lim = abortSTM RequestEntityTooLarge []
652 (Just $ "Request body must be smaller than "
653 ⊕ T.pack (show lim) ⊕ " bytes.")
655 seqToLBS ∷ Seq ByteString → Lazy.ByteString
656 {-# INLINE seqToLBS #-}
657 seqToLBS = Lazy.fromChunks ∘ toList
659 -- | Computation of @'inputChunk' limit@ attempts to read a part of
660 -- request body up to @limit@ bytes. You can read any large request by
661 -- repeating computation of this action. When you've read all the
662 -- request body, 'inputChunk' returns an empty string and then make
663 -- the 'Resource' transit to /Deciding Header/ state.
665 -- @limit@ may be less than or equal to zero. In this case, the
666 -- default limitation value ('cnfMaxEntityLength') is used. See
669 -- Note that 'inputChunkLBS' is more efficient than 'inputChunk' so you
670 -- should use it whenever possible.
671 inputChunk ∷ Int → Resource Lazy.ByteString
673 = do driftTo GettingBody
675 chunk ← if reqMustHaveBody $ fromJust $ itrRequest itr then
678 do driftTo DecidingHeader
682 askForInput ∷ Interaction → Resource Lazy.ByteString
683 askForInput (Interaction {..})
684 = do let confLimit = cnfMaxEntityLength itrConfig
685 actualLimit = if limit < 0 then
689 when (actualLimit ≤ 0)
690 $ fail ("inputChunkLBS: limit must be positive: " ++ show actualLimit)
693 $ writeTVar itrReqBodyWanted actualLimit
694 -- 應答を待つ。トランザクションを分けなければ當然デッドロック。
695 chunk ← liftIO $ atomically
696 $ do chunkLen ← readTVar itrReceivedBodyLen
697 -- 要求された量に滿たなくて、まだ殘りがある
699 when (chunkLen < actualLimit)
700 $ do chunkIsOver ← readTVar itrReqChunkIsOver
704 chunk ← seqToLBS <$> readTVar itrReceivedBody
705 writeTVar itrReceivedBody (∅)
706 writeTVar itrReceivedBodyLen 0
708 when (Lazy.null chunk)
709 $ driftTo DecidingHeader
712 -- | Computation of @'inputForm' limit@ attempts to read the request
713 -- body with 'input' and parse it as
714 -- @application\/x-www-form-urlencoded@ or @multipart\/form-data@. If
715 -- the request header \"Content-Type\" is neither of them, 'inputForm'
716 -- makes 'Resource' abort with status \"415 Unsupported Media
717 -- Type\". If the request has no \"Content-Type\", it aborts with
718 -- \"400 Bad Request\".
720 -- Field names in @multipart\/form-data@ will be precisely decoded in
721 -- accordance with RFC 2231. On the other hand,
722 -- @application\/x-www-form-urlencoded@ says nothing about the
723 -- encoding of field names, so they'll always be decoded in UTF-8.
724 inputForm ∷ Int → Resource [(Text, FormData)]
726 = do cTypeM ← getContentType
729 → abort BadRequest [] (Just "Missing Content-Type")
730 Just (MIMEType "application" "x-www-form-urlencoded" _)
731 → readWWWFormURLEncoded
732 Just (MIMEType "multipart" "form-data" params)
733 → readMultipartFormData params
735 → abort UnsupportedMediaType []
739 $ A.toAsciiBuilder "Unsupported media type: "
740 ⊕ printMIMEType cType
742 readWWWFormURLEncoded
743 = (map toPairWithFormData ∘ parseWWWFormURLEncoded)
745 (bsToAscii =≪ input limit)
748 = case A.fromByteString (Strict.concat (Lazy.toChunks bs)) of
750 Nothing → abort BadRequest [] (Just "Malformed x-www-form-urlencoded")
752 readMultipartFormData params
753 = do case M.lookup "boundary" params of
755 → abort BadRequest [] (Just "Missing boundary of multipart/form-data")
757 → do src ← input limit
758 b ← case A.fromText boundary of
760 Nothing → abort BadRequest []
761 (Just $ "Malformed boundary: " ⊕ boundary)
762 case LP.parse (p b) src of
765 _ → abort BadRequest [] (Just "Unparsable multipart/form-data")
767 p b = do xs ← multipartFormP b
771 -- | This is just a constant @-1@. It's better to say @'input'
772 -- 'defaultLimit'@ than to say @'input' (-1)@ but these are exactly
778 {- DecidingHeader 時に使用するアクション群 -}
780 -- | Set the response status code. If you omit to compute this action,
781 -- the status code will be defaulted to \"200 OK\".
782 setStatus ∷ StatusCode → Resource ()
784 = do driftTo DecidingHeader
788 $ setResponseStatus itr sc
790 -- | Set a value of given resource header. Comparison of header name
791 -- is case-insensitive. Note that this action is not intended to be
792 -- used so frequently: there should be actions like 'setContentType'
793 -- for every common headers.
795 -- Some important headers (especially \"Content-Length\" and
796 -- \"Transfer-Encoding\") may be silently dropped or overwritten by
797 -- the system not to corrupt the interaction with client at the
798 -- viewpoint of HTTP protocol layer. For instance, if we are keeping
799 -- the connection alive, without this process it causes a catastrophe
800 -- to send a header \"Content-Length: 10\" and actually send a body of
801 -- 20 bytes long. In this case the client shall only accept the first
802 -- 10 bytes of response body and thinks that the residual 10 bytes is
803 -- a part of header of the next response.
804 setHeader ∷ CIAscii → Ascii → Resource ()
806 = driftTo DecidingHeader ≫ setHeader' name value
808 setHeader' ∷ CIAscii → Ascii → Resource ()
809 setHeader' name value
810 = do itr ← getInteraction
812 $ do res ← readTVar $ itrResponse itr
813 let res' = H.setHeader name value res
814 writeTVar (itrResponse itr) res'
815 when (name ≡ "Content-Type")
816 $ writeTVar (itrResponseHasCType itr) True
818 -- | Computation of @'redirect' code uri@ sets the response status to
819 -- @code@ and \"Location\" header to @uri@. The @code@ must satisfy
820 -- 'isRedirection' or it causes an error.
821 redirect ∷ StatusCode → URI → Resource ()
823 = do when (code ≡ NotModified ∨ not (isRedirection code))
824 $ abort InternalServerError []
828 $ A.toAsciiBuilder "Attempted to redirect with status "
829 ⊕ printStatusCode code
833 -- | Computation of @'setContentType' mType@ sets the response header
834 -- \"Content-Type\" to @mType@.
835 setContentType ∷ MIMEType → Resource ()
836 {-# INLINE setContentType #-}
837 setContentType = setHeader "Content-Type" ∘ A.fromAsciiBuilder ∘ printMIMEType
839 -- | Computation of @'setLocation' uri@ sets the response header
840 -- \"Location\" to @uri@.
841 setLocation ∷ URI → Resource ()
843 = case A.fromChars uriStr of
844 Just a → setHeader "Location" a
845 Nothing → abort InternalServerError []
846 (Just $ "Malformed URI: " ⊕ T.pack uriStr)
848 uriStr = uriToString id uri ""
850 -- |Computation of @'setContentEncoding' codings@ sets the response
851 -- header \"Content-Encoding\" to @codings@.
852 setContentEncoding ∷ [CIAscii] → Resource ()
853 setContentEncoding codings
854 = do ver ← getRequestVersion
856 HttpVersion 1 0 → return (toAB ∘ unnormalizeCoding)
857 HttpVersion 1 1 → return toAB
858 _ → abort InternalServerError []
859 (Just "setContentEncoding: Unknown HTTP version")
860 setHeader "Content-Encoding"
861 (A.fromAsciiBuilder $ joinWith ", " $ map tr codings)
863 toAB = A.toAsciiBuilder ∘ A.fromCIAscii
865 -- |Computation of @'setWWWAuthenticate' challenge@ sets the response
866 -- header \"WWW-Authenticate\" to @challenge@.
867 setWWWAuthenticate ∷ AuthChallenge → Resource ()
868 setWWWAuthenticate challenge
869 = setHeader "WWW-Authenticate" (printAuthChallenge challenge)
872 {- DecidingBody 時に使用するアクション群 -}
874 -- | Write a 'Lazy.ByteString' to the response body, and then transit
875 -- to the /Done/ state. It is safe to apply 'output' to an infinite
876 -- string, such as the lazy stream of \/dev\/random.
878 -- Note that you must first set the \"Content-Type\" response header
879 -- before applying this function. See: 'setContentType'
880 output ∷ Lazy.ByteString → Resource ()
881 {-# INLINE output #-}
882 output str = outputChunk str *> driftTo Done
884 -- | Write a 'Lazy.ByteString' to the response body. This action can
885 -- be repeated as many times as you want. It is safe to apply
886 -- 'outputChunk' to an infinite string.
888 -- Note that you must first set the \"Content-Type\" response header
889 -- before applying this function. See: 'setContentType'
890 outputChunk ∷ Lazy.ByteString → Resource ()
892 = do driftTo DecidingBody
895 $ do hasCType ← readTVar $ itrResponseHasCType itr
897 $ abortSTM InternalServerError []
898 $ Just "outputChunk: Content-Type has not been set."
899 putTMVar (itrBodyToSend itr) (BB.fromLazyByteString str)
901 driftTo ∷ InteractionState → Resource ()
903 = do itr ← getInteraction
905 $ do oldState ← readTVar $ itrState itr
906 if newState < oldState then
907 throwStateError oldState newState
909 do let a = [oldState .. newState]
912 mapM_ (uncurry $ drift itr) c
913 writeTVar (itrState itr) newState
915 throwStateError ∷ Monad m ⇒ InteractionState → InteractionState → m a
916 throwStateError Done DecidingBody
917 = fail "It makes no sense to output something after finishing outputs."
918 throwStateError old new
919 = fail ("state error: " ⧺ show old ⧺ " ==> " ⧺ show new)
921 drift ∷ Interaction → InteractionState → InteractionState → STM ()
922 drift (Interaction {..}) GettingBody _
923 = writeTVar itrReqBodyWasteAll True
924 drift itr DecidingHeader _