3 , GeneralizedNewtypeDeriving
9 {-# OPTIONS_HADDOCK prune #-}
11 -- |This is the Resource Monad; monadic actions to define the behavior
12 -- of each resources. The 'Resource' Monad is a kind of 'Prelude.IO'
13 -- Monad thus it implements 'Control.Monad.Trans.MonadIO' class. It is
14 -- also a state machine.
16 -- Request Processing Flow:
18 -- 1. A client issues an HTTP request.
20 -- 2. If the URI of it matches to any resource, the corresponding
21 -- 'Resource' Monad starts running on a newly spawned thread.
23 -- 3. The 'Resource' Monad looks at the request header, find (or not
24 -- find) an entity, receive the request body (if any), decide the
25 -- response header, and decide the response body. This process
26 -- will be discussed later.
28 -- 4. The 'Resource' Monad and its thread stops running. The client
29 -- may or may not be sending us the next request at this point.
31 -- 'Resource' Monad takes the following states. The initial state is
32 -- /Examining Request/ and the final state is /Done/.
34 -- [/Examining Request/] In this state, a 'Resource' looks at the
35 -- request header and thinks about an entity for it. If there is a
36 -- suitable entity, the 'Resource' tells the system an entity tag
37 -- and its last modification time ('foundEntity'). If it found no
38 -- entity, it tells the system so ('foundNoEntity'). In case it is
39 -- impossible to decide the existence of entity, which is a typical
40 -- case for POST requests, 'Resource' does nothing in this state.
42 -- [/Getting Body/] A 'Resource' asks the system to receive a
43 -- request body from client. Before actually reading from the
44 -- socket, the system sends \"100 Continue\" to the client if need
45 -- be. When a 'Resource' transits to the next state without
46 -- receiving all or part of request body, the system still reads it
47 -- and just throws it away.
49 -- [/Deciding Header/] A 'Resource' makes a decision of status code
50 -- and response header. When it transits to the next state, the
51 -- system checks the validness of response header and then write
52 -- them to the socket.
54 -- [/Deciding Body/] In this state, a 'Resource' asks the system to
55 -- write some response body to the socket. When it transits to the
56 -- next state without writing any response body, the system
57 -- completes it depending on the status code.
59 -- [/Done/] Everything is over. A 'Resource' can do nothing for the
60 -- HTTP interaction anymore.
62 -- Note that the state transition is one-way: for instance, it is an
63 -- error to try to read a request body after writing some
64 -- response. This limitation is for efficiency. We don't want to read
65 -- the entire request before starting 'Resource', nor we don't want to
66 -- postpone writing the entire response till the end of 'Resource'
69 module Network.HTTP.Lucu.Resource
78 -- ** Getting request header
80 -- |These actions can be computed regardless of the current state,
81 -- and they don't change the state.
86 , getRemoteCertificate
97 , isEncodingAcceptable
101 -- ** Finding an entity
103 -- |These actions can be computed only in the /Examining Request/
104 -- state. After the computation, the 'Resource' transits to
105 -- /Getting Body/ state.
111 -- ** Getting a request body
113 -- |Computation of these actions changes the state to /Getting
120 -- ** Setting response headers
122 -- |Computation of these actions changes the state to /Deciding
132 -- ** Writing a response body
134 -- |Computation of these actions changes the state to /Deciding
142 import Blaze.ByteString.Builder (Builder)
143 import qualified Blaze.ByteString.Builder.ByteString as BB
144 import Control.Applicative
145 import Control.Concurrent.STM
146 import Control.Monad.Reader
147 import Control.Monad.Unicode
148 import Data.Ascii (Ascii, CIAscii)
149 import qualified Data.Ascii as A
150 import qualified Data.Attoparsec.Char8 as P
151 import qualified Data.Attoparsec.Lazy as LP
152 import Data.ByteString (ByteString)
153 import qualified Data.ByteString as Strict
154 import qualified Data.ByteString.Lazy as Lazy
155 import Data.Foldable (toList)
157 import qualified Data.Map as M
160 import Data.Monoid.Unicode
161 import Data.Sequence (Seq)
162 import Data.Text (Text)
163 import qualified Data.Text as T
164 import qualified Data.Text.Encoding as T
166 import qualified Data.Time.HTTP as HTTP
167 import Network.HTTP.Lucu.Abortion
168 import Network.HTTP.Lucu.Authorization
169 import Network.HTTP.Lucu.Config
170 import Network.HTTP.Lucu.ContentCoding
171 import Network.HTTP.Lucu.DefaultPage
172 import Network.HTTP.Lucu.ETag
173 import qualified Network.HTTP.Lucu.Headers as H
174 import Network.HTTP.Lucu.HttpVersion
175 import Network.HTTP.Lucu.Interaction
176 import Network.HTTP.Lucu.MultipartForm
177 import Network.HTTP.Lucu.Postprocess
178 import Network.HTTP.Lucu.Request
179 import Network.HTTP.Lucu.Response
180 import Network.HTTP.Lucu.MIMEType
181 import Network.HTTP.Lucu.Utils
182 import Network.Socket hiding (accept)
183 import Network.URI hiding (path)
185 import Prelude.Unicode
187 -- |The 'Resource' monad. This monad implements 'MonadIO' so it can do
191 unRes ∷ ReaderT Interaction IO a
193 deriving (Applicative, Functor, Monad, MonadIO)
195 runRes ∷ Resource a → Interaction → IO a
197 = runReaderT (unRes r) itr
199 getInteraction ∷ Resource Interaction
200 getInteraction = Resource ask
202 -- |Get the 'Config' value which is used for the httpd.
203 getConfig ∷ Resource Config
204 getConfig = itrConfig <$> getInteraction
206 -- |Get the 'SockAddr' of the remote host. If you want a string
207 -- representation instead of 'SockAddr', use 'getRemoteAddr''.
208 getRemoteAddr ∷ Resource SockAddr
209 getRemoteAddr = itrRemoteAddr <$> getInteraction
211 -- |Get the string representation of the address of remote host. If
212 -- you want a 'SockAddr' instead of 'String', use 'getRemoteAddr'.
213 getRemoteAddr' ∷ Resource HostName
215 = do sa ← getRemoteAddr
216 (Just a, _) ← liftIO $ getNameInfo [NI_NUMERICHOST] False False sa
219 -- |Resolve an address to the remote host.
220 getRemoteHost ∷ Resource (Maybe HostName)
222 = do sa ← getRemoteAddr
223 fst <$> (liftIO $ getNameInfo [] True False sa)
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 'SSLConfig' has not been set to
233 -- 'OpenSSL.Session.VerifyPeer'.
234 getRemoteCertificate ∷ Resource (Maybe X509)
235 getRemoteCertificate = itrRemoteCert <$> getInteraction
237 -- |Get the 'Request' value which represents the request header. In
238 -- general you don't have to use this action.
239 getRequest ∷ Resource Request
241 = do itr ← getInteraction
242 liftIO $ atomically $ fromJust <$> readItr itrRequest itr
244 -- |Get the 'Method' value of the request.
245 getMethod ∷ Resource Method
246 getMethod = reqMethod <$> getRequest
248 -- |Get the URI of the request.
249 getRequestURI ∷ Resource URI
250 getRequestURI = reqURI <$> getRequest
252 -- |Get the HTTP version of the request.
253 getRequestVersion ∷ Resource HttpVersion
254 getRequestVersion = reqVersion <$> getRequest
256 -- |Get the path of this 'Resource' (to be exact,
257 -- 'Network.HTTP.Lucu.Resource.Tree.ResourceDef') in the
258 -- 'Network.HTTP.Lucu.Resource.Tree.ResTree'. The result of this
259 -- action is the exact path in the tree even if the
260 -- 'Network.HTTP.Lucu.Resource.Tree.ResourceDef' is greedy.
264 -- > main = let tree = mkResTree [ (["foo"], resFoo) ]
265 -- > in runHttpd defaultConfig tree
267 -- > resFoo = ResourceDef {
268 -- > resIsGreedy = True
269 -- > , resGet = Just $ do requestURI ← getRequestURI
270 -- > resourcePath ← getResourcePath
271 -- > pathInfo ← getPathInfo
272 -- > -- uriPath requestURI == "/foo/bar/baz"
273 -- > -- resourcePath == ["foo"]
274 -- > -- pathInfo == ["bar", "baz"]
278 getResourcePath ∷ Resource [Text]
279 getResourcePath = (fromJust ∘ itrResourcePath) <$> getInteraction
281 -- |This is an analogy of CGI PATH_INFO. The result is
282 -- URI-unescaped. It is always @[]@ if the
283 -- 'Network.HTTP.Lucu.Resource.Tree.ResourceDef' is not greedy. See
284 -- 'getResourcePath'.
286 -- Note that the returned path is URI-decoded and then UTF-8 decoded.
287 getPathInfo ∷ Resource [Text]
288 getPathInfo = do rsrcPath ← getResourcePath
289 reqPath ← splitPathInfo <$> getRequestURI
290 -- rsrcPath と reqPath の共通する先頭部分を reqPath か
291 -- ら全部取り除くと、それは PATH_INFO のやうなものにな
292 -- る。rsrcPath は全部一致してゐるに決まってゐる(でな
293 -- ければこの Resource が撰ばれた筈が無い)ので、
294 -- rsrcPath の長さの分だけ削除すれば良い。
295 return $ drop (length rsrcPath) reqPath
297 -- |Assume the query part of request URI as
298 -- application\/x-www-form-urlencoded, and parse it to pairs of
299 -- @(name, formData)@. This action doesn't parse the request body. See
300 -- 'inputForm'. Field names are decoded in UTF-8.
301 getQueryForm ∷ Resource [(Text, FormData)]
302 getQueryForm = parse' <$> getRequestURI
304 parse' = map toPairWithFormData ∘
305 parseWWWFormURLEncoded ∘
311 toPairWithFormData ∷ (ByteString, ByteString) → (Text, FormData)
312 toPairWithFormData (name, value)
313 = let fd = FormData {
315 , fdContent = Lazy.fromChunks [value]
317 in (T.decodeUtf8 name, fd)
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 ∷ CIAscii → Resource (Maybe Ascii)
325 = H.getHeader name <$> getRequest
327 -- |Get a list of 'MIMEType' enumerated on header \"Accept\".
328 getAccept ∷ Resource [MIMEType]
330 = do acceptM ← getHeader "Accept"
335 → case P.parseOnly p (A.toByteString accept) of
337 Left _ → abort BadRequest []
338 (Just $ "Unparsable Accept: " ⊕ A.toText accept)
340 p = do xs ← mimeTypeListP
344 -- |Get a list of @(contentCoding, qvalue)@ enumerated on header
345 -- \"Accept-Encoding\". The list is sorted in descending order by
347 getAcceptEncoding ∷ Resource [(CIAscii, Maybe Double)]
349 = do accEncM ← getHeader "Accept-Encoding"
352 -- HTTP/1.0 には Accept-Encoding が無い場合の規定が無い
353 -- ので安全の爲 identity が指定された事にする。HTTP/1.1
354 -- の場合は何でも受け入れて良い事になってゐるので "*" が
356 → do ver ← getRequestVersion
358 HttpVersion 1 0 → return [("identity", Nothing)]
359 HttpVersion 1 1 → return [("*" , Nothing)]
360 _ → abort InternalServerError []
361 (Just "getAcceptEncoding: unknown HTTP version")
365 return [("identity", Nothing)]
367 case P.parseOnly p (A.toByteString ae) of
368 Right xs → return $ map toTuple $ reverse $ sort xs
369 Left _ → abort BadRequest []
370 (Just $ "Unparsable Accept-Encoding: " ⊕ A.toText ae)
372 p = do xs ← acceptEncodingListP
376 toTuple (AcceptEncoding {..})
377 = (aeEncoding, aeQValue)
379 -- |Check whether a given content-coding is acceptable.
380 isEncodingAcceptable ∷ CIAscii → Resource Bool
381 isEncodingAcceptable encoding = any f <$> getAcceptEncoding
384 = (e ≡ "*" ∨ e ≡ encoding) ∧ q ≢ Just 0
386 -- |Get the header \"Content-Type\" as 'MIMEType'.
387 getContentType ∷ Resource (Maybe MIMEType)
389 = do cTypeM ← getHeader "Content-Type"
394 → case P.parseOnly p (A.toByteString cType) of
395 Right t → return $ Just t
396 Left _ → abort BadRequest []
397 (Just $ "Unparsable Content-Type: " ⊕ A.toText cType)
403 -- |Get the header \"Authorization\" as 'AuthCredential'.
404 getAuthorization ∷ Resource (Maybe AuthCredential)
406 = do authM ← getHeader "Authorization"
411 → case P.parseOnly p (A.toByteString auth) of
412 Right ac → return $ Just ac
413 Left _ → return Nothing
415 p = do ac ← authCredentialP
420 {- ExaminingRequest 時に使用するアクション群 -}
422 -- |Tell the system that the 'Resource' found an entity for the
423 -- request URI. If this is a GET or HEAD request, a found entity means
424 -- a datum to be replied. If this is a PUT or DELETE request, it means
425 -- a datum which was stored for the URI until now. It is an error to
426 -- compute 'foundEntity' if this is a POST request.
428 -- Computation of 'foundEntity' performs \"If-Match\" test or
429 -- \"If-None-Match\" test if possible. When those tests fail, the
430 -- computation of 'Resource' immediately aborts with status \"412
431 -- Precondition Failed\" or \"304 Not Modified\" depending on the
434 -- If this is a GET or HEAD request, 'foundEntity' automatically puts
435 -- \"ETag\" and \"Last-Modified\" headers into the response.
436 foundEntity ∷ ETag → UTCTime → Resource ()
437 foundEntity !tag !timeStamp
438 = do driftTo ExaminingRequest
441 when (method ≡ GET ∨ method ≡ HEAD)
442 $ setHeader' "Last-Modified" (HTTP.toAscii timeStamp)
444 $ abort InternalServerError []
445 (Just "Illegal computation of foundEntity for a POST request.")
450 -- |Tell the system that the 'Resource' found an entity for the
451 -- request URI. The only difference from 'foundEntity' is that
452 -- 'foundETag' doesn't (and can't) put \"Last-Modified\" header into
455 -- This action is not preferred. You should use 'foundEntity' whenever
457 foundETag ∷ ETag → Resource ()
459 = do driftTo ExaminingRequest
462 when (method ≡ GET ∨ method ≡ HEAD)
463 $ setHeader' "ETag" (printETag tag)
465 $ abort InternalServerError []
466 (Just "Illegal computation of foundETag for POST request.")
468 -- If-Match があればそれを見る。
469 ifMatch ← getHeader "If-Match"
472 Just value → if value ≡ "*" then
475 case P.parseOnly p (A.toByteString value) of
477 -- tags の中に一致するものが無ければ
478 -- PreconditionFailed で終了。
479 → when ((¬) (any (≡ tag) tags))
480 $ abort PreconditionFailed []
481 (Just $ "The entity tag doesn't match: " ⊕ A.toText value)
483 → abort BadRequest [] (Just $ "Unparsable If-Match: " ⊕ A.toText value)
485 let statusForNoneMatch
486 = if method ≡ GET ∨ method ≡ HEAD then
491 -- If-None-Match があればそれを見る。
492 ifNoneMatch ← getHeader "If-None-Match"
495 Just value → if value ≡ "*" then
496 abort statusForNoneMatch [] (Just "The entity tag matches: *")
498 case P.parseOnly p (A.toByteString value) of
500 → when (any (≡ tag) tags)
501 $ abort statusForNoneMatch []
502 (Just $ "The entity tag matches: " ⊕ A.toText value)
504 → abort BadRequest []
505 (Just $ "Unparsable If-None-Match: " ⊕ A.toText value)
509 p = do xs ← eTagListP
513 -- |Tell the system that the 'Resource' found an entity for the
514 -- request URI. The only difference from 'foundEntity' is that
515 -- 'foundTimeStamp' performs \"If-Modified-Since\" test or
516 -- \"If-Unmodified-Since\" test instead of \"If-Match\" test or
517 -- \"If-None-Match\" test. Be aware that any tests based on last
518 -- modification time are unsafe because it is possible to mess up such
519 -- tests by modifying the entity twice in a second.
521 -- This action is not preferred. You should use 'foundEntity' whenever
523 foundTimeStamp ∷ UTCTime → Resource ()
524 foundTimeStamp timeStamp
525 = do driftTo ExaminingRequest
528 when (method ≡ GET ∨ method ≡ HEAD)
529 $ setHeader' "Last-Modified" (HTTP.toAscii timeStamp)
531 $ abort InternalServerError []
532 (Just "Illegal computation of foundTimeStamp for POST request.")
534 let statusForIfModSince
535 = if method ≡ GET ∨ method ≡ HEAD then
540 -- If-Modified-Since があればそれを見る。
541 ifModSince ← getHeader "If-Modified-Since"
543 Just str → case HTTP.fromAscii str of
545 → when (timeStamp ≤ lastTime)
546 $ abort statusForIfModSince []
547 (Just $ "The entity has not been modified since " ⊕ A.toText str)
549 → return () -- 不正な時刻は無視
552 -- If-Unmodified-Since があればそれを見る。
553 ifUnmodSince ← getHeader "If-Unmodified-Since"
555 Just str → case HTTP.fromAscii str of
557 → when (timeStamp > lastTime)
558 $ abort PreconditionFailed []
559 (Just $ "The entity has not been modified since " ⊕ A.toText str)
561 → return () -- 不正な時刻は無視
566 -- | Computation of @'foundNoEntity' mStr@ tells the system that the
567 -- 'Resource' found no entity for the request URI. @mStr@ is an
568 -- optional error message to be replied to the client.
570 -- If this is a PUT request, 'foundNoEntity' performs \"If-Match\"
571 -- test and aborts with status \"412 Precondition Failed\" when it
572 -- failed. If this is a GET, HEAD, POST or DELETE request,
573 -- 'foundNoEntity' always aborts with status \"404 Not Found\".
574 foundNoEntity ∷ Maybe Text → Resource ()
576 = do driftTo ExaminingRequest
580 $ abort NotFound [] msgM
582 -- エンティティが存在しないと云ふ事は、"*" も含めたどのやうな
583 -- If-Match: 條件も滿たさない。
584 ifMatch ← getHeader "If-Match"
585 when (ifMatch ≢ Nothing)
586 $ abort PreconditionFailed [] msgM
591 {- GettingBody 時に使用するアクション群 -}
593 -- | Computation of @'input' limit@ attempts to read the request body
594 -- up to @limit@ bytes, and then make the 'Resource' transit to
595 -- /Deciding Header/ state. When the actual size of body is larger
596 -- than @limit@ bytes, computation of 'Resource' immediately aborts
597 -- with status \"413 Request Entity Too Large\". When the request has
598 -- no body, 'input' returns an empty string.
600 -- @limit@ may be less than or equal to zero. In this case, the
601 -- default limitation value ('cnfMaxEntityLength') is used. See
604 -- 'input' returns a 'Lazy.ByteString' but it's not really lazy:
605 -- reading from the socket just happens at the computation of 'input',
606 -- not at the evaluation of the 'Lazy.ByteString'. The same goes for
608 input ∷ Int → Resource Lazy.ByteString
610 = do driftTo GettingBody
612 hasBody ← liftIO $ atomically $ readItr itrRequestHasBody itr
613 chunk ← if hasBody then
616 do driftTo DecidingHeader
620 askForInput ∷ Interaction → Resource Lazy.ByteString
622 = do let confLimit = cnfMaxEntityLength $ itrConfig itr
623 actualLimit = if limit ≤ 0 then
627 when (actualLimit ≤ 0)
628 $ fail ("inputLBS: limit must be positive: " ⧺ show actualLimit)
631 $ do chunkLen ← readItr itrReqChunkLength itr
632 writeItr itrWillReceiveBody True itr
633 if ((> actualLimit) <$> chunkLen) ≡ Just True then
637 writeItr itrReqBodyWanted (Just actualLimit) itr
638 -- 應答を待つ。トランザクションを分けなければ當然デッドロックする。
639 chunk ← liftIO $ atomically
640 $ do chunkLen ← readItr itrReceivedBodyLen itr
641 chunkIsOver ← readItr itrReqChunkIsOver itr
642 if chunkLen < actualLimit then
643 -- 要求された量に滿たなくて、まだ殘りが
648 -- 制限値一杯まで讀むやうに指示したのに
649 -- まだ殘ってゐるなら、それは多過ぎる。
651 $ tooLarge actualLimit
652 -- 成功。itr 内にチャンクを置いたままにする
654 chunk ← seqToLBS <$> readItr itrReceivedBody itr
655 writeItr itrReceivedBody (∅) itr
656 writeItr itrReceivedBodyLen 0 itr
659 driftTo DecidingHeader
662 tooLarge ∷ Int → STM ()
663 tooLarge lim = abortSTM RequestEntityTooLarge []
664 (Just $ "Request body must be smaller than "
665 ⊕ T.pack (show lim) ⊕ " bytes.")
667 seqToLBS ∷ Seq ByteString → Lazy.ByteString
668 {-# INLINE seqToLBS #-}
669 seqToLBS = Lazy.fromChunks ∘ toList
671 -- | Computation of @'inputChunk' limit@ attempts to read a part of
672 -- request body up to @limit@ bytes. You can read any large request by
673 -- repeating computation of this action. When you've read all the
674 -- request body, 'inputChunk' returns an empty string and then make
675 -- the 'Resource' transit to /Deciding Header/ state.
677 -- @limit@ may be less than or equal to zero. In this case, the
678 -- default limitation value ('cnfMaxEntityLength') is used. See
681 -- Note that 'inputChunkLBS' is more efficient than 'inputChunk' so you
682 -- should use it whenever possible.
683 inputChunk ∷ Int → Resource Lazy.ByteString
685 = do driftTo GettingBody
687 hasBody ← liftIO $ atomically $ readItr itrRequestHasBody itr
688 chunk ← if hasBody then
691 do driftTo DecidingHeader
695 askForInput ∷ Interaction → Resource Lazy.ByteString
697 = do let confLimit = cnfMaxEntityLength $ itrConfig itr
698 actualLimit = if limit < 0 then
702 when (actualLimit <= 0)
703 $ fail ("inputChunkLBS: limit must be positive: " ++ show actualLimit)
706 $ do writeItr itrReqBodyWanted (Just actualLimit) itr
707 writeItr itrWillReceiveBody True itr
708 -- 應答を待つ。トランザクションを分けなければ當然デッドロック。
709 chunk ← liftIO $ atomically
710 $ do chunkLen ← readItr itrReceivedBodyLen itr
711 -- 要求された量に滿たなくて、まだ殘りがある
713 when (chunkLen < actualLimit)
714 $ do chunkIsOver ← readItr itrReqChunkIsOver itr
718 chunk ← seqToLBS <$> readItr itrReceivedBody itr
719 writeItr itrReceivedBody (∅) itr
720 writeItr itrReceivedBodyLen 0 itr
722 when (Lazy.null chunk)
723 $ driftTo DecidingHeader
726 -- | Computation of @'inputForm' limit@ attempts to read the request
727 -- body with 'input' and parse it as
728 -- @application\/x-www-form-urlencoded@ or @multipart\/form-data@. If
729 -- the request header \"Content-Type\" is neither of them, 'inputForm'
730 -- makes 'Resource' abort with status \"415 Unsupported Media
731 -- Type\". If the request has no \"Content-Type\", it aborts with
732 -- \"400 Bad Request\".
734 -- Field names in @multipart\/form-data@ will be precisely decoded in
735 -- accordance with RFC 2231. On the other hand,
736 -- @application\/x-www-form-urlencoded@ says nothing about the
737 -- encoding of field names, so they'll always be decoded in UTF-8.
738 inputForm ∷ Int → Resource [(Text, FormData)]
740 = do cTypeM ← getContentType
743 → abort BadRequest [] (Just "Missing Content-Type")
744 Just (MIMEType "application" "x-www-form-urlencoded" _)
745 → readWWWFormURLEncoded
746 Just (MIMEType "multipart" "form-data" params)
747 → readMultipartFormData params
749 → abort UnsupportedMediaType []
753 $ A.toAsciiBuilder "Unsupported media type: "
754 ⊕ printMIMEType cType
756 readWWWFormURLEncoded
757 = (map toPairWithFormData ∘ parseWWWFormURLEncoded)
759 (bsToAscii =≪ input limit)
762 = case A.fromByteString (Strict.concat (Lazy.toChunks bs)) of
764 Nothing → abort BadRequest [] (Just "Malformed x-www-form-urlencoded")
766 readMultipartFormData params
767 = do case M.lookup "boundary" params of
769 → abort BadRequest [] (Just "Missing boundary of multipart/form-data")
771 → do src ← input limit
772 b ← case A.fromText boundary of
774 Nothing → abort BadRequest []
775 (Just $ "Malformed boundary: " ⊕ boundary)
776 case LP.parse (p b) src of
779 _ → abort BadRequest [] (Just "Unparsable multipart/form-data")
781 p b = do xs ← multipartFormP b
785 -- | This is just a constant @-1@. It's better to say @'input'
786 -- 'defaultLimit'@ than to say @'input' (-1)@ but these are exactly
792 {- DecidingHeader 時に使用するアクション群 -}
794 -- | Set the response status code. If you omit to compute this action,
795 -- the status code will be defaulted to \"200 OK\".
796 setStatus ∷ StatusCode → Resource ()
798 = do driftTo DecidingHeader
800 liftIO $ atomically $ updateItr itrResponse f itr
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 $ updateItr itrResponse (H.setHeader name value) itr
830 -- | Computation of @'redirect' code uri@ sets the response status to
831 -- @code@ and \"Location\" header to @uri@. The @code@ must satisfy
832 -- 'isRedirection' or it causes an error.
833 redirect ∷ StatusCode → URI → Resource ()
835 = do when (code ≡ NotModified ∨ not (isRedirection code))
836 $ abort InternalServerError []
840 $ A.toAsciiBuilder "Attempted to redirect with status "
841 ⊕ printStatusCode code
845 -- | Computation of @'setContentType' mType@ sets the response header
846 -- \"Content-Type\" to @mType@.
847 setContentType ∷ MIMEType → Resource ()
849 = setHeader "Content-Type" ∘ A.fromAsciiBuilder ∘ printMIMEType
851 -- | Computation of @'setLocation' uri@ sets the response header
852 -- \"Location\" to @uri@.
853 setLocation ∷ URI → Resource ()
855 = case A.fromChars uriStr of
856 Just a → setHeader "Location" a
857 Nothing → abort InternalServerError []
858 (Just $ "Malformed URI: " ⊕ T.pack uriStr)
860 uriStr = uriToString id uri ""
862 -- |Computation of @'setContentEncoding' codings@ sets the response
863 -- header \"Content-Encoding\" to @codings@.
864 setContentEncoding ∷ [CIAscii] → Resource ()
865 setContentEncoding codings
866 = do ver ← getRequestVersion
868 HttpVersion 1 0 → return (toAB ∘ unnormalizeCoding)
869 HttpVersion 1 1 → return toAB
870 _ → abort InternalServerError []
871 (Just "setContentEncoding: Unknown HTTP version")
872 setHeader "Content-Encoding"
873 (A.fromAsciiBuilder $ joinWith ", " $ map tr codings)
875 toAB = A.toAsciiBuilder ∘ A.fromCIAscii
877 -- |Computation of @'setWWWAuthenticate' challenge@ sets the response
878 -- header \"WWW-Authenticate\" to @challenge@.
879 setWWWAuthenticate ∷ AuthChallenge → Resource ()
880 setWWWAuthenticate challenge
881 = setHeader "WWW-Authenticate" (printAuthChallenge challenge)
884 {- DecidingBody 時に使用するアクション群 -}
886 -- | Computation of @'output' str@ writes @str@ as a response body,
887 -- and then make the 'Resource' transit to /Done/ state. It is safe to
888 -- apply 'output' to an infinite string, such as a lazy stream of
890 output ∷ Lazy.ByteString → Resource ()
891 {-# INLINE output #-}
892 output str = outputChunk str *> driftTo Done
894 -- | Computation of @'outputChunk' str@ writes @str@ as a part of
895 -- response body. You can compute this action multiple times to write
896 -- a body little at a time. It is safe to apply 'outputChunk' to an
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 $
909 readItr itrWillDiscardBody itr
912 $ sendChunks wholeChunk limit
914 unless (Lazy.null wholeChunk)
915 $ liftIO $ atomically $
916 writeItr itrSentNoBody False itr
918 sendChunks ∷ Lazy.ByteString → Int → Resource ()
920 | Lazy.null str = return ()
921 | otherwise = do let (chunk, remaining) = Lazy.splitAt (fromIntegral limit) str
924 $ putTMVar (itrBodyToSend itr) (chunkToBuilder chunk)
925 sendChunks remaining limit
927 chunkToBuilder ∷ Lazy.ByteString → Builder
928 chunkToBuilder = mconcat ∘ map BB.fromByteString ∘ Lazy.toChunks
932 [GettingBody からそれ以降の状態に遷移する時]
934 body を讀み終へてゐなければ、殘りの body を讀み捨てる。
937 [DecidingHeader からそれ以降の状態に遷移する時]
944 bodyIsNull が False ならば何もしない。True だった場合は出力補完す
949 driftTo ∷ InteractionState → Resource ()
951 = do itr ← getInteraction
952 liftIO $ atomically $ do oldState ← readItr itrState itr
953 if newState < oldState then
954 throwStateError oldState newState
956 do let a = [oldState .. newState]
959 mapM_ (uncurry $ drift itr) c
960 writeItr itrState newState itr
962 throwStateError ∷ Monad m => InteractionState → InteractionState → m a
964 throwStateError Done DecidingBody
965 = fail "It makes no sense to output something after finishing to output."
967 throwStateError old new
968 = fail ("state error: " ⧺ show old ⧺ " ==> " ⧺ show new)
971 drift ∷ Interaction → InteractionState → InteractionState → STM ()
973 drift itr GettingBody _
974 = writeItr itrReqBodyWasteAll True itr
976 drift itr DecidingHeader _
980 = do bodyIsNull ← readItr itrSentNoBody itr
982 $ writeDefaultPage itr