2 GeneralizedNewtypeDeriving
8 {-# OPTIONS_HADDOCK prune #-}
10 -- |This is the Resource Monad; monadic actions to define the behavior
11 -- of each resources. The 'Resource' Monad is a kind of 'Prelude.IO'
12 -- Monad thus it implements 'Control.Monad.Trans.MonadIO' class. It is
13 -- also a state machine.
15 -- Request Processing Flow:
17 -- 1. A client issues an HTTP request.
19 -- 2. If the URI of it matches to any resource, the corresponding
20 -- 'Resource' Monad starts running on a newly spawned thread.
22 -- 3. The 'Resource' Monad looks at the request header, find (or not
23 -- find) an entity, receive the request body (if any), decide the
24 -- response header, and decide the response body. This process
25 -- will be discussed later.
27 -- 4. The 'Resource' Monad and its thread stops running. The client
28 -- may or may not be sending us the next request at this point.
30 -- 'Resource' Monad takes the following states. The initial state is
31 -- /Examining Request/ and the final state is /Done/.
33 -- [/Examining Request/] In this state, a 'Resource' looks at the
34 -- request header and thinks about an entity for it. If there is a
35 -- suitable entity, the 'Resource' tells the system an entity tag
36 -- and its last modification time ('foundEntity'). If it found no
37 -- entity, it tells the system so ('foundNoEntity'). In case it is
38 -- impossible to decide the existence of entity, which is a typical
39 -- case for POST requests, 'Resource' does nothing in this state.
41 -- [/Getting Body/] A 'Resource' asks the system to receive a
42 -- request body from client. Before actually reading from the
43 -- socket, the system sends \"100 Continue\" to the client if need
44 -- be. When a 'Resource' transits to the next state without
45 -- receiving all or part of request body, the system still reads it
46 -- and just throws it away.
48 -- [/Deciding Header/] A 'Resource' makes a decision of status code
49 -- and response header. When it transits to the next state, the
50 -- system checks the validness of response header and then write
51 -- them to the socket.
53 -- [/Deciding Body/] In this state, a 'Resource' asks the system to
54 -- write some response body to the socket. When it transits to the
55 -- next state without writing any response body, the system
56 -- completes it depending on the status code.
58 -- [/Done/] Everything is over. A 'Resource' can do nothing for the
59 -- HTTP interaction anymore.
61 -- Note that the state transition is one-way: for instance, it is an
62 -- error to try to read a request body after writing some
63 -- response. This limitation is for efficiency. We don't want to read
64 -- the entire request before starting 'Resource', nor we don't want to
65 -- postpone writing the entire response till the end of 'Resource'
68 module Network.HTTP.Lucu.Resource
77 -- ** Getting request header
79 -- |These actions can be computed regardless of the current state,
80 -- and they don't change the state.
85 , getRemoteCertificate
96 , isEncodingAcceptable
100 -- ** Finding an entity
102 -- |These actions can be computed only in the /Examining Request/
103 -- state. After the computation, the 'Resource' transits to
104 -- /Getting Body/ state.
110 -- ** Getting a request body
112 -- |Computation of these actions changes the state to /Getting
119 -- ** Setting response headers
121 -- |Computation of these actions changes the state to /Deciding
131 -- ** Writing a response body
133 -- |Computation of these actions changes the state to /Deciding
141 import Blaze.ByteString.Builder (Builder)
142 import qualified Blaze.ByteString.Builder.ByteString as BB
143 import Control.Applicative
144 import Control.Concurrent.STM
145 import Control.Monad.Reader
146 import Control.Monad.Unicode
147 import Data.Ascii (Ascii, CIAscii)
148 import qualified Data.Ascii as A
149 import qualified Data.Attoparsec.Char8 as P
150 import qualified Data.Attoparsec.Lazy as LP
151 import Data.ByteString (ByteString)
152 import qualified Data.ByteString as Strict
153 import qualified Data.ByteString.Lazy as Lazy
154 import Data.Foldable (toList)
156 import qualified Data.Map as M
159 import Data.Monoid.Unicode
160 import Data.Sequence (Seq)
161 import Data.Text (Text)
162 import qualified Data.Text as T
163 import qualified Data.Text.Encoding as T
165 import qualified Data.Time.HTTP as HTTP
166 import Network.HTTP.Lucu.Abortion
167 import Network.HTTP.Lucu.Authorization
168 import Network.HTTP.Lucu.Config
169 import Network.HTTP.Lucu.ContentCoding
170 import Network.HTTP.Lucu.DefaultPage
171 import Network.HTTP.Lucu.ETag
172 import qualified Network.HTTP.Lucu.Headers as H
173 import Network.HTTP.Lucu.HttpVersion
174 import Network.HTTP.Lucu.Interaction
175 import Network.HTTP.Lucu.MultipartForm
176 import Network.HTTP.Lucu.Postprocess
177 import Network.HTTP.Lucu.Request
178 import Network.HTTP.Lucu.Response
179 import Network.HTTP.Lucu.MIMEType
180 import Network.HTTP.Lucu.Utils
181 import Network.Socket hiding (accept)
182 import Network.URI hiding (path)
184 import Prelude.Unicode
186 -- |The 'Resource' monad. This monad implements 'MonadIO' so it can do
190 unRes ∷ ReaderT Interaction IO a
192 deriving (Applicative, Functor, Monad, MonadIO)
194 runRes ∷ Resource a → Interaction → IO a
196 = runReaderT (unRes r) itr
198 getInteraction ∷ Resource Interaction
199 getInteraction = Resource ask
201 -- |Get the 'Config' value which is used for the httpd.
202 getConfig ∷ Resource Config
203 getConfig = itrConfig <$> getInteraction
205 -- |Get the 'SockAddr' of the remote host. If you want a string
206 -- representation instead of 'SockAddr', use 'getRemoteAddr''.
207 getRemoteAddr ∷ Resource SockAddr
208 getRemoteAddr = itrRemoteAddr <$> getInteraction
210 -- |Get the string representation of the address of remote host. If
211 -- you want a 'SockAddr' instead of 'String', use 'getRemoteAddr'.
212 getRemoteAddr' ∷ Resource HostName
214 = do sa ← getRemoteAddr
215 (Just a, _) ← liftIO $ getNameInfo [NI_NUMERICHOST] False False sa
218 -- |Resolve an address to the remote host.
219 getRemoteHost ∷ Resource (Maybe HostName)
221 = do sa ← getRemoteAddr
222 fst <$> (liftIO $ getNameInfo [] True False sa)
224 -- | Return the X.509 certificate of the client, or 'Nothing' if:
226 -- * This request didn't came through an SSL stream.
228 -- * The client didn't send us its certificate.
230 -- * The 'OpenSSL.Session.VerificationMode' of
231 -- 'OpenSSL.Session.SSLContext' in 'SSLConfig' has not been set to
232 -- 'OpenSSL.Session.VerifyPeer'.
233 getRemoteCertificate ∷ Resource (Maybe X509)
234 getRemoteCertificate = itrRemoteCert <$> getInteraction
236 -- |Get the 'Request' value which represents the request header. In
237 -- general you don't have to use this action.
238 getRequest ∷ Resource Request
240 = do itr ← getInteraction
241 liftIO $ atomically $ fromJust <$> readTVar (itrRequest itr)
243 -- |Get the 'Method' value of the request.
244 getMethod ∷ Resource Method
245 getMethod = reqMethod <$> getRequest
247 -- |Get the URI of the request.
248 getRequestURI ∷ Resource URI
249 getRequestURI = reqURI <$> getRequest
251 -- |Get the HTTP version of the request.
252 getRequestVersion ∷ Resource HttpVersion
253 getRequestVersion = reqVersion <$> getRequest
255 -- |Get the path of this 'Resource' (to be exact,
256 -- 'Network.HTTP.Lucu.Resource.Tree.ResourceDef') in the
257 -- 'Network.HTTP.Lucu.Resource.Tree.ResTree'. The result of this
258 -- action is the exact path in the tree even if the
259 -- 'Network.HTTP.Lucu.Resource.Tree.ResourceDef' is greedy.
263 -- > main = let tree = mkResTree [ (["foo"], resFoo) ]
264 -- > in runHttpd defaultConfig tree
266 -- > resFoo = ResourceDef {
267 -- > resIsGreedy = True
268 -- > , resGet = Just $ do requestURI ← getRequestURI
269 -- > resourcePath ← getResourcePath
270 -- > pathInfo ← getPathInfo
271 -- > -- uriPath requestURI == "/foo/bar/baz"
272 -- > -- resourcePath == ["foo"]
273 -- > -- pathInfo == ["bar", "baz"]
277 getResourcePath ∷ Resource [Text]
278 getResourcePath = (fromJust ∘ itrResourcePath) <$> getInteraction
280 -- |This is an analogy of CGI PATH_INFO. The result is
281 -- URI-unescaped. It is always @[]@ if the
282 -- 'Network.HTTP.Lucu.Resource.Tree.ResourceDef' is not greedy. See
283 -- 'getResourcePath'.
285 -- Note that the returned path is URI-decoded and then UTF-8 decoded.
286 getPathInfo ∷ Resource [Text]
287 getPathInfo = do rsrcPath ← getResourcePath
288 reqPath ← splitPathInfo <$> getRequestURI
289 -- rsrcPath と reqPath の共通する先頭部分を reqPath か
290 -- ら全部取り除くと、それは PATH_INFO のやうなものにな
291 -- る。rsrcPath は全部一致してゐるに決まってゐる(でな
292 -- ければこの Resource が撰ばれた筈が無い)ので、
293 -- rsrcPath の長さの分だけ削除すれば良い。
294 return $ drop (length rsrcPath) reqPath
296 -- |Assume the query part of request URI as
297 -- application\/x-www-form-urlencoded, and parse it to pairs of
298 -- @(name, formData)@. This action doesn't parse the request body. See
299 -- 'inputForm'. Field names are decoded in UTF-8.
300 getQueryForm ∷ Resource [(Text, FormData)]
301 getQueryForm = parse' <$> getRequestURI
303 parse' = map toPairWithFormData ∘
304 parseWWWFormURLEncoded ∘
310 toPairWithFormData ∷ (ByteString, ByteString) → (Text, FormData)
311 toPairWithFormData (name, value)
312 = let fd = FormData {
314 , fdContent = Lazy.fromChunks [value]
316 in (T.decodeUtf8 name, fd)
318 -- |Get a value of given request header. Comparison of header name is
319 -- case-insensitive. Note that this action is not intended to be used
320 -- so frequently: there should be actions like 'getContentType' for
321 -- every common headers.
322 getHeader ∷ CIAscii → Resource (Maybe Ascii)
324 = H.getHeader name <$> getRequest
326 -- |Get a list of 'MIMEType' enumerated on header \"Accept\".
327 getAccept ∷ Resource [MIMEType]
329 = do acceptM ← getHeader "Accept"
334 → case P.parseOnly p (A.toByteString accept) of
336 Left _ → abort BadRequest []
337 (Just $ "Unparsable Accept: " ⊕ A.toText accept)
339 p = do xs ← mimeTypeListP
343 -- |Get a list of @(contentCoding, qvalue)@ enumerated on header
344 -- \"Accept-Encoding\". The list is sorted in descending order by
346 getAcceptEncoding ∷ Resource [(CIAscii, Maybe Double)]
348 = do accEncM ← getHeader "Accept-Encoding"
351 -- HTTP/1.0 には Accept-Encoding が無い場合の規定が無い
352 -- ので安全の爲 identity が指定された事にする。HTTP/1.1
353 -- の場合は何でも受け入れて良い事になってゐるので "*" が
355 → do ver ← getRequestVersion
357 HttpVersion 1 0 → return [("identity", Nothing)]
358 HttpVersion 1 1 → return [("*" , Nothing)]
359 _ → abort InternalServerError []
360 (Just "getAcceptEncoding: unknown HTTP version")
364 return [("identity", Nothing)]
366 case P.parseOnly p (A.toByteString ae) of
367 Right xs → return $ map toTuple $ reverse $ sort xs
368 Left _ → abort BadRequest []
369 (Just $ "Unparsable Accept-Encoding: " ⊕ A.toText ae)
371 p = do xs ← acceptEncodingListP
375 toTuple (AcceptEncoding {..})
376 = (aeEncoding, aeQValue)
378 -- |Check whether a given content-coding is acceptable.
379 isEncodingAcceptable ∷ CIAscii → Resource Bool
380 isEncodingAcceptable encoding = any f <$> getAcceptEncoding
383 = (e ≡ "*" ∨ e ≡ encoding) ∧ q ≢ Just 0
385 -- |Get the header \"Content-Type\" as 'MIMEType'.
386 getContentType ∷ Resource (Maybe MIMEType)
388 = do cTypeM ← getHeader "Content-Type"
393 → case P.parseOnly p (A.toByteString cType) of
394 Right t → return $ Just t
395 Left _ → abort BadRequest []
396 (Just $ "Unparsable Content-Type: " ⊕ A.toText cType)
402 -- |Get the header \"Authorization\" as 'AuthCredential'.
403 getAuthorization ∷ Resource (Maybe AuthCredential)
405 = do authM ← getHeader "Authorization"
410 → case P.parseOnly p (A.toByteString auth) of
411 Right ac → return $ Just ac
412 Left _ → return Nothing
414 p = do ac ← authCredentialP
419 {- ExaminingRequest 時に使用するアクション群 -}
421 -- |Tell the system that the 'Resource' found an entity for the
422 -- request URI. If this is a GET or HEAD request, a found entity means
423 -- a datum to be replied. If this is a PUT or DELETE request, it means
424 -- a datum which was stored for the URI until now. It is an error to
425 -- compute 'foundEntity' if this is a POST request.
427 -- Computation of 'foundEntity' performs \"If-Match\" test or
428 -- \"If-None-Match\" test if possible. When those tests fail, the
429 -- computation of 'Resource' immediately aborts with status \"412
430 -- Precondition Failed\" or \"304 Not Modified\" depending on the
433 -- If this is a GET or HEAD request, 'foundEntity' automatically puts
434 -- \"ETag\" and \"Last-Modified\" headers into the response.
435 foundEntity ∷ ETag → UTCTime → Resource ()
436 foundEntity tag timeStamp
437 = do driftTo ExaminingRequest
440 when (method ≡ GET ∨ method ≡ HEAD)
441 $ setHeader' "Last-Modified" (HTTP.toAscii timeStamp)
443 $ abort InternalServerError []
444 (Just "Illegal computation of foundEntity for a POST request.")
449 -- |Tell the system that the 'Resource' found an entity for the
450 -- request URI. The only difference from 'foundEntity' is that
451 -- 'foundETag' doesn't (and can't) put \"Last-Modified\" header into
454 -- This action is not preferred. You should use 'foundEntity' whenever
456 foundETag ∷ ETag → Resource ()
458 = do driftTo ExaminingRequest
461 when (method ≡ GET ∨ method ≡ HEAD)
462 $ setHeader' "ETag" (printETag tag)
464 $ abort InternalServerError []
465 (Just "Illegal computation of foundETag for POST request.")
467 -- If-Match があればそれを見る。
468 ifMatch ← getHeader "If-Match"
471 Just value → if value ≡ "*" then
474 case P.parseOnly p (A.toByteString value) of
476 -- tags の中に一致するものが無ければ
477 -- PreconditionFailed で終了。
478 → when ((¬) (any (≡ tag) tags))
479 $ abort PreconditionFailed []
480 (Just $ "The entity tag doesn't match: " ⊕ A.toText value)
482 → abort BadRequest [] (Just $ "Unparsable If-Match: " ⊕ A.toText value)
484 let statusForNoneMatch
485 = if method ≡ GET ∨ method ≡ HEAD then
490 -- If-None-Match があればそれを見る。
491 ifNoneMatch ← getHeader "If-None-Match"
494 Just value → if value ≡ "*" then
495 abort statusForNoneMatch [] (Just "The entity tag matches: *")
497 case P.parseOnly p (A.toByteString value) of
499 → when (any (≡ tag) tags)
500 $ abort statusForNoneMatch []
501 (Just $ "The entity tag matches: " ⊕ A.toText value)
503 → abort BadRequest []
504 (Just $ "Unparsable If-None-Match: " ⊕ A.toText value)
508 p = do xs ← eTagListP
512 -- |Tell the system that the 'Resource' found an entity for the
513 -- request URI. The only difference from 'foundEntity' is that
514 -- 'foundTimeStamp' performs \"If-Modified-Since\" test or
515 -- \"If-Unmodified-Since\" test instead of \"If-Match\" test or
516 -- \"If-None-Match\" test. Be aware that any tests based on last
517 -- modification time are unsafe because it is possible to mess up such
518 -- tests by modifying the entity twice in a second.
520 -- This action is not preferred. You should use 'foundEntity' whenever
522 foundTimeStamp ∷ UTCTime → Resource ()
523 foundTimeStamp timeStamp
524 = do driftTo ExaminingRequest
527 when (method ≡ GET ∨ method ≡ HEAD)
528 $ setHeader' "Last-Modified" (HTTP.toAscii timeStamp)
530 $ abort InternalServerError []
531 (Just "Illegal computation of foundTimeStamp for POST request.")
533 let statusForIfModSince
534 = if method ≡ GET ∨ method ≡ HEAD then
539 -- If-Modified-Since があればそれを見る。
540 ifModSince ← getHeader "If-Modified-Since"
542 Just str → case HTTP.fromAscii str of
544 → when (timeStamp ≤ lastTime)
545 $ abort statusForIfModSince []
546 (Just $ "The entity has not been modified since " ⊕ A.toText str)
548 → return () -- 不正な時刻は無視
551 -- If-Unmodified-Since があればそれを見る。
552 ifUnmodSince ← getHeader "If-Unmodified-Since"
554 Just str → case HTTP.fromAscii str of
556 → when (timeStamp > lastTime)
557 $ abort PreconditionFailed []
558 (Just $ "The entity has not been modified since " ⊕ A.toText str)
560 → return () -- 不正な時刻は無視
565 -- | Computation of @'foundNoEntity' mStr@ tells the system that the
566 -- 'Resource' found no entity for the request URI. @mStr@ is an
567 -- optional error message to be replied to the client.
569 -- If this is a PUT request, 'foundNoEntity' performs \"If-Match\"
570 -- test and aborts with status \"412 Precondition Failed\" when it
571 -- failed. If this is a GET, HEAD, POST or DELETE request,
572 -- 'foundNoEntity' always aborts with status \"404 Not Found\".
573 foundNoEntity ∷ Maybe Text → Resource ()
575 = do driftTo ExaminingRequest
579 $ abort NotFound [] msgM
581 -- エンティティが存在しないと云ふ事は、"*" も含めたどのやうな
582 -- If-Match: 條件も滿たさない。
583 ifMatch ← getHeader "If-Match"
584 when (ifMatch ≢ Nothing)
585 $ abort PreconditionFailed [] msgM
590 {- GettingBody 時に使用するアクション群 -}
592 -- | Computation of @'input' limit@ attempts to read the request body
593 -- up to @limit@ bytes, and then make the 'Resource' transit to
594 -- /Deciding Header/ state. When the actual size of body is larger
595 -- than @limit@ bytes, computation of 'Resource' immediately aborts
596 -- with status \"413 Request Entity Too Large\". When the request has
597 -- no body, 'input' returns an empty string.
599 -- @limit@ may be less than or equal to zero. In this case, the
600 -- default limitation value ('cnfMaxEntityLength') is used. See
603 -- 'input' returns a 'Lazy.ByteString' but it's not really lazy:
604 -- reading from the socket just happens at the computation of 'input',
605 -- not at the evaluation of the 'Lazy.ByteString'. The same goes for
607 input ∷ Int → Resource Lazy.ByteString
609 = do driftTo GettingBody
611 hasBody ← liftIO $ atomically $ readTVar $ itrRequestHasBody itr
612 chunk ← if hasBody then
615 do driftTo DecidingHeader
619 askForInput ∷ Interaction → Resource Lazy.ByteString
620 askForInput (Interaction {..})
621 = do let confLimit = cnfMaxEntityLength itrConfig
622 actualLimit = if limit ≤ 0 then
626 when (actualLimit ≤ 0)
627 $ fail ("inputLBS: limit must be positive: " ⧺ show actualLimit)
630 $ do chunkLen ← readTVar itrReqChunkLength
631 writeTVar itrWillReceiveBody True
632 if ((> actualLimit) <$> chunkLen) ≡ Just True then
636 writeTVar itrReqBodyWanted (Just actualLimit)
637 -- 應答を待つ。トランザクションを分けなければ當然デッドロックする。
638 chunk ← liftIO $ atomically
639 $ do chunkLen ← readTVar itrReceivedBodyLen
640 chunkIsOver ← readTVar itrReqChunkIsOver
641 if chunkLen < actualLimit then
642 -- 要求された量に滿たなくて、まだ殘りが
647 -- 制限値一杯まで讀むやうに指示したのに
648 -- まだ殘ってゐるなら、それは多過ぎる。
650 $ tooLarge actualLimit
651 -- 成功。itr 内にチャンクを置いたままにする
653 chunk ← seqToLBS <$> readTVar itrReceivedBody
654 writeTVar itrReceivedBody (∅)
655 writeTVar itrReceivedBodyLen 0
658 driftTo DecidingHeader
661 tooLarge ∷ Int → STM ()
662 tooLarge lim = abortSTM RequestEntityTooLarge []
663 (Just $ "Request body must be smaller than "
664 ⊕ T.pack (show lim) ⊕ " bytes.")
666 seqToLBS ∷ Seq ByteString → Lazy.ByteString
667 {-# INLINE seqToLBS #-}
668 seqToLBS = Lazy.fromChunks ∘ toList
670 -- | Computation of @'inputChunk' limit@ attempts to read a part of
671 -- request body up to @limit@ bytes. You can read any large request by
672 -- repeating computation of this action. When you've read all the
673 -- request body, 'inputChunk' returns an empty string and then make
674 -- the 'Resource' transit to /Deciding Header/ state.
676 -- @limit@ may be less than or equal to zero. In this case, the
677 -- default limitation value ('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 Lazy.ByteString
684 = do driftTo GettingBody
686 hasBody ← liftIO $ atomically $ readTVar $ itrRequestHasBody itr
687 chunk ← if hasBody then
690 do driftTo DecidingHeader
694 askForInput ∷ Interaction → Resource Lazy.ByteString
695 askForInput (Interaction {..})
696 = do let confLimit = cnfMaxEntityLength itrConfig
697 actualLimit = if limit < 0 then
701 when (actualLimit <= 0)
702 $ fail ("inputChunkLBS: limit must be positive: " ++ show actualLimit)
705 $ do writeTVar itrReqBodyWanted (Just actualLimit)
706 writeTVar itrWillReceiveBody True
707 -- 應答を待つ。トランザクションを分けなければ當然デッドロック。
708 chunk ← liftIO $ atomically
709 $ do chunkLen ← readTVar itrReceivedBodyLen
710 -- 要求された量に滿たなくて、まだ殘りがある
712 when (chunkLen < actualLimit)
713 $ do chunkIsOver ← readTVar itrReqChunkIsOver
717 chunk ← seqToLBS <$> readTVar itrReceivedBody
718 writeTVar itrReceivedBody (∅)
719 writeTVar itrReceivedBodyLen 0
721 when (Lazy.null chunk)
722 $ driftTo DecidingHeader
725 -- | Computation of @'inputForm' limit@ attempts to read the request
726 -- body with 'input' and parse it as
727 -- @application\/x-www-form-urlencoded@ or @multipart\/form-data@. If
728 -- the request header \"Content-Type\" is neither of them, 'inputForm'
729 -- makes 'Resource' abort with status \"415 Unsupported Media
730 -- Type\". If the request has no \"Content-Type\", it aborts with
731 -- \"400 Bad Request\".
733 -- Field names in @multipart\/form-data@ will be precisely decoded in
734 -- accordance with RFC 2231. On the other hand,
735 -- @application\/x-www-form-urlencoded@ says nothing about the
736 -- encoding of field names, so they'll always be decoded in UTF-8.
737 inputForm ∷ Int → Resource [(Text, FormData)]
739 = do cTypeM ← getContentType
742 → abort BadRequest [] (Just "Missing Content-Type")
743 Just (MIMEType "application" "x-www-form-urlencoded" _)
744 → readWWWFormURLEncoded
745 Just (MIMEType "multipart" "form-data" params)
746 → readMultipartFormData params
748 → abort UnsupportedMediaType []
752 $ A.toAsciiBuilder "Unsupported media type: "
753 ⊕ printMIMEType cType
755 readWWWFormURLEncoded
756 = (map toPairWithFormData ∘ parseWWWFormURLEncoded)
758 (bsToAscii =≪ input limit)
761 = case A.fromByteString (Strict.concat (Lazy.toChunks bs)) of
763 Nothing → abort BadRequest [] (Just "Malformed x-www-form-urlencoded")
765 readMultipartFormData params
766 = do case M.lookup "boundary" params of
768 → abort BadRequest [] (Just "Missing boundary of multipart/form-data")
770 → do src ← input limit
771 b ← case A.fromText boundary of
773 Nothing → abort BadRequest []
774 (Just $ "Malformed boundary: " ⊕ boundary)
775 case LP.parse (p b) src of
778 _ → abort BadRequest [] (Just "Unparsable multipart/form-data")
780 p b = do xs ← multipartFormP b
784 -- | This is just a constant @-1@. It's better to say @'input'
785 -- 'defaultLimit'@ than to say @'input' (-1)@ but these are exactly
791 {- DecidingHeader 時に使用するアクション群 -}
793 -- | Set the response status code. If you omit to compute this action,
794 -- the status code will be defaulted to \"200 OK\".
795 setStatus ∷ StatusCode → Resource ()
797 = do driftTo DecidingHeader
800 $ do res ← readTVar $ itrResponse itr
804 writeTVar (itrResponse itr) res'
806 -- | Set a value of given resource header. Comparison of header name
807 -- is case-insensitive. Note that this action is not intended to be
808 -- used so frequently: there should be actions like 'setContentType'
809 -- for every common headers.
811 -- Some important headers (especially \"Content-Length\" and
812 -- \"Transfer-Encoding\") may be silently dropped or overwritten by
813 -- the system not to corrupt the interaction with client at the
814 -- viewpoint of HTTP protocol layer. For instance, if we are keeping
815 -- the connection alive, without this process it causes a catastrophe
816 -- to send a header \"Content-Length: 10\" and actually send a body of
817 -- 20 bytes long. In this case the client shall only accept the first
818 -- 10 bytes of response body and thinks that the residual 10 bytes is
819 -- a part of header of the next response.
820 setHeader ∷ CIAscii → Ascii → Resource ()
822 = driftTo DecidingHeader ≫ setHeader' name value
824 setHeader' ∷ CIAscii → Ascii → Resource ()
825 setHeader' name value
826 = do itr ← getInteraction
828 $ do res ← readTVar $ itrResponse itr
829 let res' = H.setHeader name value res
830 writeTVar (itrResponse itr) res'
832 -- | Computation of @'redirect' code uri@ sets the response status to
833 -- @code@ and \"Location\" header to @uri@. The @code@ must satisfy
834 -- 'isRedirection' or it causes an error.
835 redirect ∷ StatusCode → URI → Resource ()
837 = do when (code ≡ NotModified ∨ not (isRedirection code))
838 $ abort InternalServerError []
842 $ A.toAsciiBuilder "Attempted to redirect with status "
843 ⊕ printStatusCode code
847 -- | Computation of @'setContentType' mType@ sets the response header
848 -- \"Content-Type\" to @mType@.
849 setContentType ∷ MIMEType → Resource ()
851 = setHeader "Content-Type" ∘ A.fromAsciiBuilder ∘ printMIMEType
853 -- | Computation of @'setLocation' uri@ sets the response header
854 -- \"Location\" to @uri@.
855 setLocation ∷ URI → Resource ()
857 = case A.fromChars uriStr of
858 Just a → setHeader "Location" a
859 Nothing → abort InternalServerError []
860 (Just $ "Malformed URI: " ⊕ T.pack uriStr)
862 uriStr = uriToString id uri ""
864 -- |Computation of @'setContentEncoding' codings@ sets the response
865 -- header \"Content-Encoding\" to @codings@.
866 setContentEncoding ∷ [CIAscii] → Resource ()
867 setContentEncoding codings
868 = do ver ← getRequestVersion
870 HttpVersion 1 0 → return (toAB ∘ unnormalizeCoding)
871 HttpVersion 1 1 → return toAB
872 _ → abort InternalServerError []
873 (Just "setContentEncoding: Unknown HTTP version")
874 setHeader "Content-Encoding"
875 (A.fromAsciiBuilder $ joinWith ", " $ map tr codings)
877 toAB = A.toAsciiBuilder ∘ A.fromCIAscii
879 -- |Computation of @'setWWWAuthenticate' challenge@ sets the response
880 -- header \"WWW-Authenticate\" to @challenge@.
881 setWWWAuthenticate ∷ AuthChallenge → Resource ()
882 setWWWAuthenticate challenge
883 = setHeader "WWW-Authenticate" (printAuthChallenge challenge)
886 {- DecidingBody 時に使用するアクション群 -}
888 -- | Write a 'Lazy.ByteString' to the response body, and then transit
889 -- to the /Done/ state. It is safe to apply 'output' to an infinite
890 -- string, such as the lazy stream of \/dev\/random.
891 output ∷ Lazy.ByteString → Resource ()
892 {-# INLINE output #-}
893 output str = outputChunk str *> driftTo Done
895 -- | Write a 'Lazy.ByteString' to the response body. This action can
896 -- be repeated as many times as you want. It is safe to apply
897 -- 'outputChunk' to an infinite string.
898 outputChunk ∷ Lazy.ByteString → Resource ()
899 outputChunk wholeChunk
900 = do driftTo DecidingBody
903 let limit = cnfMaxOutputChunkLength $ itrConfig itr
905 $ abort InternalServerError []
906 (Just $ "cnfMaxOutputChunkLength must be positive: " ⊕ T.pack (show limit))
908 discardBody ← liftIO $ atomically $ readTVar $ itrWillDiscardBody itr
910 $ sendChunks itr wholeChunk limit
912 unless (Lazy.null wholeChunk)
913 $ liftIO $ atomically $
914 writeTVar (itrSentNoBody itr) False
916 sendChunks ∷ Interaction → Lazy.ByteString → Int → Resource ()
917 sendChunks itr@(Interaction {..}) str limit
918 | Lazy.null str = return ()
919 | otherwise = do let (chunk, remaining) = Lazy.splitAt (fromIntegral limit) str
921 $ putTMVar itrBodyToSend (chunkToBuilder chunk)
922 sendChunks itr remaining limit
924 chunkToBuilder ∷ Lazy.ByteString → Builder
925 chunkToBuilder = mconcat ∘ map BB.fromByteString ∘ Lazy.toChunks
929 [GettingBody からそれ以降の状態に遷移する時]
931 body を讀み終へてゐなければ、殘りの body を讀み捨てる。
934 [DecidingHeader からそれ以降の状態に遷移する時]
941 bodyIsNull が False ならば何もしない。True だった場合は出力補完す
946 driftTo ∷ InteractionState → Resource ()
948 = do itr ← getInteraction
950 $ do oldState ← readTVar $ itrState itr
951 if newState < oldState then
952 throwStateError oldState newState
954 do let a = [oldState .. newState]
957 mapM_ (uncurry $ drift itr) c
958 writeTVar (itrState itr) newState
960 throwStateError ∷ Monad m ⇒ InteractionState → InteractionState → m a
961 throwStateError Done DecidingBody
962 = fail "It makes no sense to output something after finishing to output."
963 throwStateError old new
964 = fail ("state error: " ⧺ show old ⧺ " ==> " ⧺ show new)
966 drift ∷ Interaction → InteractionState → InteractionState → STM ()
967 drift (Interaction {..}) GettingBody _
968 = writeTVar itrReqBodyWasteAll True
969 drift itr DecidingHeader _
971 drift itr@(Interaction {..}) _ Done
972 = do bodyIsNull ← readTVar itrSentNoBody
974 $ writeDefaultPage itr