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
70 -- ** Getting request header
72 -- |These actions can be computed regardless of the current state,
73 -- and they don't change the state.
78 , getRemoteCertificate
89 , isEncodingAcceptable
93 -- ** Finding an entity
95 -- |These actions can be computed only in the /Examining Request/
96 -- state. After the computation, the 'Resource' transits to
97 -- /Getting Body/ state.
103 -- ** Getting a request body
105 -- |Computation of these actions changes the state to /Getting
114 -- ** Setting response headers
116 -- |Computation of these actions changes the state to /Deciding
126 -- ** Writing a response body
128 -- |Computation of these actions changes the state to /Deciding
139 import Control.Concurrent.STM
140 import Control.Monad.Reader
141 import qualified Data.ByteString as Strict (ByteString)
142 import qualified Data.ByteString.Lazy as Lazy (ByteString)
143 import qualified Data.ByteString.Char8 as C8 hiding (ByteString)
144 import qualified Data.ByteString.Lazy.Char8 as L8 hiding (ByteString)
149 import Network.HTTP.Lucu.Abortion
150 import Network.HTTP.Lucu.Authorization
151 import Network.HTTP.Lucu.Config
152 import Network.HTTP.Lucu.ContentCoding
153 import Network.HTTP.Lucu.DefaultPage
154 import Network.HTTP.Lucu.ETag
155 import qualified Network.HTTP.Lucu.Headers as H
156 import Network.HTTP.Lucu.HttpVersion
157 import Network.HTTP.Lucu.Interaction
158 import Network.HTTP.Lucu.MultipartForm
159 import Network.HTTP.Lucu.Parser
160 import Network.HTTP.Lucu.Postprocess
161 import Network.HTTP.Lucu.RFC1123DateTime
162 import Network.HTTP.Lucu.Request
163 import Network.HTTP.Lucu.Response
164 import Network.HTTP.Lucu.MIMEType
165 import Network.HTTP.Lucu.Utils
166 import Network.Socket hiding (accept)
167 import Network.URI hiding (path)
170 -- |The 'Resource' monad. This monad implements
171 -- 'Control.Monad.Trans.MonadIO' so it can do any 'Prelude.IO'
173 newtype Resource a = Resource { unRes :: ReaderT Interaction IO a }
175 instance Functor Resource where
176 fmap f c = Resource (fmap f (unRes c))
178 instance Monad Resource where
179 c >>= f = Resource (unRes c >>= unRes . f)
180 return = Resource . return
181 fail = Resource . fail
183 instance MonadIO Resource where
184 liftIO = Resource . liftIO
187 runRes :: Resource a -> Interaction -> IO a
189 = runReaderT (unRes r) itr
192 getInteraction :: Resource Interaction
193 getInteraction = Resource ask
196 -- |Get the 'Network.HTTP.Lucu.Config.Config' value which is used for
198 getConfig :: Resource Config
199 getConfig = do itr <- getInteraction
200 return $! itrConfig itr
203 -- |Get the 'Network.Socket.SockAddr' of the remote host. If you want
204 -- a string representation instead of 'Network.Socket.SockAddr', use
206 getRemoteAddr :: Resource SockAddr
207 getRemoteAddr = do itr <- getInteraction
208 return $! itrRemoteAddr itr
211 -- |Get the string representation of the address of remote host. If
212 -- you want a 'Network.Socket.SockAddr' instead of 'Prelude.String',
213 -- use 'getRemoteAddr'.
214 getRemoteAddr' :: Resource String
215 getRemoteAddr' = do addr <- getRemoteAddr
216 (Just str, _) <- liftIO $! getNameInfo [NI_NUMERICHOST] True False addr
219 -- |Resolve an address to the remote host.
220 getRemoteHost :: Resource String
221 getRemoteHost = do addr <- getRemoteAddr
222 (Just str, _) <- liftIO $! getNameInfo [] True False addr
225 -- | Return the X.509 certificate of the client, or 'Nothing' if:
227 -- * This request didn't came through an SSL stream.
229 -- * The client didn't send us its certificate.
231 -- * The 'OpenSSL.Session.VerificationMode' of
232 -- 'OpenSSL.Session.SSLContext' in
233 -- 'Network.HTTP.Lucu.Config.SSLConfig' has not been set to
234 -- 'OpenSSL.Session.VerifyPeer'.
235 getRemoteCertificate :: Resource (Maybe X509)
236 getRemoteCertificate = do itr <- getInteraction
237 return $! itrRemoteCert itr
239 -- |Get the 'Network.HTTP.Lucu.Request.Request' value which represents
240 -- the request header. In general you don't have to use this action.
241 getRequest :: Resource Request
242 getRequest = do itr <- getInteraction
243 req <- liftIO $! atomically $! readItr itr itrRequest fromJust
246 -- |Get the 'Network.HTTP.Lucu.Request.Method' value of the request.
247 getMethod :: Resource Method
248 getMethod = do req <- getRequest
249 return $! reqMethod req
251 -- |Get the URI of the request.
252 getRequestURI :: Resource URI
253 getRequestURI = do req <- getRequest
256 -- |Get the HTTP version of the request.
257 getRequestVersion :: Resource HttpVersion
258 getRequestVersion = do req <- getRequest
259 return $! reqVersion req
261 -- |Get the path of this 'Resource' (to be exact,
262 -- 'Network.HTTP.Lucu.Resource.Tree.ResourceDef') in the
263 -- 'Network.HTTP.Lucu.Resource.Tree.ResTree'. The result of this
264 -- action is the exact path in the tree even if the
265 -- 'Network.HTTP.Lucu.Resource.Tree.ResourceDef' is greedy.
269 -- > main = let tree = mkResTree [ (["foo"], resFoo) ]
270 -- > in runHttpd defaultConfig tree
272 -- > resFoo = ResourceDef {
273 -- > resIsGreedy = True
274 -- > , resGet = Just $ do requestURI <- getRequestURI
275 -- > resourcePath <- getResourcePath
276 -- > pathInfo <- getPathInfo
277 -- > -- uriPath requestURI == "/foo/bar/baz"
278 -- > -- resourcePath == ["foo"]
279 -- > -- pathInfo == ["bar", "baz"]
283 getResourcePath :: Resource [String]
284 getResourcePath = do itr <- getInteraction
285 return $! fromJust $! itrResourcePath itr
288 -- |This is an analogy of CGI PATH_INFO. The result is
289 -- URI-unescaped. It is always @[]@ if the
290 -- 'Network.HTTP.Lucu.Resource.Tree.ResourceDef' is not greedy. See
291 -- 'getResourcePath'.
292 getPathInfo :: Resource [String]
293 getPathInfo = do rsrcPath <- getResourcePath
295 let reqPathStr = uriPath uri
296 reqPath = [unEscapeString x | x <- splitBy (== '/') reqPathStr, x /= ""]
297 -- rsrcPath と reqPath の共通する先頭部分を reqPath か
298 -- ら全部取り除くと、それは PATH_INFO のやうなものにな
299 -- る。rsrcPath は全部一致してゐるに決まってゐる(でな
300 -- ければこの Resource が撰ばれた筈が無い)ので、
301 -- rsrcPath の長さの分だけ削除すれば良い。
302 return $! drop (length rsrcPath) reqPath
304 -- | Assume the query part of request URI as
305 -- application\/x-www-form-urlencoded, and parse it. This action
306 -- doesn't parse the request body. See 'inputForm'.
307 getQueryForm :: Resource [FormData]
308 getQueryForm = do uri <- getRequestURI
309 return $! map pairToFormData $ parseWWWFormURLEncoded $ snd $ splitAt 1 $ uriQuery uri
311 pairToFormData :: (String, String) -> FormData
312 pairToFormData (name, value)
315 , fdFileName = Nothing
316 , fdContent = L8.pack value
319 -- |Get a value of given request header. Comparison of header name is
320 -- case-insensitive. Note that this action is not intended to be used
321 -- so frequently: there should be actions like 'getContentType' for
322 -- every common headers.
323 getHeader :: Strict.ByteString -> Resource (Maybe Strict.ByteString)
324 getHeader name = name `seq`
326 return $! H.getHeader name req
328 -- |Get a list of 'Network.HTTP.Lucu.MIMEType.MIMEType' enumerated on
329 -- header \"Accept\".
330 getAccept :: Resource [MIMEType]
331 getAccept = do acceptM <- getHeader (C8.pack "Accept")
336 -> case parse mimeTypeListP (L8.fromChunks [accept]) of
337 (# Success xs, _ #) -> return xs
338 (# _ , _ #) -> abort BadRequest []
339 (Just $ "Unparsable Accept: " ++ C8.unpack accept)
341 -- |Get a list of @(contentCoding, qvalue)@ enumerated on header
342 -- \"Accept-Encoding\". The list is sorted in descending order by
344 getAcceptEncoding :: Resource [(String, Maybe Double)]
346 = do accEncM <- getHeader (C8.pack "Accept-Encoding")
349 -- HTTP/1.0 には Accept-Encoding が無い場合の規定が無い
350 -- ので安全の爲 identity が指定された事にする。HTTP/1.1
351 -- の場合は何でも受け入れて良い事になってゐるので "*" が
353 -> do ver <- getRequestVersion
355 HttpVersion 1 0 -> return [("identity", Nothing)]
356 HttpVersion 1 1 -> return [("*" , Nothing)]
359 -> if C8.null value then
361 return [("identity", Nothing)]
363 case parse acceptEncodingListP (L8.fromChunks [value]) of
364 (# Success x, _ #) -> return $ reverse $ sortBy orderAcceptEncodings x
365 (# _ , _ #) -> abort BadRequest []
366 (Just $ "Unparsable Accept-Encoding: " ++ C8.unpack value)
368 -- |Check whether a given content-coding is acceptable.
369 isEncodingAcceptable :: String -> Resource Bool
370 isEncodingAcceptable coding
371 = do accList <- getAcceptEncoding
372 return (flip any accList $ \ (c, q) ->
373 (c == "*" || C8.pack c `H.noCaseEq` C8.pack coding) && q /= Just 0)
376 -- |Get the header \"Content-Type\" as
377 -- 'Network.HTTP.Lucu.MIMEType.MIMEType'.
378 getContentType :: Resource (Maybe MIMEType)
380 = do cTypeM <- getHeader (C8.pack "Content-Type")
385 -> case parse mimeTypeP (L8.fromChunks [cType]) of
386 (# Success t, _ #) -> return $ Just t
387 (# _ , _ #) -> abort BadRequest []
388 (Just $ "Unparsable Content-Type: " ++ C8.unpack cType)
391 -- |Get the header \"Authorization\" as
392 -- 'Network.HTTP.Lucu.Authorization.AuthCredential'.
393 getAuthorization :: Resource (Maybe AuthCredential)
395 = do authM <- getHeader (C8.pack "Authorization")
400 -> case parse authCredentialP (L8.fromChunks [auth]) of
401 (# Success a, _ #) -> return $ Just a
402 (# _ , _ #) -> return Nothing
405 {- ExaminingRequest 時に使用するアクション群 -}
407 -- |Tell the system that the 'Resource' found an entity for the
408 -- request URI. If this is a GET or HEAD request, a found entity means
409 -- a datum to be replied. If this is a PUT or DELETE request, it means
410 -- a datum which was stored for the URI up to now. It is an error to
411 -- compute 'foundEntity' if this is a POST request.
413 -- Computation of 'foundEntity' performs \"If-Match\" test or
414 -- \"If-None-Match\" test if possible. When those tests fail, the
415 -- computation of 'Resource' immediately aborts with status \"412
416 -- Precondition Failed\" or \"304 Not Modified\" depending on the
419 -- If this is a GET or HEAD request, 'foundEntity' automatically puts
420 -- \"ETag\" and \"Last-Modified\" headers into the response.
421 foundEntity :: ETag -> UTCTime -> Resource ()
422 foundEntity tag timeStamp
423 = tag `seq` timeStamp `seq`
424 do driftTo ExaminingRequest
427 when (method == GET || method == HEAD)
428 $ setHeader' (C8.pack "Last-Modified") (C8.pack $ formatHTTPDateTime timeStamp)
429 when (method == POST)
430 $ abort InternalServerError []
431 (Just "Illegal computation of foundEntity for POST request.")
436 -- |Tell the system that the 'Resource' found an entity for the
437 -- request URI. The only difference from 'foundEntity' is that
438 -- 'foundETag' doesn't (and can't) put \"Last-Modified\" header into
441 -- This action is not preferred. You should use 'foundEntity' whenever
443 foundETag :: ETag -> Resource ()
446 do driftTo ExaminingRequest
449 when (method == GET || method == HEAD)
450 $ setHeader' (C8.pack "ETag") (C8.pack $ show tag)
451 when (method == POST)
452 $ abort InternalServerError []
453 (Just "Illegal computation of foundETag for POST request.")
455 -- If-Match があればそれを見る。
456 ifMatch <- getHeader (C8.pack "If-Match")
459 Just value -> if value == C8.pack "*" then
462 case parse eTagListP (L8.fromChunks [value]) of
463 (# Success tags, _ #)
464 -- tags の中に一致するものが無ければ
465 -- PreconditionFailed で終了。
466 -> when (not $ any (== tag) tags)
467 $ abort PreconditionFailed []
468 $! Just ("The entity tag doesn't match: " ++ C8.unpack value)
470 -> abort BadRequest [] $! Just ("Unparsable If-Match: " ++ C8.unpack value)
472 let statusForNoneMatch = if method == GET || method == HEAD then
477 -- If-None-Match があればそれを見る。
478 ifNoneMatch <- getHeader (C8.pack "If-None-Match")
481 Just value -> if value == C8.pack "*" then
482 abort statusForNoneMatch [] $! Just ("The entity tag matches: *")
484 case parse eTagListP (L8.fromChunks [value]) of
485 (# Success tags, _ #)
486 -> when (any (== tag) tags)
487 $ abort statusForNoneMatch [] $! Just ("The entity tag matches: " ++ C8.unpack value)
489 -> abort BadRequest [] $! Just ("Unparsable If-None-Match: " ++ C8.unpack value)
493 -- |Tell the system that the 'Resource' found an entity for the
494 -- request URI. The only difference from 'foundEntity' is that
495 -- 'foundTimeStamp' performs \"If-Modified-Since\" test or
496 -- \"If-Unmodified-Since\" test instead of \"If-Match\" test or
497 -- \"If-None-Match\" test. Be aware that any tests based on last
498 -- modification time are unsafe because it is possible to mess up such
499 -- tests by modifying the entity twice in a second.
501 -- This action is not preferred. You should use 'foundEntity' whenever
503 foundTimeStamp :: UTCTime -> Resource ()
504 foundTimeStamp timeStamp
506 do driftTo ExaminingRequest
509 when (method == GET || method == HEAD)
510 $ setHeader' (C8.pack "Last-Modified") (C8.pack $ formatHTTPDateTime timeStamp)
511 when (method == POST)
512 $ abort InternalServerError []
513 (Just "Illegal computation of foundTimeStamp for POST request.")
515 let statusForIfModSince = if method == GET || method == HEAD then
520 -- If-Modified-Since があればそれを見る。
521 ifModSince <- getHeader (C8.pack "If-Modified-Since")
523 Just str -> case parseHTTPDateTime (L8.fromChunks [str]) of
525 -> when (timeStamp <= lastTime)
526 $ abort statusForIfModSince []
527 $! Just ("The entity has not been modified since " ++ C8.unpack str)
529 -> return () -- 不正な時刻は無視
532 -- If-Unmodified-Since があればそれを見る。
533 ifUnmodSince <- getHeader (C8.pack "If-Unmodified-Since")
535 Just str -> case parseHTTPDateTime (L8.fromChunks [str]) of
537 -> when (timeStamp > lastTime)
538 $ abort PreconditionFailed []
539 $! Just ("The entity has not been modified since " ++ C8.unpack str)
541 -> return () -- 不正な時刻は無視
546 -- | Computation of @'foundNoEntity' mStr@ tells the system that the
547 -- 'Resource' found no entity for the request URI. @mStr@ is an
548 -- optional error message to be replied to the client.
550 -- If this is a PUT request, 'foundNoEntity' performs \"If-Match\"
551 -- test and aborts with status \"412 Precondition Failed\" when it
552 -- failed. If this is a GET, HEAD, POST or DELETE request,
553 -- 'foundNoEntity' always aborts with status \"404 Not Found\".
554 foundNoEntity :: Maybe String -> Resource ()
557 do driftTo ExaminingRequest
561 $ abort NotFound [] msgM
563 -- エンティティが存在しないと云ふ事は、"*" も含めたどのやうな
564 -- If-Match: 條件も滿たさない。
565 ifMatch <- getHeader (C8.pack "If-Match")
566 when (ifMatch /= Nothing)
567 $ abort PreconditionFailed [] msgM
572 {- GettingBody 時に使用するアクション群 -}
574 -- | Computation of @'input' limit@ attempts to read the request body
575 -- up to @limit@ bytes, and then make the 'Resource' transit to
576 -- /Deciding Header/ state. When the actual size of body is larger
577 -- than @limit@ bytes, computation of 'Resource' immediately aborts
578 -- with status \"413 Request Entity Too Large\". When the request has
579 -- no body, 'input' returns an empty string.
581 -- @limit@ may be less than or equal to zero. In this case, the
582 -- default limitation value
583 -- ('Network.HTTP.Lucu.Config.cnfMaxEntityLength') is used. See
586 -- Note that 'inputLBS' is more efficient than 'input' so you should
587 -- use it whenever possible.
588 input :: Int -> Resource String
589 input limit = limit `seq`
590 inputLBS limit >>= return . L8.unpack
593 -- | This is mostly the same as 'input' but is more
594 -- efficient. 'inputLBS' returns a 'Data.ByteString.Lazy.ByteString'
595 -- but it's not really lazy: reading from the socket just happens at
596 -- the computation of 'inputLBS', not at the evaluation of the
597 -- 'Data.ByteString.Lazy.ByteString'. The same goes for
599 inputLBS :: Int -> Resource Lazy.ByteString
602 do driftTo GettingBody
603 itr <- getInteraction
604 hasBody <- liftIO $! atomically $! readItr itr itrRequestHasBody id
605 chunk <- if hasBody then
608 do driftTo DecidingHeader
612 askForInput :: Interaction -> Resource Lazy.ByteString
615 do let confLimit = cnfMaxEntityLength $ itrConfig itr
616 actualLimit = if limit <= 0 then
620 when (actualLimit <= 0)
621 $ fail ("inputLBS: limit must be positive: " ++ show actualLimit)
624 $! do chunkLen <- readItr itr itrReqChunkLength id
625 writeItr itr itrWillReceiveBody True
626 if fmap (> actualLimit) chunkLen == Just True then
630 writeItr itr itrReqBodyWanted $ Just actualLimit
631 -- 應答を待つ。トランザクションを分けなければ當然デッドロック。
632 chunk <- liftIO $! atomically
633 $! do chunk <- readItr itr itrReceivedBody id
634 chunkIsOver <- readItr itr itrReqChunkIsOver id
635 if L8.length chunk < fromIntegral actualLimit then
645 $ tooLarge actualLimit
646 -- 成功。itr 内にチャンクを置いたままにす
648 writeItr itr itrReceivedBody L8.empty
650 driftTo DecidingHeader
653 tooLarge :: Int -> STM ()
654 tooLarge lim = lim `seq`
655 abortSTM RequestEntityTooLarge []
656 $! Just ("Request body must be smaller than "
657 ++ show lim ++ " bytes.")
659 -- | Computation of @'inputChunk' limit@ attempts to read a part of
660 -- request body up to @limit@ bytes. You can read any large request by
661 -- repeating computation of this action. When you've read all the
662 -- request body, 'inputChunk' returns an empty string and then make
663 -- the 'Resource' transit to /Deciding Header/ state.
665 -- @limit@ may be less than or equal to zero. In this case, the
666 -- default limitation value
667 -- ('Network.HTTP.Lucu.Config.cnfMaxEntityLength') is used. See
670 -- Note that 'inputChunkLBS' is more efficient than 'inputChunk' so you
671 -- should use it whenever possible.
672 inputChunk :: Int -> Resource String
673 inputChunk limit = limit `seq`
674 inputChunkLBS limit >>= return . L8.unpack
677 -- | This is mostly the same as 'inputChunk' but is more
678 -- efficient. See 'inputLBS'.
679 inputChunkLBS :: Int -> Resource Lazy.ByteString
682 do driftTo GettingBody
683 itr <- getInteraction
684 hasBody <- liftIO $ atomically $ readItr itr itrRequestHasBody id
685 chunk <- if hasBody then
688 do driftTo DecidingHeader
692 askForInput :: Interaction -> Resource Lazy.ByteString
695 do let confLimit = cnfMaxEntityLength $! itrConfig itr
696 actualLimit = if limit < 0 then
700 when (actualLimit <= 0)
701 $ fail ("inputChunkLBS: limit must be positive: " ++ show actualLimit)
704 $! do writeItr itr itrReqBodyWanted $! Just actualLimit
705 writeItr itr itrWillReceiveBody True
706 -- 應答を待つ。トランザクションを分けなければ當然デッドロック。
707 chunk <- liftIO $! atomically
708 $ do chunk <- readItr itr itrReceivedBody id
709 -- 要求された量に滿たなくて、まだ殘りがあ
711 when (L8.length chunk < fromIntegral actualLimit)
712 $ do chunkIsOver <- readItr itr itrReqChunkIsOver id
716 writeItr itr itrReceivedBody L8.empty
719 $ driftTo DecidingHeader
722 -- | Computation of @'inputForm' limit@ attempts to read the request
723 -- body with 'input' and parse it as
724 -- application\/x-www-form-urlencoded or multipart\/form-data. If the
725 -- request header \"Content-Type\" is neither of them, 'inputForm'
726 -- makes 'Resource' abort with status \"415 Unsupported Media
727 -- Type\". If the request has no \"Content-Type\", it aborts with
728 -- \"400 Bad Request\".
729 inputForm :: Int -> Resource [FormData]
732 do cTypeM <- getContentType
735 -> abort BadRequest [] (Just "Missing Content-Type")
736 Just (MIMEType "application" "x-www-form-urlencoded" _)
737 -> readWWWFormURLEncoded
738 Just (MIMEType "multipart" "form-data" params)
739 -> readMultipartFormData params
741 -> abort UnsupportedMediaType [] (Just $! "Unsupported media type: "
744 readWWWFormURLEncoded
745 = do src <- input limit
746 return $ map pairToFormData $ parseWWWFormURLEncoded src
748 readMultipartFormData params
749 = do case find ((== "boundary") . map toLower . fst) params of
751 -> abort BadRequest [] (Just "Missing boundary of multipart/form-data")
753 -> do src <- inputLBS limit
754 case parse (multipartFormP boundary) src of
755 (# Success fdList, _ #) -> return fdList
757 -> abort BadRequest [] (Just "Unparsable multipart/form-data")
759 -- | This is just a constant @-1@. It's better to say @'input'
760 -- 'defaultLimit'@ than to say @'input' (-1)@ but these are exactly
767 {- DecidingHeader 時に使用するアクション群 -}
769 -- | Set the response status code. If you omit to compute this action,
770 -- the status code will be defaulted to \"200 OK\".
771 setStatus :: StatusCode -> Resource ()
774 do driftTo DecidingHeader
775 itr <- getInteraction
776 liftIO $! atomically $! updateItr itr itrResponse
781 -- | Set a value of given resource header. Comparison of header name
782 -- is case-insensitive. Note that this action is not intended to be
783 -- used so frequently: there should be actions like 'setContentType'
784 -- for every common headers.
786 -- Some important headers (especially \"Content-Length\" and
787 -- \"Transfer-Encoding\") may be silently dropped or overwritten by
788 -- the system not to corrupt the interaction with client at the
789 -- viewpoint of HTTP protocol layer. For instance, if we are keeping
790 -- the connection alive, without this process it causes a catastrophe
791 -- to send a header \"Content-Length: 10\" and actually send a body of
792 -- 20 bytes long. In this case the client shall only accept the first
793 -- 10 bytes of response body and thinks that the residual 10 bytes is
794 -- a part of header of the next response.
795 setHeader :: Strict.ByteString -> Strict.ByteString -> Resource ()
797 = name `seq` value `seq`
798 driftTo DecidingHeader >> setHeader' name value
801 setHeader' :: Strict.ByteString -> Strict.ByteString -> Resource ()
802 setHeader' name value
803 = name `seq` value `seq`
804 do itr <- getInteraction
806 $ updateItr itr itrResponse
807 $ H.setHeader name value
809 -- | Computation of @'redirect' code uri@ sets the response status to
810 -- @code@ and \"Location\" header to @uri@. The @code@ must satisfy
811 -- 'Network.HTTP.Lucu.Response.isRedirection' or it causes an error.
812 redirect :: StatusCode -> URI -> Resource ()
814 = code `seq` uri `seq`
815 do when (code == NotModified || not (isRedirection code))
816 $ abort InternalServerError []
817 $! Just ("Attempted to redirect with status " ++ show code)
820 {-# INLINE redirect #-}
823 -- | Computation of @'setContentType' mType@ sets the response header
824 -- \"Content-Type\" to @mType@.
825 setContentType :: MIMEType -> Resource ()
827 = setHeader (C8.pack "Content-Type") (C8.pack $ show mType)
829 -- | Computation of @'setLocation' uri@ sets the response header
830 -- \"Location\" to @uri@.
831 setLocation :: URI -> Resource ()
833 = setHeader (C8.pack "Location") (C8.pack $ uriToString id uri $ "")
835 -- |Computation of @'setContentEncoding' codings@ sets the response
836 -- header \"Content-Encoding\" to @codings@.
837 setContentEncoding :: [String] -> Resource ()
838 setContentEncoding codings
839 = do ver <- getRequestVersion
841 HttpVersion 1 0 -> unnormalizeCoding
842 HttpVersion 1 1 -> id
844 setHeader (C8.pack "Content-Encoding") (C8.pack $ joinWith ", " $ map tr codings)
846 -- |Computation of @'setWWWAuthenticate' challenge@ sets the response
847 -- header \"WWW-Authenticate\" to @challenge@.
848 setWWWAuthenticate :: AuthChallenge -> Resource ()
849 setWWWAuthenticate challenge
850 = setHeader (C8.pack "WWW-Authenticate") (C8.pack $ show challenge)
853 {- DecidingBody 時に使用するアクション群 -}
855 -- | Computation of @'output' str@ writes @str@ as a response body,
856 -- and then make the 'Resource' transit to /Done/ state. It is safe to
857 -- apply 'output' to an infinite string, such as a lazy stream of
860 -- Note that 'outputLBS' is more efficient than 'output' so you should
861 -- use it whenever possible.
862 output :: String -> Resource ()
863 output str = outputLBS $! L8.pack str
864 {-# INLINE output #-}
866 -- | This is mostly the same as 'output' but is more efficient.
867 outputLBS :: Lazy.ByteString -> Resource ()
868 outputLBS str = do outputChunkLBS str
870 {-# INLINE outputLBS #-}
872 -- | Computation of @'outputChunk' str@ writes @str@ as a part of
873 -- response body. You can compute this action multiple times to write
874 -- a body little at a time. It is safe to apply 'outputChunk' to an
877 -- Note that 'outputChunkLBS' is more efficient than 'outputChunk' so
878 -- you should use it whenever possible.
879 outputChunk :: String -> Resource ()
880 outputChunk str = outputChunkLBS $! L8.pack str
881 {-# INLINE outputChunk #-}
883 -- | This is mostly the same as 'outputChunk' but is more efficient.
884 outputChunkLBS :: Lazy.ByteString -> Resource ()
885 outputChunkLBS wholeChunk
887 do driftTo DecidingBody
888 itr <- getInteraction
890 let limit = cnfMaxOutputChunkLength $ itrConfig itr
892 $ fail ("cnfMaxOutputChunkLength must be positive: "
895 discardBody <- liftIO $ atomically $
896 readItr itr itrWillDiscardBody id
899 $ sendChunks wholeChunk limit
901 unless (L8.null wholeChunk)
902 $ liftIO $ atomically $
903 writeItr itr itrBodyIsNull False
905 -- チャンクの大きさは Config で制限されてゐる。もし例へば
906 -- "/dev/zero" を L8.readFile して作った Lazy.ByteString をそのまま
907 -- ResponseWriter に渡したりすると大變な事が起こる。何故なら
908 -- ResponseWriter は Transfer-Encoding: chunked の時、ヘッダを書
910 sendChunks :: Lazy.ByteString -> Int -> Resource ()
912 | L8.null str = return ()
913 | otherwise = do let (chunk, remaining) = L8.splitAt (fromIntegral limit) str
914 itr <- getInteraction
915 liftIO $ atomically $
916 do buf <- readItr itr itrBodyToSend id
919 writeItr itr itrBodyToSend chunk
924 sendChunks remaining limit
928 [GettingBody からそれ以降の状態に遷移する時]
930 body を讀み終へてゐなければ、殘りの body を讀み捨てる。
933 [DecidingHeader からそれ以降の状態に遷移する時]
940 bodyIsNull が False ならば何もしない。True だった場合は出力補完す
945 driftTo :: InteractionState -> Resource ()
948 do itr <- getInteraction
949 liftIO $ atomically $ do oldState <- readItr itr itrState id
950 if newState < oldState then
951 throwStateError oldState newState
953 do let a = [oldState .. newState]
956 mapM_ (uncurry $ drift itr) c
957 writeItr itr itrState newState
959 throwStateError :: Monad m => InteractionState -> InteractionState -> m a
961 throwStateError Done DecidingBody
962 = fail "It makes no sense to output something after finishing to output."
964 throwStateError old new
965 = fail ("state error: " ++ show old ++ " ==> " ++ show new)
968 drift :: Interaction -> InteractionState -> InteractionState -> STM ()
970 drift itr GettingBody _
971 = writeItr itr itrReqBodyWasteAll True
973 drift itr DecidingHeader _
977 = do bodyIsNull <- readItr itr itrBodyIsNull id
979 $ writeDefaultPage itr