3 , GeneralizedNewtypeDeriving
9 {-# OPTIONS_HADDOCK prune #-}
11 -- |This is the Resource Monad; monadic actions to define the behavior
12 -- of each resources. The 'Resource' Monad is a kind of 'Prelude.IO'
13 -- Monad thus it implements 'Control.Monad.Trans.MonadIO' class. It is
14 -- also a state machine.
16 -- Request Processing Flow:
18 -- 1. A client issues an HTTP request.
20 -- 2. If the URI of it matches to any resource, the corresponding
21 -- 'Resource' Monad starts running on a newly spawned thread.
23 -- 3. The 'Resource' Monad looks at the request header, find (or not
24 -- find) an entity, receive the request body (if any), decide the
25 -- response header, and decide the response body. This process
26 -- will be discussed later.
28 -- 4. The 'Resource' Monad and its thread stops running. The client
29 -- may or may not be sending us the next request at this point.
31 -- 'Resource' Monad takes the following states. The initial state is
32 -- /Examining Request/ and the final state is /Done/.
34 -- [/Examining Request/] In this state, a 'Resource' looks at the
35 -- request header and thinks about an entity for it. If there is a
36 -- suitable entity, the 'Resource' tells the system an entity tag
37 -- and its last modification time ('foundEntity'). If it found no
38 -- entity, it tells the system so ('foundNoEntity'). In case it is
39 -- impossible to decide the existence of entity, which is a typical
40 -- case for POST requests, 'Resource' does nothing in this state.
42 -- [/Getting Body/] A 'Resource' asks the system to receive a
43 -- request body from client. Before actually reading from the
44 -- socket, the system sends \"100 Continue\" to the client if need
45 -- be. When a 'Resource' transits to the next state without
46 -- receiving all or part of request body, the system still reads it
47 -- and just throws it away.
49 -- [/Deciding Header/] A 'Resource' makes a decision of status code
50 -- and response header. When it transits to the next state, the
51 -- system checks the validness of response header and then write
52 -- them to the socket.
54 -- [/Deciding Body/] In this state, a 'Resource' asks the system to
55 -- write some response body to the socket. When it transits to the
56 -- next state without writing any response body, the system
57 -- completes it depending on the status code.
59 -- [/Done/] Everything is over. A 'Resource' can do nothing for the
60 -- HTTP interaction anymore.
62 -- Note that the state transition is one-way: for instance, it is an
63 -- error to try to read a request body after writing some
64 -- response. This limitation is for efficiency. We don't want to read
65 -- the entire request before starting 'Resource', nor we don't want to
66 -- postpone writing the entire response till the end of 'Resource'
69 module Network.HTTP.Lucu.Resource
78 -- ** Getting request header
80 -- |These actions can be computed regardless of the current state,
81 -- and they don't change the state.
86 , getRemoteCertificate
97 , isEncodingAcceptable
101 -- ** Finding an entity
103 -- |These actions can be computed only in the /Examining Request/
104 -- state. After the computation, the 'Resource' transits to
105 -- /Getting Body/ state.
111 -- ** Getting a request body
113 -- |Computation of these actions changes the state to /Getting
120 -- ** Setting response headers
122 -- |Computation of these actions changes the state to /Deciding
132 -- ** Writing a response body
134 -- |Computation of these actions changes the state to /Deciding
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.Char8 as C8
152 import qualified Data.ByteString.Lazy as Lazy
153 import qualified Data.ByteString.Lazy.Char8 as L8
155 import qualified Data.Map as M
157 import Data.Monoid.Unicode
158 import qualified Data.Sequence as S
159 import Data.Text (Text)
160 import qualified Data.Text as T
161 import qualified Data.Text.Encoding as T
162 import qualified Data.Text.Encoding.Error as T
164 import qualified Data.Time.HTTP as HTTP
165 import Network.HTTP.Lucu.Abortion
166 import Network.HTTP.Lucu.Authorization
167 import Network.HTTP.Lucu.Config
168 import Network.HTTP.Lucu.ContentCoding
169 import Network.HTTP.Lucu.DefaultPage
170 import Network.HTTP.Lucu.ETag
171 import qualified Network.HTTP.Lucu.Headers as H
172 import Network.HTTP.Lucu.HttpVersion
173 import Network.HTTP.Lucu.Interaction
174 import Network.HTTP.Lucu.MultipartForm
175 import Network.HTTP.Lucu.Postprocess
176 import Network.HTTP.Lucu.Request
177 import Network.HTTP.Lucu.Response
178 import Network.HTTP.Lucu.MIMEType
179 import Network.HTTP.Lucu.Utils
180 import Network.Socket hiding (accept)
181 import Network.URI hiding (path)
183 import Prelude.Unicode
185 -- |The 'Resource' monad. This monad implements 'MonadIO' so it can do
189 unRes ∷ ReaderT Interaction IO a
191 deriving (Applicative, Functor, Monad, MonadIO)
193 runRes ∷ Resource a → Interaction → IO a
195 = runReaderT (unRes r) itr
197 getInteraction ∷ Resource Interaction
198 getInteraction = Resource ask
200 -- |Get the 'Config' value which is used for the httpd.
201 getConfig ∷ Resource Config
202 getConfig = itrConfig <$> getInteraction
204 -- |Get the 'SockAddr' of the remote host. If you want a string
205 -- representation instead of 'SockAddr', use 'getRemoteAddr''.
206 getRemoteAddr ∷ Resource SockAddr
207 getRemoteAddr = itrRemoteAddr <$> getInteraction
209 -- |Get the string representation of the address of remote host. If
210 -- you want a 'SockAddr' instead of 'String', use 'getRemoteAddr'.
211 getRemoteAddr' ∷ Resource HostName
213 = do sa ← getRemoteAddr
214 (Just a, _) ← liftIO $ getNameInfo [NI_NUMERICHOST] False False sa
217 -- |Resolve an address to the remote host.
218 getRemoteHost ∷ Resource (Maybe HostName)
220 = do sa ← getRemoteAddr
221 fst <$> (liftIO $ getNameInfo [] True False sa)
223 -- | Return the X.509 certificate of the client, or 'Nothing' if:
225 -- * This request didn't came through an SSL stream.
227 -- * The client didn't send us its certificate.
229 -- * The 'OpenSSL.Session.VerificationMode' of
230 -- 'OpenSSL.Session.SSLContext' in 'SSLConfig' has not been set to
231 -- 'OpenSSL.Session.VerifyPeer'.
232 getRemoteCertificate ∷ Resource (Maybe X509)
233 getRemoteCertificate = itrRemoteCert <$> getInteraction
235 -- |Get the 'Request' value which represents the request header. In
236 -- general you don't have to use this action.
237 getRequest ∷ Resource Request
239 = do itr ← getInteraction
240 liftIO $ atomically $ readItr itrRequest fromJust itr
242 -- |Get the 'Method' value of the request.
243 getMethod ∷ Resource Method
244 getMethod = reqMethod <$> getRequest
246 -- |Get the URI of the request.
247 getRequestURI ∷ Resource URI
248 getRequestURI = reqURI <$> getRequest
250 -- |Get the HTTP version of the request.
251 getRequestVersion ∷ Resource HttpVersion
252 getRequestVersion = reqVersion <$> getRequest
254 -- |Get the path of this 'Resource' (to be exact,
255 -- 'Network.HTTP.Lucu.Resource.Tree.ResourceDef') in the
256 -- 'Network.HTTP.Lucu.Resource.Tree.ResTree'. The result of this
257 -- action is the exact path in the tree even if the
258 -- 'Network.HTTP.Lucu.Resource.Tree.ResourceDef' is greedy.
262 -- > main = let tree = mkResTree [ (["foo"], resFoo) ]
263 -- > in runHttpd defaultConfig tree
265 -- > resFoo = ResourceDef {
266 -- > resIsGreedy = True
267 -- > , resGet = Just $ do requestURI ← getRequestURI
268 -- > resourcePath ← getResourcePath
269 -- > pathInfo ← getPathInfo
270 -- > -- uriPath requestURI == "/foo/bar/baz"
271 -- > -- resourcePath == ["foo"]
272 -- > -- pathInfo == ["bar", "baz"]
276 getResourcePath ∷ Resource [Ascii]
277 getResourcePath = (fromJust ∘ itrResourcePath) <$> getInteraction
279 -- |This is an analogy of CGI PATH_INFO. The result is
280 -- URI-unescaped. It is always @[]@ if the
281 -- 'Network.HTTP.Lucu.Resource.Tree.ResourceDef' is not greedy. See
282 -- 'getResourcePath'.
283 getPathInfo ∷ Resource [ByteString]
284 getPathInfo = do rsrcPath ← getResourcePath
286 let reqPathStr = uriPath uri
287 reqPath = [unEscapeString x | x ← splitBy (≡ '/') reqPathStr, (¬) (null x)]
288 -- rsrcPath と reqPath の共通する先頭部分を reqPath か
289 -- ら全部取り除くと、それは PATH_INFO のやうなものにな
290 -- る。rsrcPath は全部一致してゐるに決まってゐる(でな
291 -- ければこの Resource が撰ばれた筈が無い)ので、
292 -- rsrcPath の長さの分だけ削除すれば良い。
293 return $ map C8.pack $ drop (length rsrcPath) reqPath
295 -- |Assume the query part of request URI as
296 -- application\/x-www-form-urlencoded, and parse it to pairs of
297 -- @(name, formData)@. This action doesn't parse the request body. See
298 -- 'inputForm'. Field names are decoded in UTF-8.
299 getQueryForm ∷ Resource [(Text, FormData)]
300 getQueryForm = parse' <$> getRequestURI
302 parse' = map toPairWithFormData ∘
303 parseWWWFormURLEncoded ∘
309 toPairWithFormData ∷ (ByteString, ByteString) → (Text, FormData)
310 toPairWithFormData (name, value)
311 = let fd = FormData {
313 , fdContent = L8.fromChunks [value]
315 in (T.decodeUtf8With T.lenientDecode name, fd)
317 -- |Get a value of given request header. Comparison of header name is
318 -- case-insensitive. Note that this action is not intended to be used
319 -- so frequently: there should be actions like 'getContentType' for
320 -- every common headers.
321 getHeader ∷ CIAscii → Resource (Maybe Ascii)
323 = H.getHeader name <$> getRequest
325 -- |Get a list of 'MIMEType' enumerated on header \"Accept\".
326 getAccept ∷ Resource [MIMEType]
328 = do acceptM ← getHeader "Accept"
333 → case P.parseOnly p (A.toByteString accept) of
335 Left _ → abort BadRequest []
336 (Just $ "Unparsable Accept: " ⊕ A.toText accept)
338 p = do xs ← mimeTypeListP
342 -- |Get a list of @(contentCoding, qvalue)@ enumerated on header
343 -- \"Accept-Encoding\". The list is sorted in descending order by
345 getAcceptEncoding ∷ Resource [(CIAscii, Maybe Double)]
347 = do accEncM ← getHeader "Accept-Encoding"
350 -- HTTP/1.0 には Accept-Encoding が無い場合の規定が無い
351 -- ので安全の爲 identity が指定された事にする。HTTP/1.1
352 -- の場合は何でも受け入れて良い事になってゐるので "*" が
354 → do ver ← getRequestVersion
356 HttpVersion 1 0 → return [("identity", Nothing)]
357 HttpVersion 1 1 → return [("*" , Nothing)]
358 _ → abort InternalServerError []
359 (Just "getAcceptEncoding: unknown HTTP version")
363 return [("identity", Nothing)]
365 case P.parseOnly p (A.toByteString ae) of
366 Right xs → return $ map toTuple $ reverse $ sort xs
367 Left _ → abort BadRequest []
368 (Just $ "Unparsable Accept-Encoding: " ⊕ A.toText ae)
370 p = do xs ← acceptEncodingListP
374 toTuple (AcceptEncoding {..})
375 = (aeEncoding, aeQValue)
377 -- |Check whether a given content-coding is acceptable.
378 isEncodingAcceptable ∷ CIAscii → Resource Bool
379 isEncodingAcceptable encoding = any f <$> getAcceptEncoding
382 = (e ≡ "*" ∨ e ≡ encoding) ∧ q ≢ Just 0
384 -- |Get the header \"Content-Type\" as 'MIMEType'.
385 getContentType ∷ Resource (Maybe MIMEType)
387 = do cTypeM ← getHeader "Content-Type"
392 → case P.parseOnly p (A.toByteString cType) of
393 Right t → return $ Just t
394 Left _ → abort BadRequest []
395 (Just $ "Unparsable Content-Type: " ⊕ A.toText cType)
401 -- |Get the header \"Authorization\" as 'AuthCredential'.
402 getAuthorization ∷ Resource (Maybe AuthCredential)
404 = do authM ← getHeader "Authorization"
409 → case P.parseOnly p (A.toByteString auth) of
410 Right ac → return $ Just ac
411 Left _ → return Nothing
413 p = do ac ← authCredentialP
418 {- ExaminingRequest 時に使用するアクション群 -}
420 -- |Tell the system that the 'Resource' found an entity for the
421 -- request URI. If this is a GET or HEAD request, a found entity means
422 -- a datum to be replied. If this is a PUT or DELETE request, it means
423 -- a datum which was stored for the URI until now. It is an error to
424 -- compute 'foundEntity' if this is a POST request.
426 -- Computation of 'foundEntity' performs \"If-Match\" test or
427 -- \"If-None-Match\" test if possible. When those tests fail, the
428 -- computation of 'Resource' immediately aborts with status \"412
429 -- Precondition Failed\" or \"304 Not Modified\" depending on the
432 -- If this is a GET or HEAD request, 'foundEntity' automatically puts
433 -- \"ETag\" and \"Last-Modified\" headers into the response.
434 foundEntity ∷ ETag → UTCTime → Resource ()
435 foundEntity !tag !timeStamp
436 = do driftTo ExaminingRequest
439 when (method ≡ GET ∨ method ≡ HEAD)
440 $ setHeader' "Last-Modified" (HTTP.toAscii timeStamp)
442 $ abort InternalServerError []
443 (Just "Illegal computation of foundEntity for a POST request.")
448 -- |Tell the system that the 'Resource' found an entity for the
449 -- request URI. The only difference from 'foundEntity' is that
450 -- 'foundETag' doesn't (and can't) put \"Last-Modified\" header into
453 -- This action is not preferred. You should use 'foundEntity' whenever
455 foundETag ∷ ETag → Resource ()
457 = do driftTo ExaminingRequest
460 when (method ≡ GET ∨ method ≡ HEAD)
461 $ setHeader' "ETag" (printETag tag)
463 $ abort InternalServerError []
464 (Just "Illegal computation of foundETag for POST request.")
466 -- If-Match があればそれを見る。
467 ifMatch ← getHeader "If-Match"
470 Just value → if value ≡ "*" then
473 case P.parseOnly p (A.toByteString value) of
475 -- tags の中に一致するものが無ければ
476 -- PreconditionFailed で終了。
477 → when ((¬) (any (≡ tag) tags))
478 $ abort PreconditionFailed []
479 (Just $ "The entity tag doesn't match: " ⊕ A.toText value)
481 → abort BadRequest [] (Just $ "Unparsable If-Match: " ⊕ A.toText value)
483 let statusForNoneMatch
484 = if method ≡ GET ∨ method ≡ HEAD then
489 -- If-None-Match があればそれを見る。
490 ifNoneMatch ← getHeader "If-None-Match"
493 Just value → if value ≡ "*" then
494 abort statusForNoneMatch [] (Just "The entity tag matches: *")
496 case P.parseOnly p (A.toByteString value) of
498 → when (any (≡ tag) tags)
499 $ abort statusForNoneMatch []
500 (Just $ "The entity tag matches: " ⊕ A.toText value)
502 → abort BadRequest []
503 (Just $ "Unparsable If-None-Match: " ⊕ A.toText value)
507 p = do xs ← eTagListP
511 -- |Tell the system that the 'Resource' found an entity for the
512 -- request URI. The only difference from 'foundEntity' is that
513 -- 'foundTimeStamp' performs \"If-Modified-Since\" test or
514 -- \"If-Unmodified-Since\" test instead of \"If-Match\" test or
515 -- \"If-None-Match\" test. Be aware that any tests based on last
516 -- modification time are unsafe because it is possible to mess up such
517 -- tests by modifying the entity twice in a second.
519 -- This action is not preferred. You should use 'foundEntity' whenever
521 foundTimeStamp ∷ UTCTime → Resource ()
522 foundTimeStamp timeStamp
523 = do driftTo ExaminingRequest
526 when (method ≡ GET ∨ method ≡ HEAD)
527 $ setHeader' "Last-Modified" (HTTP.toAscii timeStamp)
529 $ abort InternalServerError []
530 (Just "Illegal computation of foundTimeStamp for POST request.")
532 let statusForIfModSince
533 = if method ≡ GET ∨ method ≡ HEAD then
538 -- If-Modified-Since があればそれを見る。
539 ifModSince ← getHeader "If-Modified-Since"
541 Just str → case HTTP.fromAscii str of
543 → when (timeStamp ≤ lastTime)
544 $ abort statusForIfModSince []
545 (Just $ "The entity has not been modified since " ⊕ A.toText str)
547 → return () -- 不正な時刻は無視
550 -- If-Unmodified-Since があればそれを見る。
551 ifUnmodSince ← getHeader "If-Unmodified-Since"
553 Just str → case HTTP.fromAscii str of
555 → when (timeStamp > lastTime)
556 $ abort PreconditionFailed []
557 (Just $ "The entity has not been modified since " ⊕ A.toText str)
559 → return () -- 不正な時刻は無視
564 -- | Computation of @'foundNoEntity' mStr@ tells the system that the
565 -- 'Resource' found no entity for the request URI. @mStr@ is an
566 -- optional error message to be replied to the client.
568 -- If this is a PUT request, 'foundNoEntity' performs \"If-Match\"
569 -- test and aborts with status \"412 Precondition Failed\" when it
570 -- failed. If this is a GET, HEAD, POST or DELETE request,
571 -- 'foundNoEntity' always aborts with status \"404 Not Found\".
572 foundNoEntity ∷ Maybe Text → Resource ()
574 = do driftTo ExaminingRequest
578 $ abort NotFound [] msgM
580 -- エンティティが存在しないと云ふ事は、"*" も含めたどのやうな
581 -- If-Match: 條件も滿たさない。
582 ifMatch ← getHeader "If-Match"
583 when (ifMatch ≢ Nothing)
584 $ abort PreconditionFailed [] msgM
589 {- GettingBody 時に使用するアクション群 -}
591 -- | Computation of @'input' limit@ attempts to read the request body
592 -- up to @limit@ bytes, and then make the 'Resource' transit to
593 -- /Deciding Header/ state. When the actual size of body is larger
594 -- than @limit@ bytes, computation of 'Resource' immediately aborts
595 -- with status \"413 Request Entity Too Large\". When the request has
596 -- no body, 'input' returns an empty string.
598 -- @limit@ may be less than or equal to zero. In this case, the
599 -- default limitation value ('cnfMaxEntityLength') is used. See
602 -- 'input' returns a 'Lazy.ByteString' but it's not really lazy:
603 -- reading from the socket just happens at the computation of 'input',
604 -- not at the evaluation of the 'Lazy.ByteString'. The same goes for
606 input ∷ Int → Resource Lazy.ByteString
608 = do driftTo GettingBody
610 hasBody ← liftIO $ atomically $ readItr itrRequestHasBody id itr
611 chunk ← if hasBody then
614 do driftTo DecidingHeader
618 askForInput ∷ Interaction → Resource Lazy.ByteString
620 = do let confLimit = cnfMaxEntityLength $ itrConfig itr
621 actualLimit = if limit ≤ 0 then
625 when (actualLimit ≤ 0)
626 $ fail ("inputLBS: limit must be positive: " ⧺ show actualLimit)
629 $ do chunkLen ← readItr itrReqChunkLength id itr
630 writeItr itrWillReceiveBody True itr
631 if fmap (> actualLimit) chunkLen ≡ Just True then
635 writeItr itrReqBodyWanted (Just actualLimit) itr
636 -- 應答を待つ。トランザクションを分けなければ當然デッドロックする。
637 chunk ← liftIO $ atomically
638 $ do chunk ← readItr itrReceivedBody chunksToLBS itr
639 chunkIsOver ← readItr itrReqChunkIsOver id itr
640 if L8.length chunk < fromIntegral actualLimit then
641 -- 要求された量に滿たなくて、まだ殘りが
646 -- 制限値一杯まで讀むやうに指示したのに
647 -- まだ殘ってゐるなら、それは多過ぎる。
649 $ tooLarge actualLimit
650 -- 成功。itr 内にチャンクを置いたままにする
652 writeItr itrReceivedBody (∅) itr
654 driftTo DecidingHeader
657 tooLarge ∷ Int → STM ()
658 tooLarge lim = abortSTM RequestEntityTooLarge []
659 (Just $ "Request body must be smaller than "
660 ⊕ T.pack (show lim) ⊕ " bytes.")
662 -- | Computation of @'inputChunk' limit@ attempts to read a part of
663 -- request body up to @limit@ bytes. You can read any large request by
664 -- repeating computation of this action. When you've read all the
665 -- request body, 'inputChunk' returns an empty string and then make
666 -- the 'Resource' transit to /Deciding Header/ state.
668 -- @limit@ may be less than or equal to zero. In this case, the
669 -- default limitation value ('cnfMaxEntityLength') is used. See
672 -- Note that 'inputChunkLBS' is more efficient than 'inputChunk' so you
673 -- should use it whenever possible.
674 inputChunk ∷ Int → Resource Lazy.ByteString
676 = do driftTo GettingBody
678 hasBody ← liftIO $ atomically $ readItr itrRequestHasBody id itr
679 chunk ← if hasBody then
682 do driftTo DecidingHeader
686 askForInput ∷ Interaction → Resource Lazy.ByteString
688 = do let confLimit = cnfMaxEntityLength $ itrConfig itr
689 actualLimit = if limit < 0 then
693 when (actualLimit <= 0)
694 $ fail ("inputChunkLBS: limit must be positive: " ++ show actualLimit)
697 $ do writeItr itrReqBodyWanted (Just actualLimit) itr
698 writeItr itrWillReceiveBody True itr
699 -- 應答を待つ。トランザクションを分けなければ當然デッドロック。
700 chunk ← liftIO $ atomically
701 $ do chunk ← readItr itrReceivedBody chunksToLBS itr
702 -- 要求された量に滿たなくて、まだ殘りがあ
704 when (L8.length chunk < fromIntegral actualLimit)
705 $ do chunkIsOver ← readItr itrReqChunkIsOver id itr
709 writeItr itrReceivedBody (∅) itr
712 $ driftTo DecidingHeader
715 -- | Computation of @'inputForm' limit@ attempts to read the request
716 -- body with 'input' and parse it as
717 -- application\/x-www-form-urlencoded or multipart\/form-data. If the
718 -- request header \"Content-Type\" is neither of them, 'inputForm'
719 -- makes 'Resource' abort with status \"415 Unsupported Media
720 -- Type\". If the request has no \"Content-Type\", it aborts with
721 -- \"400 Bad Request\".
722 inputForm ∷ Int → Resource [(Text, FormData)]
724 = do cTypeM ← getContentType
727 → abort BadRequest [] (Just "Missing Content-Type")
728 Just (MIMEType "application" "x-www-form-urlencoded" _)
729 → readWWWFormURLEncoded
730 Just (MIMEType "multipart" "form-data" params)
731 → readMultipartFormData params
733 → abort UnsupportedMediaType []
734 (Just $ "Unsupported media type: " ⊕ A.toText (printMIMEType cType))
736 readWWWFormURLEncoded
737 = (map toPairWithFormData ∘ parseWWWFormURLEncoded)
739 (bsToAscii =≪ input limit)
742 = case A.fromByteString (C8.concat (L8.toChunks bs)) of
744 Nothing → abort BadRequest [] (Just "Malformed x-www-form-urlencoded")
746 readMultipartFormData params
747 = do case M.lookup "boundary" params of
749 → abort BadRequest [] (Just "Missing boundary of multipart/form-data")
751 → do src ← input limit
752 b ← case A.fromText boundary of
754 Nothing → abort BadRequest []
755 (Just $ "Malformed boundary: " ⊕ boundary)
756 case LP.parse (p b) src of
759 _ → abort BadRequest [] (Just "Unparsable multipart/form-data")
761 p b = do xs ← multipartFormP b
765 -- | This is just a constant @-1@. It's better to say @'input'
766 -- 'defaultLimit'@ than to say @'input' (-1)@ but these are exactly
772 {- DecidingHeader 時に使用するアクション群 -}
774 -- | Set the response status code. If you omit to compute this action,
775 -- the status code will be defaulted to \"200 OK\".
776 setStatus ∷ StatusCode → Resource ()
778 = do driftTo DecidingHeader
780 liftIO $ atomically $ updateItr itrResponse f itr
786 -- | Set a value of given resource header. Comparison of header name
787 -- is case-insensitive. Note that this action is not intended to be
788 -- used so frequently: there should be actions like 'setContentType'
789 -- for every common headers.
791 -- Some important headers (especially \"Content-Length\" and
792 -- \"Transfer-Encoding\") may be silently dropped or overwritten by
793 -- the system not to corrupt the interaction with client at the
794 -- viewpoint of HTTP protocol layer. For instance, if we are keeping
795 -- the connection alive, without this process it causes a catastrophe
796 -- to send a header \"Content-Length: 10\" and actually send a body of
797 -- 20 bytes long. In this case the client shall only accept the first
798 -- 10 bytes of response body and thinks that the residual 10 bytes is
799 -- a part of header of the next response.
800 setHeader ∷ CIAscii → Ascii → Resource ()
802 = driftTo DecidingHeader ≫ setHeader' name value
804 setHeader' ∷ CIAscii → Ascii → Resource ()
805 setHeader' name value
806 = do itr ← getInteraction
808 $ updateItr itrResponse (H.setHeader name value) itr
810 -- | Computation of @'redirect' code uri@ sets the response status to
811 -- @code@ and \"Location\" header to @uri@. The @code@ must satisfy
812 -- 'isRedirection' or it causes an error.
813 redirect ∷ StatusCode → URI → Resource ()
815 = do when (code ≡ NotModified ∨ not (isRedirection code))
816 $ abort InternalServerError []
817 (Just $ "Attempted to redirect with status " ⊕ A.toText (printStatusCode code))
821 -- | Computation of @'setContentType' mType@ sets the response header
822 -- \"Content-Type\" to @mType@.
823 setContentType ∷ MIMEType → Resource ()
825 = setHeader "Content-Type" (printMIMEType mType)
827 -- | Computation of @'setLocation' uri@ sets the response header
828 -- \"Location\" to @uri@.
829 setLocation ∷ URI → Resource ()
831 = case A.fromChars uriStr of
832 Just a → setHeader "Location" a
833 Nothing → abort InternalServerError []
834 (Just $ "Malformed URI: " ⊕ T.pack uriStr)
836 uriStr = uriToString id uri ""
838 -- |Computation of @'setContentEncoding' codings@ sets the response
839 -- header \"Content-Encoding\" to @codings@.
840 setContentEncoding ∷ [CIAscii] → Resource ()
841 setContentEncoding codings
842 = do ver ← getRequestVersion
844 HttpVersion 1 0 → return (toAB ∘ unnormalizeCoding)
845 HttpVersion 1 1 → return toAB
846 _ → abort InternalServerError []
847 (Just "setContentEncoding: Unknown HTTP version")
848 setHeader "Content-Encoding"
849 (A.fromAsciiBuilder $ joinWith ", " $ map tr codings)
851 toAB = A.toAsciiBuilder ∘ A.fromCIAscii
853 -- |Computation of @'setWWWAuthenticate' challenge@ sets the response
854 -- header \"WWW-Authenticate\" to @challenge@.
855 setWWWAuthenticate ∷ AuthChallenge → Resource ()
856 setWWWAuthenticate challenge
857 = setHeader "WWW-Authenticate" (printAuthChallenge challenge)
860 {- DecidingBody 時に使用するアクション群 -}
862 -- | Computation of @'output' str@ writes @str@ as a response body,
863 -- and then make the 'Resource' transit to /Done/ state. It is safe to
864 -- apply 'output' to an infinite string, such as a lazy stream of
866 output ∷ Lazy.ByteString → Resource ()
867 {-# INLINE output #-}
868 output str = do outputChunk str
871 -- | Computation of @'outputChunk' str@ writes @str@ as a part of
872 -- response body. You can compute this action multiple times to write
873 -- a body little at a time. It is safe to apply 'outputChunk' to an
875 outputChunk ∷ Lazy.ByteString → Resource ()
876 outputChunk wholeChunk
877 = do driftTo DecidingBody
880 let limit = cnfMaxOutputChunkLength $ itrConfig itr
882 $ abort InternalServerError []
883 (Just $ "cnfMaxOutputChunkLength must be positive: " ⊕ T.pack (show limit))
885 discardBody ← liftIO $ atomically $
886 readItr itrWillDiscardBody id itr
889 $ sendChunks wholeChunk limit
891 unless (L8.null wholeChunk)
892 $ liftIO $ atomically $
893 writeItr itrBodyIsNull False itr
895 -- チャンクの大きさは Config で制限されてゐる。もし例へば
896 -- "/dev/zero" を L8.readFile して作った Lazy.ByteString をそのまま
897 -- ResponseWriter に渡したりすると大變な事が起こる。何故なら
898 -- ResponseWriter は Transfer-Encoding: chunked の時、ヘッダを書
899 -- く爲にチャンクの大きさを測るからだ。
900 sendChunks ∷ Lazy.ByteString → Int → Resource ()
902 | L8.null str = return ()
903 | otherwise = do let (chunk, remaining) = L8.splitAt (fromIntegral limit) str
905 liftIO $ atomically $
906 do buf ← readItr itrBodyToSend id itr
909 writeItr itrBodyToSend (chunksFromLBS chunk) itr
914 sendChunks remaining limit
918 [GettingBody からそれ以降の状態に遷移する時]
920 body を讀み終へてゐなければ、殘りの body を讀み捨てる。
923 [DecidingHeader からそれ以降の状態に遷移する時]
930 bodyIsNull が False ならば何もしない。True だった場合は出力補完す
935 driftTo ∷ InteractionState → Resource ()
937 = do itr ← getInteraction
938 liftIO $ atomically $ do oldState ← readItr itrState id itr
939 if newState < oldState then
940 throwStateError oldState newState
942 do let a = [oldState .. newState]
945 mapM_ (uncurry $ drift itr) c
946 writeItr itrState newState itr
948 throwStateError ∷ Monad m => InteractionState → InteractionState → m a
950 throwStateError Done DecidingBody
951 = fail "It makes no sense to output something after finishing to output."
953 throwStateError old new
954 = fail ("state error: " ⧺ show old ⧺ " ==> " ⧺ show new)
957 drift ∷ Interaction → InteractionState → InteractionState → STM ()
959 drift itr GettingBody _
960 = writeItr itrReqBodyWasteAll True itr
962 drift itr DecidingHeader _
966 = do bodyIsNull ← readItr itrBodyIsNull id itr
968 $ writeDefaultPage itr