3 -- |This is the Resource Monad; monadic actions to define the behavior
4 -- of each resources. The 'Resource' Monad is a kind of IO Monad thus
5 -- it implements MonadIO class. It is also a state machine.
7 -- Request Processing Flow:
9 -- 1. A client issues an HTTP request.
11 -- 2. If the URI of it matches to any resource, the corresponding
12 -- 'Resource' Monad starts running on a newly spawned thread.
14 -- 3. The 'Resource' Monad looks at the request header, find (or not
15 -- find) an entity, receive the request body (if any), decide the
16 -- response header, and decide the response body. This process
17 -- will be discussed later.
19 -- 4. The 'Resource' Monad and its thread stops running. The client
20 -- may or may not be sending us the next request at this point.
22 -- 'Resource' Monad takes the following states. The initial state is
23 -- /Examining Request/ and the final state is /Done/.
25 -- [/Examining Request/] In this state, a 'Resource' looks at the
26 -- request header and thinks about an entity for it. If there is a
27 -- suitable entity, the 'Resource' tells the system an entity tag
28 -- and its last modification time ('foundEntity'). If it found no
29 -- entity, it tells the system so ('foundNoEntity'). In case it is
30 -- impossible to decide the existence of entity, which is a typical
31 -- case for POST requests, 'Resource' does nothing in this state.
33 -- [/Getting Body/] A 'Resource' asks the system to receive a
34 -- request body from client. Before actually reading from the
35 -- socket, the system sends \"100 Continue\" to the client if need
36 -- be. When a 'Resource' transits to the next state without
37 -- receiving all or part of request body, the system still reads it
38 -- and just throws it away.
40 -- [/Deciding Header/] A 'Resource' makes a decision of status code
41 -- and response header. When it transits to the next state, the
42 -- system checks the validness of response header and then write
43 -- them to the socket.
45 -- [/Deciding Body/] In this state, a 'Resource' asks the system to
46 -- write some response body to the socket. When it transits to the
47 -- next state without writing any response body, the system
48 -- completes it depending on the status code.
50 -- [/Done/] Everything is over. A 'Resource' can do nothing for the
51 -- HTTP interaction anymore.
53 -- Note that the state transition is one-way: for instance, it is an
54 -- error to try to read a request body after writing some
55 -- response. This limitation is for efficiency. We don't want to read
56 -- the entire request before starting 'Resource', nor we don't want to
57 -- postpone writing the entire response till the end of 'Resource'
60 module Network.HTTP.Lucu.Resource
67 -- ** Getting request header
69 -- |These actions can be computed regardless of the current state,
70 -- and they don't change the state.
86 -- ** Finding an entity
88 -- |These actions can be computed only in the /Examining Request/
89 -- state. After the computation, the 'Resource' transits to
90 -- /Getting Body/ state.
96 -- ** Getting a request body
98 -- |Computation of these actions changes the state to /Getting
107 -- ** Setting response headers
109 -- |Computation of these actions changes the state to /Deciding
118 -- ** Writing a response body
120 -- |Computation of these actions changes the state to /Deciding
131 import Control.Concurrent.STM
132 import Control.Monad.Reader
134 import qualified Data.ByteString.Lazy.Char8 as B
135 import Data.ByteString.Lazy.Char8 (ByteString)
139 import Network.HTTP.Lucu.Abortion
140 import Network.HTTP.Lucu.Config
141 import Network.HTTP.Lucu.DefaultPage
142 import Network.HTTP.Lucu.ETag
143 import qualified Network.HTTP.Lucu.Headers as H
144 import Network.HTTP.Lucu.HttpVersion
145 import Network.HTTP.Lucu.Interaction
146 import Network.HTTP.Lucu.Parser
147 import Network.HTTP.Lucu.Parser.Http
148 import Network.HTTP.Lucu.Postprocess
149 import Network.HTTP.Lucu.RFC1123DateTime
150 import Network.HTTP.Lucu.Request
151 import Network.HTTP.Lucu.Response
152 import Network.HTTP.Lucu.MIMEType
153 import Network.HTTP.Lucu.Utils
154 import Network.Socket
158 -- |The 'Resource' monad. /Interaction/ is an internal state thus it
159 -- is not exposed to users. This monad implements 'MonadIO' so it can
160 -- do any IO actions.
161 type Resource a = ReaderT Interaction IO a
163 -- |Get the 'Network.HTTP.Lucu.Config.Config' value which is used for
165 getConfig :: Resource Config
166 getConfig = do itr <- ask
167 return $! itrConfig itr
170 -- |Get the SockAddr of the remote host. If you want a string
171 -- representation instead of SockAddr, use 'getRemoteAddr''.
172 getRemoteAddr :: Resource SockAddr
173 getRemoteAddr = do itr <- ask
174 return $! itrRemoteAddr itr
177 -- |Get the string representation of the address of remote host. If
178 -- you want a SockAddr instead of String, use 'getRemoteAddr'.
179 getRemoteAddr' :: Resource String
180 getRemoteAddr' = do addr <- getRemoteAddr
182 -- Network.Socket は IPv6 を考慮してゐないやうだ…
183 (SockAddrInet _ v4addr)
184 -> let b1 = (v4addr `shiftR` 24) .&. 0xFF
185 b2 = (v4addr `shiftR` 16) .&. 0xFF
186 b3 = (v4addr `shiftR` 8) .&. 0xFF
189 return $ concat $ intersperse "." $ map show [b1, b2, b3, b4]
194 -- |Get the 'Network.HTTP.Lucu.Request.Request' value which represents
195 -- the request header. In general you don't have to use this action.
196 getRequest :: Resource Request
197 getRequest = do itr <- ask
198 req <- liftIO $! atomically $! readItr itr itrRequest fromJust
201 -- |Get the 'Network.HTTP.Lucu.Request.Method' value of the request.
202 getMethod :: Resource Method
203 getMethod = do req <- getRequest
204 return $! reqMethod req
206 -- |Get the URI of the request.
207 getRequestURI :: Resource URI
208 getRequestURI = do req <- getRequest
211 -- |Get the HTTP version of the request.
212 getRequestVersion :: Resource HttpVersion
213 getRequestVersion = do req <- getRequest
214 return $! reqVersion req
216 -- |Get the path of this 'Resource' (to be exact,
217 -- 'Network.HTTP.Lucu.Resource.Tree.ResourceDef') in the
218 -- 'Network.HTTP.Lucu.Resource.Tree.ResTree'. The result of this
219 -- action is the exact path in the tree even if the
220 -- 'Network.HTTP.Lucu.Resource.Tree.ResourceDef' is greedy.
224 -- > main = let tree = mkResTree [ (["foo"], resFoo) ]
225 -- > in runHttpd defaultConfig tree
227 -- > resFoo = ResourceDef {
228 -- > resIsGreedy = True
229 -- > , resGet = Just $ do requestURI <- getRequestURI
230 -- > resourcePath <- getResourcePath
231 -- > pathInfo <- getPathInfo
232 -- > -- uriPath requestURI == "/foo/bar/baz"
233 -- > -- resourcePath == ["foo"]
234 -- > -- pathInfo == ["bar", "baz"]
238 getResourcePath :: Resource [String]
239 getResourcePath = do itr <- ask
240 return $! fromJust $! itrResourcePath itr
243 -- |This is an analogy of CGI PATH_INFO. Its result is always @[]@ if
244 -- the 'Network.HTTP.Lucu.Resource.Tree.ResourceDef' is not
245 -- greedy. See 'getResourcePath'.
246 getPathInfo :: Resource [String]
247 getPathInfo = do rsrcPath <- getResourcePath
248 reqURI <- getRequestURI
249 let reqPathStr = uriPath reqURI
250 reqPath = [x | x <- splitBy (== '/') reqPathStr, x /= ""]
251 -- rsrcPath と reqPath の共通する先頭部分を reqPath か
252 -- ら全部取り除くと、それは PATH_INFO のやうなものにな
253 -- る。rsrcPath は全部一致してゐるに決まってゐる(でな
254 -- ければこの Resource が撰ばれた筈が無い)ので、
255 -- rsrcPath の長さの分だけ削除すれば良い。
256 return $! drop (length rsrcPath) reqPath
258 -- | Assume the query part of request URI as
259 -- application\/x-www-form-urlencoded, and parse it. This action
260 -- doesn't parse the request body. See 'inputForm'.
261 getQueryForm :: Resource [(String, String)]
262 getQueryForm = do reqURI <- getRequestURI
263 return $! parseWWWFormURLEncoded $ uriQuery reqURI
265 -- |Get a value of given request header. Comparison of header name is
266 -- case-insensitive. Note that this action is not intended to be used
267 -- so frequently: there should be actions like 'getContentType' for
268 -- every common headers.
269 getHeader :: String -> Resource (Maybe String)
270 getHeader name = name `seq`
272 return $! H.getHeader name req
274 -- |Get a list of 'Network.HTTP.Lucu.MIMEType.MIMEType' enumerated on
275 -- header \"Accept\".
276 getAccept :: Resource [MIMEType]
277 getAccept = do acceptM <- getHeader "Accept"
282 -> case parseStr mimeTypeListP accept of
283 (Success xs, _) -> return xs
284 _ -> abort BadRequest []
285 (Just $ "Unparsable Accept: " ++ accept)
287 -- |Get a list of @(contentCoding, qvalue)@ enumerated on header
288 -- \"Accept-Encoding\".
289 getAcceptEncoding :: Resource [(String, Maybe Double)]
291 = do accEncM <- getHeader "Accept-Encoding"
294 -- HTTP/1.0 には Accept-Encoding が無い場合の規定が無い
295 -- ので安全の爲 identity が指定された事にする。HTTP/1.1
296 -- の場合は何でも受け入れて良い事になってゐるので "*" が
298 -> do ver <- getRequestVersion
300 HttpVersion 1 0 -> return [("identity", Nothing)]
301 HttpVersion 1 1 -> return [("*" , Nothing)]
304 -> return [("identity", Nothing)]
306 -> case parseStr accEncListP accEnc of
307 (Success x, _) -> return x
308 _ -> abort BadRequest []
309 (Just $ "Unparsable Accept-Encoding: " ++ accEnc)
311 accEncListP :: Parser [(String, Maybe Double)]
312 accEncListP = allowEOF $! listOf accEncP
314 accEncP :: Parser (String, Maybe Double)
315 accEncP = do coding <- token
316 qVal <- option Nothing
320 return (normalizeCoding coding, qVal)
322 normalizeCoding :: String -> String
323 normalizeCoding coding
324 = case map toLower coding of
326 "x-compress" -> "compress"
329 -- |Get the header \"Content-Type\" as
330 -- 'Network.HTTP.Lucu.MIMEType.MIMEType'.
331 getContentType :: Resource (Maybe MIMEType)
333 = do cTypeM <- getHeader "Content-Type"
338 -> case parseStr mimeTypeP cType of
339 (Success t, _) -> return $ Just t
340 _ -> abort BadRequest []
341 (Just $ "Unparsable Content-Type: " ++ cType)
344 {- ExaminingRequest 時に使用するアクション群 -}
346 -- |Tell the system that the 'Resource' found an entity for the
347 -- request URI. If this is a GET or HEAD request, a found entity means
348 -- a datum to be replied. If this is a PUT or DELETE request, it means
349 -- a datum which was stored for the URI up to now. It is an error to
350 -- compute 'foundEntity' if this is a POST request.
352 -- Computation of 'foundEntity' performs \"If-Match\" test or
353 -- \"If-None-Match\" test if possible. When those tests fail, the
354 -- computation of 'Resource' immediately aborts with status \"412
355 -- Precondition Failed\" or \"304 Not Modified\" depending on the
358 -- If this is a GET or HEAD request, 'foundEntity' automatically puts
359 -- \"ETag\" and \"Last-Modified\" headers into the response.
360 foundEntity :: ETag -> ClockTime -> Resource ()
361 foundEntity tag timeStamp
362 = tag `seq` timeStamp `seq`
363 do driftTo ExaminingRequest
366 when (method == GET || method == HEAD)
367 $ setHeader' "Last-Modified" $! formatHTTPDateTime timeStamp
368 when (method == POST)
369 $ abort InternalServerError []
370 (Just "Illegal computation of foundEntity for POST request.")
375 -- |Tell the system that the 'Resource' found an entity for the
376 -- request URI. The only difference from 'foundEntity' is that
377 -- 'foundETag' doesn't (and can't) put \"Last-Modified\" header into
380 -- This action is not preferred. You should use 'foundEntity' when
382 foundETag :: ETag -> Resource ()
385 do driftTo ExaminingRequest
388 when (method == GET || method == HEAD)
389 $ setHeader' "ETag" $! show tag
390 when (method == POST)
391 $ abort InternalServerError []
392 (Just "Illegal computation of foundETag for POST request.")
394 -- If-Match があればそれを見る。
395 ifMatch <- getHeader "If-Match"
398 Just "*" -> return ()
399 Just list -> case parseStr eTagListP list of
401 -- tags の中に一致するものが無ければ
402 -- PreconditionFailed で終了。
403 -> when (not $ any (== tag) tags)
404 $ abort PreconditionFailed []
405 $! Just ("The entity tag doesn't match: " ++ list)
406 _ -> abort BadRequest [] $! Just ("Unparsable If-Match: " ++ fromJust ifMatch)
408 let statusForNoneMatch = if method == GET || method == HEAD then
413 -- If-None-Match があればそれを見る。
414 ifNoneMatch <- getHeader "If-None-Match"
417 Just "*" -> abort statusForNoneMatch [] $! Just ("The entity tag matches: *")
418 Just list -> case parseStr eTagListP list of
420 -> when (any (== tag) tags)
421 $ abort statusForNoneMatch [] $! Just ("The entity tag matches: " ++ list)
422 _ -> abort BadRequest [] $! Just ("Unparsable If-None-Match: " ++ list)
426 -- |Tell the system that the 'Resource' found an entity for the
427 -- request URI. The only difference from 'foundEntity' is that
428 -- 'foundTimeStamp' performs \"If-Modified-Since\" test or
429 -- \"If-Unmodified-Since\" test instead of \"If-Match\" test or
430 -- \"If-None-Match\" test. Be aware that any tests based on last
431 -- modification time are unsafe because it is possible to mess up such
432 -- tests by modifying the entity twice in a second.
434 -- This action is not preferred. You should use 'foundEntity' when
436 foundTimeStamp :: ClockTime -> Resource ()
437 foundTimeStamp timeStamp
439 do driftTo ExaminingRequest
442 when (method == GET || method == HEAD)
443 $ setHeader' "Last-Modified" $! formatHTTPDateTime timeStamp
444 when (method == POST)
445 $ abort InternalServerError []
446 (Just "Illegal computation of foundTimeStamp for POST request.")
448 let statusForIfModSince = if method == GET || method == HEAD then
453 -- If-Modified-Since があればそれを見る。
454 ifModSince <- getHeader "If-Modified-Since"
456 Just str -> case parseHTTPDateTime str of
458 -> when (timeStamp <= lastTime)
459 $ abort statusForIfModSince []
460 $! Just ("The entity has not been modified since " ++ str)
462 -> return () -- 不正な時刻は無視
465 -- If-Unmodified-Since があればそれを見る。
466 ifUnmodSince <- getHeader "If-Unmodified-Since"
468 Just str -> case parseHTTPDateTime str of
470 -> when (timeStamp > lastTime)
471 $ abort PreconditionFailed []
472 $! Just ("The entity has not been modified since " ++ str)
474 -> return () -- 不正な時刻は無視
479 -- | Computation of @'foundNoEntity' mStr@ tells the system that the
480 -- 'Resource' found no entity for the request URI. @mStr@ is an
481 -- optional error message to be replied to the client.
483 -- If this is a PUT request, 'foundNoEntity' performs \"If-Match\"
484 -- test and aborts with status \"412 Precondition Failed\" when it
485 -- failed. If this is a GET, HEAD, POST or DELETE request,
486 -- 'foundNoEntity' always aborts with status \"404 Not Found\".
487 foundNoEntity :: Maybe String -> Resource ()
490 do driftTo ExaminingRequest
494 $ abort NotFound [] msgM
496 -- エンティティが存在しないと云ふ事は、"*" も含めたどのやうな
497 -- If-Match: 條件も滿たさない。
498 ifMatch <- getHeader "If-Match"
499 when (ifMatch /= Nothing)
500 $ abort PreconditionFailed [] msgM
505 {- GettingBody 時に使用するアクション群 -}
507 -- | Computation of @'input' limit@ attempts to read the request body
508 -- up to @limit@ bytes, and then make the 'Resource' transit to
509 -- /Deciding Header/ state. When the actual size of body is larger
510 -- than @limit@ bytes, computation of 'Resource' immediately aborts
511 -- with status \"413 Request Entity Too Large\". When the request has
512 -- no body, 'input' returns an empty string.
514 -- @limit@ may be less than or equal to zero. In this case, the
515 -- default limitation value
516 -- ('Network.HTTP.Lucu.Config.cnfMaxEntityLength') is used. See
519 -- Note that 'inputBS' is more efficient than 'input' so you should
520 -- use it whenever possible.
521 input :: Int -> Resource String
522 input limit = limit `seq`
523 inputBS limit >>= return . B.unpack
526 -- | This is mostly the same as 'input' but is more
527 -- efficient. 'inputBS' returns a lazy ByteString but it's not really
528 -- lazy: reading from the socket just happens at the computation of
529 -- 'inputBS', not at the lazy evaluation of the ByteString. The same
530 -- goes for 'inputChunkBS'.
531 inputBS :: Int -> Resource ByteString
534 do driftTo GettingBody
536 hasBody <- liftIO $! atomically $! readItr itr itrRequestHasBody id
537 chunk <- if hasBody then
540 do driftTo DecidingHeader
544 askForInput :: Interaction -> Resource ByteString
547 do let defaultLimit = cnfMaxEntityLength $ itrConfig itr
548 actualLimit = if limit <= 0 then
552 when (actualLimit <= 0)
553 $ fail ("inputBS: limit must be positive: " ++ show actualLimit)
556 $! do chunkLen <- readItr itr itrReqChunkLength id
557 writeItr itr itrWillReceiveBody True
558 if fmap (> actualLimit) chunkLen == Just True then
562 writeItr itr itrReqBodyWanted $ Just actualLimit
563 -- 應答を待つ。トランザクションを分けなければ當然デッドロック。
564 chunk <- liftIO $! atomically
565 $! do chunk <- readItr itr itrReceivedBody id
566 chunkIsOver <- readItr itr itrReqChunkIsOver id
567 if B.length chunk < fromIntegral actualLimit then
577 $ tooLarge actualLimit
578 -- 成功。itr 内にチャンクを置いたままにす
580 writeItr itr itrReceivedBody B.empty
582 driftTo DecidingHeader
585 tooLarge :: Int -> STM ()
586 tooLarge lim = lim `seq`
587 abortSTM RequestEntityTooLarge []
588 $! Just ("Request body must be smaller than "
589 ++ show lim ++ " bytes.")
591 -- | Computation of @'inputChunk' limit@ attempts to read a part of
592 -- request body up to @limit@ bytes. You can read any large request by
593 -- repeating computation of this action. When you've read all the
594 -- request body, 'inputChunk' returns an empty string and then make
595 -- the 'Resource' transit to /Deciding Header/ state.
597 -- @limit@ may be less than or equal to zero. In this case, the
598 -- default limitation value
599 -- ('Network.HTTP.Lucu.Config.cnfMaxEntityLength') is used. See
602 -- Note that 'inputChunkBS' is more efficient than 'inputChunk' so you
603 -- should use it whenever possible.
604 inputChunk :: Int -> Resource String
605 inputChunk limit = limit `seq`
606 inputChunkBS limit >>= return . B.unpack
609 -- | This is mostly the same as 'inputChunk' but is more
610 -- efficient. See 'inputBS'.
611 inputChunkBS :: Int -> Resource ByteString
614 do driftTo GettingBody
616 hasBody <- liftIO $ atomically $ readItr itr itrRequestHasBody id
617 chunk <- if hasBody then
620 do driftTo DecidingHeader
624 askForInput :: Interaction -> Resource ByteString
627 do let defaultLimit = cnfMaxEntityLength $! itrConfig itr
628 actualLimit = if limit < 0 then
632 when (actualLimit <= 0)
633 $ fail ("inputChunkBS: limit must be positive: " ++ show actualLimit)
636 $! do writeItr itr itrReqBodyWanted $! Just actualLimit
637 writeItr itr itrWillReceiveBody True
638 -- 應答を待つ。トランザクションを分けなければ當然デッドロック。
639 chunk <- liftIO $! atomically
640 $ do chunk <- readItr itr itrReceivedBody id
641 -- 要求された量に滿たなくて、まだ殘りがあ
643 when (B.length chunk < fromIntegral actualLimit)
644 $ do chunkIsOver <- readItr itr itrReqChunkIsOver id
648 writeItr itr itrReceivedBody B.empty
651 $ driftTo DecidingHeader
654 -- | Computation of @'inputForm' limit@ attempts to read the request
655 -- body with 'input' and parse it as
656 -- application\/x-www-form-urlencoded. If the request header
657 -- \"Content-Type\" is not application\/x-www-form-urlencoded,
658 -- 'inputForm' makes 'Resource' abort with status \"415 Unsupported
659 -- Media Type\". If the request has no \"Content-Type\", it aborts
660 -- with \"400 Bad Request\".
662 -- This action should also support multipart\/form-data somehow, but
663 -- it is not (yet) done.
664 inputForm :: Int -> Resource [(String, String)]
667 do cTypeM <- getContentType
670 -> abort BadRequest [] (Just "Missing Content-Type")
671 Just (MIMEType "application" "x-www-form-urlencoded" _)
672 -> readWWWFormURLEncoded
673 Just (MIMEType "multipart" "form-data" _)
674 -> readMultipartFormData
676 -> abort UnsupportedMediaType [] (Just $! "Unsupported media type: "
679 readWWWFormURLEncoded
680 = do src <- input limit
681 return $ parseWWWFormURLEncoded src
683 readMultipartFormData -- FIXME: 未對應
684 = abort UnsupportedMediaType []
685 (Just $! "Sorry, inputForm does not currently support multipart/form-data.")
687 -- | This is just a constant -1. It's better to say @'input'
688 -- 'defaultLimit'@ than to say @'input' (-1)@ but these are exactly
695 {- DecidingHeader 時に使用するアクション群 -}
697 -- | Set the response status code. If you omit to compute this action,
698 -- the status code will be defaulted to \"200 OK\".
699 setStatus :: StatusCode -> Resource ()
702 do driftTo DecidingHeader
704 liftIO $! atomically $! updateItr itr itrResponse
709 -- | Set a value of given resource header. Comparison of header name
710 -- is case-insensitive. Note that this action is not intended to be
711 -- used so frequently: there should be actions like 'setContentType'
712 -- for every common headers.
714 -- Some important headers (especially \"Content-Length\" and
715 -- \"Transfer-Encoding\") may be silently dropped or overwritten by
716 -- the system not to corrupt the interaction with client at the
717 -- viewpoint of HTTP protocol layer. For instance, if we are keeping
718 -- the connection alive, without this process it causes a catastrophe
719 -- to send a header \"Content-Length: 10\" and actually send a body of
720 -- 20 bytes long. In this case the client shall only accept the first
721 -- 10 bytes of response body and thinks that the residual 10 bytes is
722 -- a part of header of the next response.
723 setHeader :: String -> String -> Resource ()
725 = name `seq` value `seq`
726 driftTo DecidingHeader >> setHeader' name value
729 setHeader' :: String -> String -> Resource ()
730 setHeader' name value
731 = name `seq` value `seq`
734 $ updateItr itr itrResponse
735 $ H.setHeader name value
737 -- | Computation of @'redirect' code uri@ sets the response status to
738 -- @code@ and \"Location\" header to @uri@. @code@ must satisfy
739 -- 'Network.HTTP.Lucu.Response.isRedirection' or it causes an error.
740 redirect :: StatusCode -> URI -> Resource ()
742 = code `seq` uri `seq`
743 do when (code == NotModified || not (isRedirection code))
744 $ abort InternalServerError []
745 $! Just ("Attempted to redirect with status " ++ show code)
748 {-# INLINE redirect #-}
751 -- | Computation of @'setContentType' mType@ sets the response header
752 -- \"Content-Type\" to @mType@.
753 setContentType :: MIMEType -> Resource ()
755 = setHeader "Content-Type" $! show mType
757 -- | Computation of @'setLocation' uri@ sets the response header
758 -- \"Location\" to @uri@.
759 setLocation :: URI -> Resource ()
761 = setHeader "Location" $ uriToString id uri $ ""
763 -- |Computation of @'setContentEncoding' codings@ sets the response
764 -- header \"Content-Encoding\" to @codings@.
765 setContentEncoding :: [String] -> Resource ()
766 setContentEncoding codings
767 = setHeader "Content-Encoding" $ joinWith ", " codings
770 {- DecidingBody 時に使用するアクション群 -}
772 -- | Computation of @'output' str@ writes @str@ as a response body,
773 -- and then make the 'Resource' transit to /Done/ state. It is safe to
774 -- apply 'output' to an infinite string, such as a lazy stream of
777 -- Note that 'outputBS' is more efficient than 'output' so you should
778 -- use it whenever possible.
779 output :: String -> Resource ()
780 output str = outputBS $! B.pack str
781 {-# INLINE output #-}
783 -- | This is mostly the same as 'output' but is more efficient.
784 outputBS :: ByteString -> Resource ()
785 outputBS str = do outputChunkBS str
787 {-# INLINE outputBS #-}
789 -- | Computation of @'outputChunk' str@ writes @str@ as a part of
790 -- response body. You can compute this action multiple times to write
791 -- a body little at a time. It is safe to apply 'outputChunk' to an
794 -- Note that 'outputChunkBS' is more efficient than 'outputChunk' so
795 -- you should use it whenever possible.
796 outputChunk :: String -> Resource ()
797 outputChunk str = outputChunkBS $! B.pack str
798 {-# INLINE outputChunk #-}
800 -- | This is mostly the same as 'outputChunk' but is more efficient.
801 outputChunkBS :: ByteString -> Resource ()
804 do driftTo DecidingBody
807 let limit = cnfMaxOutputChunkLength $ itrConfig itr
809 $ fail ("cnfMaxOutputChunkLength must be positive: "
812 discardBody <- liftIO $ atomically $
813 readItr itr itrWillDiscardBody id
816 $ sendChunks str limit
819 $ liftIO $ atomically $
820 writeItr itr itrBodyIsNull False
822 {- チャンクの大きさは Config で制限されてゐる。もし例へば
823 /dev/zero を B.readFile して作った ByteString をそのまま
824 ResponseWriter に渡したりすると大變な事が起こる。何故なら
825 ResponseWriter はTransfer-Encoding: chunked の時、ヘッダを書く
826 爲にチャンクの大きさを測るから、その時に起こるであらう事は言ふ
828 sendChunks :: ByteString -> Int -> Resource ()
830 | B.null str = return ()
831 | otherwise = do let (chunk, remaining) = B.splitAt (fromIntegral limit) str
833 liftIO $ atomically $
834 do buf <- readItr itr itrBodyToSend id
837 writeItr itr itrBodyToSend chunk
842 sendChunks remaining limit
846 [GettingBody からそれ以降の状態に遷移する時]
848 body を讀み終へてゐなければ、殘りの body を讀み捨てる。
851 [DecidingHeader からそれ以降の状態に遷移する時]
858 bodyIsNull が False ならば何もしない。True だった場合は出力補完す
863 driftTo :: InteractionState -> Resource ()
867 liftIO $ atomically $ do oldState <- readItr itr itrState id
868 if newState < oldState then
869 throwStateError oldState newState
871 do let a = [oldState .. newState]
874 mapM_ (uncurry $ drift itr) c
875 writeItr itr itrState newState
877 throwStateError :: Monad m => InteractionState -> InteractionState -> m a
879 throwStateError Done DecidingBody
880 = fail "It makes no sense to output something after finishing to output."
882 throwStateError old new
883 = fail ("state error: " ++ show old ++ " ==> " ++ show new)
886 drift :: Interaction -> InteractionState -> InteractionState -> STM ()
888 drift itr GettingBody _
889 = writeItr itr itrReqBodyWasteAll True
891 drift itr DecidingHeader _
895 = do bodyIsNull <- readItr itr itrBodyIsNull id
897 $ writeDefaultPage itr