2 GeneralizedNewtypeDeriving
8 -- |This is the Resource Monad; monadic actions to define a behavior
9 -- of resource. The 'Resource' Monad is a kind of 'IO' Monad thus it
10 -- implements 'MonadIO' class, and it is a state machine as well.
12 -- Request Processing Flow:
14 -- 1. A client issues an HTTP request.
16 -- 2. If the URI of it matches to any resource, the corresponding
17 -- 'Resource' Monad starts running on a newly spawned thread.
19 -- 3. The 'Resource' Monad looks at request headers, find (or not
20 -- find) an entity, receive the request body (if any), send
21 -- response headers, and then send a response body. This process
22 -- will be discussed later.
24 -- 4. The 'Resource' Monad and its thread stops running. The client
25 -- may or may not be sending us the next request at this point.
27 -- 'Resource' Monad takes the following states. The initial state is
28 -- /Examining Request/ and the final state is /Done/.
30 -- [/Examining Request/] In this state, a 'Resource' looks at the
31 -- request header fields and thinks about a corresponding entity for
32 -- it. If there is a suitable entity, the 'Resource' tells the
33 -- system an entity tag and its last modification time
34 -- ('foundEntity'). If it found no entity, it tells the system so
35 -- ('foundNoEntity'). In case it is impossible to decide the
36 -- existence of entity, which is a typical case for POST requests,
37 -- 'Resource' does nothing in this state.
39 -- [/Receiving Body/] A 'Resource' asks the system to receive a
40 -- request body from the client. Before actually reading from the
41 -- socket, the system sends \"100 Continue\" to the client if need
42 -- be. When a 'Resource' transits to the next state without
43 -- receiving all or part of a request body, the system automatically
44 -- receives and discards it.
46 -- [/Deciding Header/] A 'Resource' makes a decision of status code
47 -- and response header fields. When it transits to the next state,
48 -- the system validates and completes the response header fields and
49 -- then sends them to the client.
51 -- [/Sending Body/] In this state, a 'Resource' asks the system to
52 -- write some response body to the socket. When it transits to the
53 -- next state without writing any response body, the system
54 -- automatically completes it depending on the status code. (To be
55 -- exact, such completion only occurs when the 'Resource' transits
56 -- to this state without even declaring the \"Content-Type\" header
57 -- field. See 'setContentType'.)
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'
68 module Network.HTTP.Lucu.Resource
74 -- * Getting request header
75 -- |These functions can be called regardless of the current state,
76 -- and they don't change the state of 'Resource'.
81 , getRemoteCertificate
92 , isEncodingAcceptable
96 -- * Finding an entity
97 -- |These functions can be called only in the /Examining Request/
98 -- state. They make the 'Resource' transit to the /Receiving Body/
105 -- * Receiving a request body
106 -- |These functions make the 'Resource' transit to the /Receiving
112 -- * Declaring response status and header fields
113 -- |These functions can be called at any time before transiting to
114 -- the /Sending Body/ state, but they themselves never causes any
115 -- state transitions.
122 -- ** Less frequently used functions
127 -- * Sending a response body
128 -- |These functions make the 'Resource' transit to the /Sending
135 import qualified Blaze.ByteString.Builder.ByteString as BB
136 import Control.Applicative
138 import Control.Monad.IO.Class
139 import Control.Monad.Unicode
140 import Data.Ascii (Ascii, CIAscii)
141 import qualified Data.Ascii as A
142 import qualified Data.Attoparsec.Char8 as P
143 import qualified Data.Attoparsec.Lazy as LP
144 import Data.ByteString (ByteString)
145 import qualified Data.ByteString as Strict
146 import qualified Data.ByteString.Lazy as Lazy
147 import qualified Data.ByteString.Lazy.Internal as Lazy
148 import Data.Foldable (toList)
150 import qualified Data.Map as M
152 import Data.Monoid.Unicode
153 import Data.Sequence (Seq)
154 import Data.Sequence.Unicode hiding ((∅))
155 import Data.Text (Text)
156 import qualified Data.Text as T
157 import qualified Data.Text.Encoding as T
159 import qualified Data.Time.HTTP as HTTP
160 import Network.HTTP.Lucu.Abortion
161 import Network.HTTP.Lucu.Authorization
162 import Network.HTTP.Lucu.Config
163 import Network.HTTP.Lucu.ContentCoding
164 import Network.HTTP.Lucu.ETag
165 import qualified Network.HTTP.Lucu.Headers as H
166 import Network.HTTP.Lucu.HttpVersion
167 import Network.HTTP.Lucu.Interaction
168 import Network.HTTP.Lucu.MultipartForm
169 import Network.HTTP.Lucu.Request
170 import Network.HTTP.Lucu.Resource.Internal
171 import Network.HTTP.Lucu.Response
172 import Network.HTTP.Lucu.MIMEType
173 import Network.HTTP.Lucu.Utils
174 import Network.Socket hiding (accept)
175 import Network.URI hiding (path)
176 import Prelude.Unicode
178 -- |Get the string representation of the address of remote host. If
179 -- you want a 'SockAddr' instead of 'HostName', use 'getRemoteAddr'.
180 getRemoteAddr' ∷ Resource HostName
182 = do sa ← getRemoteAddr
183 (fromJust ∘ fst) <$> (liftIO $ getNameInfo [NI_NUMERICHOST] True False sa)
185 -- |Resolve an address to the remote host.
186 getRemoteHost ∷ Resource (Maybe HostName)
188 = do sa ← getRemoteAddr
189 fst <$> (liftIO $ getNameInfo [] True False sa)
191 -- |Get the 'Method' value of the request.
192 getMethod ∷ Resource Method
193 getMethod = reqMethod <$> getRequest
195 -- |Get the URI of the request.
196 getRequestURI ∷ Resource URI
197 getRequestURI = reqURI <$> getRequest
199 -- |Get the HTTP version of the request.
200 getRequestVersion ∷ Resource HttpVersion
201 getRequestVersion = reqVersion <$> getRequest
203 -- |This is an analogy of CGI PATH_INFO. 'getPathInfo' always returns
204 -- @[]@ if the corresponding
205 -- 'Network.HTTP.Lucu.Resource.Tree.ResourceDef' is not greedy. See
206 -- 'getResourcePath'.
208 -- Note that the returned path is URI-decoded and then UTF-8 decoded.
209 getPathInfo ∷ Resource [Text]
210 getPathInfo = do rsrcPath ← getResourcePath
211 reqPath ← splitPathInfo <$> getRequestURI
212 -- rsrcPath と reqPath の共通する先頭部分を reqPath か
213 -- ら全部取り除くと、それは PATH_INFO のやうなものにな
214 -- る。rsrcPath は全部一致してゐるに決まってゐる(でな
215 -- ければこの Resource が撰ばれた筈が無い)ので、
216 -- rsrcPath の長さの分だけ削除すれば良い。
217 return $ drop (length rsrcPath) reqPath
219 -- |Assume the query part of request URI as
220 -- application\/x-www-form-urlencoded, and parse it into pairs of
221 -- @(name, formData)@. This function doesn't read the request
222 -- body. Field names are decoded in UTF-8. See 'getForm'.
223 getQueryForm ∷ Resource [(Text, FormData)]
224 getQueryForm = parse' <$> getRequestURI
226 parse' = map toPairWithFormData ∘
227 parseWWWFormURLEncoded ∘
233 toPairWithFormData ∷ (ByteString, ByteString) → (Text, FormData)
234 toPairWithFormData (name, value)
235 = let fd = FormData {
237 , fdContent = Lazy.fromChunks [value]
239 in (T.decodeUtf8 name, fd)
241 -- |@'getHeader' name@ returns the value of the request header field
242 -- @name@. Comparison of header name is case-insensitive. Note that
243 -- this function is not intended to be used so frequently: there
244 -- should be actions like 'getContentType' for every common headers.
245 getHeader ∷ CIAscii → Resource (Maybe Ascii)
247 = H.getHeader name <$> getRequest
249 -- |Return the list of 'MIMEType' enumerated on the value of request
250 -- header \"Accept\", or @[]@ if absent.
251 getAccept ∷ Resource [MIMEType]
253 = do acceptM ← getHeader "Accept"
258 → case P.parseOnly p (A.toByteString accept) of
260 Left _ → abort BadRequest []
261 (Just $ "Unparsable Accept: " ⊕ A.toText accept)
263 p = do xs ← mimeTypeListP
267 -- |Return the list of @(contentCoding, qvalue)@ enumerated on the
268 -- value of request header \"Accept-Encoding\". The list is sorted in
269 -- descending order by qvalue.
270 getAcceptEncoding ∷ Resource [(CIAscii, Maybe Double)]
272 = do accEncM ← getHeader "Accept-Encoding"
275 -- HTTP/1.0 には Accept-Encoding が無い場合の規定が無い
276 -- ので安全の爲 identity が指定された事にする。HTTP/1.1
277 -- の場合は何でも受け入れて良い事になってゐるので "*" が
279 → do ver ← getRequestVersion
281 HttpVersion 1 0 → return [("identity", Nothing)]
282 HttpVersion 1 1 → return [("*" , Nothing)]
283 _ → abort InternalServerError []
284 (Just "getAcceptEncoding: unknown HTTP version")
288 return [("identity", Nothing)]
290 case P.parseOnly p (A.toByteString ae) of
291 Right xs → return $ map toTuple $ reverse $ sort xs
292 Left _ → abort BadRequest []
293 (Just $ "Unparsable Accept-Encoding: " ⊕ A.toText ae)
295 p = do xs ← acceptEncodingListP
299 toTuple (AcceptEncoding {..})
300 = (aeEncoding, aeQValue)
302 -- |Return 'True' iff a given content-coding is acceptable.
303 isEncodingAcceptable ∷ CIAscii → Resource Bool
304 isEncodingAcceptable encoding = any doesMatch <$> getAcceptEncoding
306 doesMatch ∷ (CIAscii, Maybe Double) → Bool
307 doesMatch (e, q) = (e ≡ "*" ∨ e ≡ encoding) ∧ q ≢ Just 0
309 -- |Return the value of request header \"Content-Type\" as 'MIMEType'.
310 getContentType ∷ Resource (Maybe MIMEType)
312 = do cTypeM ← getHeader "Content-Type"
317 → case P.parseOnly p (A.toByteString cType) of
318 Right t → return $ Just t
319 Left _ → abort BadRequest []
320 (Just $ "Unparsable Content-Type: " ⊕ A.toText cType)
326 -- |Return the value of request header \"Authorization\" as
328 getAuthorization ∷ Resource (Maybe AuthCredential)
330 = do authM ← getHeader "Authorization"
335 → case P.parseOnly p (A.toByteString auth) of
336 Right ac → return $ Just ac
337 Left _ → return Nothing
339 p = do ac ← authCredentialP
343 -- |Tell the system that the 'Resource' found an entity for the
344 -- request URI. If this is a GET or HEAD request, a found entity means
345 -- a datum to be replied. If this is a PUT or DELETE request, it means
346 -- a datum which was stored for the URI until now. For POST requests
347 -- it raises an error.
349 -- 'foundEntity' performs \"If-Match\" test or \"If-None-Match\" test
350 -- whenever possible, and if those tests fail, it immediately aborts
351 -- with status \"412 Precondition Failed\" or \"304 Not Modified\"
352 -- depending on the situation.
354 -- If the request method is either GET or HEAD, 'foundEntity'
355 -- automatically puts \"ETag\" and \"Last-Modified\" headers into the
357 foundEntity ∷ ETag → UTCTime → Resource ()
358 foundEntity tag timeStamp
359 = do driftTo ExaminingRequest
362 when (method ≡ GET ∨ method ≡ HEAD)
363 $ setHeader "Last-Modified" (HTTP.toAscii timeStamp)
365 $ abort InternalServerError []
366 (Just "foundEntity: this is a POST request.")
369 driftTo ReceivingBody
371 -- |Tell the system that the 'Resource' found an entity for the
372 -- request URI. The only difference from 'foundEntity' is that
373 -- 'foundETag' doesn't (nor can't) put \"Last-Modified\" header into
376 -- Using this function is discouraged. You should use 'foundEntity'
377 -- whenever possible.
378 foundETag ∷ ETag → Resource ()
380 = do driftTo ExaminingRequest
383 when (method ≡ GET ∨ method ≡ HEAD)
388 $ abort InternalServerError []
389 $ Just "Illegal computation of foundETag for POST request."
391 -- If-Match があればそれを見る。
392 ifMatch ← getHeader "If-Match"
395 Just value → if value ≡ "*" then
398 case P.parseOnly p (A.toByteString value) of
400 -- tags の中に一致するものが無ければ
401 -- PreconditionFailed で終了。
402 → when ((¬) (any (≡ tag) tags))
403 $ abort PreconditionFailed []
405 $ "The entity tag doesn't match: " ⊕ A.toText value
407 → abort BadRequest []
409 $ "Unparsable If-Match: " ⊕ A.toText value
411 let statusForNoneMatch
412 = if method ≡ GET ∨ method ≡ HEAD then
417 -- If-None-Match があればそれを見る。
418 ifNoneMatch ← getHeader "If-None-Match"
421 Just value → if value ≡ "*" then
422 abort statusForNoneMatch [] (Just "The entity tag matches: *")
424 case P.parseOnly p (A.toByteString value) of
426 → when (any (≡ tag) tags)
427 $ abort statusForNoneMatch []
429 $ "The entity tag matches: " ⊕ A.toText value
431 → abort BadRequest []
433 $ "Unparsable If-None-Match: " ⊕ A.toText value
435 driftTo ReceivingBody
437 p = do xs ← eTagListP
441 -- |Tell the system that the 'Resource' found an entity for the
442 -- request URI. The only difference from 'foundEntity' is that
443 -- 'foundTimeStamp' performs \"If-Modified-Since\" test or
444 -- \"If-Unmodified-Since\" test instead of \"If-Match\" test or
445 -- \"If-None-Match\" test. Be aware that any tests based on a last
446 -- modification time are unsafe because it is possible to mess up such
447 -- tests by modifying the entity twice in a second.
449 -- Using this function is discouraged. You should use 'foundEntity'
450 -- whenever possible.
451 foundTimeStamp ∷ UTCTime → Resource ()
452 foundTimeStamp timeStamp
453 = do driftTo ExaminingRequest
456 when (method ≡ GET ∨ method ≡ HEAD)
457 $ setHeader "Last-Modified" (HTTP.toAscii timeStamp)
459 $ abort InternalServerError []
460 (Just "Illegal computation of foundTimeStamp for POST request.")
462 let statusForIfModSince
463 = if method ≡ GET ∨ method ≡ HEAD then
468 -- If-Modified-Since があればそれを見る。
469 ifModSince ← getHeader "If-Modified-Since"
471 Just str → case HTTP.fromAscii str of
473 → when (timeStamp ≤ lastTime)
474 $ abort statusForIfModSince []
475 (Just $ "The entity has not been modified since " ⊕ A.toText str)
477 → return () -- 不正な時刻は無視
480 -- If-Unmodified-Since があればそれを見る。
481 ifUnmodSince ← getHeader "If-Unmodified-Since"
483 Just str → case HTTP.fromAscii str of
485 → when (timeStamp > lastTime)
486 $ abort PreconditionFailed []
487 (Just $ "The entity has not been modified since " ⊕ A.toText str)
489 → return () -- 不正な時刻は無視
492 driftTo ReceivingBody
494 -- |@'foundNoEntity' mStr@ tells the system that the 'Resource' found
495 -- no entity for the request URI. @mStr@ is an optional error message
496 -- to be replied to the client.
498 -- If the request method is PUT, 'foundNoEntity' performs \"If-Match\"
499 -- test and when that fails it aborts with status \"412 Precondition
500 -- Failed\". If the request method is GET, HEAD, POST or DELETE,
501 -- 'foundNoEntity' always aborts with status \"404 Not Found\".
502 foundNoEntity ∷ Maybe Text → Resource ()
504 = do driftTo ExaminingRequest
508 $ abort NotFound [] msgM
510 -- エンティティが存在しないと云ふ事は、"*" も含めたどのやうな
511 -- If-Match: 條件も滿たさない。
512 ifMatch ← getHeader "If-Match"
513 when (ifMatch ≢ Nothing)
514 $ abort PreconditionFailed [] msgM
516 driftTo ReceivingBody
519 -- |@'getChunks' limit@ attemts to read the entire request body up to
520 -- @limit@ bytes, and then make the 'Resource' transit to the
521 -- /Deciding Header/ state. When the actual size of the body is larger
522 -- than @limit@ bytes, 'getChunks' immediately aborts with status
523 -- \"413 Request Entity Too Large\". When the request has no body, it
524 -- returns an empty string.
526 -- When the @limit@ is 'Nothing', 'getChunks' uses the default
527 -- limitation value ('cnfMaxEntityLength') instead.
529 -- 'getChunks' returns a 'Lazy.ByteString' but it's not really lazy:
530 -- reading from the socket just happens at the computation of
531 -- 'getChunks', not at the evaluation of the 'Lazy.ByteString'.
532 getChunks ∷ Maybe Int → Resource Lazy.ByteString
534 | n < 0 = fail ("getChunks: limit must not be negative: " ⧺ show n)
536 | otherwise = getChunks' n
538 = getConfig ≫= getChunks ∘ Just ∘ cnfMaxEntityLength
540 getChunks' ∷ Int → Resource Lazy.ByteString
541 getChunks' limit = go limit (∅)
543 go ∷ Int → Seq Strict.ByteString → Resource Lazy.ByteString
544 go 0 _ = abort RequestEntityTooLarge []
545 (Just $ "Request body must be smaller than "
546 ⊕ T.pack (show limit) ⊕ " bytes.")
547 go n xs = do let n' = min n Lazy.defaultChunkSize
549 if Strict.null chunk then
551 return $ Lazy.fromChunks $ toList xs
553 do let n'' = n' - Strict.length chunk
557 -- |@'getForm' limit@ attempts to read the request body with
558 -- 'getChunks' and parse it as @application\/x-www-form-urlencoded@ or
559 -- @multipart\/form-data@. If the request header \"Content-Type\" is
560 -- neither of them, 'getForm' aborts with status \"415 Unsupported
561 -- Media Type\". If the request has no \"Content-Type\", it aborts
562 -- with \"400 Bad Request\".
564 -- Field names in @multipart\/form-data@ will be precisely decoded in
565 -- accordance with RFC 2231. On the other hand,
566 -- @application\/x-www-form-urlencoded@ says nothing about the
567 -- encoding of field names, so they'll always be decoded in
568 -- UTF-8. (This could be a bad design, but I can't think of any better
570 getForm ∷ Maybe Int → Resource [(Text, FormData)]
572 = do cTypeM ← getContentType
575 → abort BadRequest [] (Just "Missing Content-Type")
576 Just (MIMEType "application" "x-www-form-urlencoded" _)
577 → readWWWFormURLEncoded
578 Just (MIMEType "multipart" "form-data" params)
579 → readMultipartFormData params
581 → abort UnsupportedMediaType []
585 $ A.toAsciiBuilder "Unsupported media type: "
586 ⊕ printMIMEType cType
588 readWWWFormURLEncoded
589 = (map toPairWithFormData ∘ parseWWWFormURLEncoded)
591 (bsToAscii =≪ getChunks limit)
594 = case A.fromByteString (Strict.concat (Lazy.toChunks bs)) of
596 Nothing → abort BadRequest [] (Just "Malformed x-www-form-urlencoded")
598 readMultipartFormData params
599 = do case M.lookup "boundary" params of
601 → abort BadRequest [] (Just "Missing boundary of multipart/form-data")
603 → do src ← getChunks limit
604 b ← case A.fromText boundary of
606 Nothing → abort BadRequest []
607 (Just $ "Malformed boundary: " ⊕ boundary)
608 case LP.parse (p b) src of
611 _ → abort BadRequest [] (Just "Unparsable multipart/form-data")
613 p b = do xs ← multipartFormP b
617 -- |@'redirect' code uri@ declares the response status as @code@ and
618 -- \"Location\" header field as @uri@. The @code@ must satisfy
619 -- 'isRedirection' or it raises an error.
620 redirect ∷ StatusCode → URI → Resource ()
622 = do when (code ≡ NotModified ∨ not (isRedirection code))
623 $ abort InternalServerError []
627 $ A.toAsciiBuilder "Attempted to redirect with status "
628 ⊕ printStatusCode code
632 -- |@'setContentType' mType@ declares the response header
633 -- \"Content-Type\" as @mType@. Declaring \"Content-Type\" is
634 -- mandatory for sending a response body.
635 setContentType ∷ MIMEType → Resource ()
637 = setHeader "Content-Type" ∘ A.fromAsciiBuilder ∘ printMIMEType
639 -- |@'setLocation' uri@ declares the response header \"Location\" as
640 -- @uri@. You usually don't need to call this function directly.
641 setLocation ∷ URI → Resource ()
643 = case A.fromChars uriStr of
644 Just a → setHeader "Location" a
645 Nothing → abort InternalServerError []
646 (Just $ "Malformed URI: " ⊕ T.pack uriStr)
648 uriStr = uriToString id uri ""
650 -- |@'setContentEncoding' codings@ declares the response header
651 -- \"Content-Encoding\" as @codings@.
652 setContentEncoding ∷ [CIAscii] → Resource ()
653 setContentEncoding codings
654 = do ver ← getRequestVersion
656 HttpVersion 1 0 → return (toAB ∘ unnormalizeCoding)
657 HttpVersion 1 1 → return toAB
658 _ → abort InternalServerError []
659 (Just "setContentEncoding: Unknown HTTP version")
660 setHeader "Content-Encoding"
661 (A.fromAsciiBuilder $ joinWith ", " $ map tr codings)
663 toAB = A.toAsciiBuilder ∘ A.fromCIAscii
665 -- |@'setWWWAuthenticate' challenge@ declares the response header
666 -- \"WWW-Authenticate\" as @challenge@.
667 setWWWAuthenticate ∷ AuthChallenge → Resource ()
668 setWWWAuthenticate = setHeader "WWW-Authenticate" ∘ printAuthChallenge
670 -- |Write a chunk in 'Strict.ByteString' to the response body. You
671 -- must first declare the response header \"Content-Type\" before
672 -- applying this function. See 'setContentType'.
673 putChunk ∷ Strict.ByteString → Resource ()
674 putChunk = putBuilder ∘ BB.fromByteString
676 -- |Write a chunk in 'Lazy.ByteString' to the response body. It is
677 -- safe to apply this function to an infinitely long
678 -- 'Lazy.ByteString'.
680 -- Note that you must first declare the response header
681 -- \"Content-Type\" before applying this function. See
683 putChunks ∷ Lazy.ByteString → Resource ()
684 putChunks = putBuilder ∘ BB.fromLazyByteString