5 {-# OPTIONS_HADDOCK prune #-}
7 -- |This is the Resource Monad; monadic actions to define the behavior
8 -- of each resources. The 'Resource' Monad is a kind of 'Prelude.IO'
9 -- Monad thus it implements 'Control.Monad.Trans.MonadIO' class. It is
10 -- also a state machine.
12 -- Request Processing Flow:
14 -- 1. A client issues an HTTP request.
16 -- 2. If the URI of it matches to any resource, the corresponding
17 -- 'Resource' Monad starts running on a newly spawned thread.
19 -- 3. The 'Resource' Monad looks at the request header, find (or not
20 -- find) an entity, receive the request body (if any), decide the
21 -- response header, and decide the response body. This process
22 -- will be discussed later.
24 -- 4. The 'Resource' Monad and its thread stops running. The client
25 -- may or may not be sending us the next request at this point.
27 -- 'Resource' Monad takes the following states. The initial state is
28 -- /Examining Request/ and the final state is /Done/.
30 -- [/Examining Request/] In this state, a 'Resource' looks at the
31 -- request header and thinks about an entity for it. If there is a
32 -- suitable entity, the 'Resource' tells the system an entity tag
33 -- and its last modification time ('foundEntity'). If it found no
34 -- entity, it tells the system so ('foundNoEntity'). In case it is
35 -- impossible to decide the existence of entity, which is a typical
36 -- case for POST requests, 'Resource' does nothing in this state.
38 -- [/Getting Body/] A 'Resource' asks the system to receive a
39 -- request body from client. Before actually reading from the
40 -- socket, the system sends \"100 Continue\" to the client if need
41 -- be. When a 'Resource' transits to the next state without
42 -- receiving all or part of request body, the system still reads it
43 -- and just throws it away.
45 -- [/Deciding Header/] A 'Resource' makes a decision of status code
46 -- and response header. When it transits to the next state, the
47 -- system checks the validness of response header and then write
48 -- them to the socket.
50 -- [/Deciding Body/] In this state, a 'Resource' asks the system to
51 -- write some response body to the socket. When it transits to the
52 -- next state without writing any response body, the system
53 -- completes it depending on the status code.
55 -- [/Done/] Everything is over. A 'Resource' can do nothing for the
56 -- HTTP interaction anymore.
58 -- Note that the state transition is one-way: for instance, it is an
59 -- error to try to read a request body after writing some
60 -- response. This limitation is for efficiency. We don't want to read
61 -- the entire request before starting 'Resource', nor we don't want to
62 -- postpone writing the entire response till the end of 'Resource'
65 module Network.HTTP.Lucu.Resource
74 -- ** Getting request header
76 -- |These actions can be computed regardless of the current state,
77 -- and they don't change the state.
82 , getRemoteCertificate
93 , isEncodingAcceptable
97 -- ** Finding an entity
99 -- |These actions can be computed only in the /Examining Request/
100 -- state. After the computation, the 'Resource' transits to
101 -- /Getting Body/ state.
107 -- ** Getting a request body
109 -- |Computation of these actions changes the state to /Getting
118 -- ** Setting response headers
120 -- |Computation of these actions changes the state to /Deciding
130 -- ** Writing a response body
132 -- |Computation of these actions changes the state to /Deciding
142 import Control.Concurrent.STM
143 import Control.Monad.Reader
144 import qualified Data.ByteString as Strict (ByteString)
145 import qualified Data.ByteString.Lazy as Lazy (ByteString)
146 import qualified Data.ByteString.Char8 as C8 hiding (ByteString)
147 import qualified Data.ByteString.Lazy.Char8 as L8 hiding (ByteString)
152 import qualified Data.Time.HTTP as HTTP
153 import Network.HTTP.Lucu.Abortion
154 import Network.HTTP.Lucu.Authorization
155 import Network.HTTP.Lucu.Config
156 import Network.HTTP.Lucu.ContentCoding
157 import Network.HTTP.Lucu.DefaultPage
158 import Network.HTTP.Lucu.ETag
159 import qualified Network.HTTP.Lucu.Headers as H
160 import Network.HTTP.Lucu.HttpVersion
161 import Network.HTTP.Lucu.Interaction
162 import Network.HTTP.Lucu.MultipartForm
163 import Network.HTTP.Lucu.Postprocess
164 import Network.HTTP.Lucu.Request
165 import Network.HTTP.Lucu.Response
166 import Network.HTTP.Lucu.MIMEType
167 import Network.HTTP.Lucu.Utils
168 import Network.Socket hiding (accept)
169 import Network.URI hiding (path)
172 -- |The 'Resource' monad. This monad implements
173 -- 'Control.Monad.Trans.MonadIO' so it can do any 'Prelude.IO'
175 newtype Resource a = Resource { unRes :: ReaderT Interaction IO a }
177 instance Functor Resource where
178 fmap f c = Resource (fmap f (unRes c))
180 instance Monad Resource where
181 c >>= f = Resource (unRes c >>= unRes . f)
182 return = Resource . return
183 fail = Resource . fail
185 instance MonadIO Resource where
186 liftIO = Resource . liftIO
189 runRes :: Resource a -> Interaction -> IO a
191 = runReaderT (unRes r) itr
194 getInteraction :: Resource Interaction
195 getInteraction = Resource ask
198 -- |Get the 'Network.HTTP.Lucu.Config.Config' value which is used for
200 getConfig :: Resource Config
201 getConfig = do itr <- getInteraction
202 return $! itrConfig itr
205 -- |Get the 'Network.Socket.SockAddr' of the remote host. If you want
206 -- a string representation instead of 'Network.Socket.SockAddr', use
208 getRemoteAddr :: Resource SockAddr
209 getRemoteAddr = do itr <- getInteraction
210 return $! itrRemoteAddr itr
213 -- |Get the string representation of the address of remote host. If
214 -- you want a 'Network.Socket.SockAddr' instead of 'Prelude.String',
215 -- use 'getRemoteAddr'.
216 getRemoteAddr' :: Resource String
217 getRemoteAddr' = do addr <- getRemoteAddr
218 (Just str, _) <- liftIO $! getNameInfo [NI_NUMERICHOST] True False addr
221 -- |Resolve an address to the remote host.
222 getRemoteHost :: Resource String
223 getRemoteHost = do addr <- getRemoteAddr
224 (Just str, _) <- liftIO $! getNameInfo [] True False addr
227 -- | Return the X.509 certificate of the client, or 'Nothing' if:
229 -- * This request didn't came through an SSL stream.
231 -- * The client didn't send us its certificate.
233 -- * The 'OpenSSL.Session.VerificationMode' of
234 -- 'OpenSSL.Session.SSLContext' in
235 -- 'Network.HTTP.Lucu.Config.SSLConfig' has not been set to
236 -- 'OpenSSL.Session.VerifyPeer'.
237 getRemoteCertificate :: Resource (Maybe X509)
238 getRemoteCertificate = do itr <- getInteraction
239 return $! itrRemoteCert itr
241 -- |Get the 'Network.HTTP.Lucu.Request.Request' value which represents
242 -- the request header. In general you don't have to use this action.
243 getRequest :: Resource Request
244 getRequest = do itr <- getInteraction
245 req <- liftIO $! atomically $! readItr itr itrRequest fromJust
248 -- |Get the 'Network.HTTP.Lucu.Request.Method' value of the request.
249 getMethod :: Resource Method
250 getMethod = do req <- getRequest
251 return $! reqMethod req
253 -- |Get the URI of the request.
254 getRequestURI :: Resource URI
255 getRequestURI = do req <- getRequest
258 -- |Get the HTTP version of the request.
259 getRequestVersion :: Resource HttpVersion
260 getRequestVersion = do req <- getRequest
261 return $! reqVersion req
263 -- |Get the path of this 'Resource' (to be exact,
264 -- 'Network.HTTP.Lucu.Resource.Tree.ResourceDef') in the
265 -- 'Network.HTTP.Lucu.Resource.Tree.ResTree'. The result of this
266 -- action is the exact path in the tree even if the
267 -- 'Network.HTTP.Lucu.Resource.Tree.ResourceDef' is greedy.
271 -- > main = let tree = mkResTree [ (["foo"], resFoo) ]
272 -- > in runHttpd defaultConfig tree
274 -- > resFoo = ResourceDef {
275 -- > resIsGreedy = True
276 -- > , resGet = Just $ do requestURI <- getRequestURI
277 -- > resourcePath <- getResourcePath
278 -- > pathInfo <- getPathInfo
279 -- > -- uriPath requestURI == "/foo/bar/baz"
280 -- > -- resourcePath == ["foo"]
281 -- > -- pathInfo == ["bar", "baz"]
285 getResourcePath :: Resource [String]
286 getResourcePath = do itr <- getInteraction
287 return $! fromJust $! itrResourcePath itr
290 -- |This is an analogy of CGI PATH_INFO. The result is
291 -- URI-unescaped. It is always @[]@ if the
292 -- 'Network.HTTP.Lucu.Resource.Tree.ResourceDef' is not greedy. See
293 -- 'getResourcePath'.
294 getPathInfo :: Resource [String]
295 getPathInfo = do rsrcPath <- getResourcePath
297 let reqPathStr = uriPath uri
298 reqPath = [unEscapeString x | x <- splitBy (== '/') reqPathStr, x /= ""]
299 -- rsrcPath と reqPath の共通する先頭部分を reqPath か
300 -- ら全部取り除くと、それは PATH_INFO のやうなものにな
301 -- る。rsrcPath は全部一致してゐるに決まってゐる(でな
302 -- ければこの Resource が撰ばれた筈が無い)ので、
303 -- rsrcPath の長さの分だけ削除すれば良い。
304 return $! drop (length rsrcPath) reqPath
306 -- |Assume the query part of request URI as
307 -- application\/x-www-form-urlencoded, and parse it to pairs of
308 -- @(name, formData)@. This action doesn't parse the request body. See
310 getQueryForm :: Resource [(String, FormData)]
311 getQueryForm = liftM parse' getRequestURI
313 parse' = map toPairWithFormData .
314 parseWWWFormURLEncoded .
319 toPairWithFormData :: (String, String) -> (String, FormData)
320 toPairWithFormData (name, value)
321 = let fd = FormData {
323 , fdContent = L8.pack value
327 -- |Get a value of given request header. Comparison of header name is
328 -- case-insensitive. Note that this action is not intended to be used
329 -- so frequently: there should be actions like 'getContentType' for
330 -- every common headers.
331 getHeader :: Strict.ByteString -> Resource (Maybe Strict.ByteString)
332 getHeader name = name `seq`
334 return $! H.getHeader name req
336 -- |Get a list of 'Network.HTTP.Lucu.MIMEType.MIMEType' enumerated on
337 -- header \"Accept\".
338 getAccept :: Resource [MIMEType]
339 getAccept = do acceptM <- getHeader (C8.pack "Accept")
344 -> case parse mimeTypeListP (L8.fromChunks [accept]) of
345 (# Success xs, _ #) -> return xs
346 (# _ , _ #) -> abort BadRequest []
347 (Just $ "Unparsable Accept: " ++ C8.unpack accept)
349 -- |Get a list of @(contentCoding, qvalue)@ enumerated on header
350 -- \"Accept-Encoding\". The list is sorted in descending order by
352 getAcceptEncoding :: Resource [(String, Maybe Double)]
354 = do accEncM <- getHeader (C8.pack "Accept-Encoding")
357 -- HTTP/1.0 には Accept-Encoding が無い場合の規定が無い
358 -- ので安全の爲 identity が指定された事にする。HTTP/1.1
359 -- の場合は何でも受け入れて良い事になってゐるので "*" が
361 -> do ver <- getRequestVersion
363 HttpVersion 1 0 -> return [("identity", Nothing)]
364 HttpVersion 1 1 -> return [("*" , Nothing)]
367 -> if C8.null value then
369 return [("identity", Nothing)]
371 case parse acceptEncodingListP (L8.fromChunks [value]) of
372 (# Success x, _ #) -> return $ reverse $ sortBy orderAcceptEncodings x
373 (# _ , _ #) -> abort BadRequest []
374 (Just $ "Unparsable Accept-Encoding: " ++ C8.unpack value)
376 -- |Check whether a given content-coding is acceptable.
377 isEncodingAcceptable :: String -> Resource Bool
378 isEncodingAcceptable coding
379 = do accList <- getAcceptEncoding
380 return (flip any accList $ \ (c, q) ->
381 (c == "*" || C8.pack c `H.noCaseEq` C8.pack coding) && q /= Just 0)
384 -- |Get the header \"Content-Type\" as
385 -- 'Network.HTTP.Lucu.MIMEType.MIMEType'.
386 getContentType :: Resource (Maybe MIMEType)
388 = do cTypeM <- getHeader (C8.pack "Content-Type")
393 -> case parse mimeTypeP (L8.fromChunks [cType]) of
394 (# Success t, _ #) -> return $ Just t
395 (# _ , _ #) -> abort BadRequest []
396 (Just $ "Unparsable Content-Type: " ++ C8.unpack cType)
399 -- |Get the header \"Authorization\" as
400 -- 'Network.HTTP.Lucu.Authorization.AuthCredential'.
401 getAuthorization :: Resource (Maybe AuthCredential)
403 = do authM <- getHeader (C8.pack "Authorization")
408 -> case parse authCredentialP (L8.fromChunks [auth]) of
409 (# Success a, _ #) -> return $ Just a
410 (# _ , _ #) -> return Nothing
413 {- ExaminingRequest 時に使用するアクション群 -}
415 -- |Tell the system that the 'Resource' found an entity for the
416 -- request URI. If this is a GET or HEAD request, a found entity means
417 -- a datum to be replied. If this is a PUT or DELETE request, it means
418 -- a datum which was stored for the URI until now. It is an error to
419 -- compute 'foundEntity' if this is a POST request.
421 -- Computation of 'foundEntity' performs \"If-Match\" test or
422 -- \"If-None-Match\" test if possible. When those tests fail, the
423 -- computation of 'Resource' immediately aborts with status \"412
424 -- Precondition Failed\" or \"304 Not Modified\" depending on the
427 -- If this is a GET or HEAD request, 'foundEntity' automatically puts
428 -- \"ETag\" and \"Last-Modified\" headers into the response.
429 foundEntity :: ETag -> UTCTime -> Resource ()
430 foundEntity tag timeStamp
431 = tag `seq` timeStamp `seq`
432 do driftTo ExaminingRequest
435 when (method == GET || method == HEAD)
436 $ setHeader' (C8.pack "Last-Modified") (C8.pack $ HTTP.format timeStamp)
437 when (method == POST)
438 $ abort InternalServerError []
439 (Just "Illegal computation of foundEntity for a POST request.")
444 -- |Tell the system that the 'Resource' found an entity for the
445 -- request URI. The only difference from 'foundEntity' is that
446 -- 'foundETag' doesn't (and can't) put \"Last-Modified\" header into
449 -- This action is not preferred. You should use 'foundEntity' whenever
451 foundETag :: ETag -> Resource ()
454 do driftTo ExaminingRequest
457 when (method == GET || method == HEAD)
458 $ setHeader' (C8.pack "ETag") (C8.pack $ show tag)
459 when (method == POST)
460 $ abort InternalServerError []
461 (Just "Illegal computation of foundETag for POST request.")
463 -- If-Match があればそれを見る。
464 ifMatch <- getHeader (C8.pack "If-Match")
467 Just value -> if value == C8.pack "*" then
470 case parse eTagListP (L8.fromChunks [value]) of
471 (# Success tags, _ #)
472 -- tags の中に一致するものが無ければ
473 -- PreconditionFailed で終了。
474 -> when (not $ any (== tag) tags)
475 $ abort PreconditionFailed []
476 $! Just ("The entity tag doesn't match: " ++ C8.unpack value)
478 -> abort BadRequest [] $! Just ("Unparsable If-Match: " ++ C8.unpack value)
480 let statusForNoneMatch = if method == GET || method == HEAD then
485 -- If-None-Match があればそれを見る。
486 ifNoneMatch <- getHeader (C8.pack "If-None-Match")
489 Just value -> if value == C8.pack "*" then
490 abort statusForNoneMatch [] $! Just ("The entity tag matches: *")
492 case parse eTagListP (L8.fromChunks [value]) of
493 (# Success tags, _ #)
494 -> when (any (== tag) tags)
495 $ abort statusForNoneMatch [] $! Just ("The entity tag matches: " ++ C8.unpack value)
497 -> abort BadRequest [] $! Just ("Unparsable If-None-Match: " ++ C8.unpack value)
501 -- |Tell the system that the 'Resource' found an entity for the
502 -- request URI. The only difference from 'foundEntity' is that
503 -- 'foundTimeStamp' performs \"If-Modified-Since\" test or
504 -- \"If-Unmodified-Since\" test instead of \"If-Match\" test or
505 -- \"If-None-Match\" test. Be aware that any tests based on last
506 -- modification time are unsafe because it is possible to mess up such
507 -- tests by modifying the entity twice in a second.
509 -- This action is not preferred. You should use 'foundEntity' whenever
511 foundTimeStamp :: UTCTime -> Resource ()
512 foundTimeStamp timeStamp
514 do driftTo ExaminingRequest
517 when (method == GET || method == HEAD)
518 $ setHeader' (C8.pack "Last-Modified") (C8.pack $ HTTP.format timeStamp)
519 when (method == POST)
520 $ abort InternalServerError []
521 (Just "Illegal computation of foundTimeStamp for POST request.")
523 let statusForIfModSince = if method == GET || method == HEAD then
528 -- If-Modified-Since があればそれを見る。
529 ifModSince <- getHeader (C8.pack "If-Modified-Since")
531 Just str -> case HTTP.parse (C8.unpack str) of
533 -> when (timeStamp <= lastTime)
534 $ abort statusForIfModSince []
535 $! Just ("The entity has not been modified since " ++ C8.unpack str)
537 -> return () -- 不正な時刻は無視
540 -- If-Unmodified-Since があればそれを見る。
541 ifUnmodSince <- getHeader (C8.pack "If-Unmodified-Since")
543 Just str -> case HTTP.parse (C8.unpack str) of
545 -> when (timeStamp > lastTime)
546 $ abort PreconditionFailed []
547 $! Just ("The entity has not been modified since " ++ C8.unpack str)
549 -> return () -- 不正な時刻は無視
554 -- | Computation of @'foundNoEntity' mStr@ tells the system that the
555 -- 'Resource' found no entity for the request URI. @mStr@ is an
556 -- optional error message to be replied to the client.
558 -- If this is a PUT request, 'foundNoEntity' performs \"If-Match\"
559 -- test and aborts with status \"412 Precondition Failed\" when it
560 -- failed. If this is a GET, HEAD, POST or DELETE request,
561 -- 'foundNoEntity' always aborts with status \"404 Not Found\".
562 foundNoEntity :: Maybe String -> Resource ()
565 do driftTo ExaminingRequest
569 $ abort NotFound [] msgM
571 -- エンティティが存在しないと云ふ事は、"*" も含めたどのやうな
572 -- If-Match: 條件も滿たさない。
573 ifMatch <- getHeader (C8.pack "If-Match")
574 when (ifMatch /= Nothing)
575 $ abort PreconditionFailed [] msgM
580 {- GettingBody 時に使用するアクション群 -}
582 -- | Computation of @'input' limit@ attempts to read the request body
583 -- up to @limit@ bytes, and then make the 'Resource' transit to
584 -- /Deciding Header/ state. When the actual size of body is larger
585 -- than @limit@ bytes, computation of 'Resource' immediately aborts
586 -- with status \"413 Request Entity Too Large\". When the request has
587 -- no body, 'input' returns an empty string.
589 -- @limit@ may be less than or equal to zero. In this case, the
590 -- default limitation value
591 -- ('Network.HTTP.Lucu.Config.cnfMaxEntityLength') is used. See
594 -- Note that 'inputLBS' is more efficient than 'input' so you should
595 -- use it whenever possible.
596 input :: Int -> Resource String
597 input limit = limit `seq`
598 inputLBS limit >>= return . L8.unpack
601 -- | This is mostly the same as 'input' but is more
602 -- efficient. 'inputLBS' returns a 'Data.ByteString.Lazy.ByteString'
603 -- but it's not really lazy: reading from the socket just happens at
604 -- the computation of 'inputLBS', not at the evaluation of the
605 -- 'Data.ByteString.Lazy.ByteString'. The same goes for
607 inputLBS :: Int -> Resource Lazy.ByteString
610 do driftTo GettingBody
611 itr <- getInteraction
612 hasBody <- liftIO $! atomically $! readItr itr itrRequestHasBody id
613 chunk <- if hasBody then
616 do driftTo DecidingHeader
620 askForInput :: Interaction -> Resource Lazy.ByteString
623 do let confLimit = cnfMaxEntityLength $ itrConfig itr
624 actualLimit = if limit <= 0 then
628 when (actualLimit <= 0)
629 $ fail ("inputLBS: limit must be positive: " ++ show actualLimit)
632 $! do chunkLen <- readItr itr itrReqChunkLength id
633 writeItr itr itrWillReceiveBody True
634 if fmap (> actualLimit) chunkLen == Just True then
638 writeItr itr itrReqBodyWanted $ Just actualLimit
639 -- 應答を待つ。トランザクションを分けなければ當然デッドロック。
640 chunk <- liftIO $! atomically
641 $! do chunk <- readItr itr itrReceivedBody id
642 chunkIsOver <- readItr itr itrReqChunkIsOver id
643 if L8.length chunk < fromIntegral actualLimit then
653 $ tooLarge actualLimit
654 -- 成功。itr 内にチャンクを置いたままにす
656 writeItr itr itrReceivedBody L8.empty
658 driftTo DecidingHeader
661 tooLarge :: Int -> STM ()
662 tooLarge lim = lim `seq`
663 abortSTM RequestEntityTooLarge []
664 $! Just ("Request body must be smaller than "
665 ++ show lim ++ " bytes.")
667 -- | Computation of @'inputChunk' limit@ attempts to read a part of
668 -- request body up to @limit@ bytes. You can read any large request by
669 -- repeating computation of this action. When you've read all the
670 -- request body, 'inputChunk' returns an empty string and then make
671 -- the 'Resource' transit to /Deciding Header/ state.
673 -- @limit@ may be less than or equal to zero. In this case, the
674 -- default limitation value
675 -- ('Network.HTTP.Lucu.Config.cnfMaxEntityLength') is used. See
678 -- Note that 'inputChunkLBS' is more efficient than 'inputChunk' so you
679 -- should use it whenever possible.
680 inputChunk :: Int -> Resource String
681 inputChunk limit = limit `seq`
682 inputChunkLBS limit >>= return . L8.unpack
685 -- | This is mostly the same as 'inputChunk' but is more
686 -- efficient. See 'inputLBS'.
687 inputChunkLBS :: Int -> Resource Lazy.ByteString
690 do driftTo GettingBody
691 itr <- getInteraction
692 hasBody <- liftIO $ atomically $ readItr itr itrRequestHasBody id
693 chunk <- if hasBody then
696 do driftTo DecidingHeader
700 askForInput :: Interaction -> Resource Lazy.ByteString
703 do let confLimit = cnfMaxEntityLength $! itrConfig itr
704 actualLimit = if limit < 0 then
708 when (actualLimit <= 0)
709 $ fail ("inputChunkLBS: limit must be positive: " ++ show actualLimit)
712 $! do writeItr itr itrReqBodyWanted $! Just actualLimit
713 writeItr itr itrWillReceiveBody True
714 -- 應答を待つ。トランザクションを分けなければ當然デッドロック。
715 chunk <- liftIO $! atomically
716 $ do chunk <- readItr itr itrReceivedBody id
717 -- 要求された量に滿たなくて、まだ殘りがあ
719 when (L8.length chunk < fromIntegral actualLimit)
720 $ do chunkIsOver <- readItr itr itrReqChunkIsOver id
724 writeItr itr itrReceivedBody L8.empty
727 $ driftTo DecidingHeader
730 -- | Computation of @'inputForm' limit@ attempts to read the request
731 -- body with 'input' and parse it as
732 -- application\/x-www-form-urlencoded or multipart\/form-data. If the
733 -- request header \"Content-Type\" is neither of them, 'inputForm'
734 -- makes 'Resource' abort with status \"415 Unsupported Media
735 -- Type\". If the request has no \"Content-Type\", it aborts with
736 -- \"400 Bad Request\".
737 inputForm :: Int -> Resource [(String, FormData)]
740 do cTypeM <- getContentType
743 -> abort BadRequest [] (Just "Missing Content-Type")
744 Just (MIMEType "application" "x-www-form-urlencoded" _)
745 -> readWWWFormURLEncoded
746 Just (MIMEType "multipart" "form-data" params)
747 -> readMultipartFormData params
749 -> abort UnsupportedMediaType [] (Just $! "Unsupported media type: "
752 readWWWFormURLEncoded
753 = liftM (map toPairWithFormData . parseWWWFormURLEncoded) (input limit)
755 readMultipartFormData params
756 = do case find ((== "boundary") . map toLower . fst) params of
758 -> abort BadRequest [] (Just "Missing boundary of multipart/form-data")
760 -> do src <- inputLBS limit
761 case parse (multipartFormP boundary) src of
762 (# Success formList, _ #)
765 -> abort BadRequest [] (Just "Unparsable multipart/form-data")
767 -- | This is just a constant @-1@. It's better to say @'input'
768 -- 'defaultLimit'@ than to say @'input' (-1)@ but these are exactly
775 {- DecidingHeader 時に使用するアクション群 -}
777 -- | Set the response status code. If you omit to compute this action,
778 -- the status code will be defaulted to \"200 OK\".
779 setStatus :: StatusCode -> Resource ()
782 do driftTo DecidingHeader
783 itr <- getInteraction
784 liftIO $! atomically $! updateItr itr itrResponse
789 -- | Set a value of given resource header. Comparison of header name
790 -- is case-insensitive. Note that this action is not intended to be
791 -- used so frequently: there should be actions like 'setContentType'
792 -- for every common headers.
794 -- Some important headers (especially \"Content-Length\" and
795 -- \"Transfer-Encoding\") may be silently dropped or overwritten by
796 -- the system not to corrupt the interaction with client at the
797 -- viewpoint of HTTP protocol layer. For instance, if we are keeping
798 -- the connection alive, without this process it causes a catastrophe
799 -- to send a header \"Content-Length: 10\" and actually send a body of
800 -- 20 bytes long. In this case the client shall only accept the first
801 -- 10 bytes of response body and thinks that the residual 10 bytes is
802 -- a part of header of the next response.
803 setHeader :: Strict.ByteString -> Strict.ByteString -> Resource ()
805 = name `seq` value `seq`
806 driftTo DecidingHeader >> setHeader' name value
809 setHeader' :: Strict.ByteString -> Strict.ByteString -> Resource ()
810 setHeader' name value
811 = name `seq` value `seq`
812 do itr <- getInteraction
814 $ updateItr itr itrResponse
815 $ H.setHeader name value
817 -- | Computation of @'redirect' code uri@ sets the response status to
818 -- @code@ and \"Location\" header to @uri@. The @code@ must satisfy
819 -- 'Network.HTTP.Lucu.Response.isRedirection' or it causes an error.
820 redirect :: StatusCode -> URI -> Resource ()
822 = code `seq` uri `seq`
823 do when (code == NotModified || not (isRedirection code))
824 $ abort InternalServerError []
825 $! Just ("Attempted to redirect with status " ++ show code)
828 {-# INLINE redirect #-}
831 -- | Computation of @'setContentType' mType@ sets the response header
832 -- \"Content-Type\" to @mType@.
833 setContentType :: MIMEType -> Resource ()
835 = setHeader (C8.pack "Content-Type") (C8.pack $ show mType)
837 -- | Computation of @'setLocation' uri@ sets the response header
838 -- \"Location\" to @uri@.
839 setLocation :: URI -> Resource ()
841 = setHeader (C8.pack "Location") (C8.pack $ uriToString id uri $ "")
843 -- |Computation of @'setContentEncoding' codings@ sets the response
844 -- header \"Content-Encoding\" to @codings@.
845 setContentEncoding :: [String] -> Resource ()
846 setContentEncoding codings
847 = do ver <- getRequestVersion
849 HttpVersion 1 0 -> unnormalizeCoding
850 HttpVersion 1 1 -> id
852 setHeader (C8.pack "Content-Encoding") (C8.pack $ joinWith ", " $ map tr codings)
854 -- |Computation of @'setWWWAuthenticate' challenge@ sets the response
855 -- header \"WWW-Authenticate\" to @challenge@.
856 setWWWAuthenticate :: AuthChallenge -> Resource ()
857 setWWWAuthenticate challenge
858 = setHeader (C8.pack "WWW-Authenticate") (C8.pack $ show challenge)
861 {- DecidingBody 時に使用するアクション群 -}
863 -- | Computation of @'output' str@ writes @str@ as a response body,
864 -- and then make the 'Resource' transit to /Done/ state. It is safe to
865 -- apply 'output' to an infinite string, such as a lazy stream of
868 -- Note that 'outputLBS' is more efficient than 'output' so you should
869 -- use it whenever possible.
870 output :: String -> Resource ()
871 output str = outputLBS $! L8.pack str
872 {-# INLINE output #-}
874 -- | This is mostly the same as 'output' but is more efficient.
875 outputLBS :: Lazy.ByteString -> Resource ()
876 outputLBS str = do outputChunkLBS str
878 {-# INLINE outputLBS #-}
880 -- | Computation of @'outputChunk' str@ writes @str@ as a part of
881 -- response body. You can compute this action multiple times to write
882 -- a body little at a time. It is safe to apply 'outputChunk' to an
885 -- Note that 'outputChunkLBS' is more efficient than 'outputChunk' so
886 -- you should use it whenever possible.
887 outputChunk :: String -> Resource ()
888 outputChunk str = outputChunkLBS $! L8.pack str
889 {-# INLINE outputChunk #-}
891 -- | This is mostly the same as 'outputChunk' but is more efficient.
892 outputChunkLBS :: Lazy.ByteString -> Resource ()
893 outputChunkLBS wholeChunk
895 do driftTo DecidingBody
896 itr <- getInteraction
898 let limit = cnfMaxOutputChunkLength $ itrConfig itr
900 $ fail ("cnfMaxOutputChunkLength must be positive: "
903 discardBody <- liftIO $ atomically $
904 readItr itr itrWillDiscardBody id
907 $ sendChunks wholeChunk limit
909 unless (L8.null wholeChunk)
910 $ liftIO $ atomically $
911 writeItr itr itrBodyIsNull False
913 -- チャンクの大きさは Config で制限されてゐる。もし例へば
914 -- "/dev/zero" を L8.readFile して作った Lazy.ByteString をそのまま
915 -- ResponseWriter に渡したりすると大變な事が起こる。何故なら
916 -- ResponseWriter は Transfer-Encoding: chunked の時、ヘッダを書
918 sendChunks :: Lazy.ByteString -> Int -> Resource ()
920 | L8.null str = return ()
921 | otherwise = do let (chunk, remaining) = L8.splitAt (fromIntegral limit) str
922 itr <- getInteraction
923 liftIO $ atomically $
924 do buf <- readItr itr itrBodyToSend id
927 writeItr itr itrBodyToSend chunk
932 sendChunks remaining limit
936 [GettingBody からそれ以降の状態に遷移する時]
938 body を讀み終へてゐなければ、殘りの body を讀み捨てる。
941 [DecidingHeader からそれ以降の状態に遷移する時]
948 bodyIsNull が False ならば何もしない。True だった場合は出力補完す
953 driftTo :: InteractionState -> Resource ()
956 do itr <- getInteraction
957 liftIO $ atomically $ do oldState <- readItr itr itrState id
958 if newState < oldState then
959 throwStateError oldState newState
961 do let a = [oldState .. newState]
964 mapM_ (uncurry $ drift itr) c
965 writeItr itr itrState newState
967 throwStateError :: Monad m => InteractionState -> InteractionState -> m a
969 throwStateError Done DecidingBody
970 = fail "It makes no sense to output something after finishing to output."
972 throwStateError old new
973 = fail ("state error: " ++ show old ++ " ==> " ++ show new)
976 drift :: Interaction -> InteractionState -> InteractionState -> STM ()
978 drift itr GettingBody _
979 = writeItr itr itrReqBodyWasteAll True
981 drift itr DecidingHeader _
985 = do bodyIsNull <- readItr itr itrBodyIsNull id
987 $ writeDefaultPage itr