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.
84 , isEncodingAcceptable
87 -- ** Finding an entity
89 -- |These actions can be computed only in the /Examining Request/
90 -- state. After the computation, the 'Resource' transits to
91 -- /Getting Body/ state.
97 -- ** Getting a request body
99 -- |Computation of these actions changes the state to /Getting
108 -- ** Setting response headers
110 -- |Computation of these actions changes the state to /Deciding
119 -- ** Writing a response body
121 -- |Computation of these actions changes the state to /Deciding
132 import Control.Concurrent.STM
133 import Control.Monad.Reader
135 import qualified Data.ByteString.Lazy.Char8 as B
136 import Data.ByteString.Lazy.Char8 (ByteString)
139 import Network.HTTP.Lucu.Abortion
140 import Network.HTTP.Lucu.Config
141 import Network.HTTP.Lucu.ContentCoding
142 import Network.HTTP.Lucu.DefaultPage
143 import Network.HTTP.Lucu.ETag
144 import qualified Network.HTTP.Lucu.Headers as H
145 import Network.HTTP.Lucu.HttpVersion
146 import Network.HTTP.Lucu.Interaction
147 import Network.HTTP.Lucu.Parser
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\". The list is sorted in descending order by
290 getAcceptEncoding :: Resource [(String, Maybe Double)]
292 = do accEncM <- getHeader "Accept-Encoding"
295 -- HTTP/1.0 には Accept-Encoding が無い場合の規定が無い
296 -- ので安全の爲 identity が指定された事にする。HTTP/1.1
297 -- の場合は何でも受け入れて良い事になってゐるので "*" が
299 -> do ver <- getRequestVersion
301 HttpVersion 1 0 -> return [("identity", Nothing)]
302 HttpVersion 1 1 -> return [("*" , Nothing)]
305 -> return [("identity", Nothing)]
307 -> case parseStr acceptEncodingListP accEnc of
308 (Success x, _) -> return $ reverse $ sortBy orderAcceptEncodings x
309 _ -> abort BadRequest []
310 (Just $ "Unparsable Accept-Encoding: " ++ accEnc)
312 -- |Check whether a given content-coding is acceptable.
313 isEncodingAcceptable :: String -> Resource Bool
314 isEncodingAcceptable coding
315 = do accList <- getAcceptEncoding
316 return (flip any accList $ \ (c, q) ->
317 (c == "*" || c `noCaseEq` coding) && q /= Just 0)
320 -- |Get the header \"Content-Type\" as
321 -- 'Network.HTTP.Lucu.MIMEType.MIMEType'.
322 getContentType :: Resource (Maybe MIMEType)
324 = do cTypeM <- getHeader "Content-Type"
329 -> case parseStr mimeTypeP cType of
330 (Success t, _) -> return $ Just t
331 _ -> abort BadRequest []
332 (Just $ "Unparsable Content-Type: " ++ cType)
335 {- ExaminingRequest 時に使用するアクション群 -}
337 -- |Tell the system that the 'Resource' found an entity for the
338 -- request URI. If this is a GET or HEAD request, a found entity means
339 -- a datum to be replied. If this is a PUT or DELETE request, it means
340 -- a datum which was stored for the URI up to now. It is an error to
341 -- compute 'foundEntity' if this is a POST request.
343 -- Computation of 'foundEntity' performs \"If-Match\" test or
344 -- \"If-None-Match\" test if possible. When those tests fail, the
345 -- computation of 'Resource' immediately aborts with status \"412
346 -- Precondition Failed\" or \"304 Not Modified\" depending on the
349 -- If this is a GET or HEAD request, 'foundEntity' automatically puts
350 -- \"ETag\" and \"Last-Modified\" headers into the response.
351 foundEntity :: ETag -> ClockTime -> Resource ()
352 foundEntity tag timeStamp
353 = tag `seq` timeStamp `seq`
354 do driftTo ExaminingRequest
357 when (method == GET || method == HEAD)
358 $ setHeader' "Last-Modified" $! formatHTTPDateTime timeStamp
359 when (method == POST)
360 $ abort InternalServerError []
361 (Just "Illegal computation of foundEntity for POST request.")
366 -- |Tell the system that the 'Resource' found an entity for the
367 -- request URI. The only difference from 'foundEntity' is that
368 -- 'foundETag' doesn't (and can't) put \"Last-Modified\" header into
371 -- This action is not preferred. You should use 'foundEntity' when
373 foundETag :: ETag -> Resource ()
376 do driftTo ExaminingRequest
379 when (method == GET || method == HEAD)
380 $ setHeader' "ETag" $! show tag
381 when (method == POST)
382 $ abort InternalServerError []
383 (Just "Illegal computation of foundETag for POST request.")
385 -- If-Match があればそれを見る。
386 ifMatch <- getHeader "If-Match"
389 Just "*" -> return ()
390 Just list -> case parseStr eTagListP list of
392 -- tags の中に一致するものが無ければ
393 -- PreconditionFailed で終了。
394 -> when (not $ any (== tag) tags)
395 $ abort PreconditionFailed []
396 $! Just ("The entity tag doesn't match: " ++ list)
397 _ -> abort BadRequest [] $! Just ("Unparsable If-Match: " ++ fromJust ifMatch)
399 let statusForNoneMatch = if method == GET || method == HEAD then
404 -- If-None-Match があればそれを見る。
405 ifNoneMatch <- getHeader "If-None-Match"
408 Just "*" -> abort statusForNoneMatch [] $! Just ("The entity tag matches: *")
409 Just list -> case parseStr eTagListP list of
411 -> when (any (== tag) tags)
412 $ abort statusForNoneMatch [] $! Just ("The entity tag matches: " ++ list)
413 _ -> abort BadRequest [] $! Just ("Unparsable If-None-Match: " ++ list)
417 -- |Tell the system that the 'Resource' found an entity for the
418 -- request URI. The only difference from 'foundEntity' is that
419 -- 'foundTimeStamp' performs \"If-Modified-Since\" test or
420 -- \"If-Unmodified-Since\" test instead of \"If-Match\" test or
421 -- \"If-None-Match\" test. Be aware that any tests based on last
422 -- modification time are unsafe because it is possible to mess up such
423 -- tests by modifying the entity twice in a second.
425 -- This action is not preferred. You should use 'foundEntity' when
427 foundTimeStamp :: ClockTime -> Resource ()
428 foundTimeStamp timeStamp
430 do driftTo ExaminingRequest
433 when (method == GET || method == HEAD)
434 $ setHeader' "Last-Modified" $! formatHTTPDateTime timeStamp
435 when (method == POST)
436 $ abort InternalServerError []
437 (Just "Illegal computation of foundTimeStamp for POST request.")
439 let statusForIfModSince = if method == GET || method == HEAD then
444 -- If-Modified-Since があればそれを見る。
445 ifModSince <- getHeader "If-Modified-Since"
447 Just str -> case parseHTTPDateTime str of
449 -> when (timeStamp <= lastTime)
450 $ abort statusForIfModSince []
451 $! Just ("The entity has not been modified since " ++ str)
453 -> return () -- 不正な時刻は無視
456 -- If-Unmodified-Since があればそれを見る。
457 ifUnmodSince <- getHeader "If-Unmodified-Since"
459 Just str -> case parseHTTPDateTime str of
461 -> when (timeStamp > lastTime)
462 $ abort PreconditionFailed []
463 $! Just ("The entity has not been modified since " ++ str)
465 -> return () -- 不正な時刻は無視
470 -- | Computation of @'foundNoEntity' mStr@ tells the system that the
471 -- 'Resource' found no entity for the request URI. @mStr@ is an
472 -- optional error message to be replied to the client.
474 -- If this is a PUT request, 'foundNoEntity' performs \"If-Match\"
475 -- test and aborts with status \"412 Precondition Failed\" when it
476 -- failed. If this is a GET, HEAD, POST or DELETE request,
477 -- 'foundNoEntity' always aborts with status \"404 Not Found\".
478 foundNoEntity :: Maybe String -> Resource ()
481 do driftTo ExaminingRequest
485 $ abort NotFound [] msgM
487 -- エンティティが存在しないと云ふ事は、"*" も含めたどのやうな
488 -- If-Match: 條件も滿たさない。
489 ifMatch <- getHeader "If-Match"
490 when (ifMatch /= Nothing)
491 $ abort PreconditionFailed [] msgM
496 {- GettingBody 時に使用するアクション群 -}
498 -- | Computation of @'input' limit@ attempts to read the request body
499 -- up to @limit@ bytes, and then make the 'Resource' transit to
500 -- /Deciding Header/ state. When the actual size of body is larger
501 -- than @limit@ bytes, computation of 'Resource' immediately aborts
502 -- with status \"413 Request Entity Too Large\". When the request has
503 -- no body, 'input' returns an empty string.
505 -- @limit@ may be less than or equal to zero. In this case, the
506 -- default limitation value
507 -- ('Network.HTTP.Lucu.Config.cnfMaxEntityLength') is used. See
510 -- Note that 'inputBS' is more efficient than 'input' so you should
511 -- use it whenever possible.
512 input :: Int -> Resource String
513 input limit = limit `seq`
514 inputBS limit >>= return . B.unpack
517 -- | This is mostly the same as 'input' but is more
518 -- efficient. 'inputBS' returns a lazy ByteString but it's not really
519 -- lazy: reading from the socket just happens at the computation of
520 -- 'inputBS', not at the lazy evaluation of the ByteString. The same
521 -- goes for 'inputChunkBS'.
522 inputBS :: Int -> Resource ByteString
525 do driftTo GettingBody
527 hasBody <- liftIO $! atomically $! readItr itr itrRequestHasBody id
528 chunk <- if hasBody then
531 do driftTo DecidingHeader
535 askForInput :: Interaction -> Resource ByteString
538 do let defaultLimit = cnfMaxEntityLength $ itrConfig itr
539 actualLimit = if limit <= 0 then
543 when (actualLimit <= 0)
544 $ fail ("inputBS: limit must be positive: " ++ show actualLimit)
547 $! do chunkLen <- readItr itr itrReqChunkLength id
548 writeItr itr itrWillReceiveBody True
549 if fmap (> actualLimit) chunkLen == Just True then
553 writeItr itr itrReqBodyWanted $ Just actualLimit
554 -- 應答を待つ。トランザクションを分けなければ當然デッドロック。
555 chunk <- liftIO $! atomically
556 $! do chunk <- readItr itr itrReceivedBody id
557 chunkIsOver <- readItr itr itrReqChunkIsOver id
558 if B.length chunk < fromIntegral actualLimit then
568 $ tooLarge actualLimit
569 -- 成功。itr 内にチャンクを置いたままにす
571 writeItr itr itrReceivedBody B.empty
573 driftTo DecidingHeader
576 tooLarge :: Int -> STM ()
577 tooLarge lim = lim `seq`
578 abortSTM RequestEntityTooLarge []
579 $! Just ("Request body must be smaller than "
580 ++ show lim ++ " bytes.")
582 -- | Computation of @'inputChunk' limit@ attempts to read a part of
583 -- request body up to @limit@ bytes. You can read any large request by
584 -- repeating computation of this action. When you've read all the
585 -- request body, 'inputChunk' returns an empty string and then make
586 -- the 'Resource' transit to /Deciding Header/ state.
588 -- @limit@ may be less than or equal to zero. In this case, the
589 -- default limitation value
590 -- ('Network.HTTP.Lucu.Config.cnfMaxEntityLength') is used. See
593 -- Note that 'inputChunkBS' is more efficient than 'inputChunk' so you
594 -- should use it whenever possible.
595 inputChunk :: Int -> Resource String
596 inputChunk limit = limit `seq`
597 inputChunkBS limit >>= return . B.unpack
600 -- | This is mostly the same as 'inputChunk' but is more
601 -- efficient. See 'inputBS'.
602 inputChunkBS :: Int -> Resource ByteString
605 do driftTo GettingBody
607 hasBody <- liftIO $ atomically $ readItr itr itrRequestHasBody id
608 chunk <- if hasBody then
611 do driftTo DecidingHeader
615 askForInput :: Interaction -> Resource ByteString
618 do let defaultLimit = cnfMaxEntityLength $! itrConfig itr
619 actualLimit = if limit < 0 then
623 when (actualLimit <= 0)
624 $ fail ("inputChunkBS: limit must be positive: " ++ show actualLimit)
627 $! do writeItr itr itrReqBodyWanted $! Just actualLimit
628 writeItr itr itrWillReceiveBody True
629 -- 應答を待つ。トランザクションを分けなければ當然デッドロック。
630 chunk <- liftIO $! atomically
631 $ do chunk <- readItr itr itrReceivedBody id
632 -- 要求された量に滿たなくて、まだ殘りがあ
634 when (B.length chunk < fromIntegral actualLimit)
635 $ do chunkIsOver <- readItr itr itrReqChunkIsOver id
639 writeItr itr itrReceivedBody B.empty
642 $ driftTo DecidingHeader
645 -- | Computation of @'inputForm' limit@ attempts to read the request
646 -- body with 'input' and parse it as
647 -- application\/x-www-form-urlencoded. If the request header
648 -- \"Content-Type\" is not application\/x-www-form-urlencoded,
649 -- 'inputForm' makes 'Resource' abort with status \"415 Unsupported
650 -- Media Type\". If the request has no \"Content-Type\", it aborts
651 -- with \"400 Bad Request\".
653 -- This action should also support multipart\/form-data somehow, but
654 -- it is not (yet) done.
655 inputForm :: Int -> Resource [(String, String)]
658 do cTypeM <- getContentType
661 -> abort BadRequest [] (Just "Missing Content-Type")
662 Just (MIMEType "application" "x-www-form-urlencoded" _)
663 -> readWWWFormURLEncoded
664 Just (MIMEType "multipart" "form-data" _)
665 -> readMultipartFormData
667 -> abort UnsupportedMediaType [] (Just $! "Unsupported media type: "
670 readWWWFormURLEncoded
671 = do src <- input limit
672 return $ parseWWWFormURLEncoded src
674 readMultipartFormData -- FIXME: 未對應
675 = abort UnsupportedMediaType []
676 (Just $! "Sorry, inputForm does not currently support multipart/form-data.")
678 -- | This is just a constant -1. It's better to say @'input'
679 -- 'defaultLimit'@ than to say @'input' (-1)@ but these are exactly
686 {- DecidingHeader 時に使用するアクション群 -}
688 -- | Set the response status code. If you omit to compute this action,
689 -- the status code will be defaulted to \"200 OK\".
690 setStatus :: StatusCode -> Resource ()
693 do driftTo DecidingHeader
695 liftIO $! atomically $! updateItr itr itrResponse
700 -- | Set a value of given resource header. Comparison of header name
701 -- is case-insensitive. Note that this action is not intended to be
702 -- used so frequently: there should be actions like 'setContentType'
703 -- for every common headers.
705 -- Some important headers (especially \"Content-Length\" and
706 -- \"Transfer-Encoding\") may be silently dropped or overwritten by
707 -- the system not to corrupt the interaction with client at the
708 -- viewpoint of HTTP protocol layer. For instance, if we are keeping
709 -- the connection alive, without this process it causes a catastrophe
710 -- to send a header \"Content-Length: 10\" and actually send a body of
711 -- 20 bytes long. In this case the client shall only accept the first
712 -- 10 bytes of response body and thinks that the residual 10 bytes is
713 -- a part of header of the next response.
714 setHeader :: String -> String -> Resource ()
716 = name `seq` value `seq`
717 driftTo DecidingHeader >> setHeader' name value
720 setHeader' :: String -> String -> Resource ()
721 setHeader' name value
722 = name `seq` value `seq`
725 $ updateItr itr itrResponse
726 $ H.setHeader name value
728 -- | Computation of @'redirect' code uri@ sets the response status to
729 -- @code@ and \"Location\" header to @uri@. @code@ must satisfy
730 -- 'Network.HTTP.Lucu.Response.isRedirection' or it causes an error.
731 redirect :: StatusCode -> URI -> Resource ()
733 = code `seq` uri `seq`
734 do when (code == NotModified || not (isRedirection code))
735 $ abort InternalServerError []
736 $! Just ("Attempted to redirect with status " ++ show code)
739 {-# INLINE redirect #-}
742 -- | Computation of @'setContentType' mType@ sets the response header
743 -- \"Content-Type\" to @mType@.
744 setContentType :: MIMEType -> Resource ()
746 = setHeader "Content-Type" $! show mType
748 -- | Computation of @'setLocation' uri@ sets the response header
749 -- \"Location\" to @uri@.
750 setLocation :: URI -> Resource ()
752 = setHeader "Location" $ uriToString id uri $ ""
754 -- |Computation of @'setContentEncoding' codings@ sets the response
755 -- header \"Content-Encoding\" to @codings@.
756 setContentEncoding :: [String] -> Resource ()
757 setContentEncoding codings
758 = do ver <- getRequestVersion
760 HttpVersion 1 0 -> unnormalizeCoding
761 HttpVersion 1 1 -> id
762 setHeader "Content-Encoding" $ joinWith ", " $ map tr codings
765 {- DecidingBody 時に使用するアクション群 -}
767 -- | Computation of @'output' str@ writes @str@ as a response body,
768 -- and then make the 'Resource' transit to /Done/ state. It is safe to
769 -- apply 'output' to an infinite string, such as a lazy stream of
772 -- Note that 'outputBS' is more efficient than 'output' so you should
773 -- use it whenever possible.
774 output :: String -> Resource ()
775 output str = outputBS $! B.pack str
776 {-# INLINE output #-}
778 -- | This is mostly the same as 'output' but is more efficient.
779 outputBS :: ByteString -> Resource ()
780 outputBS str = do outputChunkBS str
782 {-# INLINE outputBS #-}
784 -- | Computation of @'outputChunk' str@ writes @str@ as a part of
785 -- response body. You can compute this action multiple times to write
786 -- a body little at a time. It is safe to apply 'outputChunk' to an
789 -- Note that 'outputChunkBS' is more efficient than 'outputChunk' so
790 -- you should use it whenever possible.
791 outputChunk :: String -> Resource ()
792 outputChunk str = outputChunkBS $! B.pack str
793 {-# INLINE outputChunk #-}
795 -- | This is mostly the same as 'outputChunk' but is more efficient.
796 outputChunkBS :: ByteString -> Resource ()
799 do driftTo DecidingBody
802 let limit = cnfMaxOutputChunkLength $ itrConfig itr
804 $ fail ("cnfMaxOutputChunkLength must be positive: "
807 discardBody <- liftIO $ atomically $
808 readItr itr itrWillDiscardBody id
811 $ sendChunks str limit
814 $ liftIO $ atomically $
815 writeItr itr itrBodyIsNull False
817 {- チャンクの大きさは Config で制限されてゐる。もし例へば
818 /dev/zero を B.readFile して作った ByteString をそのまま
819 ResponseWriter に渡したりすると大變な事が起こる。何故なら
820 ResponseWriter はTransfer-Encoding: chunked の時、ヘッダを書く
821 爲にチャンクの大きさを測るから、その時に起こるであらう事は言ふ
823 sendChunks :: ByteString -> Int -> Resource ()
825 | B.null str = return ()
826 | otherwise = do let (chunk, remaining) = B.splitAt (fromIntegral limit) str
828 liftIO $ atomically $
829 do buf <- readItr itr itrBodyToSend id
832 writeItr itr itrBodyToSend chunk
837 sendChunks remaining limit
841 [GettingBody からそれ以降の状態に遷移する時]
843 body を讀み終へてゐなければ、殘りの body を讀み捨てる。
846 [DecidingHeader からそれ以降の状態に遷移する時]
853 bodyIsNull が False ならば何もしない。True だった場合は出力補完す
858 driftTo :: InteractionState -> Resource ()
862 liftIO $ atomically $ do oldState <- readItr itr itrState id
863 if newState < oldState then
864 throwStateError oldState newState
866 do let a = [oldState .. newState]
869 mapM_ (uncurry $ drift itr) c
870 writeItr itr itrState newState
872 throwStateError :: Monad m => InteractionState -> InteractionState -> m a
874 throwStateError Done DecidingBody
875 = fail "It makes no sense to output something after finishing to output."
877 throwStateError old new
878 = fail ("state error: " ++ show old ++ " ==> " ++ show new)
881 drift :: Interaction -> InteractionState -> InteractionState -> STM ()
883 drift itr GettingBody _
884 = writeItr itr itrReqBodyWasteAll True
886 drift itr DecidingHeader _
890 = do bodyIsNull <- readItr itr itrBodyIsNull id
892 $ writeDefaultPage itr