2 GeneralizedNewtypeDeriving
8 {-# OPTIONS_HADDOCK prune #-}
9 -- |This is the Resource Monad; monadic actions to define the behavior
10 -- of each resources. The 'Resource' Monad is a kind of 'Prelude.IO'
11 -- Monad thus it implements 'Control.Monad.Trans.MonadIO' class. It is
12 -- also a state machine.
14 -- Request Processing Flow:
16 -- 1. A client issues an HTTP request.
18 -- 2. If the URI of it matches to any resource, the corresponding
19 -- 'Resource' Monad starts running on a newly spawned thread.
21 -- 3. The 'Resource' Monad looks at the request header, find (or not
22 -- find) an entity, receive the request body (if any), decide the
23 -- response header, and decide the response body. This process
24 -- will be discussed later.
26 -- 4. The 'Resource' Monad and its thread stops running. The client
27 -- may or may not be sending us the next request at this point.
29 -- 'Resource' Monad takes the following states. The initial state is
30 -- /Examining Request/ and the final state is /Done/.
32 -- [/Examining Request/] In this state, a 'Resource' looks at the
33 -- request header and thinks about an entity for it. If there is a
34 -- suitable entity, the 'Resource' tells the system an entity tag
35 -- and its last modification time ('foundEntity'). If it found no
36 -- entity, it tells the system so ('foundNoEntity'). In case it is
37 -- impossible to decide the existence of entity, which is a typical
38 -- case for POST requests, 'Resource' does nothing in this state.
40 -- [/Getting Body/] A 'Resource' asks the system to receive a
41 -- request body from client. Before actually reading from the
42 -- socket, the system sends \"100 Continue\" to the client if need
43 -- be. When a 'Resource' transits to the next state without
44 -- receiving all or part of request body, the system still reads it
45 -- and just throws it away.
47 -- [/Deciding Header/] A 'Resource' makes a decision of status code
48 -- and response header. When it transits to the next state, the
49 -- system checks the validness of response header and then write
50 -- them to the socket.
52 -- [/Deciding Body/] In this state, a 'Resource' asks the system to
53 -- write some response body to the socket. When it transits to the
54 -- next state without writing any response body, the system
55 -- completes it depending on the status code.
57 -- [/Done/] Everything is over. A 'Resource' can do nothing for the
58 -- HTTP interaction anymore.
60 -- Note that the state transition is one-way: for instance, it is an
61 -- error to try to read a request body after writing some
62 -- response. This limitation is for efficiency. We don't want to read
63 -- the entire request before starting 'Resource', nor we don't want to
64 -- postpone writing the entire response till the end of 'Resource'
67 module Network.HTTP.Lucu.Resource
76 -- ** Getting request header
78 -- |These actions can be computed regardless of the current state,
79 -- and they don't change the state.
84 , getRemoteCertificate
95 , isEncodingAcceptable
99 -- ** Finding an entity
101 -- |These actions can be computed only in the /Examining Request/
102 -- state. After the computation, the 'Resource' transits to
103 -- /Getting Body/ state.
109 -- ** Getting a request body
111 -- |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
140 import Blaze.ByteString.Builder (Builder)
141 import qualified Blaze.ByteString.Builder.ByteString as BB
142 import Control.Applicative
143 import Control.Concurrent.STM
144 import Control.Monad.Reader
145 import Control.Monad.Unicode
146 import Data.Ascii (Ascii, CIAscii)
147 import qualified Data.Ascii as A
148 import qualified Data.Attoparsec.Char8 as P
149 import qualified Data.Attoparsec.Lazy as LP
150 import Data.ByteString (ByteString)
151 import qualified Data.ByteString as Strict
152 import qualified Data.ByteString.Lazy as Lazy
153 import Data.Foldable (toList)
155 import qualified Data.Map as M
158 import Data.Monoid.Unicode
159 import Data.Sequence (Seq)
160 import Data.Text (Text)
161 import qualified Data.Text as T
162 import qualified Data.Text.Encoding as T
164 import qualified Data.Time.HTTP as HTTP
165 import Network.HTTP.Lucu.Abortion
166 import Network.HTTP.Lucu.Authorization
167 import Network.HTTP.Lucu.Config
168 import Network.HTTP.Lucu.ContentCoding
169 import Network.HTTP.Lucu.DefaultPage
170 import Network.HTTP.Lucu.ETag
171 import qualified Network.HTTP.Lucu.Headers as H
172 import Network.HTTP.Lucu.HttpVersion
173 import Network.HTTP.Lucu.Interaction
174 import Network.HTTP.Lucu.MultipartForm
175 import Network.HTTP.Lucu.Postprocess
176 import Network.HTTP.Lucu.Request
177 import Network.HTTP.Lucu.Response
178 import Network.HTTP.Lucu.MIMEType
179 import Network.HTTP.Lucu.Utils
180 import Network.Socket hiding (accept)
181 import Network.URI hiding (path)
183 import Prelude.Unicode
185 -- |The 'Resource' monad. This monad implements 'MonadIO' so it can do
189 unRes ∷ ReaderT Interaction IO a
191 deriving (Applicative, Functor, Monad, MonadIO)
193 runRes ∷ Resource a → Interaction → IO a
195 = runReaderT (unRes r) itr
197 getInteraction ∷ Resource Interaction
198 getInteraction = Resource ask
200 -- |Get the 'Config' value which is used for the httpd.
201 getConfig ∷ Resource Config
202 getConfig = itrConfig <$> getInteraction
204 -- |Get the 'SockAddr' of the remote host. If you want a string
205 -- representation instead of 'SockAddr', use 'getRemoteAddr''.
206 getRemoteAddr ∷ Resource SockAddr
207 getRemoteAddr = itrRemoteAddr <$> getInteraction
209 -- |Get the string representation of the address of remote host. If
210 -- you want a 'SockAddr' instead of 'String', use 'getRemoteAddr'.
211 getRemoteAddr' ∷ Resource HostName
213 = do sa ← getRemoteAddr
214 (Just a, _) ← liftIO $ getNameInfo [NI_NUMERICHOST] True False sa
217 -- |Resolve an address to the remote host.
218 getRemoteHost ∷ Resource (Maybe HostName)
220 = do sa ← getRemoteAddr
221 fst <$> (liftIO $ getNameInfo [] True False sa)
223 -- | Return the X.509 certificate of the client, or 'Nothing' if:
225 -- * This request didn't came through an SSL stream.
227 -- * The client didn't send us its certificate.
229 -- * The 'OpenSSL.Session.VerificationMode' of
230 -- 'OpenSSL.Session.SSLContext' in 'SSLConfig' has not been set to
231 -- 'OpenSSL.Session.VerifyPeer'.
232 getRemoteCertificate ∷ Resource (Maybe X509)
233 getRemoteCertificate = itrRemoteCert <$> getInteraction
235 -- |Get the 'Request' value which represents the request header. In
236 -- general you don't have to use this action.
237 getRequest ∷ Resource Request
238 getRequest = (fromJust ∘ itrRequest) <$> getInteraction
240 -- |Get the 'Method' value of the request.
241 getMethod ∷ Resource Method
242 getMethod = reqMethod <$> getRequest
244 -- |Get the URI of the request.
245 getRequestURI ∷ Resource URI
246 getRequestURI = reqURI <$> getRequest
248 -- |Get the HTTP version of the request.
249 getRequestVersion ∷ Resource HttpVersion
250 getRequestVersion = reqVersion <$> getRequest
252 -- |Get the path of this 'Resource' (to be exact,
253 -- 'Network.HTTP.Lucu.Resource.Tree.ResourceDef') in the
254 -- 'Network.HTTP.Lucu.Resource.Tree.ResTree'. The result of this
255 -- action is the exact path in the tree even when the
256 -- 'Network.HTTP.Lucu.Resource.Tree.ResourceDef' is greedy.
260 -- > main = let tree = mkResTree [ (["foo"], resFoo) ]
261 -- > in runHttpd defaultConfig tree
263 -- > resFoo = ResourceDef {
264 -- > resIsGreedy = True
265 -- > , resGet = Just $ do requestURI <- getRequestURI
266 -- > resourcePath <- getResourcePath
267 -- > pathInfo <- getPathInfo
268 -- > -- uriPath requestURI == "/foo/bar/baz"
269 -- > -- resourcePath == ["foo"]
270 -- > -- pathInfo == ["bar", "baz"]
274 getResourcePath ∷ Resource [Text]
275 getResourcePath = (fromJust ∘ itrResourcePath) <$> getInteraction
277 -- |This is an analogy of CGI PATH_INFO. The result is
278 -- URI-unescaped. It is always @[]@ if the
279 -- 'Network.HTTP.Lucu.Resource.Tree.ResourceDef' is not greedy. See
280 -- 'getResourcePath'.
282 -- Note that the returned path is URI-decoded and then UTF-8 decoded.
283 getPathInfo ∷ Resource [Text]
284 getPathInfo = do rsrcPath ← getResourcePath
285 reqPath ← splitPathInfo <$> getRequestURI
286 -- rsrcPath と reqPath の共通する先頭部分を reqPath か
287 -- ら全部取り除くと、それは PATH_INFO のやうなものにな
288 -- る。rsrcPath は全部一致してゐるに決まってゐる(でな
289 -- ければこの Resource が撰ばれた筈が無い)ので、
290 -- rsrcPath の長さの分だけ削除すれば良い。
291 return $ drop (length rsrcPath) reqPath
293 -- |Assume the query part of request URI as
294 -- application\/x-www-form-urlencoded, and parse it to pairs of
295 -- @(name, formData)@. This action doesn't parse the request body. See
296 -- 'inputForm'. Field names are decoded in UTF-8.
297 getQueryForm ∷ Resource [(Text, FormData)]
298 getQueryForm = parse' <$> getRequestURI
300 parse' = map toPairWithFormData ∘
301 parseWWWFormURLEncoded ∘
307 toPairWithFormData ∷ (ByteString, ByteString) → (Text, FormData)
308 toPairWithFormData (name, value)
309 = let fd = FormData {
311 , fdContent = Lazy.fromChunks [value]
313 in (T.decodeUtf8 name, fd)
315 -- |Get a value of given request header. Comparison of header name is
316 -- case-insensitive. Note that this action is not intended to be used
317 -- so frequently: there should be actions like 'getContentType' for
318 -- every common headers.
319 getHeader ∷ CIAscii → Resource (Maybe Ascii)
321 = H.getHeader name <$> getRequest
323 -- |Get a list of 'MIMEType' enumerated on header \"Accept\".
324 getAccept ∷ Resource [MIMEType]
326 = do acceptM ← getHeader "Accept"
331 → case P.parseOnly p (A.toByteString accept) of
333 Left _ → abort BadRequest []
334 (Just $ "Unparsable Accept: " ⊕ A.toText accept)
336 p = do xs ← mimeTypeListP
340 -- |Get a list of @(contentCoding, qvalue)@ enumerated on header
341 -- \"Accept-Encoding\". The list is sorted in descending order by
343 getAcceptEncoding ∷ Resource [(CIAscii, Maybe Double)]
345 = do accEncM ← getHeader "Accept-Encoding"
348 -- HTTP/1.0 には Accept-Encoding が無い場合の規定が無い
349 -- ので安全の爲 identity が指定された事にする。HTTP/1.1
350 -- の場合は何でも受け入れて良い事になってゐるので "*" が
352 → do ver ← getRequestVersion
354 HttpVersion 1 0 → return [("identity", Nothing)]
355 HttpVersion 1 1 → return [("*" , Nothing)]
356 _ → abort InternalServerError []
357 (Just "getAcceptEncoding: unknown HTTP version")
361 return [("identity", Nothing)]
363 case P.parseOnly p (A.toByteString ae) of
364 Right xs → return $ map toTuple $ reverse $ sort xs
365 Left _ → abort BadRequest []
366 (Just $ "Unparsable Accept-Encoding: " ⊕ A.toText ae)
368 p = do xs ← acceptEncodingListP
372 toTuple (AcceptEncoding {..})
373 = (aeEncoding, aeQValue)
375 -- |Check whether a given content-coding is acceptable.
376 isEncodingAcceptable ∷ CIAscii → Resource Bool
377 isEncodingAcceptable encoding = any f <$> getAcceptEncoding
380 = (e ≡ "*" ∨ e ≡ encoding) ∧ q ≢ Just 0
382 -- |Get the header \"Content-Type\" as 'MIMEType'.
383 getContentType ∷ Resource (Maybe MIMEType)
385 = do cTypeM ← getHeader "Content-Type"
390 → case P.parseOnly p (A.toByteString cType) of
391 Right t → return $ Just t
392 Left _ → abort BadRequest []
393 (Just $ "Unparsable Content-Type: " ⊕ A.toText cType)
399 -- |Get the header \"Authorization\" as 'AuthCredential'.
400 getAuthorization ∷ Resource (Maybe AuthCredential)
402 = do authM ← getHeader "Authorization"
407 → case P.parseOnly p (A.toByteString auth) of
408 Right ac → return $ Just ac
409 Left _ → return Nothing
411 p = do ac ← authCredentialP
416 {- ExaminingRequest 時に使用するアクション群 -}
418 -- |Tell the system that the 'Resource' found an entity for the
419 -- request URI. If this is a GET or HEAD request, a found entity means
420 -- a datum to be replied. If this is a PUT or DELETE request, it means
421 -- a datum which was stored for the URI until now. It is an error to
422 -- compute 'foundEntity' if this is a POST request.
424 -- Computation of 'foundEntity' performs \"If-Match\" test or
425 -- \"If-None-Match\" test if possible. When those tests fail, the
426 -- computation of 'Resource' immediately aborts with status \"412
427 -- Precondition Failed\" or \"304 Not Modified\" depending on the
430 -- If this is a GET or HEAD request, 'foundEntity' automatically puts
431 -- \"ETag\" and \"Last-Modified\" headers into the response.
432 foundEntity ∷ ETag → UTCTime → Resource ()
433 foundEntity tag timeStamp
434 = do driftTo ExaminingRequest
437 when (method ≡ GET ∨ method ≡ HEAD)
438 $ setHeader' "Last-Modified" (HTTP.toAscii timeStamp)
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 ()
455 = do driftTo ExaminingRequest
458 when (method ≡ GET ∨ method ≡ HEAD)
463 $ abort InternalServerError []
464 (Just "Illegal computation of foundETag for POST request.")
466 -- If-Match があればそれを見る。
467 ifMatch ← getHeader "If-Match"
470 Just value → if value ≡ "*" then
473 case P.parseOnly p (A.toByteString value) of
475 -- tags の中に一致するものが無ければ
476 -- PreconditionFailed で終了。
477 → when ((¬) (any (≡ tag) tags))
478 $ abort PreconditionFailed []
479 (Just $ "The entity tag doesn't match: " ⊕ A.toText value)
481 → abort BadRequest [] (Just $ "Unparsable If-Match: " ⊕ A.toText value)
483 let statusForNoneMatch
484 = if method ≡ GET ∨ method ≡ HEAD then
489 -- If-None-Match があればそれを見る。
490 ifNoneMatch ← getHeader "If-None-Match"
493 Just value → if value ≡ "*" then
494 abort statusForNoneMatch [] (Just "The entity tag matches: *")
496 case P.parseOnly p (A.toByteString value) of
498 → when (any (≡ tag) tags)
499 $ abort statusForNoneMatch []
500 (Just $ "The entity tag matches: " ⊕ A.toText value)
502 → abort BadRequest []
503 (Just $ "Unparsable If-None-Match: " ⊕ A.toText value)
507 p = do xs ← eTagListP
511 -- |Tell the system that the 'Resource' found an entity for the
512 -- request URI. The only difference from 'foundEntity' is that
513 -- 'foundTimeStamp' performs \"If-Modified-Since\" test or
514 -- \"If-Unmodified-Since\" test instead of \"If-Match\" test or
515 -- \"If-None-Match\" test. Be aware that any tests based on last
516 -- modification time are unsafe because it is possible to mess up such
517 -- tests by modifying the entity twice in a second.
519 -- This action is not preferred. You should use 'foundEntity' whenever
521 foundTimeStamp ∷ UTCTime → Resource ()
522 foundTimeStamp timeStamp
523 = do driftTo ExaminingRequest
526 when (method ≡ GET ∨ method ≡ HEAD)
527 $ setHeader' "Last-Modified" (HTTP.toAscii timeStamp)
529 $ abort InternalServerError []
530 (Just "Illegal computation of foundTimeStamp for POST request.")
532 let statusForIfModSince
533 = if method ≡ GET ∨ method ≡ HEAD then
538 -- If-Modified-Since があればそれを見る。
539 ifModSince ← getHeader "If-Modified-Since"
541 Just str → case HTTP.fromAscii str of
543 → when (timeStamp ≤ lastTime)
544 $ abort statusForIfModSince []
545 (Just $ "The entity has not been modified since " ⊕ A.toText str)
547 → return () -- 不正な時刻は無視
550 -- If-Unmodified-Since があればそれを見る。
551 ifUnmodSince ← getHeader "If-Unmodified-Since"
553 Just str → case HTTP.fromAscii str of
555 → when (timeStamp > lastTime)
556 $ abort PreconditionFailed []
557 (Just $ "The entity has not been modified since " ⊕ A.toText str)
559 → return () -- 不正な時刻は無視
564 -- | Computation of @'foundNoEntity' mStr@ tells the system that the
565 -- 'Resource' found no entity for the request URI. @mStr@ is an
566 -- optional error message to be replied to the client.
568 -- If this is a PUT request, 'foundNoEntity' performs \"If-Match\"
569 -- test and aborts with status \"412 Precondition Failed\" when it
570 -- failed. If this is a GET, HEAD, POST or DELETE request,
571 -- 'foundNoEntity' always aborts with status \"404 Not Found\".
572 foundNoEntity ∷ Maybe Text → Resource ()
574 = do driftTo ExaminingRequest
578 $ abort NotFound [] msgM
580 -- エンティティが存在しないと云ふ事は、"*" も含めたどのやうな
581 -- If-Match: 條件も滿たさない。
582 ifMatch ← getHeader "If-Match"
583 when (ifMatch ≢ Nothing)
584 $ abort PreconditionFailed [] msgM
589 {- GettingBody 時に使用するアクション群 -}
591 -- | Computation of @'input' limit@ attempts to read the request body
592 -- up to @limit@ bytes, and then make the 'Resource' transit to
593 -- /Deciding Header/ state. When the actual size of body is larger
594 -- than @limit@ bytes, computation of 'Resource' immediately aborts
595 -- with status \"413 Request Entity Too Large\". When the request has
596 -- no body, 'input' returns an empty string.
598 -- @limit@ may be less than or equal to zero. In this case, the
599 -- default limitation value ('cnfMaxEntityLength') is used. See
602 -- 'input' returns a 'Lazy.ByteString' but it's not really lazy:
603 -- reading from the socket just happens at the computation of 'input',
604 -- not at the evaluation of the 'Lazy.ByteString'. The same goes for
606 input ∷ Int → Resource Lazy.ByteString
608 = do driftTo GettingBody
610 chunk ← if reqHasBody $ fromJust $ itrRequest itr then
613 do driftTo DecidingHeader
617 askForInput ∷ Interaction → Resource Lazy.ByteString
618 askForInput (Interaction {..})
619 = do let confLimit = cnfMaxEntityLength itrConfig
620 actualLimit = if limit ≤ 0 then
624 when (actualLimit ≤ 0)
625 $ fail ("inputLBS: limit must be positive: " ⧺ show actualLimit)
628 $ writeTVar itrReqBodyWanted actualLimit
629 -- 應答を待つ。トランザクションを分けなければ當然デッドロックする。
630 chunk ← liftIO $ atomically
631 $ do chunkLen ← readTVar itrReceivedBodyLen
632 chunkIsOver ← readTVar itrReqChunkIsOver
633 if chunkLen < actualLimit then
634 -- 要求された量に滿たなくて、まだ殘りが
639 -- 制限値一杯まで讀むやうに指示したのに
640 -- まだ殘ってゐるなら、それは多過ぎる。
642 $ tooLarge actualLimit
643 -- 成功。itr 内にチャンクを置いたままにする
645 chunk ← seqToLBS <$> readTVar itrReceivedBody
646 writeTVar itrReceivedBody (∅)
647 writeTVar itrReceivedBodyLen 0
650 driftTo DecidingHeader
653 tooLarge ∷ Int → STM ()
654 tooLarge lim = abortSTM RequestEntityTooLarge []
655 (Just $ "Request body must be smaller than "
656 ⊕ T.pack (show lim) ⊕ " bytes.")
658 seqToLBS ∷ Seq ByteString → Lazy.ByteString
659 {-# INLINE seqToLBS #-}
660 seqToLBS = Lazy.fromChunks ∘ toList
662 -- | Computation of @'inputChunk' limit@ attempts to read a part of
663 -- request body up to @limit@ bytes. You can read any large request by
664 -- repeating computation of this action. When you've read all the
665 -- request body, 'inputChunk' returns an empty string and then make
666 -- the 'Resource' transit to /Deciding Header/ state.
668 -- @limit@ may be less than or equal to zero. In this case, the
669 -- default limitation value ('cnfMaxEntityLength') is used. See
672 -- Note that 'inputChunkLBS' is more efficient than 'inputChunk' so you
673 -- should use it whenever possible.
674 inputChunk ∷ Int → Resource Lazy.ByteString
676 = do driftTo GettingBody
678 chunk ← if reqHasBody $ fromJust $ itrRequest itr then
681 do driftTo DecidingHeader
685 askForInput ∷ Interaction → Resource Lazy.ByteString
686 askForInput (Interaction {..})
687 = do let confLimit = cnfMaxEntityLength itrConfig
688 actualLimit = if limit < 0 then
692 when (actualLimit ≤ 0)
693 $ fail ("inputChunkLBS: limit must be positive: " ++ show actualLimit)
696 $ writeTVar itrReqBodyWanted actualLimit
697 -- 應答を待つ。トランザクションを分けなければ當然デッドロック。
698 chunk ← liftIO $ atomically
699 $ do chunkLen ← readTVar itrReceivedBodyLen
700 -- 要求された量に滿たなくて、まだ殘りがある
702 when (chunkLen < actualLimit)
703 $ do chunkIsOver ← readTVar itrReqChunkIsOver
707 chunk ← seqToLBS <$> readTVar itrReceivedBody
708 writeTVar itrReceivedBody (∅)
709 writeTVar itrReceivedBodyLen 0
711 when (Lazy.null chunk)
712 $ driftTo DecidingHeader
715 -- | Computation of @'inputForm' limit@ attempts to read the request
716 -- body with 'input' and parse it as
717 -- @application\/x-www-form-urlencoded@ or @multipart\/form-data@. If
718 -- the request header \"Content-Type\" is neither of them, 'inputForm'
719 -- makes 'Resource' abort with status \"415 Unsupported Media
720 -- Type\". If the request has no \"Content-Type\", it aborts with
721 -- \"400 Bad Request\".
723 -- Field names in @multipart\/form-data@ will be precisely decoded in
724 -- accordance with RFC 2231. On the other hand,
725 -- @application\/x-www-form-urlencoded@ says nothing about the
726 -- encoding of field names, so they'll always be decoded in UTF-8.
727 inputForm ∷ Int → Resource [(Text, FormData)]
729 = do cTypeM ← getContentType
732 → abort BadRequest [] (Just "Missing Content-Type")
733 Just (MIMEType "application" "x-www-form-urlencoded" _)
734 → readWWWFormURLEncoded
735 Just (MIMEType "multipart" "form-data" params)
736 → readMultipartFormData params
738 → abort UnsupportedMediaType []
742 $ A.toAsciiBuilder "Unsupported media type: "
743 ⊕ printMIMEType cType
745 readWWWFormURLEncoded
746 = (map toPairWithFormData ∘ parseWWWFormURLEncoded)
748 (bsToAscii =≪ input limit)
751 = case A.fromByteString (Strict.concat (Lazy.toChunks bs)) of
753 Nothing → abort BadRequest [] (Just "Malformed x-www-form-urlencoded")
755 readMultipartFormData params
756 = do case M.lookup "boundary" params of
758 → abort BadRequest [] (Just "Missing boundary of multipart/form-data")
760 → do src ← input limit
761 b ← case A.fromText boundary of
763 Nothing → abort BadRequest []
764 (Just $ "Malformed boundary: " ⊕ boundary)
765 case LP.parse (p b) src of
768 _ → abort BadRequest [] (Just "Unparsable multipart/form-data")
770 p b = do xs ← multipartFormP b
774 -- | This is just a constant @-1@. It's better to say @'input'
775 -- 'defaultLimit'@ than to say @'input' (-1)@ but these are exactly
781 {- DecidingHeader 時に使用するアクション群 -}
783 -- | Set the response status code. If you omit to compute this action,
784 -- the status code will be defaulted to \"200 OK\".
785 setStatus ∷ StatusCode → Resource ()
787 = do driftTo DecidingHeader
791 $ setResponseStatus itr sc
793 -- | Set a value of given resource header. Comparison of header name
794 -- is case-insensitive. Note that this action is not intended to be
795 -- used so frequently: there should be actions like 'setContentType'
796 -- for every common headers.
798 -- Some important headers (especially \"Content-Length\" and
799 -- \"Transfer-Encoding\") may be silently dropped or overwritten by
800 -- the system not to corrupt the interaction with client at the
801 -- viewpoint of HTTP protocol layer. For instance, if we are keeping
802 -- the connection alive, without this process it causes a catastrophe
803 -- to send a header \"Content-Length: 10\" and actually send a body of
804 -- 20 bytes long. In this case the client shall only accept the first
805 -- 10 bytes of response body and thinks that the residual 10 bytes is
806 -- a part of header of the next response.
807 setHeader ∷ CIAscii → Ascii → Resource ()
809 = driftTo DecidingHeader ≫ setHeader' name value
811 setHeader' ∷ CIAscii → Ascii → Resource ()
812 setHeader' name value
813 = do itr ← getInteraction
815 $ do res ← readTVar $ itrResponse itr
816 let res' = H.setHeader name value res
817 writeTVar (itrResponse itr) res'
819 -- | Computation of @'redirect' code uri@ sets the response status to
820 -- @code@ and \"Location\" header to @uri@. The @code@ must satisfy
821 -- 'isRedirection' or it causes an error.
822 redirect ∷ StatusCode → URI → Resource ()
824 = do when (code ≡ NotModified ∨ not (isRedirection code))
825 $ abort InternalServerError []
829 $ A.toAsciiBuilder "Attempted to redirect with status "
830 ⊕ printStatusCode code
834 -- | Computation of @'setContentType' mType@ sets the response header
835 -- \"Content-Type\" to @mType@.
836 setContentType ∷ MIMEType → Resource ()
838 = setHeader "Content-Type" ∘ A.fromAsciiBuilder ∘ printMIMEType
840 -- | Computation of @'setLocation' uri@ sets the response header
841 -- \"Location\" to @uri@.
842 setLocation ∷ URI → Resource ()
844 = case A.fromChars uriStr of
845 Just a → setHeader "Location" a
846 Nothing → abort InternalServerError []
847 (Just $ "Malformed URI: " ⊕ T.pack uriStr)
849 uriStr = uriToString id uri ""
851 -- |Computation of @'setContentEncoding' codings@ sets the response
852 -- header \"Content-Encoding\" to @codings@.
853 setContentEncoding ∷ [CIAscii] → Resource ()
854 setContentEncoding codings
855 = do ver ← getRequestVersion
857 HttpVersion 1 0 → return (toAB ∘ unnormalizeCoding)
858 HttpVersion 1 1 → return toAB
859 _ → abort InternalServerError []
860 (Just "setContentEncoding: Unknown HTTP version")
861 setHeader "Content-Encoding"
862 (A.fromAsciiBuilder $ joinWith ", " $ map tr codings)
864 toAB = A.toAsciiBuilder ∘ A.fromCIAscii
866 -- |Computation of @'setWWWAuthenticate' challenge@ sets the response
867 -- header \"WWW-Authenticate\" to @challenge@.
868 setWWWAuthenticate ∷ AuthChallenge → Resource ()
869 setWWWAuthenticate challenge
870 = setHeader "WWW-Authenticate" (printAuthChallenge challenge)
873 {- DecidingBody 時に使用するアクション群 -}
875 -- | Write a 'Lazy.ByteString' to the response body, and then transit
876 -- to the /Done/ state. It is safe to apply 'output' to an infinite
877 -- string, such as the lazy stream of \/dev\/random.
878 output ∷ Lazy.ByteString → Resource ()
879 {-# INLINE output #-}
880 output str = outputChunk str *> driftTo Done
882 -- | Write a 'Lazy.ByteString' to the response body. This action can
883 -- be repeated as many times as you want. It is safe to apply
884 -- 'outputChunk' to an infinite string.
885 outputChunk ∷ Lazy.ByteString → Resource ()
887 = do driftTo DecidingBody
890 $ do putTMVar (itrBodyToSend itr) (BB.fromLazyByteString str)
891 unless (Lazy.null str)
892 $ writeTVar (itrSentNoBodySoFar itr) False
896 [GettingBody からそれ以降の状態に遷移する時]
898 body を讀み終へてゐなければ、殘りの body を讀み捨てる。
901 [DecidingHeader からそれ以降の状態に遷移する時]
908 bodyIsNull が False ならば何もしない。True だった場合は出力補完す
913 driftTo ∷ InteractionState → Resource ()
915 = do itr ← getInteraction
917 $ do oldState ← readTVar $ itrState itr
918 if newState < oldState then
919 throwStateError oldState newState
921 do let a = [oldState .. newState]
924 mapM_ (uncurry $ drift itr) c
925 writeTVar (itrState itr) newState
927 throwStateError ∷ Monad m ⇒ InteractionState → InteractionState → m a
928 throwStateError Done DecidingBody
929 = fail "It makes no sense to output something after finishing to output."
930 throwStateError old new
931 = fail ("state error: " ⧺ show old ⧺ " ==> " ⧺ show new)
933 drift ∷ Interaction → InteractionState → InteractionState → STM ()
934 drift (Interaction {..}) GettingBody _
935 = writeTVar itrReqBodyWasteAll True
936 drift itr DecidingHeader _
938 drift itr@(Interaction {..}) _ Done
939 = do bodyIsNull ← readTVar itrSentNoBodySoFar
941 $ writeDefaultPage itr