1 {-# OPTIONS_HADDOCK prune #-}
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.
77 , getRemoteCertificate
88 , isEncodingAcceptable
92 -- ** Finding an entity
94 -- |These actions can be computed only in the /Examining Request/
95 -- state. After the computation, the 'Resource' transits to
96 -- /Getting Body/ state.
102 -- ** Getting a request body
104 -- |Computation of these actions changes the state to /Getting
113 -- ** Setting response headers
115 -- |Computation of these actions changes the state to /Deciding
125 -- ** Writing a response body
127 -- |Computation of these actions changes the state to /Deciding
138 import Control.Concurrent.STM
139 import Control.Monad.Reader
140 import qualified Data.ByteString as Strict (ByteString)
141 import qualified Data.ByteString.Lazy as Lazy (ByteString)
142 import qualified Data.ByteString.Char8 as C8 hiding (ByteString)
143 import qualified Data.ByteString.Lazy.Char8 as L8 hiding (ByteString)
148 import Network.HTTP.Lucu.Abortion
149 import Network.HTTP.Lucu.Authorization
150 import Network.HTTP.Lucu.Config
151 import Network.HTTP.Lucu.ContentCoding
152 import Network.HTTP.Lucu.DefaultPage
153 import Network.HTTP.Lucu.ETag
154 import qualified Network.HTTP.Lucu.Headers as H
155 import Network.HTTP.Lucu.HttpVersion
156 import Network.HTTP.Lucu.Interaction
157 import Network.HTTP.Lucu.MultipartForm
158 import Network.HTTP.Lucu.Parser
159 import Network.HTTP.Lucu.Postprocess
160 import Network.HTTP.Lucu.RFC1123DateTime
161 import Network.HTTP.Lucu.Request
162 import Network.HTTP.Lucu.Response
163 import Network.HTTP.Lucu.MIMEType
164 import Network.HTTP.Lucu.Utils
165 import Network.Socket hiding (accept)
166 import Network.URI hiding (path)
169 -- |The 'Resource' monad. This monad implements
170 -- 'Control.Monad.Trans.MonadIO' so it can do any 'Prelude.IO'
172 newtype Resource a = Resource { unRes :: ReaderT Interaction IO a }
174 instance Functor Resource where
175 fmap f c = Resource (fmap f (unRes c))
177 instance Monad Resource where
178 c >>= f = Resource (unRes c >>= unRes . f)
179 return = Resource . return
180 fail = Resource . fail
182 instance MonadIO Resource where
183 liftIO = Resource . liftIO
186 runRes :: Resource a -> Interaction -> IO a
188 = runReaderT (unRes r) itr
191 getInteraction :: Resource Interaction
192 getInteraction = Resource ask
195 -- |Get the 'Network.HTTP.Lucu.Config.Config' value which is used for
197 getConfig :: Resource Config
198 getConfig = do itr <- getInteraction
199 return $! itrConfig itr
202 -- |Get the 'Network.Socket.SockAddr' of the remote host. If you want
203 -- a string representation instead of 'Network.Socket.SockAddr', use
205 getRemoteAddr :: Resource SockAddr
206 getRemoteAddr = do itr <- getInteraction
207 return $! itrRemoteAddr itr
210 -- |Get the string representation of the address of remote host. If
211 -- you want a 'Network.Socket.SockAddr' instead of 'Prelude.String',
212 -- use 'getRemoteAddr'.
213 getRemoteAddr' :: Resource String
214 getRemoteAddr' = do addr <- getRemoteAddr
215 (Just str, _) <- liftIO $! getNameInfo [NI_NUMERICHOST] True False addr
218 -- |Resolve an address to the remote host.
219 getRemoteHost :: Resource String
220 getRemoteHost = do addr <- getRemoteAddr
221 (Just str, _) <- liftIO $! getNameInfo [] True False addr
224 -- | Return the X.509 certificate of the client, or 'Nothing' if:
226 -- * This request didn't came through an SSL stream.
228 -- * The client didn't send us its certificate.
230 -- * The 'OpenSSL.Session.VerificationMode' of
231 -- 'OpenSSL.Session.SSLContext' in
232 -- 'Network.HTTP.Lucu.Config.SSLConfig' has not been set to
233 -- 'OpenSSL.Session.VerifyPeer'.
234 getRemoteCertificate :: Resource (Maybe X509)
235 getRemoteCertificate = do itr <- getInteraction
236 return $! itrRemoteCert itr
238 -- |Get the 'Network.HTTP.Lucu.Request.Request' value which represents
239 -- the request header. In general you don't have to use this action.
240 getRequest :: Resource Request
241 getRequest = do itr <- getInteraction
242 req <- liftIO $! atomically $! readItr itr itrRequest fromJust
245 -- |Get the 'Network.HTTP.Lucu.Request.Method' value of the request.
246 getMethod :: Resource Method
247 getMethod = do req <- getRequest
248 return $! reqMethod req
250 -- |Get the URI of the request.
251 getRequestURI :: Resource URI
252 getRequestURI = do req <- getRequest
255 -- |Get the HTTP version of the request.
256 getRequestVersion :: Resource HttpVersion
257 getRequestVersion = do req <- getRequest
258 return $! reqVersion req
260 -- |Get the path of this 'Resource' (to be exact,
261 -- 'Network.HTTP.Lucu.Resource.Tree.ResourceDef') in the
262 -- 'Network.HTTP.Lucu.Resource.Tree.ResTree'. The result of this
263 -- action is the exact path in the tree even if the
264 -- 'Network.HTTP.Lucu.Resource.Tree.ResourceDef' is greedy.
268 -- > main = let tree = mkResTree [ (["foo"], resFoo) ]
269 -- > in runHttpd defaultConfig tree
271 -- > resFoo = ResourceDef {
272 -- > resIsGreedy = True
273 -- > , resGet = Just $ do requestURI <- getRequestURI
274 -- > resourcePath <- getResourcePath
275 -- > pathInfo <- getPathInfo
276 -- > -- uriPath requestURI == "/foo/bar/baz"
277 -- > -- resourcePath == ["foo"]
278 -- > -- pathInfo == ["bar", "baz"]
282 getResourcePath :: Resource [String]
283 getResourcePath = do itr <- getInteraction
284 return $! fromJust $! itrResourcePath itr
287 -- |This is an analogy of CGI PATH_INFO. Its result is always @[]@ if
288 -- the 'Network.HTTP.Lucu.Resource.Tree.ResourceDef' is not
289 -- greedy. See 'getResourcePath'.
290 getPathInfo :: Resource [String]
291 getPathInfo = do rsrcPath <- getResourcePath
293 let reqPathStr = uriPath uri
294 reqPath = [x | x <- splitBy (== '/') reqPathStr, x /= ""]
295 -- rsrcPath と reqPath の共通する先頭部分を reqPath か
296 -- ら全部取り除くと、それは PATH_INFO のやうなものにな
297 -- る。rsrcPath は全部一致してゐるに決まってゐる(でな
298 -- ければこの Resource が撰ばれた筈が無い)ので、
299 -- rsrcPath の長さの分だけ削除すれば良い。
300 return $! drop (length rsrcPath) reqPath
302 -- | Assume the query part of request URI as
303 -- application\/x-www-form-urlencoded, and parse it. This action
304 -- doesn't parse the request body. See 'inputForm'.
305 getQueryForm :: Resource [(String, String)]
306 getQueryForm = do uri <- getRequestURI
307 return $! parseWWWFormURLEncoded $ snd $ splitAt 1 $ uriQuery uri
309 -- |Get a value of given request header. Comparison of header name is
310 -- case-insensitive. Note that this action is not intended to be used
311 -- so frequently: there should be actions like 'getContentType' for
312 -- every common headers.
313 getHeader :: Strict.ByteString -> Resource (Maybe Strict.ByteString)
314 getHeader name = name `seq`
316 return $! H.getHeader name req
318 -- |Get a list of 'Network.HTTP.Lucu.MIMEType.MIMEType' enumerated on
319 -- header \"Accept\".
320 getAccept :: Resource [MIMEType]
321 getAccept = do acceptM <- getHeader (C8.pack "Accept")
326 -> case parse mimeTypeListP (L8.fromChunks [accept]) of
327 (# Success xs, _ #) -> return xs
328 (# _ , _ #) -> abort BadRequest []
329 (Just $ "Unparsable Accept: " ++ C8.unpack accept)
331 -- |Get a list of @(contentCoding, qvalue)@ enumerated on header
332 -- \"Accept-Encoding\". The list is sorted in descending order by
334 getAcceptEncoding :: Resource [(String, Maybe Double)]
336 = do accEncM <- getHeader (C8.pack "Accept-Encoding")
339 -- HTTP/1.0 には Accept-Encoding が無い場合の規定が無い
340 -- ので安全の爲 identity が指定された事にする。HTTP/1.1
341 -- の場合は何でも受け入れて良い事になってゐるので "*" が
343 -> do ver <- getRequestVersion
345 HttpVersion 1 0 -> return [("identity", Nothing)]
346 HttpVersion 1 1 -> return [("*" , Nothing)]
349 -> if C8.null value then
351 return [("identity", Nothing)]
353 case parse acceptEncodingListP (L8.fromChunks [value]) of
354 (# Success x, _ #) -> return $ reverse $ sortBy orderAcceptEncodings x
355 (# _ , _ #) -> abort BadRequest []
356 (Just $ "Unparsable Accept-Encoding: " ++ C8.unpack value)
358 -- |Check whether a given content-coding is acceptable.
359 isEncodingAcceptable :: String -> Resource Bool
360 isEncodingAcceptable coding
361 = do accList <- getAcceptEncoding
362 return (flip any accList $ \ (c, q) ->
363 (c == "*" || C8.pack c `H.noCaseEq` C8.pack coding) && q /= Just 0)
366 -- |Get the header \"Content-Type\" as
367 -- 'Network.HTTP.Lucu.MIMEType.MIMEType'.
368 getContentType :: Resource (Maybe MIMEType)
370 = do cTypeM <- getHeader (C8.pack "Content-Type")
375 -> case parse mimeTypeP (L8.fromChunks [cType]) of
376 (# Success t, _ #) -> return $ Just t
377 (# _ , _ #) -> abort BadRequest []
378 (Just $ "Unparsable Content-Type: " ++ C8.unpack cType)
381 -- |Get the header \"Authorization\" as
382 -- 'Network.HTTP.Lucu.Authorization.AuthCredential'.
383 getAuthorization :: Resource (Maybe AuthCredential)
385 = do authM <- getHeader (C8.pack "Authorization")
390 -> case parse authCredentialP (L8.fromChunks [auth]) of
391 (# Success a, _ #) -> return $ Just a
392 (# _ , _ #) -> return Nothing
395 {- ExaminingRequest 時に使用するアクション群 -}
397 -- |Tell the system that the 'Resource' found an entity for the
398 -- request URI. If this is a GET or HEAD request, a found entity means
399 -- a datum to be replied. If this is a PUT or DELETE request, it means
400 -- a datum which was stored for the URI up to now. It is an error to
401 -- compute 'foundEntity' if this is a POST request.
403 -- Computation of 'foundEntity' performs \"If-Match\" test or
404 -- \"If-None-Match\" test if possible. When those tests fail, the
405 -- computation of 'Resource' immediately aborts with status \"412
406 -- Precondition Failed\" or \"304 Not Modified\" depending on the
409 -- If this is a GET or HEAD request, 'foundEntity' automatically puts
410 -- \"ETag\" and \"Last-Modified\" headers into the response.
411 foundEntity :: ETag -> UTCTime -> Resource ()
412 foundEntity tag timeStamp
413 = tag `seq` timeStamp `seq`
414 do driftTo ExaminingRequest
417 when (method == GET || method == HEAD)
418 $ setHeader' (C8.pack "Last-Modified") (C8.pack $ formatHTTPDateTime timeStamp)
419 when (method == POST)
420 $ abort InternalServerError []
421 (Just "Illegal computation of foundEntity for POST request.")
426 -- |Tell the system that the 'Resource' found an entity for the
427 -- request URI. The only difference from 'foundEntity' is that
428 -- 'foundETag' doesn't (and can't) put \"Last-Modified\" header into
431 -- This action is not preferred. You should use 'foundEntity' whenever
433 foundETag :: ETag -> Resource ()
436 do driftTo ExaminingRequest
439 when (method == GET || method == HEAD)
440 $ setHeader' (C8.pack "ETag") (C8.pack $ show tag)
441 when (method == POST)
442 $ abort InternalServerError []
443 (Just "Illegal computation of foundETag for POST request.")
445 -- If-Match があればそれを見る。
446 ifMatch <- getHeader (C8.pack "If-Match")
449 Just value -> if value == C8.pack "*" then
452 case parse eTagListP (L8.fromChunks [value]) of
453 (# Success tags, _ #)
454 -- tags の中に一致するものが無ければ
455 -- PreconditionFailed で終了。
456 -> when (not $ any (== tag) tags)
457 $ abort PreconditionFailed []
458 $! Just ("The entity tag doesn't match: " ++ C8.unpack value)
460 -> abort BadRequest [] $! Just ("Unparsable If-Match: " ++ C8.unpack value)
462 let statusForNoneMatch = if method == GET || method == HEAD then
467 -- If-None-Match があればそれを見る。
468 ifNoneMatch <- getHeader (C8.pack "If-None-Match")
471 Just value -> if value == C8.pack "*" then
472 abort statusForNoneMatch [] $! Just ("The entity tag matches: *")
474 case parse eTagListP (L8.fromChunks [value]) of
475 (# Success tags, _ #)
476 -> when (any (== tag) tags)
477 $ abort statusForNoneMatch [] $! Just ("The entity tag matches: " ++ C8.unpack value)
479 -> abort BadRequest [] $! Just ("Unparsable If-None-Match: " ++ C8.unpack value)
483 -- |Tell the system that the 'Resource' found an entity for the
484 -- request URI. The only difference from 'foundEntity' is that
485 -- 'foundTimeStamp' performs \"If-Modified-Since\" test or
486 -- \"If-Unmodified-Since\" test instead of \"If-Match\" test or
487 -- \"If-None-Match\" test. Be aware that any tests based on last
488 -- modification time are unsafe because it is possible to mess up such
489 -- tests by modifying the entity twice in a second.
491 -- This action is not preferred. You should use 'foundEntity' whenever
493 foundTimeStamp :: UTCTime -> Resource ()
494 foundTimeStamp timeStamp
496 do driftTo ExaminingRequest
499 when (method == GET || method == HEAD)
500 $ setHeader' (C8.pack "Last-Modified") (C8.pack $ formatHTTPDateTime timeStamp)
501 when (method == POST)
502 $ abort InternalServerError []
503 (Just "Illegal computation of foundTimeStamp for POST request.")
505 let statusForIfModSince = if method == GET || method == HEAD then
510 -- If-Modified-Since があればそれを見る。
511 ifModSince <- getHeader (C8.pack "If-Modified-Since")
513 Just str -> case parseHTTPDateTime (L8.fromChunks [str]) of
515 -> when (timeStamp <= lastTime)
516 $ abort statusForIfModSince []
517 $! Just ("The entity has not been modified since " ++ C8.unpack str)
519 -> return () -- 不正な時刻は無視
522 -- If-Unmodified-Since があればそれを見る。
523 ifUnmodSince <- getHeader (C8.pack "If-Unmodified-Since")
525 Just str -> case parseHTTPDateTime (L8.fromChunks [str]) of
527 -> when (timeStamp > lastTime)
528 $ abort PreconditionFailed []
529 $! Just ("The entity has not been modified since " ++ C8.unpack str)
531 -> return () -- 不正な時刻は無視
536 -- | Computation of @'foundNoEntity' mStr@ tells the system that the
537 -- 'Resource' found no entity for the request URI. @mStr@ is an
538 -- optional error message to be replied to the client.
540 -- If this is a PUT request, 'foundNoEntity' performs \"If-Match\"
541 -- test and aborts with status \"412 Precondition Failed\" when it
542 -- failed. If this is a GET, HEAD, POST or DELETE request,
543 -- 'foundNoEntity' always aborts with status \"404 Not Found\".
544 foundNoEntity :: Maybe String -> Resource ()
547 do driftTo ExaminingRequest
551 $ abort NotFound [] msgM
553 -- エンティティが存在しないと云ふ事は、"*" も含めたどのやうな
554 -- If-Match: 條件も滿たさない。
555 ifMatch <- getHeader (C8.pack "If-Match")
556 when (ifMatch /= Nothing)
557 $ abort PreconditionFailed [] msgM
562 {- GettingBody 時に使用するアクション群 -}
564 -- | Computation of @'input' limit@ attempts to read the request body
565 -- up to @limit@ bytes, and then make the 'Resource' transit to
566 -- /Deciding Header/ state. When the actual size of body is larger
567 -- than @limit@ bytes, computation of 'Resource' immediately aborts
568 -- with status \"413 Request Entity Too Large\". When the request has
569 -- no body, 'input' returns an empty string.
571 -- @limit@ may be less than or equal to zero. In this case, the
572 -- default limitation value
573 -- ('Network.HTTP.Lucu.Config.cnfMaxEntityLength') is used. See
576 -- Note that 'inputLBS' is more efficient than 'input' so you should
577 -- use it whenever possible.
578 input :: Int -> Resource String
579 input limit = limit `seq`
580 inputLBS limit >>= return . L8.unpack
583 -- | This is mostly the same as 'input' but is more
584 -- efficient. 'inputLBS' returns a 'Data.ByteString.Lazy.ByteString'
585 -- but it's not really lazy: reading from the socket just happens at
586 -- the computation of 'inputLBS', not at the evaluation of the
587 -- 'Data.ByteString.Lazy.ByteString'. The same goes for
589 inputLBS :: Int -> Resource Lazy.ByteString
592 do driftTo GettingBody
593 itr <- getInteraction
594 hasBody <- liftIO $! atomically $! readItr itr itrRequestHasBody id
595 chunk <- if hasBody then
598 do driftTo DecidingHeader
602 askForInput :: Interaction -> Resource Lazy.ByteString
605 do let confLimit = cnfMaxEntityLength $ itrConfig itr
606 actualLimit = if limit <= 0 then
610 when (actualLimit <= 0)
611 $ fail ("inputLBS: limit must be positive: " ++ show actualLimit)
614 $! do chunkLen <- readItr itr itrReqChunkLength id
615 writeItr itr itrWillReceiveBody True
616 if fmap (> actualLimit) chunkLen == Just True then
620 writeItr itr itrReqBodyWanted $ Just actualLimit
621 -- 應答を待つ。トランザクションを分けなければ當然デッドロック。
622 chunk <- liftIO $! atomically
623 $! do chunk <- readItr itr itrReceivedBody id
624 chunkIsOver <- readItr itr itrReqChunkIsOver id
625 if L8.length chunk < fromIntegral actualLimit then
635 $ tooLarge actualLimit
636 -- 成功。itr 内にチャンクを置いたままにす
638 writeItr itr itrReceivedBody L8.empty
640 driftTo DecidingHeader
643 tooLarge :: Int -> STM ()
644 tooLarge lim = lim `seq`
645 abortSTM RequestEntityTooLarge []
646 $! Just ("Request body must be smaller than "
647 ++ show lim ++ " bytes.")
649 -- | Computation of @'inputChunk' limit@ attempts to read a part of
650 -- request body up to @limit@ bytes. You can read any large request by
651 -- repeating computation of this action. When you've read all the
652 -- request body, 'inputChunk' returns an empty string and then make
653 -- the 'Resource' transit to /Deciding Header/ state.
655 -- @limit@ may be less than or equal to zero. In this case, the
656 -- default limitation value
657 -- ('Network.HTTP.Lucu.Config.cnfMaxEntityLength') is used. See
660 -- Note that 'inputChunkLBS' is more efficient than 'inputChunk' so you
661 -- should use it whenever possible.
662 inputChunk :: Int -> Resource String
663 inputChunk limit = limit `seq`
664 inputChunkLBS limit >>= return . L8.unpack
667 -- | This is mostly the same as 'inputChunk' but is more
668 -- efficient. See 'inputLBS'.
669 inputChunkLBS :: Int -> Resource Lazy.ByteString
672 do driftTo GettingBody
673 itr <- getInteraction
674 hasBody <- liftIO $ atomically $ readItr itr itrRequestHasBody id
675 chunk <- if hasBody then
678 do driftTo DecidingHeader
682 askForInput :: Interaction -> Resource Lazy.ByteString
685 do let confLimit = cnfMaxEntityLength $! itrConfig itr
686 actualLimit = if limit < 0 then
690 when (actualLimit <= 0)
691 $ fail ("inputChunkLBS: limit must be positive: " ++ show actualLimit)
694 $! do writeItr itr itrReqBodyWanted $! Just actualLimit
695 writeItr itr itrWillReceiveBody True
696 -- 應答を待つ。トランザクションを分けなければ當然デッドロック。
697 chunk <- liftIO $! atomically
698 $ do chunk <- readItr itr itrReceivedBody id
699 -- 要求された量に滿たなくて、まだ殘りがあ
701 when (L8.length chunk < fromIntegral actualLimit)
702 $ do chunkIsOver <- readItr itr itrReqChunkIsOver id
706 writeItr itr itrReceivedBody L8.empty
709 $ driftTo DecidingHeader
712 -- | Computation of @'inputForm' limit@ attempts to read the request
713 -- body with 'input' and parse it as
714 -- application\/x-www-form-urlencoded or multipart\/form-data. If the
715 -- request header \"Content-Type\" is neither of them, 'inputForm'
716 -- makes 'Resource' abort with status \"415 Unsupported Media
717 -- Type\". If the request has no \"Content-Type\", it aborts with
718 -- \"400 Bad Request\".
719 inputForm :: Int -> Resource [(String, String)]
722 do cTypeM <- getContentType
725 -> abort BadRequest [] (Just "Missing Content-Type")
726 Just (MIMEType "application" "x-www-form-urlencoded" _)
727 -> readWWWFormURLEncoded
728 Just (MIMEType "multipart" "form-data" params)
729 -> readMultipartFormData params
731 -> abort UnsupportedMediaType [] (Just $! "Unsupported media type: "
734 readWWWFormURLEncoded
735 = do src <- input limit
736 return $ parseWWWFormURLEncoded src
738 readMultipartFormData params
739 = do case find ((== "boundary") . map toLower . fst) params of
741 -> abort BadRequest [] (Just "Missing boundary of multipart/form-data")
743 -> do src <- inputLBS limit
744 case parse (multipartFormP boundary) src of
745 (# Success pairs, _ #) -> return pairs
747 -> abort BadRequest [] (Just "Unparsable multipart/form-data")
749 -- | This is just a constant @-1@. It's better to say @'input'
750 -- 'defaultLimit'@ than to say @'input' (-1)@ but these are exactly
757 {- DecidingHeader 時に使用するアクション群 -}
759 -- | Set the response status code. If you omit to compute this action,
760 -- the status code will be defaulted to \"200 OK\".
761 setStatus :: StatusCode -> Resource ()
764 do driftTo DecidingHeader
765 itr <- getInteraction
766 liftIO $! atomically $! updateItr itr itrResponse
771 -- | Set a value of given resource header. Comparison of header name
772 -- is case-insensitive. Note that this action is not intended to be
773 -- used so frequently: there should be actions like 'setContentType'
774 -- for every common headers.
776 -- Some important headers (especially \"Content-Length\" and
777 -- \"Transfer-Encoding\") may be silently dropped or overwritten by
778 -- the system not to corrupt the interaction with client at the
779 -- viewpoint of HTTP protocol layer. For instance, if we are keeping
780 -- the connection alive, without this process it causes a catastrophe
781 -- to send a header \"Content-Length: 10\" and actually send a body of
782 -- 20 bytes long. In this case the client shall only accept the first
783 -- 10 bytes of response body and thinks that the residual 10 bytes is
784 -- a part of header of the next response.
785 setHeader :: Strict.ByteString -> Strict.ByteString -> Resource ()
787 = name `seq` value `seq`
788 driftTo DecidingHeader >> setHeader' name value
791 setHeader' :: Strict.ByteString -> Strict.ByteString -> Resource ()
792 setHeader' name value
793 = name `seq` value `seq`
794 do itr <- getInteraction
796 $ updateItr itr itrResponse
797 $ H.setHeader name value
799 -- | Computation of @'redirect' code uri@ sets the response status to
800 -- @code@ and \"Location\" header to @uri@. The @code@ must satisfy
801 -- 'Network.HTTP.Lucu.Response.isRedirection' or it causes an error.
802 redirect :: StatusCode -> URI -> Resource ()
804 = code `seq` uri `seq`
805 do when (code == NotModified || not (isRedirection code))
806 $ abort InternalServerError []
807 $! Just ("Attempted to redirect with status " ++ show code)
810 {-# INLINE redirect #-}
813 -- | Computation of @'setContentType' mType@ sets the response header
814 -- \"Content-Type\" to @mType@.
815 setContentType :: MIMEType -> Resource ()
817 = setHeader (C8.pack "Content-Type") (C8.pack $ show mType)
819 -- | Computation of @'setLocation' uri@ sets the response header
820 -- \"Location\" to @uri@.
821 setLocation :: URI -> Resource ()
823 = setHeader (C8.pack "Location") (C8.pack $ uriToString id uri $ "")
825 -- |Computation of @'setContentEncoding' codings@ sets the response
826 -- header \"Content-Encoding\" to @codings@.
827 setContentEncoding :: [String] -> Resource ()
828 setContentEncoding codings
829 = do ver <- getRequestVersion
831 HttpVersion 1 0 -> unnormalizeCoding
832 HttpVersion 1 1 -> id
834 setHeader (C8.pack "Content-Encoding") (C8.pack $ joinWith ", " $ map tr codings)
836 -- |Computation of @'setWWWAuthenticate' challenge@ sets the response
837 -- header \"WWW-Authenticate\" to @challenge@.
838 setWWWAuthenticate :: AuthChallenge -> Resource ()
839 setWWWAuthenticate challenge
840 = setHeader (C8.pack "WWW-Authenticate") (C8.pack $ show challenge)
843 {- DecidingBody 時に使用するアクション群 -}
845 -- | Computation of @'output' str@ writes @str@ as a response body,
846 -- and then make the 'Resource' transit to /Done/ state. It is safe to
847 -- apply 'output' to an infinite string, such as a lazy stream of
850 -- Note that 'outputLBS' is more efficient than 'output' so you should
851 -- use it whenever possible.
852 output :: String -> Resource ()
853 output str = outputLBS $! L8.pack str
854 {-# INLINE output #-}
856 -- | This is mostly the same as 'output' but is more efficient.
857 outputLBS :: Lazy.ByteString -> Resource ()
858 outputLBS str = do outputChunkLBS str
860 {-# INLINE outputLBS #-}
862 -- | Computation of @'outputChunk' str@ writes @str@ as a part of
863 -- response body. You can compute this action multiple times to write
864 -- a body little at a time. It is safe to apply 'outputChunk' to an
867 -- Note that 'outputChunkLBS' is more efficient than 'outputChunk' so
868 -- you should use it whenever possible.
869 outputChunk :: String -> Resource ()
870 outputChunk str = outputChunkLBS $! L8.pack str
871 {-# INLINE outputChunk #-}
873 -- | This is mostly the same as 'outputChunk' but is more efficient.
874 outputChunkLBS :: Lazy.ByteString -> Resource ()
875 outputChunkLBS wholeChunk
877 do driftTo DecidingBody
878 itr <- getInteraction
880 let limit = cnfMaxOutputChunkLength $ itrConfig itr
882 $ fail ("cnfMaxOutputChunkLength must be positive: "
885 discardBody <- liftIO $ atomically $
886 readItr itr itrWillDiscardBody id
889 $ sendChunks wholeChunk limit
891 unless (L8.null wholeChunk)
892 $ liftIO $ atomically $
893 writeItr itr itrBodyIsNull False
895 -- チャンクの大きさは Config で制限されてゐる。もし例へば
896 -- "/dev/zero" を L8.readFile して作った Lazy.ByteString をそのまま
897 -- ResponseWriter に渡したりすると大變な事が起こる。何故なら
898 -- ResponseWriter は Transfer-Encoding: chunked の時、ヘッダを書
900 sendChunks :: Lazy.ByteString -> Int -> Resource ()
902 | L8.null str = return ()
903 | otherwise = do let (chunk, remaining) = L8.splitAt (fromIntegral limit) str
904 itr <- getInteraction
905 liftIO $ atomically $
906 do buf <- readItr itr itrBodyToSend id
909 writeItr itr itrBodyToSend chunk
914 sendChunks remaining limit
918 [GettingBody からそれ以降の状態に遷移する時]
920 body を讀み終へてゐなければ、殘りの body を讀み捨てる。
923 [DecidingHeader からそれ以降の状態に遷移する時]
930 bodyIsNull が False ならば何もしない。True だった場合は出力補完す
935 driftTo :: InteractionState -> Resource ()
938 do itr <- getInteraction
939 liftIO $ atomically $ do oldState <- readItr itr itrState id
940 if newState < oldState then
941 throwStateError oldState newState
943 do let a = [oldState .. newState]
946 mapM_ (uncurry $ drift itr) c
947 writeItr itr itrState newState
949 throwStateError :: Monad m => InteractionState -> InteractionState -> m a
951 throwStateError Done DecidingBody
952 = fail "It makes no sense to output something after finishing to output."
954 throwStateError old new
955 = fail ("state error: " ++ show old ++ " ==> " ++ show new)
958 drift :: Interaction -> InteractionState -> InteractionState -> STM ()
960 drift itr GettingBody _
961 = writeItr itr itrReqBodyWasteAll True
963 drift itr DecidingHeader _
967 = do bodyIsNull <- readItr itr itrBodyIsNull id
969 $ writeDefaultPage itr