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.Char8 as C8
155 import qualified Data.ByteString.Lazy as Lazy
156 import Data.Foldable (toList)
158 import qualified Data.Map as M
161 import Data.Monoid.Unicode
162 import Data.Sequence (Seq)
163 import Data.Text (Text)
164 import qualified Data.Text as T
165 import qualified Data.Text.Encoding as T
167 import qualified Data.Time.HTTP as HTTP
168 import Network.HTTP.Lucu.Abortion
169 import Network.HTTP.Lucu.Authorization
170 import Network.HTTP.Lucu.Config
171 import Network.HTTP.Lucu.ContentCoding
172 import Network.HTTP.Lucu.DefaultPage
173 import Network.HTTP.Lucu.ETag
174 import qualified Network.HTTP.Lucu.Headers as H
175 import Network.HTTP.Lucu.HttpVersion
176 import Network.HTTP.Lucu.Interaction
177 import Network.HTTP.Lucu.MultipartForm
178 import Network.HTTP.Lucu.Postprocess
179 import Network.HTTP.Lucu.Request
180 import Network.HTTP.Lucu.Response
181 import Network.HTTP.Lucu.MIMEType
182 import Network.HTTP.Lucu.Utils
183 import Network.Socket hiding (accept)
184 import Network.URI hiding (path)
186 import Prelude.Unicode
188 -- |The 'Resource' monad. This monad implements 'MonadIO' so it can do
192 unRes ∷ ReaderT Interaction IO a
194 deriving (Applicative, Functor, Monad, MonadIO)
196 runRes ∷ Resource a → Interaction → IO a
198 = runReaderT (unRes r) itr
200 getInteraction ∷ Resource Interaction
201 getInteraction = Resource ask
203 -- |Get the 'Config' value which is used for the httpd.
204 getConfig ∷ Resource Config
205 getConfig = itrConfig <$> getInteraction
207 -- |Get the 'SockAddr' of the remote host. If you want a string
208 -- representation instead of 'SockAddr', use 'getRemoteAddr''.
209 getRemoteAddr ∷ Resource SockAddr
210 getRemoteAddr = itrRemoteAddr <$> getInteraction
212 -- |Get the string representation of the address of remote host. If
213 -- you want a 'SockAddr' instead of 'String', use 'getRemoteAddr'.
214 getRemoteAddr' ∷ Resource HostName
216 = do sa ← getRemoteAddr
217 (Just a, _) ← liftIO $ getNameInfo [NI_NUMERICHOST] False False sa
220 -- |Resolve an address to the remote host.
221 getRemoteHost ∷ Resource (Maybe HostName)
223 = do sa ← getRemoteAddr
224 fst <$> (liftIO $ getNameInfo [] True False sa)
226 -- | Return the X.509 certificate of the client, or 'Nothing' if:
228 -- * This request didn't came through an SSL stream.
230 -- * The client didn't send us its certificate.
232 -- * The 'OpenSSL.Session.VerificationMode' of
233 -- 'OpenSSL.Session.SSLContext' in 'SSLConfig' has not been set to
234 -- 'OpenSSL.Session.VerifyPeer'.
235 getRemoteCertificate ∷ Resource (Maybe X509)
236 getRemoteCertificate = itrRemoteCert <$> getInteraction
238 -- |Get the 'Request' value which represents the request header. In
239 -- general you don't have to use this action.
240 getRequest ∷ Resource Request
242 = do itr ← getInteraction
243 liftIO $ atomically $ readItr itrRequest fromJust itr
245 -- |Get the 'Method' value of the request.
246 getMethod ∷ Resource Method
247 getMethod = reqMethod <$> getRequest
249 -- |Get the URI of the request.
250 getRequestURI ∷ Resource URI
251 getRequestURI = reqURI <$> getRequest
253 -- |Get the HTTP version of the request.
254 getRequestVersion ∷ Resource HttpVersion
255 getRequestVersion = reqVersion <$> getRequest
257 -- |Get the path of this 'Resource' (to be exact,
258 -- 'Network.HTTP.Lucu.Resource.Tree.ResourceDef') in the
259 -- 'Network.HTTP.Lucu.Resource.Tree.ResTree'. The result of this
260 -- action is the exact path in the tree even if the
261 -- 'Network.HTTP.Lucu.Resource.Tree.ResourceDef' is greedy.
265 -- > main = let tree = mkResTree [ (["foo"], resFoo) ]
266 -- > in runHttpd defaultConfig tree
268 -- > resFoo = ResourceDef {
269 -- > resIsGreedy = True
270 -- > , resGet = Just $ do requestURI ← getRequestURI
271 -- > resourcePath ← getResourcePath
272 -- > pathInfo ← getPathInfo
273 -- > -- uriPath requestURI == "/foo/bar/baz"
274 -- > -- resourcePath == ["foo"]
275 -- > -- pathInfo == ["bar", "baz"]
279 getResourcePath ∷ Resource [Ascii]
280 getResourcePath = (fromJust ∘ itrResourcePath) <$> getInteraction
282 -- |This is an analogy of CGI PATH_INFO. The result is
283 -- URI-unescaped. It is always @[]@ if the
284 -- 'Network.HTTP.Lucu.Resource.Tree.ResourceDef' is not greedy. See
285 -- 'getResourcePath'.
286 getPathInfo ∷ Resource [ByteString]
287 getPathInfo = do rsrcPath ← getResourcePath
289 let reqPathStr = uriPath uri
290 reqPath = [unEscapeString x | x ← splitBy (≡ '/') reqPathStr, (¬) (null x)]
291 -- rsrcPath と reqPath の共通する先頭部分を reqPath か
292 -- ら全部取り除くと、それは PATH_INFO のやうなものにな
293 -- る。rsrcPath は全部一致してゐるに決まってゐる(でな
294 -- ければこの Resource が撰ばれた筈が無い)ので、
295 -- rsrcPath の長さの分だけ削除すれば良い。
296 return $ map C8.pack $ drop (length rsrcPath) reqPath
298 -- |Assume the query part of request URI as
299 -- application\/x-www-form-urlencoded, and parse it to pairs of
300 -- @(name, formData)@. This action doesn't parse the request body. See
301 -- 'inputForm'. Field names are decoded in UTF-8.
302 getQueryForm ∷ Resource [(Text, FormData)]
303 getQueryForm = parse' <$> getRequestURI
305 parse' = map toPairWithFormData ∘
306 parseWWWFormURLEncoded ∘
312 toPairWithFormData ∷ (ByteString, ByteString) → (Text, FormData)
313 toPairWithFormData (name, value)
314 = let fd = FormData {
316 , fdContent = Lazy.fromChunks [value]
318 in (T.decodeUtf8 name, fd)
320 -- |Get a value of given request header. Comparison of header name is
321 -- case-insensitive. Note that this action is not intended to be used
322 -- so frequently: there should be actions like 'getContentType' for
323 -- every common headers.
324 getHeader ∷ CIAscii → Resource (Maybe Ascii)
326 = H.getHeader name <$> getRequest
328 -- |Get a list of 'MIMEType' enumerated on header \"Accept\".
329 getAccept ∷ Resource [MIMEType]
331 = do acceptM ← getHeader "Accept"
336 → case P.parseOnly p (A.toByteString accept) of
338 Left _ → abort BadRequest []
339 (Just $ "Unparsable Accept: " ⊕ A.toText accept)
341 p = do xs ← mimeTypeListP
345 -- |Get a list of @(contentCoding, qvalue)@ enumerated on header
346 -- \"Accept-Encoding\". The list is sorted in descending order by
348 getAcceptEncoding ∷ Resource [(CIAscii, Maybe Double)]
350 = do accEncM ← getHeader "Accept-Encoding"
353 -- HTTP/1.0 には Accept-Encoding が無い場合の規定が無い
354 -- ので安全の爲 identity が指定された事にする。HTTP/1.1
355 -- の場合は何でも受け入れて良い事になってゐるので "*" が
357 → do ver ← getRequestVersion
359 HttpVersion 1 0 → return [("identity", Nothing)]
360 HttpVersion 1 1 → return [("*" , Nothing)]
361 _ → abort InternalServerError []
362 (Just "getAcceptEncoding: unknown HTTP version")
366 return [("identity", Nothing)]
368 case P.parseOnly p (A.toByteString ae) of
369 Right xs → return $ map toTuple $ reverse $ sort xs
370 Left _ → abort BadRequest []
371 (Just $ "Unparsable Accept-Encoding: " ⊕ A.toText ae)
373 p = do xs ← acceptEncodingListP
377 toTuple (AcceptEncoding {..})
378 = (aeEncoding, aeQValue)
380 -- |Check whether a given content-coding is acceptable.
381 isEncodingAcceptable ∷ CIAscii → Resource Bool
382 isEncodingAcceptable encoding = any f <$> getAcceptEncoding
385 = (e ≡ "*" ∨ e ≡ encoding) ∧ q ≢ Just 0
387 -- |Get the header \"Content-Type\" as 'MIMEType'.
388 getContentType ∷ Resource (Maybe MIMEType)
390 = do cTypeM ← getHeader "Content-Type"
395 → case P.parseOnly p (A.toByteString cType) of
396 Right t → return $ Just t
397 Left _ → abort BadRequest []
398 (Just $ "Unparsable Content-Type: " ⊕ A.toText cType)
404 -- |Get the header \"Authorization\" as 'AuthCredential'.
405 getAuthorization ∷ Resource (Maybe AuthCredential)
407 = do authM ← getHeader "Authorization"
412 → case P.parseOnly p (A.toByteString auth) of
413 Right ac → return $ Just ac
414 Left _ → return Nothing
416 p = do ac ← authCredentialP
421 {- ExaminingRequest 時に使用するアクション群 -}
423 -- |Tell the system that the 'Resource' found an entity for the
424 -- request URI. If this is a GET or HEAD request, a found entity means
425 -- a datum to be replied. If this is a PUT or DELETE request, it means
426 -- a datum which was stored for the URI until now. It is an error to
427 -- compute 'foundEntity' if this is a POST request.
429 -- Computation of 'foundEntity' performs \"If-Match\" test or
430 -- \"If-None-Match\" test if possible. When those tests fail, the
431 -- computation of 'Resource' immediately aborts with status \"412
432 -- Precondition Failed\" or \"304 Not Modified\" depending on the
435 -- If this is a GET or HEAD request, 'foundEntity' automatically puts
436 -- \"ETag\" and \"Last-Modified\" headers into the response.
437 foundEntity ∷ ETag → UTCTime → Resource ()
438 foundEntity !tag !timeStamp
439 = do driftTo ExaminingRequest
442 when (method ≡ GET ∨ method ≡ HEAD)
443 $ setHeader' "Last-Modified" (HTTP.toAscii timeStamp)
445 $ abort InternalServerError []
446 (Just "Illegal computation of foundEntity for a POST request.")
451 -- |Tell the system that the 'Resource' found an entity for the
452 -- request URI. The only difference from 'foundEntity' is that
453 -- 'foundETag' doesn't (and can't) put \"Last-Modified\" header into
456 -- This action is not preferred. You should use 'foundEntity' whenever
458 foundETag ∷ ETag → Resource ()
460 = do driftTo ExaminingRequest
463 when (method ≡ GET ∨ method ≡ HEAD)
464 $ setHeader' "ETag" (printETag tag)
466 $ abort InternalServerError []
467 (Just "Illegal computation of foundETag for POST request.")
469 -- If-Match があればそれを見る。
470 ifMatch ← getHeader "If-Match"
473 Just value → if value ≡ "*" then
476 case P.parseOnly p (A.toByteString value) of
478 -- tags の中に一致するものが無ければ
479 -- PreconditionFailed で終了。
480 → when ((¬) (any (≡ tag) tags))
481 $ abort PreconditionFailed []
482 (Just $ "The entity tag doesn't match: " ⊕ A.toText value)
484 → abort BadRequest [] (Just $ "Unparsable If-Match: " ⊕ A.toText value)
486 let statusForNoneMatch
487 = if method ≡ GET ∨ method ≡ HEAD then
492 -- If-None-Match があればそれを見る。
493 ifNoneMatch ← getHeader "If-None-Match"
496 Just value → if value ≡ "*" then
497 abort statusForNoneMatch [] (Just "The entity tag matches: *")
499 case P.parseOnly p (A.toByteString value) of
501 → when (any (≡ tag) tags)
502 $ abort statusForNoneMatch []
503 (Just $ "The entity tag matches: " ⊕ A.toText value)
505 → abort BadRequest []
506 (Just $ "Unparsable If-None-Match: " ⊕ A.toText value)
510 p = do xs ← eTagListP
514 -- |Tell the system that the 'Resource' found an entity for the
515 -- request URI. The only difference from 'foundEntity' is that
516 -- 'foundTimeStamp' performs \"If-Modified-Since\" test or
517 -- \"If-Unmodified-Since\" test instead of \"If-Match\" test or
518 -- \"If-None-Match\" test. Be aware that any tests based on last
519 -- modification time are unsafe because it is possible to mess up such
520 -- tests by modifying the entity twice in a second.
522 -- This action is not preferred. You should use 'foundEntity' whenever
524 foundTimeStamp ∷ UTCTime → Resource ()
525 foundTimeStamp timeStamp
526 = do driftTo ExaminingRequest
529 when (method ≡ GET ∨ method ≡ HEAD)
530 $ setHeader' "Last-Modified" (HTTP.toAscii timeStamp)
532 $ abort InternalServerError []
533 (Just "Illegal computation of foundTimeStamp for POST request.")
535 let statusForIfModSince
536 = if method ≡ GET ∨ method ≡ HEAD then
541 -- If-Modified-Since があればそれを見る。
542 ifModSince ← getHeader "If-Modified-Since"
544 Just str → case HTTP.fromAscii str of
546 → when (timeStamp ≤ lastTime)
547 $ abort statusForIfModSince []
548 (Just $ "The entity has not been modified since " ⊕ A.toText str)
550 → return () -- 不正な時刻は無視
553 -- If-Unmodified-Since があればそれを見る。
554 ifUnmodSince ← getHeader "If-Unmodified-Since"
556 Just str → case HTTP.fromAscii str of
558 → when (timeStamp > lastTime)
559 $ abort PreconditionFailed []
560 (Just $ "The entity has not been modified since " ⊕ A.toText str)
562 → return () -- 不正な時刻は無視
567 -- | Computation of @'foundNoEntity' mStr@ tells the system that the
568 -- 'Resource' found no entity for the request URI. @mStr@ is an
569 -- optional error message to be replied to the client.
571 -- If this is a PUT request, 'foundNoEntity' performs \"If-Match\"
572 -- test and aborts with status \"412 Precondition Failed\" when it
573 -- failed. If this is a GET, HEAD, POST or DELETE request,
574 -- 'foundNoEntity' always aborts with status \"404 Not Found\".
575 foundNoEntity ∷ Maybe Text → Resource ()
577 = do driftTo ExaminingRequest
581 $ abort NotFound [] msgM
583 -- エンティティが存在しないと云ふ事は、"*" も含めたどのやうな
584 -- If-Match: 條件も滿たさない。
585 ifMatch ← getHeader "If-Match"
586 when (ifMatch ≢ Nothing)
587 $ abort PreconditionFailed [] msgM
592 {- GettingBody 時に使用するアクション群 -}
594 -- | Computation of @'input' limit@ attempts to read the request body
595 -- up to @limit@ bytes, and then make the 'Resource' transit to
596 -- /Deciding Header/ state. When the actual size of body is larger
597 -- than @limit@ bytes, computation of 'Resource' immediately aborts
598 -- with status \"413 Request Entity Too Large\". When the request has
599 -- no body, 'input' returns an empty string.
601 -- @limit@ may be less than or equal to zero. In this case, the
602 -- default limitation value ('cnfMaxEntityLength') is used. See
605 -- 'input' returns a 'Lazy.ByteString' but it's not really lazy:
606 -- reading from the socket just happens at the computation of 'input',
607 -- not at the evaluation of the 'Lazy.ByteString'. The same goes for
609 input ∷ Int → Resource Lazy.ByteString
611 = do driftTo GettingBody
613 hasBody ← liftIO $ atomically $ readItr itrRequestHasBody id itr
614 chunk ← if hasBody then
617 do driftTo DecidingHeader
621 askForInput ∷ Interaction → Resource Lazy.ByteString
623 = do let confLimit = cnfMaxEntityLength $ itrConfig itr
624 actualLimit = if limit ≤ 0 then
628 when (actualLimit ≤ 0)
629 $ fail ("inputLBS: limit must be positive: " ⧺ show actualLimit)
632 $ do chunkLen ← readItr itrReqChunkLength id itr
633 writeItr itrWillReceiveBody True itr
634 if ((> actualLimit) <$> chunkLen) ≡ Just True then
638 writeItr itrReqBodyWanted (Just actualLimit) itr
639 -- 應答を待つ。トランザクションを分けなければ當然デッドロックする。
640 chunk ← liftIO $ atomically
641 $ do chunkLen ← readItr itrReceivedBodyLen id itr
642 chunkIsOver ← readItr itrReqChunkIsOver id itr
643 if chunkLen < actualLimit then
644 -- 要求された量に滿たなくて、まだ殘りが
649 -- 制限値一杯まで讀むやうに指示したのに
650 -- まだ殘ってゐるなら、それは多過ぎる。
652 $ tooLarge actualLimit
653 -- 成功。itr 内にチャンクを置いたままにする
655 chunk ← readItr itrReceivedBody seqToLBS itr
656 writeItr itrReceivedBody (∅) 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 id 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 id itr
711 -- 要求された量に滿たなくて、まだ殘りがある
713 when (chunkLen < actualLimit)
714 $ do chunkIsOver ← readItr itrReqChunkIsOver id itr
718 chunk ← readItr itrReceivedBody seqToLBS itr
719 writeItr itrReceivedBody (∅) itr
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
799 liftIO $ atomically $ updateItr itrResponse f itr
805 -- | Set a value of given resource header. Comparison of header name
806 -- is case-insensitive. Note that this action is not intended to be
807 -- used so frequently: there should be actions like 'setContentType'
808 -- for every common headers.
810 -- Some important headers (especially \"Content-Length\" and
811 -- \"Transfer-Encoding\") may be silently dropped or overwritten by
812 -- the system not to corrupt the interaction with client at the
813 -- viewpoint of HTTP protocol layer. For instance, if we are keeping
814 -- the connection alive, without this process it causes a catastrophe
815 -- to send a header \"Content-Length: 10\" and actually send a body of
816 -- 20 bytes long. In this case the client shall only accept the first
817 -- 10 bytes of response body and thinks that the residual 10 bytes is
818 -- a part of header of the next response.
819 setHeader ∷ CIAscii → Ascii → Resource ()
821 = driftTo DecidingHeader ≫ setHeader' name value
823 setHeader' ∷ CIAscii → Ascii → Resource ()
824 setHeader' name value
825 = do itr ← getInteraction
827 $ updateItr itrResponse (H.setHeader name value) itr
829 -- | Computation of @'redirect' code uri@ sets the response status to
830 -- @code@ and \"Location\" header to @uri@. The @code@ must satisfy
831 -- 'isRedirection' or it causes an error.
832 redirect ∷ StatusCode → URI → Resource ()
834 = do when (code ≡ NotModified ∨ not (isRedirection code))
835 $ abort InternalServerError []
839 $ A.toAsciiBuilder "Attempted to redirect with status "
840 ⊕ printStatusCode code
844 -- | Computation of @'setContentType' mType@ sets the response header
845 -- \"Content-Type\" to @mType@.
846 setContentType ∷ MIMEType → Resource ()
848 = setHeader "Content-Type" ∘ A.fromAsciiBuilder ∘ printMIMEType
850 -- | Computation of @'setLocation' uri@ sets the response header
851 -- \"Location\" to @uri@.
852 setLocation ∷ URI → Resource ()
854 = case A.fromChars uriStr of
855 Just a → setHeader "Location" a
856 Nothing → abort InternalServerError []
857 (Just $ "Malformed URI: " ⊕ T.pack uriStr)
859 uriStr = uriToString id uri ""
861 -- |Computation of @'setContentEncoding' codings@ sets the response
862 -- header \"Content-Encoding\" to @codings@.
863 setContentEncoding ∷ [CIAscii] → Resource ()
864 setContentEncoding codings
865 = do ver ← getRequestVersion
867 HttpVersion 1 0 → return (toAB ∘ unnormalizeCoding)
868 HttpVersion 1 1 → return toAB
869 _ → abort InternalServerError []
870 (Just "setContentEncoding: Unknown HTTP version")
871 setHeader "Content-Encoding"
872 (A.fromAsciiBuilder $ joinWith ", " $ map tr codings)
874 toAB = A.toAsciiBuilder ∘ A.fromCIAscii
876 -- |Computation of @'setWWWAuthenticate' challenge@ sets the response
877 -- header \"WWW-Authenticate\" to @challenge@.
878 setWWWAuthenticate ∷ AuthChallenge → Resource ()
879 setWWWAuthenticate challenge
880 = setHeader "WWW-Authenticate" (printAuthChallenge challenge)
883 {- DecidingBody 時に使用するアクション群 -}
885 -- | Computation of @'output' str@ writes @str@ as a response body,
886 -- and then make the 'Resource' transit to /Done/ state. It is safe to
887 -- apply 'output' to an infinite string, such as a lazy stream of
889 output ∷ Lazy.ByteString → Resource ()
890 {-# INLINE output #-}
891 output str = outputChunk str *> driftTo Done
893 -- | Computation of @'outputChunk' str@ writes @str@ as a part of
894 -- response body. You can compute this action multiple times to write
895 -- a body little at a time. It is safe to apply 'outputChunk' to an
897 outputChunk ∷ Lazy.ByteString → Resource ()
898 outputChunk wholeChunk
899 = do driftTo DecidingBody
902 let limit = cnfMaxOutputChunkLength $ itrConfig itr
904 $ abort InternalServerError []
905 (Just $ "cnfMaxOutputChunkLength must be positive: " ⊕ T.pack (show limit))
907 discardBody ← liftIO $ atomically $
908 readItr itrWillDiscardBody id itr
911 $ sendChunks wholeChunk limit
913 unless (Lazy.null wholeChunk)
914 $ liftIO $ atomically $
915 writeItr itrBodyIsNull False itr
917 sendChunks ∷ Lazy.ByteString → Int → Resource ()
919 | Lazy.null str = return ()
920 | otherwise = do let (chunk, remaining) = Lazy.splitAt (fromIntegral limit) str
923 $ putTMVar (itrBodyToSend itr) (chunkToBuilder chunk)
924 sendChunks remaining limit
926 chunkToBuilder ∷ Lazy.ByteString → Builder
927 chunkToBuilder = mconcat ∘ map BB.fromByteString ∘ Lazy.toChunks
931 [GettingBody からそれ以降の状態に遷移する時]
933 body を讀み終へてゐなければ、殘りの body を讀み捨てる。
936 [DecidingHeader からそれ以降の状態に遷移する時]
943 bodyIsNull が False ならば何もしない。True だった場合は出力補完す
948 driftTo ∷ InteractionState → Resource ()
950 = do itr ← getInteraction
951 liftIO $ atomically $ do oldState ← readItr itrState id itr
952 if newState < oldState then
953 throwStateError oldState newState
955 do let a = [oldState .. newState]
958 mapM_ (uncurry $ drift itr) c
959 writeItr itrState newState itr
961 throwStateError ∷ Monad m => InteractionState → InteractionState → m a
963 throwStateError Done DecidingBody
964 = fail "It makes no sense to output something after finishing to output."
966 throwStateError old new
967 = fail ("state error: " ⧺ show old ⧺ " ==> " ⧺ show new)
970 drift ∷ Interaction → InteractionState → InteractionState → STM ()
972 drift itr GettingBody _
973 = writeItr itrReqBodyWasteAll True itr
975 drift itr DecidingHeader _
979 = do bodyIsNull ← readItr itrBodyIsNull id itr
981 $ writeDefaultPage itr