3 -- |This is the Resource Monad; monadic actions to define the behavior
4 -- of each resources. The 'Resource' Monad is a kind of 'Prelude.IO'
5 -- Monad thus it implements 'Control.Monad.Trans.MonadIO' class. It is
6 -- also a state machine.
8 -- Request Processing Flow:
10 -- 1. A client issues an HTTP request.
12 -- 2. If the URI of it matches to any resource, the corresponding
13 -- 'Resource' Monad starts running on a newly spawned thread.
15 -- 3. The 'Resource' Monad looks at the request header, find (or not
16 -- find) an entity, receive the request body (if any), decide the
17 -- response header, and decide the response body. This process
18 -- will be discussed later.
20 -- 4. The 'Resource' Monad and its thread stops running. The client
21 -- may or may not be sending us the next request at this point.
23 -- 'Resource' Monad takes the following states. The initial state is
24 -- /Examining Request/ and the final state is /Done/.
26 -- [/Examining Request/] In this state, a 'Resource' looks at the
27 -- request header and thinks about an entity for it. If there is a
28 -- suitable entity, the 'Resource' tells the system an entity tag
29 -- and its last modification time ('foundEntity'). If it found no
30 -- entity, it tells the system so ('foundNoEntity'). In case it is
31 -- impossible to decide the existence of entity, which is a typical
32 -- case for POST requests, 'Resource' does nothing in this state.
34 -- [/Getting Body/] A 'Resource' asks the system to receive a
35 -- request body from client. Before actually reading from the
36 -- socket, the system sends \"100 Continue\" to the client if need
37 -- be. When a 'Resource' transits to the next state without
38 -- receiving all or part of request body, the system still reads it
39 -- and just throws it away.
41 -- [/Deciding Header/] A 'Resource' makes a decision of status code
42 -- and response header. When it transits to the next state, the
43 -- system checks the validness of response header and then write
44 -- them to the socket.
46 -- [/Deciding Body/] In this state, a 'Resource' asks the system to
47 -- write some response body to the socket. When it transits to the
48 -- next state without writing any response body, the system
49 -- completes it depending on the status code.
51 -- [/Done/] Everything is over. A 'Resource' can do nothing for the
52 -- HTTP interaction anymore.
54 -- Note that the state transition is one-way: for instance, it is an
55 -- error to try to read a request body after writing some
56 -- response. This limitation is for efficiency. We don't want to read
57 -- the entire request before starting 'Resource', nor we don't want to
58 -- postpone writing the entire response till the end of 'Resource'
61 module Network.HTTP.Lucu.Resource
69 -- ** Getting request header
71 -- |These actions can be computed regardless of the current state,
72 -- and they don't change the state.
86 , isEncodingAcceptable
90 -- ** Finding an entity
92 -- |These actions can be computed only in the /Examining Request/
93 -- state. After the computation, the 'Resource' transits to
94 -- /Getting Body/ state.
100 -- ** Getting a request body
102 -- |Computation of these actions changes the state to /Getting
111 -- ** Setting response headers
113 -- |Computation of these actions changes the state to /Deciding
123 -- ** Writing a response body
125 -- |Computation of these actions changes the state to /Deciding
136 import Control.Concurrent.STM
137 import Control.Monad.Reader
139 import qualified Data.ByteString as Strict (ByteString)
140 import qualified Data.ByteString.Lazy as Lazy (ByteString)
141 import qualified Data.ByteString.Char8 as C8 hiding (ByteString)
142 import qualified Data.ByteString.Lazy.Char8 as L8 hiding (ByteString)
147 import Network.HTTP.Lucu.Abortion
148 import Network.HTTP.Lucu.Authorization
149 import Network.HTTP.Lucu.Config
150 import Network.HTTP.Lucu.ContentCoding
151 import Network.HTTP.Lucu.DefaultPage
152 import Network.HTTP.Lucu.ETag
153 import qualified Network.HTTP.Lucu.Headers as H
154 import Network.HTTP.Lucu.HttpVersion
155 import Network.HTTP.Lucu.Interaction
156 import Network.HTTP.Lucu.MultipartForm
157 import Network.HTTP.Lucu.Parser
158 import Network.HTTP.Lucu.Postprocess
159 import Network.HTTP.Lucu.RFC1123DateTime
160 import Network.HTTP.Lucu.Request
161 import Network.HTTP.Lucu.Response
162 import Network.HTTP.Lucu.MIMEType
163 import Network.HTTP.Lucu.Utils
164 import Network.Socket hiding (accept)
165 import Network.URI hiding (path)
167 -- |The 'Resource' monad. This monad implements
168 -- 'Control.Monad.Trans.MonadIO' so it can do any 'Prelude.IO'
170 newtype Resource a = Resource { unRes :: ReaderT Interaction IO a }
172 instance Functor Resource where
173 fmap f c = Resource (fmap f (unRes c))
175 instance Monad Resource where
176 c >>= f = Resource (unRes c >>= unRes . f)
177 return = Resource . return
178 fail = Resource . fail
180 instance MonadIO Resource where
181 liftIO = Resource . liftIO
184 runRes :: Resource a -> Interaction -> IO a
186 = runReaderT (unRes r) itr
189 getInteraction :: Resource Interaction
190 getInteraction = Resource ask
193 -- |Get the 'Network.HTTP.Lucu.Config.Config' value which is used for
195 getConfig :: Resource Config
196 getConfig = do itr <- getInteraction
197 return $! itrConfig itr
200 -- |Get the 'Network.Socket.SockAddr' of the remote host. If you want
201 -- a string representation instead of 'Network.Socket.SockAddr', use
203 getRemoteAddr :: Resource SockAddr
204 getRemoteAddr = do itr <- getInteraction
205 return $! itrRemoteAddr itr
208 -- |Get the string representation of the address of remote host. If
209 -- you want a 'Network.Socket.SockAddr' instead of 'Prelude.String',
210 -- use 'getRemoteAddr'.
211 getRemoteAddr' :: Resource String
212 getRemoteAddr' = do addr <- getRemoteAddr
214 -- Network.Socket は IPv6 を考慮してゐないやうだ…
215 SockAddrInet _ v4addr
216 -> let b1 = (v4addr `shiftR` 24) .&. 0xFF
217 b2 = (v4addr `shiftR` 16) .&. 0xFF
218 b3 = (v4addr `shiftR` 8) .&. 0xFF
221 return $ concat $ intersperse "." $ map show [b1, b2, b3, b4]
228 -- |Get the 'Network.HTTP.Lucu.Request.Request' value which represents
229 -- the request header. In general you don't have to use this action.
230 getRequest :: Resource Request
231 getRequest = do itr <- getInteraction
232 req <- liftIO $! atomically $! readItr itr itrRequest fromJust
235 -- |Get the 'Network.HTTP.Lucu.Request.Method' value of the request.
236 getMethod :: Resource Method
237 getMethod = do req <- getRequest
238 return $! reqMethod req
240 -- |Get the URI of the request.
241 getRequestURI :: Resource URI
242 getRequestURI = do req <- getRequest
245 -- |Get the HTTP version of the request.
246 getRequestVersion :: Resource HttpVersion
247 getRequestVersion = do req <- getRequest
248 return $! reqVersion req
250 -- |Get the path of this 'Resource' (to be exact,
251 -- 'Network.HTTP.Lucu.Resource.Tree.ResourceDef') in the
252 -- 'Network.HTTP.Lucu.Resource.Tree.ResTree'. The result of this
253 -- action is the exact path in the tree even if the
254 -- 'Network.HTTP.Lucu.Resource.Tree.ResourceDef' is greedy.
258 -- > main = let tree = mkResTree [ (["foo"], resFoo) ]
259 -- > in runHttpd defaultConfig tree
261 -- > resFoo = ResourceDef {
262 -- > resIsGreedy = True
263 -- > , resGet = Just $ do requestURI <- getRequestURI
264 -- > resourcePath <- getResourcePath
265 -- > pathInfo <- getPathInfo
266 -- > -- uriPath requestURI == "/foo/bar/baz"
267 -- > -- resourcePath == ["foo"]
268 -- > -- pathInfo == ["bar", "baz"]
272 getResourcePath :: Resource [String]
273 getResourcePath = do itr <- getInteraction
274 return $! fromJust $! itrResourcePath itr
277 -- |This is an analogy of CGI PATH_INFO. Its result is always @[]@ if
278 -- the 'Network.HTTP.Lucu.Resource.Tree.ResourceDef' is not
279 -- greedy. See 'getResourcePath'.
280 getPathInfo :: Resource [String]
281 getPathInfo = do rsrcPath <- getResourcePath
283 let reqPathStr = uriPath uri
284 reqPath = [x | x <- splitBy (== '/') reqPathStr, x /= ""]
285 -- rsrcPath と reqPath の共通する先頭部分を reqPath か
286 -- ら全部取り除くと、それは PATH_INFO のやうなものにな
287 -- る。rsrcPath は全部一致してゐるに決まってゐる(でな
288 -- ければこの Resource が撰ばれた筈が無い)ので、
289 -- rsrcPath の長さの分だけ削除すれば良い。
290 return $! drop (length rsrcPath) reqPath
292 -- | Assume the query part of request URI as
293 -- application\/x-www-form-urlencoded, and parse it. This action
294 -- doesn't parse the request body. See 'inputForm'.
295 getQueryForm :: Resource [(String, String)]
296 getQueryForm = do uri <- getRequestURI
297 return $! parseWWWFormURLEncoded $ snd $ splitAt 1 $ uriQuery uri
299 -- |Get a value of given request header. Comparison of header name is
300 -- case-insensitive. Note that this action is not intended to be used
301 -- so frequently: there should be actions like 'getContentType' for
302 -- every common headers.
303 getHeader :: Strict.ByteString -> Resource (Maybe Strict.ByteString)
304 getHeader name = name `seq`
306 return $! H.getHeader name req
308 -- |Get a list of 'Network.HTTP.Lucu.MIMEType.MIMEType' enumerated on
309 -- header \"Accept\".
310 getAccept :: Resource [MIMEType]
311 getAccept = do acceptM <- getHeader (C8.pack "Accept")
316 -> case parse mimeTypeListP (L8.fromChunks [accept]) of
317 (# Success xs, _ #) -> return xs
318 (# _ , _ #) -> abort BadRequest []
319 (Just $ "Unparsable Accept: " ++ C8.unpack accept)
321 -- |Get a list of @(contentCoding, qvalue)@ enumerated on header
322 -- \"Accept-Encoding\". The list is sorted in descending order by
324 getAcceptEncoding :: Resource [(String, Maybe Double)]
326 = do accEncM <- getHeader (C8.pack "Accept-Encoding")
329 -- HTTP/1.0 には Accept-Encoding が無い場合の規定が無い
330 -- ので安全の爲 identity が指定された事にする。HTTP/1.1
331 -- の場合は何でも受け入れて良い事になってゐるので "*" が
333 -> do ver <- getRequestVersion
335 HttpVersion 1 0 -> return [("identity", Nothing)]
336 HttpVersion 1 1 -> return [("*" , Nothing)]
339 -> if C8.null value then
341 return [("identity", Nothing)]
343 case parse acceptEncodingListP (L8.fromChunks [value]) of
344 (# Success x, _ #) -> return $ reverse $ sortBy orderAcceptEncodings x
345 (# _ , _ #) -> abort BadRequest []
346 (Just $ "Unparsable Accept-Encoding: " ++ C8.unpack value)
348 -- |Check whether a given content-coding is acceptable.
349 isEncodingAcceptable :: String -> Resource Bool
350 isEncodingAcceptable coding
351 = do accList <- getAcceptEncoding
352 return (flip any accList $ \ (c, q) ->
353 (c == "*" || C8.pack c `H.noCaseEq` C8.pack coding) && q /= Just 0)
356 -- |Get the header \"Content-Type\" as
357 -- 'Network.HTTP.Lucu.MIMEType.MIMEType'.
358 getContentType :: Resource (Maybe MIMEType)
360 = do cTypeM <- getHeader (C8.pack "Content-Type")
365 -> case parse mimeTypeP (L8.fromChunks [cType]) of
366 (# Success t, _ #) -> return $ Just t
367 (# _ , _ #) -> abort BadRequest []
368 (Just $ "Unparsable Content-Type: " ++ C8.unpack cType)
371 -- |Get the header \"Authorization\" as
372 -- 'Network.HTTP.Lucu.Authorization.AuthCredential'.
373 getAuthorization :: Resource (Maybe AuthCredential)
375 = do authM <- getHeader (C8.pack "Authorization")
380 -> case parse authCredentialP (L8.fromChunks [auth]) of
381 (# Success a, _ #) -> return $ Just a
382 (# _ , _ #) -> return Nothing
385 {- ExaminingRequest 時に使用するアクション群 -}
387 -- |Tell the system that the 'Resource' found an entity for the
388 -- request URI. If this is a GET or HEAD request, a found entity means
389 -- a datum to be replied. If this is a PUT or DELETE request, it means
390 -- a datum which was stored for the URI up to now. It is an error to
391 -- compute 'foundEntity' if this is a POST request.
393 -- Computation of 'foundEntity' performs \"If-Match\" test or
394 -- \"If-None-Match\" test if possible. When those tests fail, the
395 -- computation of 'Resource' immediately aborts with status \"412
396 -- Precondition Failed\" or \"304 Not Modified\" depending on the
399 -- If this is a GET or HEAD request, 'foundEntity' automatically puts
400 -- \"ETag\" and \"Last-Modified\" headers into the response.
401 foundEntity :: ETag -> UTCTime -> Resource ()
402 foundEntity tag timeStamp
403 = tag `seq` timeStamp `seq`
404 do driftTo ExaminingRequest
407 when (method == GET || method == HEAD)
408 $ setHeader' (C8.pack "Last-Modified") (C8.pack $ formatHTTPDateTime timeStamp)
409 when (method == POST)
410 $ abort InternalServerError []
411 (Just "Illegal computation of foundEntity for POST request.")
416 -- |Tell the system that the 'Resource' found an entity for the
417 -- request URI. The only difference from 'foundEntity' is that
418 -- 'foundETag' doesn't (and can't) put \"Last-Modified\" header into
421 -- This action is not preferred. You should use 'foundEntity' whenever
423 foundETag :: ETag -> Resource ()
426 do driftTo ExaminingRequest
429 when (method == GET || method == HEAD)
430 $ setHeader' (C8.pack "ETag") (C8.pack $ show tag)
431 when (method == POST)
432 $ abort InternalServerError []
433 (Just "Illegal computation of foundETag for POST request.")
435 -- If-Match があればそれを見る。
436 ifMatch <- getHeader (C8.pack "If-Match")
439 Just value -> if value == C8.pack "*" then
442 case parse eTagListP (L8.fromChunks [value]) of
443 (# Success tags, _ #)
444 -- tags の中に一致するものが無ければ
445 -- PreconditionFailed で終了。
446 -> when (not $ any (== tag) tags)
447 $ abort PreconditionFailed []
448 $! Just ("The entity tag doesn't match: " ++ C8.unpack value)
450 -> abort BadRequest [] $! Just ("Unparsable If-Match: " ++ C8.unpack value)
452 let statusForNoneMatch = if method == GET || method == HEAD then
457 -- If-None-Match があればそれを見る。
458 ifNoneMatch <- getHeader (C8.pack "If-None-Match")
461 Just value -> if value == C8.pack "*" then
462 abort statusForNoneMatch [] $! Just ("The entity tag matches: *")
464 case parse eTagListP (L8.fromChunks [value]) of
465 (# Success tags, _ #)
466 -> when (any (== tag) tags)
467 $ abort statusForNoneMatch [] $! Just ("The entity tag matches: " ++ C8.unpack value)
469 -> abort BadRequest [] $! Just ("Unparsable If-None-Match: " ++ C8.unpack value)
473 -- |Tell the system that the 'Resource' found an entity for the
474 -- request URI. The only difference from 'foundEntity' is that
475 -- 'foundTimeStamp' performs \"If-Modified-Since\" test or
476 -- \"If-Unmodified-Since\" test instead of \"If-Match\" test or
477 -- \"If-None-Match\" test. Be aware that any tests based on last
478 -- modification time are unsafe because it is possible to mess up such
479 -- tests by modifying the entity twice in a second.
481 -- This action is not preferred. You should use 'foundEntity' whenever
483 foundTimeStamp :: UTCTime -> Resource ()
484 foundTimeStamp timeStamp
486 do driftTo ExaminingRequest
489 when (method == GET || method == HEAD)
490 $ setHeader' (C8.pack "Last-Modified") (C8.pack $ formatHTTPDateTime timeStamp)
491 when (method == POST)
492 $ abort InternalServerError []
493 (Just "Illegal computation of foundTimeStamp for POST request.")
495 let statusForIfModSince = if method == GET || method == HEAD then
500 -- If-Modified-Since があればそれを見る。
501 ifModSince <- getHeader (C8.pack "If-Modified-Since")
503 Just str -> case parseHTTPDateTime (L8.fromChunks [str]) of
505 -> when (timeStamp <= lastTime)
506 $ abort statusForIfModSince []
507 $! Just ("The entity has not been modified since " ++ C8.unpack str)
509 -> return () -- 不正な時刻は無視
512 -- If-Unmodified-Since があればそれを見る。
513 ifUnmodSince <- getHeader (C8.pack "If-Unmodified-Since")
515 Just str -> case parseHTTPDateTime (L8.fromChunks [str]) of
517 -> when (timeStamp > lastTime)
518 $ abort PreconditionFailed []
519 $! Just ("The entity has not been modified since " ++ C8.unpack str)
521 -> return () -- 不正な時刻は無視
526 -- | Computation of @'foundNoEntity' mStr@ tells the system that the
527 -- 'Resource' found no entity for the request URI. @mStr@ is an
528 -- optional error message to be replied to the client.
530 -- If this is a PUT request, 'foundNoEntity' performs \"If-Match\"
531 -- test and aborts with status \"412 Precondition Failed\" when it
532 -- failed. If this is a GET, HEAD, POST or DELETE request,
533 -- 'foundNoEntity' always aborts with status \"404 Not Found\".
534 foundNoEntity :: Maybe String -> Resource ()
537 do driftTo ExaminingRequest
541 $ abort NotFound [] msgM
543 -- エンティティが存在しないと云ふ事は、"*" も含めたどのやうな
544 -- If-Match: 條件も滿たさない。
545 ifMatch <- getHeader (C8.pack "If-Match")
546 when (ifMatch /= Nothing)
547 $ abort PreconditionFailed [] msgM
552 {- GettingBody 時に使用するアクション群 -}
554 -- | Computation of @'input' limit@ attempts to read the request body
555 -- up to @limit@ bytes, and then make the 'Resource' transit to
556 -- /Deciding Header/ state. When the actual size of body is larger
557 -- than @limit@ bytes, computation of 'Resource' immediately aborts
558 -- with status \"413 Request Entity Too Large\". When the request has
559 -- no body, 'input' returns an empty string.
561 -- @limit@ may be less than or equal to zero. In this case, the
562 -- default limitation value
563 -- ('Network.HTTP.Lucu.Config.cnfMaxEntityLength') is used. See
566 -- Note that 'inputLBS' is more efficient than 'input' so you should
567 -- use it whenever possible.
568 input :: Int -> Resource String
569 input limit = limit `seq`
570 inputLBS limit >>= return . L8.unpack
573 -- | This is mostly the same as 'input' but is more
574 -- efficient. 'inputLBS' returns a 'Data.ByteString.Lazy.ByteString'
575 -- but it's not really lazy: reading from the socket just happens at
576 -- the computation of 'inputLBS', not at the evaluation of the
577 -- 'Data.ByteString.Lazy.ByteString'. The same goes for
579 inputLBS :: Int -> Resource Lazy.ByteString
582 do driftTo GettingBody
583 itr <- getInteraction
584 hasBody <- liftIO $! atomically $! readItr itr itrRequestHasBody id
585 chunk <- if hasBody then
588 do driftTo DecidingHeader
592 askForInput :: Interaction -> Resource Lazy.ByteString
595 do let confLimit = cnfMaxEntityLength $ itrConfig itr
596 actualLimit = if limit <= 0 then
600 when (actualLimit <= 0)
601 $ fail ("inputLBS: limit must be positive: " ++ show actualLimit)
604 $! do chunkLen <- readItr itr itrReqChunkLength id
605 writeItr itr itrWillReceiveBody True
606 if fmap (> actualLimit) chunkLen == Just True then
610 writeItr itr itrReqBodyWanted $ Just actualLimit
611 -- 應答を待つ。トランザクションを分けなければ當然デッドロック。
612 chunk <- liftIO $! atomically
613 $! do chunk <- readItr itr itrReceivedBody id
614 chunkIsOver <- readItr itr itrReqChunkIsOver id
615 if L8.length chunk < fromIntegral actualLimit then
625 $ tooLarge actualLimit
626 -- 成功。itr 内にチャンクを置いたままにす
628 writeItr itr itrReceivedBody L8.empty
630 driftTo DecidingHeader
633 tooLarge :: Int -> STM ()
634 tooLarge lim = lim `seq`
635 abortSTM RequestEntityTooLarge []
636 $! Just ("Request body must be smaller than "
637 ++ show lim ++ " bytes.")
639 -- | Computation of @'inputChunk' limit@ attempts to read a part of
640 -- request body up to @limit@ bytes. You can read any large request by
641 -- repeating computation of this action. When you've read all the
642 -- request body, 'inputChunk' returns an empty string and then make
643 -- the 'Resource' transit to /Deciding Header/ state.
645 -- @limit@ may be less than or equal to zero. In this case, the
646 -- default limitation value
647 -- ('Network.HTTP.Lucu.Config.cnfMaxEntityLength') is used. See
650 -- Note that 'inputChunkLBS' is more efficient than 'inputChunk' so you
651 -- should use it whenever possible.
652 inputChunk :: Int -> Resource String
653 inputChunk limit = limit `seq`
654 inputChunkLBS limit >>= return . L8.unpack
657 -- | This is mostly the same as 'inputChunk' but is more
658 -- efficient. See 'inputLBS'.
659 inputChunkLBS :: Int -> Resource Lazy.ByteString
662 do driftTo GettingBody
663 itr <- getInteraction
664 hasBody <- liftIO $ atomically $ readItr itr itrRequestHasBody id
665 chunk <- if hasBody then
668 do driftTo DecidingHeader
672 askForInput :: Interaction -> Resource Lazy.ByteString
675 do let confLimit = cnfMaxEntityLength $! itrConfig itr
676 actualLimit = if limit < 0 then
680 when (actualLimit <= 0)
681 $ fail ("inputChunkLBS: limit must be positive: " ++ show actualLimit)
684 $! do writeItr itr itrReqBodyWanted $! Just actualLimit
685 writeItr itr itrWillReceiveBody True
686 -- 應答を待つ。トランザクションを分けなければ當然デッドロック。
687 chunk <- liftIO $! atomically
688 $ do chunk <- readItr itr itrReceivedBody id
689 -- 要求された量に滿たなくて、まだ殘りがあ
691 when (L8.length chunk < fromIntegral actualLimit)
692 $ do chunkIsOver <- readItr itr itrReqChunkIsOver id
696 writeItr itr itrReceivedBody L8.empty
699 $ driftTo DecidingHeader
702 -- | Computation of @'inputForm' limit@ attempts to read the request
703 -- body with 'input' and parse it as
704 -- application\/x-www-form-urlencoded or multipart\/form-data. If the
705 -- request header \"Content-Type\" is neither of them, 'inputForm'
706 -- makes 'Resource' abort with status \"415 Unsupported Media
707 -- Type\". If the request has no \"Content-Type\", it aborts with
708 -- \"400 Bad Request\".
709 inputForm :: Int -> Resource [(String, String)]
712 do cTypeM <- getContentType
715 -> abort BadRequest [] (Just "Missing Content-Type")
716 Just (MIMEType "application" "x-www-form-urlencoded" _)
717 -> readWWWFormURLEncoded
718 Just (MIMEType "multipart" "form-data" params)
719 -> readMultipartFormData params
721 -> abort UnsupportedMediaType [] (Just $! "Unsupported media type: "
724 readWWWFormURLEncoded
725 = do src <- input limit
726 return $ parseWWWFormURLEncoded src
728 readMultipartFormData params
729 = do case find ((== "boundary") . map toLower . fst) params of
731 -> abort BadRequest [] (Just "Missing boundary of multipart/form-data")
733 -> do src <- inputLBS limit
734 case parse (multipartFormP boundary) src of
735 (# Success pairs, _ #) -> return pairs
737 -> abort BadRequest [] (Just "Unparsable multipart/form-data")
739 -- | This is just a constant @-1@. It's better to say @'input'
740 -- 'defaultLimit'@ than to say @'input' (-1)@ but these are exactly
747 {- DecidingHeader 時に使用するアクション群 -}
749 -- | Set the response status code. If you omit to compute this action,
750 -- the status code will be defaulted to \"200 OK\".
751 setStatus :: StatusCode -> Resource ()
754 do driftTo DecidingHeader
755 itr <- getInteraction
756 liftIO $! atomically $! updateItr itr itrResponse
761 -- | Set a value of given resource header. Comparison of header name
762 -- is case-insensitive. Note that this action is not intended to be
763 -- used so frequently: there should be actions like 'setContentType'
764 -- for every common headers.
766 -- Some important headers (especially \"Content-Length\" and
767 -- \"Transfer-Encoding\") may be silently dropped or overwritten by
768 -- the system not to corrupt the interaction with client at the
769 -- viewpoint of HTTP protocol layer. For instance, if we are keeping
770 -- the connection alive, without this process it causes a catastrophe
771 -- to send a header \"Content-Length: 10\" and actually send a body of
772 -- 20 bytes long. In this case the client shall only accept the first
773 -- 10 bytes of response body and thinks that the residual 10 bytes is
774 -- a part of header of the next response.
775 setHeader :: Strict.ByteString -> Strict.ByteString -> Resource ()
777 = name `seq` value `seq`
778 driftTo DecidingHeader >> setHeader' name value
781 setHeader' :: Strict.ByteString -> Strict.ByteString -> Resource ()
782 setHeader' name value
783 = name `seq` value `seq`
784 do itr <- getInteraction
786 $ updateItr itr itrResponse
787 $ H.setHeader name value
789 -- | Computation of @'redirect' code uri@ sets the response status to
790 -- @code@ and \"Location\" header to @uri@. The @code@ must satisfy
791 -- 'Network.HTTP.Lucu.Response.isRedirection' or it causes an error.
792 redirect :: StatusCode -> URI -> Resource ()
794 = code `seq` uri `seq`
795 do when (code == NotModified || not (isRedirection code))
796 $ abort InternalServerError []
797 $! Just ("Attempted to redirect with status " ++ show code)
800 {-# INLINE redirect #-}
803 -- | Computation of @'setContentType' mType@ sets the response header
804 -- \"Content-Type\" to @mType@.
805 setContentType :: MIMEType -> Resource ()
807 = setHeader (C8.pack "Content-Type") (C8.pack $ show mType)
809 -- | Computation of @'setLocation' uri@ sets the response header
810 -- \"Location\" to @uri@.
811 setLocation :: URI -> Resource ()
813 = setHeader (C8.pack "Location") (C8.pack $ uriToString id uri $ "")
815 -- |Computation of @'setContentEncoding' codings@ sets the response
816 -- header \"Content-Encoding\" to @codings@.
817 setContentEncoding :: [String] -> Resource ()
818 setContentEncoding codings
819 = do ver <- getRequestVersion
821 HttpVersion 1 0 -> unnormalizeCoding
822 HttpVersion 1 1 -> id
824 setHeader (C8.pack "Content-Encoding") (C8.pack $ joinWith ", " $ map tr codings)
826 -- |Computation of @'setWWWAuthenticate' challenge@ sets the response
827 -- header \"WWW-Authenticate\" to @challenge@.
828 setWWWAuthenticate :: AuthChallenge -> Resource ()
829 setWWWAuthenticate challenge
830 = setHeader (C8.pack "WWW-Authenticate") (C8.pack $ show challenge)
833 {- DecidingBody 時に使用するアクション群 -}
835 -- | Computation of @'output' str@ writes @str@ as a response body,
836 -- and then make the 'Resource' transit to /Done/ state. It is safe to
837 -- apply 'output' to an infinite string, such as a lazy stream of
840 -- Note that 'outputLBS' is more efficient than 'output' so you should
841 -- use it whenever possible.
842 output :: String -> Resource ()
843 output str = outputLBS $! L8.pack str
844 {-# INLINE output #-}
846 -- | This is mostly the same as 'output' but is more efficient.
847 outputLBS :: Lazy.ByteString -> Resource ()
848 outputLBS str = do outputChunkLBS str
850 {-# INLINE outputLBS #-}
852 -- | Computation of @'outputChunk' str@ writes @str@ as a part of
853 -- response body. You can compute this action multiple times to write
854 -- a body little at a time. It is safe to apply 'outputChunk' to an
857 -- Note that 'outputChunkLBS' is more efficient than 'outputChunk' so
858 -- you should use it whenever possible.
859 outputChunk :: String -> Resource ()
860 outputChunk str = outputChunkLBS $! L8.pack str
861 {-# INLINE outputChunk #-}
863 -- | This is mostly the same as 'outputChunk' but is more efficient.
864 outputChunkLBS :: Lazy.ByteString -> Resource ()
865 outputChunkLBS wholeChunk
867 do driftTo DecidingBody
868 itr <- getInteraction
870 let limit = cnfMaxOutputChunkLength $ itrConfig itr
872 $ fail ("cnfMaxOutputChunkLength must be positive: "
875 discardBody <- liftIO $ atomically $
876 readItr itr itrWillDiscardBody id
879 $ sendChunks wholeChunk limit
881 unless (L8.null wholeChunk)
882 $ liftIO $ atomically $
883 writeItr itr itrBodyIsNull False
885 -- チャンクの大きさは Config で制限されてゐる。もし例へば
886 -- "/dev/zero" を L8.readFile して作った Lazy.ByteString をそのまま
887 -- ResponseWriter に渡したりすると大變な事が起こる。何故なら
888 -- ResponseWriter は Transfer-Encoding: chunked の時、ヘッダを書
890 sendChunks :: Lazy.ByteString -> Int -> Resource ()
892 | L8.null str = return ()
893 | otherwise = do let (chunk, remaining) = L8.splitAt (fromIntegral limit) str
894 itr <- getInteraction
895 liftIO $ atomically $
896 do buf <- readItr itr itrBodyToSend id
899 writeItr itr itrBodyToSend chunk
904 sendChunks remaining limit
908 [GettingBody からそれ以降の状態に遷移する時]
910 body を讀み終へてゐなければ、殘りの body を讀み捨てる。
913 [DecidingHeader からそれ以降の状態に遷移する時]
920 bodyIsNull が False ならば何もしない。True だった場合は出力補完す
925 driftTo :: InteractionState -> Resource ()
928 do itr <- getInteraction
929 liftIO $ atomically $ do oldState <- readItr itr itrState id
930 if newState < oldState then
931 throwStateError oldState newState
933 do let a = [oldState .. newState]
936 mapM_ (uncurry $ drift itr) c
937 writeItr itr itrState newState
939 throwStateError :: Monad m => InteractionState -> InteractionState -> m a
941 throwStateError Done DecidingBody
942 = fail "It makes no sense to output something after finishing to output."
944 throwStateError old new
945 = fail ("state error: " ++ show old ++ " ==> " ++ show new)
948 drift :: Interaction -> InteractionState -> InteractionState -> STM ()
950 drift itr GettingBody _
951 = writeItr itr itrReqBodyWasteAll True
953 drift itr DecidingHeader _
957 = do bodyIsNull <- readItr itr itrBodyIsNull id
959 $ writeDefaultPage itr