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
143 import Control.Concurrent.STM
144 import Control.Monad.Reader
145 import qualified Data.ByteString as Strict (ByteString)
146 import qualified Data.ByteString.Lazy as Lazy (ByteString)
147 import qualified Data.ByteString.Char8 as C8 hiding (ByteString)
148 import qualified Data.ByteString.Lazy.Char8 as L8 hiding (ByteString)
153 import qualified Data.Time.HTTP as HTTP
154 import Network.HTTP.Lucu.Abortion
155 import Network.HTTP.Lucu.Authorization
156 import Network.HTTP.Lucu.Config
157 import Network.HTTP.Lucu.ContentCoding
158 import Network.HTTP.Lucu.DefaultPage
159 import Network.HTTP.Lucu.ETag
160 import qualified Network.HTTP.Lucu.Headers as H
161 import Network.HTTP.Lucu.HttpVersion
162 import Network.HTTP.Lucu.Interaction
163 import Network.HTTP.Lucu.MultipartForm
164 import Network.HTTP.Lucu.Parser
165 import Network.HTTP.Lucu.Postprocess
166 import Network.HTTP.Lucu.Request
167 import Network.HTTP.Lucu.Response
168 import Network.HTTP.Lucu.MIMEType
169 import Network.HTTP.Lucu.Utils
170 import Network.Socket hiding (accept)
171 import Network.URI hiding (path)
174 -- |The 'Resource' monad. This monad implements
175 -- 'Control.Monad.Trans.MonadIO' so it can do any 'Prelude.IO'
177 newtype Resource a = Resource { unRes :: ReaderT Interaction IO a }
179 instance Functor Resource where
180 fmap f c = Resource (fmap f (unRes c))
182 instance Monad Resource where
183 c >>= f = Resource (unRes c >>= unRes . f)
184 return = Resource . return
185 fail = Resource . fail
187 instance MonadIO Resource where
188 liftIO = Resource . liftIO
191 runRes :: Resource a -> Interaction -> IO a
193 = runReaderT (unRes r) itr
196 getInteraction :: Resource Interaction
197 getInteraction = Resource ask
200 -- |Get the 'Network.HTTP.Lucu.Config.Config' value which is used for
202 getConfig :: Resource Config
203 getConfig = do itr <- getInteraction
204 return $! itrConfig itr
207 -- |Get the 'Network.Socket.SockAddr' of the remote host. If you want
208 -- a string representation instead of 'Network.Socket.SockAddr', use
210 getRemoteAddr :: Resource SockAddr
211 getRemoteAddr = do itr <- getInteraction
212 return $! itrRemoteAddr itr
215 -- |Get the string representation of the address of remote host. If
216 -- you want a 'Network.Socket.SockAddr' instead of 'Prelude.String',
217 -- use 'getRemoteAddr'.
218 getRemoteAddr' :: Resource String
219 getRemoteAddr' = do addr <- getRemoteAddr
220 (Just str, _) <- liftIO $! getNameInfo [NI_NUMERICHOST] True False addr
223 -- |Resolve an address to the remote host.
224 getRemoteHost :: Resource String
225 getRemoteHost = do addr <- getRemoteAddr
226 (Just str, _) <- liftIO $! getNameInfo [] True False addr
229 -- | Return the X.509 certificate of the client, or 'Nothing' if:
231 -- * This request didn't came through an SSL stream.
233 -- * The client didn't send us its certificate.
235 -- * The 'OpenSSL.Session.VerificationMode' of
236 -- 'OpenSSL.Session.SSLContext' in
237 -- 'Network.HTTP.Lucu.Config.SSLConfig' has not been set to
238 -- 'OpenSSL.Session.VerifyPeer'.
239 getRemoteCertificate :: Resource (Maybe X509)
240 getRemoteCertificate = do itr <- getInteraction
241 return $! itrRemoteCert itr
243 -- |Get the 'Network.HTTP.Lucu.Request.Request' value which represents
244 -- the request header. In general you don't have to use this action.
245 getRequest :: Resource Request
246 getRequest = do itr <- getInteraction
247 req <- liftIO $! atomically $! readItr itr itrRequest fromJust
250 -- |Get the 'Network.HTTP.Lucu.Request.Method' value of the request.
251 getMethod :: Resource Method
252 getMethod = do req <- getRequest
253 return $! reqMethod req
255 -- |Get the URI of the request.
256 getRequestURI :: Resource URI
257 getRequestURI = do req <- getRequest
260 -- |Get the HTTP version of the request.
261 getRequestVersion :: Resource HttpVersion
262 getRequestVersion = do req <- getRequest
263 return $! reqVersion req
265 -- |Get the path of this 'Resource' (to be exact,
266 -- 'Network.HTTP.Lucu.Resource.Tree.ResourceDef') in the
267 -- 'Network.HTTP.Lucu.Resource.Tree.ResTree'. The result of this
268 -- action is the exact path in the tree even if the
269 -- 'Network.HTTP.Lucu.Resource.Tree.ResourceDef' is greedy.
273 -- > main = let tree = mkResTree [ (["foo"], resFoo) ]
274 -- > in runHttpd defaultConfig tree
276 -- > resFoo = ResourceDef {
277 -- > resIsGreedy = True
278 -- > , resGet = Just $ do requestURI <- getRequestURI
279 -- > resourcePath <- getResourcePath
280 -- > pathInfo <- getPathInfo
281 -- > -- uriPath requestURI == "/foo/bar/baz"
282 -- > -- resourcePath == ["foo"]
283 -- > -- pathInfo == ["bar", "baz"]
287 getResourcePath :: Resource [String]
288 getResourcePath = do itr <- getInteraction
289 return $! fromJust $! itrResourcePath itr
292 -- |This is an analogy of CGI PATH_INFO. The result is
293 -- URI-unescaped. It is always @[]@ if the
294 -- 'Network.HTTP.Lucu.Resource.Tree.ResourceDef' is not greedy. See
295 -- 'getResourcePath'.
296 getPathInfo :: Resource [String]
297 getPathInfo = do rsrcPath <- getResourcePath
299 let reqPathStr = uriPath uri
300 reqPath = [unEscapeString x | x <- splitBy (== '/') reqPathStr, x /= ""]
301 -- rsrcPath と reqPath の共通する先頭部分を reqPath か
302 -- ら全部取り除くと、それは PATH_INFO のやうなものにな
303 -- る。rsrcPath は全部一致してゐるに決まってゐる(でな
304 -- ければこの Resource が撰ばれた筈が無い)ので、
305 -- rsrcPath の長さの分だけ削除すれば良い。
306 return $! drop (length rsrcPath) reqPath
308 -- |Assume the query part of request URI as
309 -- application\/x-www-form-urlencoded, and parse it to pairs of
310 -- @(name, formData)@. This action doesn't parse the request body. See
312 getQueryForm :: Resource [(String, FormData)]
313 getQueryForm = liftM parse' getRequestURI
315 parse' = map toPairWithFormData .
316 parseWWWFormURLEncoded .
321 toPairWithFormData :: (String, String) -> (String, FormData)
322 toPairWithFormData (name, value)
323 = let fd = FormData {
325 , fdContent = L8.pack value
329 -- |Get a value of given request header. Comparison of header name is
330 -- case-insensitive. Note that this action is not intended to be used
331 -- so frequently: there should be actions like 'getContentType' for
332 -- every common headers.
333 getHeader :: Strict.ByteString -> Resource (Maybe Strict.ByteString)
334 getHeader name = name `seq`
336 return $! H.getHeader name req
338 -- |Get a list of 'Network.HTTP.Lucu.MIMEType.MIMEType' enumerated on
339 -- header \"Accept\".
340 getAccept :: Resource [MIMEType]
341 getAccept = do acceptM <- getHeader (C8.pack "Accept")
346 -> case parse mimeTypeListP (L8.fromChunks [accept]) of
347 (# Success xs, _ #) -> return xs
348 (# _ , _ #) -> abort BadRequest []
349 (Just $ "Unparsable Accept: " ++ C8.unpack accept)
351 -- |Get a list of @(contentCoding, qvalue)@ enumerated on header
352 -- \"Accept-Encoding\". The list is sorted in descending order by
354 getAcceptEncoding :: Resource [(String, Maybe Double)]
356 = do accEncM <- getHeader (C8.pack "Accept-Encoding")
359 -- HTTP/1.0 には Accept-Encoding が無い場合の規定が無い
360 -- ので安全の爲 identity が指定された事にする。HTTP/1.1
361 -- の場合は何でも受け入れて良い事になってゐるので "*" が
363 -> do ver <- getRequestVersion
365 HttpVersion 1 0 -> return [("identity", Nothing)]
366 HttpVersion 1 1 -> return [("*" , Nothing)]
369 -> if C8.null value then
371 return [("identity", Nothing)]
373 case parse acceptEncodingListP (L8.fromChunks [value]) of
374 (# Success x, _ #) -> return $ reverse $ sortBy orderAcceptEncodings x
375 (# _ , _ #) -> abort BadRequest []
376 (Just $ "Unparsable Accept-Encoding: " ++ C8.unpack value)
378 -- |Check whether a given content-coding is acceptable.
379 isEncodingAcceptable :: String -> Resource Bool
380 isEncodingAcceptable coding
381 = do accList <- getAcceptEncoding
382 return (flip any accList $ \ (c, q) ->
383 (c == "*" || C8.pack c `H.noCaseEq` C8.pack coding) && q /= Just 0)
386 -- |Get the header \"Content-Type\" as
387 -- 'Network.HTTP.Lucu.MIMEType.MIMEType'.
388 getContentType :: Resource (Maybe MIMEType)
390 = do cTypeM <- getHeader (C8.pack "Content-Type")
395 -> case parse mimeTypeP (L8.fromChunks [cType]) of
396 (# Success t, _ #) -> return $ Just t
397 (# _ , _ #) -> abort BadRequest []
398 (Just $ "Unparsable Content-Type: " ++ C8.unpack cType)
401 -- |Get the header \"Authorization\" as
402 -- 'Network.HTTP.Lucu.Authorization.AuthCredential'.
403 getAuthorization :: Resource (Maybe AuthCredential)
405 = do authM <- getHeader (C8.pack "Authorization")
410 -> case parse authCredentialP (L8.fromChunks [auth]) of
411 (# Success a, _ #) -> return $ Just a
412 (# _ , _ #) -> return Nothing
415 {- ExaminingRequest 時に使用するアクション群 -}
417 -- |Tell the system that the 'Resource' found an entity for the
418 -- request URI. If this is a GET or HEAD request, a found entity means
419 -- a datum to be replied. If this is a PUT or DELETE request, it means
420 -- a datum which was stored for the URI until now. It is an error to
421 -- compute 'foundEntity' if this is a POST request.
423 -- Computation of 'foundEntity' performs \"If-Match\" test or
424 -- \"If-None-Match\" test if possible. When those tests fail, the
425 -- computation of 'Resource' immediately aborts with status \"412
426 -- Precondition Failed\" or \"304 Not Modified\" depending on the
429 -- If this is a GET or HEAD request, 'foundEntity' automatically puts
430 -- \"ETag\" and \"Last-Modified\" headers into the response.
431 foundEntity :: ETag -> UTCTime -> Resource ()
432 foundEntity tag timeStamp
433 = tag `seq` timeStamp `seq`
434 do driftTo ExaminingRequest
437 when (method == GET || method == HEAD)
438 $ setHeader' (C8.pack "Last-Modified") (C8.pack $ HTTP.format timeStamp)
439 when (method == POST)
440 $ abort InternalServerError []
441 (Just "Illegal computation of foundEntity for a POST request.")
446 -- |Tell the system that the 'Resource' found an entity for the
447 -- request URI. The only difference from 'foundEntity' is that
448 -- 'foundETag' doesn't (and can't) put \"Last-Modified\" header into
451 -- This action is not preferred. You should use 'foundEntity' whenever
453 foundETag :: ETag -> Resource ()
456 do driftTo ExaminingRequest
459 when (method == GET || method == HEAD)
460 $ setHeader' (C8.pack "ETag") (C8.pack $ show tag)
461 when (method == POST)
462 $ abort InternalServerError []
463 (Just "Illegal computation of foundETag for POST request.")
465 -- If-Match があればそれを見る。
466 ifMatch <- getHeader (C8.pack "If-Match")
469 Just value -> if value == C8.pack "*" then
472 case parse eTagListP (L8.fromChunks [value]) of
473 (# Success tags, _ #)
474 -- tags の中に一致するものが無ければ
475 -- PreconditionFailed で終了。
476 -> when (not $ any (== tag) tags)
477 $ abort PreconditionFailed []
478 $! Just ("The entity tag doesn't match: " ++ C8.unpack value)
480 -> abort BadRequest [] $! Just ("Unparsable If-Match: " ++ C8.unpack value)
482 let statusForNoneMatch = if method == GET || method == HEAD then
487 -- If-None-Match があればそれを見る。
488 ifNoneMatch <- getHeader (C8.pack "If-None-Match")
491 Just value -> if value == C8.pack "*" then
492 abort statusForNoneMatch [] $! Just ("The entity tag matches: *")
494 case parse eTagListP (L8.fromChunks [value]) of
495 (# Success tags, _ #)
496 -> when (any (== tag) tags)
497 $ abort statusForNoneMatch [] $! Just ("The entity tag matches: " ++ C8.unpack value)
499 -> abort BadRequest [] $! Just ("Unparsable If-None-Match: " ++ C8.unpack value)
503 -- |Tell the system that the 'Resource' found an entity for the
504 -- request URI. The only difference from 'foundEntity' is that
505 -- 'foundTimeStamp' performs \"If-Modified-Since\" test or
506 -- \"If-Unmodified-Since\" test instead of \"If-Match\" test or
507 -- \"If-None-Match\" test. Be aware that any tests based on last
508 -- modification time are unsafe because it is possible to mess up such
509 -- tests by modifying the entity twice in a second.
511 -- This action is not preferred. You should use 'foundEntity' whenever
513 foundTimeStamp :: UTCTime -> Resource ()
514 foundTimeStamp timeStamp
516 do driftTo ExaminingRequest
519 when (method == GET || method == HEAD)
520 $ setHeader' (C8.pack "Last-Modified") (C8.pack $ HTTP.format timeStamp)
521 when (method == POST)
522 $ abort InternalServerError []
523 (Just "Illegal computation of foundTimeStamp for POST request.")
525 let statusForIfModSince = if method == GET || method == HEAD then
530 -- If-Modified-Since があればそれを見る。
531 ifModSince <- getHeader (C8.pack "If-Modified-Since")
533 Just str -> case HTTP.parse (C8.unpack str) of
535 -> when (timeStamp <= lastTime)
536 $ abort statusForIfModSince []
537 $! Just ("The entity has not been modified since " ++ C8.unpack str)
539 -> return () -- 不正な時刻は無視
542 -- If-Unmodified-Since があればそれを見る。
543 ifUnmodSince <- getHeader (C8.pack "If-Unmodified-Since")
545 Just str -> case HTTP.parse (C8.unpack str) of
547 -> when (timeStamp > lastTime)
548 $ abort PreconditionFailed []
549 $! Just ("The entity has not been modified since " ++ C8.unpack str)
551 -> return () -- 不正な時刻は無視
556 -- | Computation of @'foundNoEntity' mStr@ tells the system that the
557 -- 'Resource' found no entity for the request URI. @mStr@ is an
558 -- optional error message to be replied to the client.
560 -- If this is a PUT request, 'foundNoEntity' performs \"If-Match\"
561 -- test and aborts with status \"412 Precondition Failed\" when it
562 -- failed. If this is a GET, HEAD, POST or DELETE request,
563 -- 'foundNoEntity' always aborts with status \"404 Not Found\".
564 foundNoEntity :: Maybe String -> Resource ()
567 do driftTo ExaminingRequest
571 $ abort NotFound [] msgM
573 -- エンティティが存在しないと云ふ事は、"*" も含めたどのやうな
574 -- If-Match: 條件も滿たさない。
575 ifMatch <- getHeader (C8.pack "If-Match")
576 when (ifMatch /= Nothing)
577 $ abort PreconditionFailed [] msgM
582 {- GettingBody 時に使用するアクション群 -}
584 -- | Computation of @'input' limit@ attempts to read the request body
585 -- up to @limit@ bytes, and then make the 'Resource' transit to
586 -- /Deciding Header/ state. When the actual size of body is larger
587 -- than @limit@ bytes, computation of 'Resource' immediately aborts
588 -- with status \"413 Request Entity Too Large\". When the request has
589 -- no body, 'input' returns an empty string.
591 -- @limit@ may be less than or equal to zero. In this case, the
592 -- default limitation value
593 -- ('Network.HTTP.Lucu.Config.cnfMaxEntityLength') is used. See
596 -- Note that 'inputLBS' is more efficient than 'input' so you should
597 -- use it whenever possible.
598 input :: Int -> Resource String
599 input limit = limit `seq`
600 inputLBS limit >>= return . L8.unpack
603 -- | This is mostly the same as 'input' but is more
604 -- efficient. 'inputLBS' returns a 'Data.ByteString.Lazy.ByteString'
605 -- but it's not really lazy: reading from the socket just happens at
606 -- the computation of 'inputLBS', not at the evaluation of the
607 -- 'Data.ByteString.Lazy.ByteString'. The same goes for
609 inputLBS :: Int -> Resource Lazy.ByteString
612 do driftTo GettingBody
613 itr <- getInteraction
614 hasBody <- liftIO $! atomically $! readItr itr itrRequestHasBody id
615 chunk <- if hasBody then
618 do driftTo DecidingHeader
622 askForInput :: Interaction -> Resource Lazy.ByteString
625 do let confLimit = cnfMaxEntityLength $ itrConfig itr
626 actualLimit = if limit <= 0 then
630 when (actualLimit <= 0)
631 $ fail ("inputLBS: limit must be positive: " ++ show actualLimit)
634 $! do chunkLen <- readItr itr itrReqChunkLength id
635 writeItr itr itrWillReceiveBody True
636 if fmap (> actualLimit) chunkLen == Just True then
640 writeItr itr itrReqBodyWanted $ Just actualLimit
641 -- 應答を待つ。トランザクションを分けなければ當然デッドロック。
642 chunk <- liftIO $! atomically
643 $! do chunk <- readItr itr itrReceivedBody id
644 chunkIsOver <- readItr itr itrReqChunkIsOver id
645 if L8.length chunk < fromIntegral actualLimit then
655 $ tooLarge actualLimit
656 -- 成功。itr 内にチャンクを置いたままにす
658 writeItr itr itrReceivedBody L8.empty
660 driftTo DecidingHeader
663 tooLarge :: Int -> STM ()
664 tooLarge lim = lim `seq`
665 abortSTM RequestEntityTooLarge []
666 $! Just ("Request body must be smaller than "
667 ++ show lim ++ " bytes.")
669 -- | Computation of @'inputChunk' limit@ attempts to read a part of
670 -- request body up to @limit@ bytes. You can read any large request by
671 -- repeating computation of this action. When you've read all the
672 -- request body, 'inputChunk' returns an empty string and then make
673 -- the 'Resource' transit to /Deciding Header/ state.
675 -- @limit@ may be less than or equal to zero. In this case, the
676 -- default limitation value
677 -- ('Network.HTTP.Lucu.Config.cnfMaxEntityLength') is used. See
680 -- Note that 'inputChunkLBS' is more efficient than 'inputChunk' so you
681 -- should use it whenever possible.
682 inputChunk :: Int -> Resource String
683 inputChunk limit = limit `seq`
684 inputChunkLBS limit >>= return . L8.unpack
687 -- | This is mostly the same as 'inputChunk' but is more
688 -- efficient. See 'inputLBS'.
689 inputChunkLBS :: Int -> Resource Lazy.ByteString
692 do driftTo GettingBody
693 itr <- getInteraction
694 hasBody <- liftIO $ atomically $ readItr itr itrRequestHasBody id
695 chunk <- if hasBody then
698 do driftTo DecidingHeader
702 askForInput :: Interaction -> Resource Lazy.ByteString
705 do let confLimit = cnfMaxEntityLength $! itrConfig itr
706 actualLimit = if limit < 0 then
710 when (actualLimit <= 0)
711 $ fail ("inputChunkLBS: limit must be positive: " ++ show actualLimit)
714 $! do writeItr itr itrReqBodyWanted $! Just actualLimit
715 writeItr itr itrWillReceiveBody True
716 -- 應答を待つ。トランザクションを分けなければ當然デッドロック。
717 chunk <- liftIO $! atomically
718 $ do chunk <- readItr itr itrReceivedBody id
719 -- 要求された量に滿たなくて、まだ殘りがあ
721 when (L8.length chunk < fromIntegral actualLimit)
722 $ do chunkIsOver <- readItr itr itrReqChunkIsOver id
726 writeItr itr itrReceivedBody L8.empty
729 $ driftTo DecidingHeader
732 -- | Computation of @'inputForm' limit@ attempts to read the request
733 -- body with 'input' and parse it as
734 -- application\/x-www-form-urlencoded or multipart\/form-data. If the
735 -- request header \"Content-Type\" is neither of them, 'inputForm'
736 -- makes 'Resource' abort with status \"415 Unsupported Media
737 -- Type\". If the request has no \"Content-Type\", it aborts with
738 -- \"400 Bad Request\".
739 inputForm :: Int -> Resource [(String, FormData)]
742 do cTypeM <- getContentType
745 -> abort BadRequest [] (Just "Missing Content-Type")
746 Just (MIMEType "application" "x-www-form-urlencoded" _)
747 -> readWWWFormURLEncoded
748 Just (MIMEType "multipart" "form-data" params)
749 -> readMultipartFormData params
751 -> abort UnsupportedMediaType [] (Just $! "Unsupported media type: "
754 readWWWFormURLEncoded
755 = liftM (map toPairWithFormData . parseWWWFormURLEncoded) (input limit)
757 readMultipartFormData params
758 = do case find ((== "boundary") . map toLower . fst) params of
760 -> abort BadRequest [] (Just "Missing boundary of multipart/form-data")
762 -> do src <- inputLBS limit
763 case parse (multipartFormP boundary) src of
764 (# Success formList, _ #)
767 -> abort BadRequest [] (Just "Unparsable multipart/form-data")
769 -- | This is just a constant @-1@. It's better to say @'input'
770 -- 'defaultLimit'@ than to say @'input' (-1)@ but these are exactly
777 {- DecidingHeader 時に使用するアクション群 -}
779 -- | Set the response status code. If you omit to compute this action,
780 -- the status code will be defaulted to \"200 OK\".
781 setStatus :: StatusCode -> Resource ()
784 do driftTo DecidingHeader
785 itr <- getInteraction
786 liftIO $! atomically $! updateItr itr itrResponse
791 -- | Set a value of given resource header. Comparison of header name
792 -- is case-insensitive. Note that this action is not intended to be
793 -- used so frequently: there should be actions like 'setContentType'
794 -- for every common headers.
796 -- Some important headers (especially \"Content-Length\" and
797 -- \"Transfer-Encoding\") may be silently dropped or overwritten by
798 -- the system not to corrupt the interaction with client at the
799 -- viewpoint of HTTP protocol layer. For instance, if we are keeping
800 -- the connection alive, without this process it causes a catastrophe
801 -- to send a header \"Content-Length: 10\" and actually send a body of
802 -- 20 bytes long. In this case the client shall only accept the first
803 -- 10 bytes of response body and thinks that the residual 10 bytes is
804 -- a part of header of the next response.
805 setHeader :: Strict.ByteString -> Strict.ByteString -> Resource ()
807 = name `seq` value `seq`
808 driftTo DecidingHeader >> setHeader' name value
811 setHeader' :: Strict.ByteString -> Strict.ByteString -> Resource ()
812 setHeader' name value
813 = name `seq` value `seq`
814 do itr <- getInteraction
816 $ updateItr itr itrResponse
817 $ H.setHeader name value
819 -- | Computation of @'redirect' code uri@ sets the response status to
820 -- @code@ and \"Location\" header to @uri@. The @code@ must satisfy
821 -- 'Network.HTTP.Lucu.Response.isRedirection' or it causes an error.
822 redirect :: StatusCode -> URI -> Resource ()
824 = code `seq` uri `seq`
825 do when (code == NotModified || not (isRedirection code))
826 $ abort InternalServerError []
827 $! Just ("Attempted to redirect with status " ++ show code)
830 {-# INLINE redirect #-}
833 -- | Computation of @'setContentType' mType@ sets the response header
834 -- \"Content-Type\" to @mType@.
835 setContentType :: MIMEType -> Resource ()
837 = setHeader (C8.pack "Content-Type") (C8.pack $ show mType)
839 -- | Computation of @'setLocation' uri@ sets the response header
840 -- \"Location\" to @uri@.
841 setLocation :: URI -> Resource ()
843 = setHeader (C8.pack "Location") (C8.pack $ uriToString id uri $ "")
845 -- |Computation of @'setContentEncoding' codings@ sets the response
846 -- header \"Content-Encoding\" to @codings@.
847 setContentEncoding :: [String] -> Resource ()
848 setContentEncoding codings
849 = do ver <- getRequestVersion
851 HttpVersion 1 0 -> unnormalizeCoding
852 HttpVersion 1 1 -> id
854 setHeader (C8.pack "Content-Encoding") (C8.pack $ joinWith ", " $ map tr codings)
856 -- |Computation of @'setWWWAuthenticate' challenge@ sets the response
857 -- header \"WWW-Authenticate\" to @challenge@.
858 setWWWAuthenticate :: AuthChallenge -> Resource ()
859 setWWWAuthenticate challenge
860 = setHeader (C8.pack "WWW-Authenticate") (C8.pack $ show challenge)
863 {- DecidingBody 時に使用するアクション群 -}
865 -- | Computation of @'output' str@ writes @str@ as a response body,
866 -- and then make the 'Resource' transit to /Done/ state. It is safe to
867 -- apply 'output' to an infinite string, such as a lazy stream of
870 -- Note that 'outputLBS' is more efficient than 'output' so you should
871 -- use it whenever possible.
872 output :: String -> Resource ()
873 output str = outputLBS $! L8.pack str
874 {-# INLINE output #-}
876 -- | This is mostly the same as 'output' but is more efficient.
877 outputLBS :: Lazy.ByteString -> Resource ()
878 outputLBS str = do outputChunkLBS str
880 {-# INLINE outputLBS #-}
882 -- | Computation of @'outputChunk' str@ writes @str@ as a part of
883 -- response body. You can compute this action multiple times to write
884 -- a body little at a time. It is safe to apply 'outputChunk' to an
887 -- Note that 'outputChunkLBS' is more efficient than 'outputChunk' so
888 -- you should use it whenever possible.
889 outputChunk :: String -> Resource ()
890 outputChunk str = outputChunkLBS $! L8.pack str
891 {-# INLINE outputChunk #-}
893 -- | This is mostly the same as 'outputChunk' but is more efficient.
894 outputChunkLBS :: Lazy.ByteString -> Resource ()
895 outputChunkLBS wholeChunk
897 do driftTo DecidingBody
898 itr <- getInteraction
900 let limit = cnfMaxOutputChunkLength $ itrConfig itr
902 $ fail ("cnfMaxOutputChunkLength must be positive: "
905 discardBody <- liftIO $ atomically $
906 readItr itr itrWillDiscardBody id
909 $ sendChunks wholeChunk limit
911 unless (L8.null wholeChunk)
912 $ liftIO $ atomically $
913 writeItr itr itrBodyIsNull False
915 -- チャンクの大きさは Config で制限されてゐる。もし例へば
916 -- "/dev/zero" を L8.readFile して作った Lazy.ByteString をそのまま
917 -- ResponseWriter に渡したりすると大變な事が起こる。何故なら
918 -- ResponseWriter は Transfer-Encoding: chunked の時、ヘッダを書
920 sendChunks :: Lazy.ByteString -> Int -> Resource ()
922 | L8.null str = return ()
923 | otherwise = do let (chunk, remaining) = L8.splitAt (fromIntegral limit) str
924 itr <- getInteraction
925 liftIO $ atomically $
926 do buf <- readItr itr itrBodyToSend id
929 writeItr itr itrBodyToSend chunk
934 sendChunks remaining limit
938 [GettingBody からそれ以降の状態に遷移する時]
940 body を讀み終へてゐなければ、殘りの body を讀み捨てる。
943 [DecidingHeader からそれ以降の状態に遷移する時]
950 bodyIsNull が False ならば何もしない。True だった場合は出力補完す
955 driftTo :: InteractionState -> Resource ()
958 do itr <- getInteraction
959 liftIO $ atomically $ do oldState <- readItr itr itrState id
960 if newState < oldState then
961 throwStateError oldState newState
963 do let a = [oldState .. newState]
966 mapM_ (uncurry $ drift itr) c
967 writeItr itr itrState newState
969 throwStateError :: Monad m => InteractionState -> InteractionState -> m a
971 throwStateError Done DecidingBody
972 = fail "It makes no sense to output something after finishing to output."
974 throwStateError old new
975 = fail ("state error: " ++ show old ++ " ==> " ++ show new)
978 drift :: Interaction -> InteractionState -> InteractionState -> STM ()
980 drift itr GettingBody _
981 = writeItr itr itrReqBodyWasteAll True
983 drift itr DecidingHeader _
987 = do bodyIsNull <- readItr itr itrBodyIsNull id
989 $ writeDefaultPage itr