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.
76 , getRemoteCertificate
87 , isEncodingAcceptable
91 -- ** Finding an entity
93 -- |These actions can be computed only in the /Examining Request/
94 -- state. After the computation, the 'Resource' transits to
95 -- /Getting Body/ state.
101 -- ** Getting a request body
103 -- |Computation of these actions changes the state to /Getting
112 -- ** Setting response headers
114 -- |Computation of these actions changes the state to /Deciding
124 -- ** Writing a response body
126 -- |Computation of these actions changes the state to /Deciding
137 import Control.Concurrent.STM
138 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
216 -- Network.Socket は IPv6 を考慮してゐないやうだ…
217 SockAddrInet _ v4addr
218 -> let b1 = (v4addr `shiftR` 24) .&. 0xFF
219 b2 = (v4addr `shiftR` 16) .&. 0xFF
220 b3 = (v4addr `shiftR` 8) .&. 0xFF
223 return $ concat $ intersperse "." $ map show [b1, b2, b3, b4]
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. Its result is always @[]@ if
293 -- the 'Network.HTTP.Lucu.Resource.Tree.ResourceDef' is not
294 -- greedy. See 'getResourcePath'.
295 getPathInfo :: Resource [String]
296 getPathInfo = do rsrcPath <- getResourcePath
298 let reqPathStr = uriPath uri
299 reqPath = [x | x <- splitBy (== '/') reqPathStr, x /= ""]
300 -- rsrcPath と reqPath の共通する先頭部分を reqPath か
301 -- ら全部取り除くと、それは PATH_INFO のやうなものにな
302 -- る。rsrcPath は全部一致してゐるに決まってゐる(でな
303 -- ければこの Resource が撰ばれた筈が無い)ので、
304 -- rsrcPath の長さの分だけ削除すれば良い。
305 return $! drop (length rsrcPath) reqPath
307 -- | Assume the query part of request URI as
308 -- application\/x-www-form-urlencoded, and parse it. This action
309 -- doesn't parse the request body. See 'inputForm'.
310 getQueryForm :: Resource [(String, String)]
311 getQueryForm = do uri <- getRequestURI
312 return $! parseWWWFormURLEncoded $ snd $ splitAt 1 $ uriQuery uri
314 -- |Get a value of given request header. Comparison of header name is
315 -- case-insensitive. Note that this action is not intended to be used
316 -- so frequently: there should be actions like 'getContentType' for
317 -- every common headers.
318 getHeader :: Strict.ByteString -> Resource (Maybe Strict.ByteString)
319 getHeader name = name `seq`
321 return $! H.getHeader name req
323 -- |Get a list of 'Network.HTTP.Lucu.MIMEType.MIMEType' enumerated on
324 -- header \"Accept\".
325 getAccept :: Resource [MIMEType]
326 getAccept = do acceptM <- getHeader (C8.pack "Accept")
331 -> case parse mimeTypeListP (L8.fromChunks [accept]) of
332 (# Success xs, _ #) -> return xs
333 (# _ , _ #) -> abort BadRequest []
334 (Just $ "Unparsable Accept: " ++ C8.unpack accept)
336 -- |Get a list of @(contentCoding, qvalue)@ enumerated on header
337 -- \"Accept-Encoding\". The list is sorted in descending order by
339 getAcceptEncoding :: Resource [(String, Maybe Double)]
341 = do accEncM <- getHeader (C8.pack "Accept-Encoding")
344 -- HTTP/1.0 には Accept-Encoding が無い場合の規定が無い
345 -- ので安全の爲 identity が指定された事にする。HTTP/1.1
346 -- の場合は何でも受け入れて良い事になってゐるので "*" が
348 -> do ver <- getRequestVersion
350 HttpVersion 1 0 -> return [("identity", Nothing)]
351 HttpVersion 1 1 -> return [("*" , Nothing)]
354 -> if C8.null value then
356 return [("identity", Nothing)]
358 case parse acceptEncodingListP (L8.fromChunks [value]) of
359 (# Success x, _ #) -> return $ reverse $ sortBy orderAcceptEncodings x
360 (# _ , _ #) -> abort BadRequest []
361 (Just $ "Unparsable Accept-Encoding: " ++ C8.unpack value)
363 -- |Check whether a given content-coding is acceptable.
364 isEncodingAcceptable :: String -> Resource Bool
365 isEncodingAcceptable coding
366 = do accList <- getAcceptEncoding
367 return (flip any accList $ \ (c, q) ->
368 (c == "*" || C8.pack c `H.noCaseEq` C8.pack coding) && q /= Just 0)
371 -- |Get the header \"Content-Type\" as
372 -- 'Network.HTTP.Lucu.MIMEType.MIMEType'.
373 getContentType :: Resource (Maybe MIMEType)
375 = do cTypeM <- getHeader (C8.pack "Content-Type")
380 -> case parse mimeTypeP (L8.fromChunks [cType]) of
381 (# Success t, _ #) -> return $ Just t
382 (# _ , _ #) -> abort BadRequest []
383 (Just $ "Unparsable Content-Type: " ++ C8.unpack cType)
386 -- |Get the header \"Authorization\" as
387 -- 'Network.HTTP.Lucu.Authorization.AuthCredential'.
388 getAuthorization :: Resource (Maybe AuthCredential)
390 = do authM <- getHeader (C8.pack "Authorization")
395 -> case parse authCredentialP (L8.fromChunks [auth]) of
396 (# Success a, _ #) -> return $ Just a
397 (# _ , _ #) -> return Nothing
400 {- ExaminingRequest 時に使用するアクション群 -}
402 -- |Tell the system that the 'Resource' found an entity for the
403 -- request URI. If this is a GET or HEAD request, a found entity means
404 -- a datum to be replied. If this is a PUT or DELETE request, it means
405 -- a datum which was stored for the URI up to now. It is an error to
406 -- compute 'foundEntity' if this is a POST request.
408 -- Computation of 'foundEntity' performs \"If-Match\" test or
409 -- \"If-None-Match\" test if possible. When those tests fail, the
410 -- computation of 'Resource' immediately aborts with status \"412
411 -- Precondition Failed\" or \"304 Not Modified\" depending on the
414 -- If this is a GET or HEAD request, 'foundEntity' automatically puts
415 -- \"ETag\" and \"Last-Modified\" headers into the response.
416 foundEntity :: ETag -> UTCTime -> Resource ()
417 foundEntity tag timeStamp
418 = tag `seq` timeStamp `seq`
419 do driftTo ExaminingRequest
422 when (method == GET || method == HEAD)
423 $ setHeader' (C8.pack "Last-Modified") (C8.pack $ formatHTTPDateTime timeStamp)
424 when (method == POST)
425 $ abort InternalServerError []
426 (Just "Illegal computation of foundEntity for POST request.")
431 -- |Tell the system that the 'Resource' found an entity for the
432 -- request URI. The only difference from 'foundEntity' is that
433 -- 'foundETag' doesn't (and can't) put \"Last-Modified\" header into
436 -- This action is not preferred. You should use 'foundEntity' whenever
438 foundETag :: ETag -> Resource ()
441 do driftTo ExaminingRequest
444 when (method == GET || method == HEAD)
445 $ setHeader' (C8.pack "ETag") (C8.pack $ show tag)
446 when (method == POST)
447 $ abort InternalServerError []
448 (Just "Illegal computation of foundETag for POST request.")
450 -- If-Match があればそれを見る。
451 ifMatch <- getHeader (C8.pack "If-Match")
454 Just value -> if value == C8.pack "*" then
457 case parse eTagListP (L8.fromChunks [value]) of
458 (# Success tags, _ #)
459 -- tags の中に一致するものが無ければ
460 -- PreconditionFailed で終了。
461 -> when (not $ any (== tag) tags)
462 $ abort PreconditionFailed []
463 $! Just ("The entity tag doesn't match: " ++ C8.unpack value)
465 -> abort BadRequest [] $! Just ("Unparsable If-Match: " ++ C8.unpack value)
467 let statusForNoneMatch = if method == GET || method == HEAD then
472 -- If-None-Match があればそれを見る。
473 ifNoneMatch <- getHeader (C8.pack "If-None-Match")
476 Just value -> if value == C8.pack "*" then
477 abort statusForNoneMatch [] $! Just ("The entity tag matches: *")
479 case parse eTagListP (L8.fromChunks [value]) of
480 (# Success tags, _ #)
481 -> when (any (== tag) tags)
482 $ abort statusForNoneMatch [] $! Just ("The entity tag matches: " ++ C8.unpack value)
484 -> abort BadRequest [] $! Just ("Unparsable If-None-Match: " ++ C8.unpack value)
488 -- |Tell the system that the 'Resource' found an entity for the
489 -- request URI. The only difference from 'foundEntity' is that
490 -- 'foundTimeStamp' performs \"If-Modified-Since\" test or
491 -- \"If-Unmodified-Since\" test instead of \"If-Match\" test or
492 -- \"If-None-Match\" test. Be aware that any tests based on last
493 -- modification time are unsafe because it is possible to mess up such
494 -- tests by modifying the entity twice in a second.
496 -- This action is not preferred. You should use 'foundEntity' whenever
498 foundTimeStamp :: UTCTime -> Resource ()
499 foundTimeStamp timeStamp
501 do driftTo ExaminingRequest
504 when (method == GET || method == HEAD)
505 $ setHeader' (C8.pack "Last-Modified") (C8.pack $ formatHTTPDateTime timeStamp)
506 when (method == POST)
507 $ abort InternalServerError []
508 (Just "Illegal computation of foundTimeStamp for POST request.")
510 let statusForIfModSince = if method == GET || method == HEAD then
515 -- If-Modified-Since があればそれを見る。
516 ifModSince <- getHeader (C8.pack "If-Modified-Since")
518 Just str -> case parseHTTPDateTime (L8.fromChunks [str]) of
520 -> when (timeStamp <= lastTime)
521 $ abort statusForIfModSince []
522 $! Just ("The entity has not been modified since " ++ C8.unpack str)
524 -> return () -- 不正な時刻は無視
527 -- If-Unmodified-Since があればそれを見る。
528 ifUnmodSince <- getHeader (C8.pack "If-Unmodified-Since")
530 Just str -> case parseHTTPDateTime (L8.fromChunks [str]) of
532 -> when (timeStamp > lastTime)
533 $ abort PreconditionFailed []
534 $! Just ("The entity has not been modified since " ++ C8.unpack str)
536 -> return () -- 不正な時刻は無視
541 -- | Computation of @'foundNoEntity' mStr@ tells the system that the
542 -- 'Resource' found no entity for the request URI. @mStr@ is an
543 -- optional error message to be replied to the client.
545 -- If this is a PUT request, 'foundNoEntity' performs \"If-Match\"
546 -- test and aborts with status \"412 Precondition Failed\" when it
547 -- failed. If this is a GET, HEAD, POST or DELETE request,
548 -- 'foundNoEntity' always aborts with status \"404 Not Found\".
549 foundNoEntity :: Maybe String -> Resource ()
552 do driftTo ExaminingRequest
556 $ abort NotFound [] msgM
558 -- エンティティが存在しないと云ふ事は、"*" も含めたどのやうな
559 -- If-Match: 條件も滿たさない。
560 ifMatch <- getHeader (C8.pack "If-Match")
561 when (ifMatch /= Nothing)
562 $ abort PreconditionFailed [] msgM
567 {- GettingBody 時に使用するアクション群 -}
569 -- | Computation of @'input' limit@ attempts to read the request body
570 -- up to @limit@ bytes, and then make the 'Resource' transit to
571 -- /Deciding Header/ state. When the actual size of body is larger
572 -- than @limit@ bytes, computation of 'Resource' immediately aborts
573 -- with status \"413 Request Entity Too Large\". When the request has
574 -- no body, 'input' returns an empty string.
576 -- @limit@ may be less than or equal to zero. In this case, the
577 -- default limitation value
578 -- ('Network.HTTP.Lucu.Config.cnfMaxEntityLength') is used. See
581 -- Note that 'inputLBS' is more efficient than 'input' so you should
582 -- use it whenever possible.
583 input :: Int -> Resource String
584 input limit = limit `seq`
585 inputLBS limit >>= return . L8.unpack
588 -- | This is mostly the same as 'input' but is more
589 -- efficient. 'inputLBS' returns a 'Data.ByteString.Lazy.ByteString'
590 -- but it's not really lazy: reading from the socket just happens at
591 -- the computation of 'inputLBS', not at the evaluation of the
592 -- 'Data.ByteString.Lazy.ByteString'. The same goes for
594 inputLBS :: Int -> Resource Lazy.ByteString
597 do driftTo GettingBody
598 itr <- getInteraction
599 hasBody <- liftIO $! atomically $! readItr itr itrRequestHasBody id
600 chunk <- if hasBody then
603 do driftTo DecidingHeader
607 askForInput :: Interaction -> Resource Lazy.ByteString
610 do let confLimit = cnfMaxEntityLength $ itrConfig itr
611 actualLimit = if limit <= 0 then
615 when (actualLimit <= 0)
616 $ fail ("inputLBS: limit must be positive: " ++ show actualLimit)
619 $! do chunkLen <- readItr itr itrReqChunkLength id
620 writeItr itr itrWillReceiveBody True
621 if fmap (> actualLimit) chunkLen == Just True then
625 writeItr itr itrReqBodyWanted $ Just actualLimit
626 -- 應答を待つ。トランザクションを分けなければ當然デッドロック。
627 chunk <- liftIO $! atomically
628 $! do chunk <- readItr itr itrReceivedBody id
629 chunkIsOver <- readItr itr itrReqChunkIsOver id
630 if L8.length chunk < fromIntegral actualLimit then
640 $ tooLarge actualLimit
641 -- 成功。itr 内にチャンクを置いたままにす
643 writeItr itr itrReceivedBody L8.empty
645 driftTo DecidingHeader
648 tooLarge :: Int -> STM ()
649 tooLarge lim = lim `seq`
650 abortSTM RequestEntityTooLarge []
651 $! Just ("Request body must be smaller than "
652 ++ show lim ++ " bytes.")
654 -- | Computation of @'inputChunk' limit@ attempts to read a part of
655 -- request body up to @limit@ bytes. You can read any large request by
656 -- repeating computation of this action. When you've read all the
657 -- request body, 'inputChunk' returns an empty string and then make
658 -- the 'Resource' transit to /Deciding Header/ state.
660 -- @limit@ may be less than or equal to zero. In this case, the
661 -- default limitation value
662 -- ('Network.HTTP.Lucu.Config.cnfMaxEntityLength') is used. See
665 -- Note that 'inputChunkLBS' is more efficient than 'inputChunk' so you
666 -- should use it whenever possible.
667 inputChunk :: Int -> Resource String
668 inputChunk limit = limit `seq`
669 inputChunkLBS limit >>= return . L8.unpack
672 -- | This is mostly the same as 'inputChunk' but is more
673 -- efficient. See 'inputLBS'.
674 inputChunkLBS :: Int -> Resource Lazy.ByteString
677 do driftTo GettingBody
678 itr <- getInteraction
679 hasBody <- liftIO $ atomically $ readItr itr itrRequestHasBody id
680 chunk <- if hasBody then
683 do driftTo DecidingHeader
687 askForInput :: Interaction -> Resource Lazy.ByteString
690 do let confLimit = cnfMaxEntityLength $! itrConfig itr
691 actualLimit = if limit < 0 then
695 when (actualLimit <= 0)
696 $ fail ("inputChunkLBS: limit must be positive: " ++ show actualLimit)
699 $! do writeItr itr itrReqBodyWanted $! Just actualLimit
700 writeItr itr itrWillReceiveBody True
701 -- 應答を待つ。トランザクションを分けなければ當然デッドロック。
702 chunk <- liftIO $! atomically
703 $ do chunk <- readItr itr itrReceivedBody id
704 -- 要求された量に滿たなくて、まだ殘りがあ
706 when (L8.length chunk < fromIntegral actualLimit)
707 $ do chunkIsOver <- readItr itr itrReqChunkIsOver id
711 writeItr itr itrReceivedBody L8.empty
714 $ driftTo DecidingHeader
717 -- | Computation of @'inputForm' limit@ attempts to read the request
718 -- body with 'input' and parse it as
719 -- application\/x-www-form-urlencoded or multipart\/form-data. If the
720 -- request header \"Content-Type\" is neither of them, 'inputForm'
721 -- makes 'Resource' abort with status \"415 Unsupported Media
722 -- Type\". If the request has no \"Content-Type\", it aborts with
723 -- \"400 Bad Request\".
724 inputForm :: Int -> Resource [(String, String)]
727 do cTypeM <- getContentType
730 -> abort BadRequest [] (Just "Missing Content-Type")
731 Just (MIMEType "application" "x-www-form-urlencoded" _)
732 -> readWWWFormURLEncoded
733 Just (MIMEType "multipart" "form-data" params)
734 -> readMultipartFormData params
736 -> abort UnsupportedMediaType [] (Just $! "Unsupported media type: "
739 readWWWFormURLEncoded
740 = do src <- input limit
741 return $ parseWWWFormURLEncoded src
743 readMultipartFormData params
744 = do case find ((== "boundary") . map toLower . fst) params of
746 -> abort BadRequest [] (Just "Missing boundary of multipart/form-data")
748 -> do src <- inputLBS limit
749 case parse (multipartFormP boundary) src of
750 (# Success pairs, _ #) -> return pairs
752 -> abort BadRequest [] (Just "Unparsable multipart/form-data")
754 -- | This is just a constant @-1@. It's better to say @'input'
755 -- 'defaultLimit'@ than to say @'input' (-1)@ but these are exactly
762 {- DecidingHeader 時に使用するアクション群 -}
764 -- | Set the response status code. If you omit to compute this action,
765 -- the status code will be defaulted to \"200 OK\".
766 setStatus :: StatusCode -> Resource ()
769 do driftTo DecidingHeader
770 itr <- getInteraction
771 liftIO $! atomically $! updateItr itr itrResponse
776 -- | Set a value of given resource header. Comparison of header name
777 -- is case-insensitive. Note that this action is not intended to be
778 -- used so frequently: there should be actions like 'setContentType'
779 -- for every common headers.
781 -- Some important headers (especially \"Content-Length\" and
782 -- \"Transfer-Encoding\") may be silently dropped or overwritten by
783 -- the system not to corrupt the interaction with client at the
784 -- viewpoint of HTTP protocol layer. For instance, if we are keeping
785 -- the connection alive, without this process it causes a catastrophe
786 -- to send a header \"Content-Length: 10\" and actually send a body of
787 -- 20 bytes long. In this case the client shall only accept the first
788 -- 10 bytes of response body and thinks that the residual 10 bytes is
789 -- a part of header of the next response.
790 setHeader :: Strict.ByteString -> Strict.ByteString -> Resource ()
792 = name `seq` value `seq`
793 driftTo DecidingHeader >> setHeader' name value
796 setHeader' :: Strict.ByteString -> Strict.ByteString -> Resource ()
797 setHeader' name value
798 = name `seq` value `seq`
799 do itr <- getInteraction
801 $ updateItr itr itrResponse
802 $ H.setHeader name value
804 -- | Computation of @'redirect' code uri@ sets the response status to
805 -- @code@ and \"Location\" header to @uri@. The @code@ must satisfy
806 -- 'Network.HTTP.Lucu.Response.isRedirection' or it causes an error.
807 redirect :: StatusCode -> URI -> Resource ()
809 = code `seq` uri `seq`
810 do when (code == NotModified || not (isRedirection code))
811 $ abort InternalServerError []
812 $! Just ("Attempted to redirect with status " ++ show code)
815 {-# INLINE redirect #-}
818 -- | Computation of @'setContentType' mType@ sets the response header
819 -- \"Content-Type\" to @mType@.
820 setContentType :: MIMEType -> Resource ()
822 = setHeader (C8.pack "Content-Type") (C8.pack $ show mType)
824 -- | Computation of @'setLocation' uri@ sets the response header
825 -- \"Location\" to @uri@.
826 setLocation :: URI -> Resource ()
828 = setHeader (C8.pack "Location") (C8.pack $ uriToString id uri $ "")
830 -- |Computation of @'setContentEncoding' codings@ sets the response
831 -- header \"Content-Encoding\" to @codings@.
832 setContentEncoding :: [String] -> Resource ()
833 setContentEncoding codings
834 = do ver <- getRequestVersion
836 HttpVersion 1 0 -> unnormalizeCoding
837 HttpVersion 1 1 -> id
839 setHeader (C8.pack "Content-Encoding") (C8.pack $ joinWith ", " $ map tr codings)
841 -- |Computation of @'setWWWAuthenticate' challenge@ sets the response
842 -- header \"WWW-Authenticate\" to @challenge@.
843 setWWWAuthenticate :: AuthChallenge -> Resource ()
844 setWWWAuthenticate challenge
845 = setHeader (C8.pack "WWW-Authenticate") (C8.pack $ show challenge)
848 {- DecidingBody 時に使用するアクション群 -}
850 -- | Computation of @'output' str@ writes @str@ as a response body,
851 -- and then make the 'Resource' transit to /Done/ state. It is safe to
852 -- apply 'output' to an infinite string, such as a lazy stream of
855 -- Note that 'outputLBS' is more efficient than 'output' so you should
856 -- use it whenever possible.
857 output :: String -> Resource ()
858 output str = outputLBS $! L8.pack str
859 {-# INLINE output #-}
861 -- | This is mostly the same as 'output' but is more efficient.
862 outputLBS :: Lazy.ByteString -> Resource ()
863 outputLBS str = do outputChunkLBS str
865 {-# INLINE outputLBS #-}
867 -- | Computation of @'outputChunk' str@ writes @str@ as a part of
868 -- response body. You can compute this action multiple times to write
869 -- a body little at a time. It is safe to apply 'outputChunk' to an
872 -- Note that 'outputChunkLBS' is more efficient than 'outputChunk' so
873 -- you should use it whenever possible.
874 outputChunk :: String -> Resource ()
875 outputChunk str = outputChunkLBS $! L8.pack str
876 {-# INLINE outputChunk #-}
878 -- | This is mostly the same as 'outputChunk' but is more efficient.
879 outputChunkLBS :: Lazy.ByteString -> Resource ()
880 outputChunkLBS wholeChunk
882 do driftTo DecidingBody
883 itr <- getInteraction
885 let limit = cnfMaxOutputChunkLength $ itrConfig itr
887 $ fail ("cnfMaxOutputChunkLength must be positive: "
890 discardBody <- liftIO $ atomically $
891 readItr itr itrWillDiscardBody id
894 $ sendChunks wholeChunk limit
896 unless (L8.null wholeChunk)
897 $ liftIO $ atomically $
898 writeItr itr itrBodyIsNull False
900 -- チャンクの大きさは Config で制限されてゐる。もし例へば
901 -- "/dev/zero" を L8.readFile して作った Lazy.ByteString をそのまま
902 -- ResponseWriter に渡したりすると大變な事が起こる。何故なら
903 -- ResponseWriter は Transfer-Encoding: chunked の時、ヘッダを書
905 sendChunks :: Lazy.ByteString -> Int -> Resource ()
907 | L8.null str = return ()
908 | otherwise = do let (chunk, remaining) = L8.splitAt (fromIntegral limit) str
909 itr <- getInteraction
910 liftIO $ atomically $
911 do buf <- readItr itr itrBodyToSend id
914 writeItr itr itrBodyToSend chunk
919 sendChunks remaining limit
923 [GettingBody からそれ以降の状態に遷移する時]
925 body を讀み終へてゐなければ、殘りの body を讀み捨てる。
928 [DecidingHeader からそれ以降の状態に遷移する時]
935 bodyIsNull が False ならば何もしない。True だった場合は出力補完す
940 driftTo :: InteractionState -> Resource ()
943 do itr <- getInteraction
944 liftIO $ atomically $ do oldState <- readItr itr itrState id
945 if newState < oldState then
946 throwStateError oldState newState
948 do let a = [oldState .. newState]
951 mapM_ (uncurry $ drift itr) c
952 writeItr itr itrState newState
954 throwStateError :: Monad m => InteractionState -> InteractionState -> m a
956 throwStateError Done DecidingBody
957 = fail "It makes no sense to output something after finishing to output."
959 throwStateError old new
960 = fail ("state error: " ++ show old ++ " ==> " ++ show new)
963 drift :: Interaction -> InteractionState -> InteractionState -> STM ()
965 drift itr GettingBody _
966 = writeItr itr itrReqBodyWasteAll True
968 drift itr DecidingHeader _
972 = do bodyIsNull <- readItr itr itrBodyIsNull id
974 $ writeDefaultPage itr