4 , GeneralizedNewtypeDeriving
11 -- |This is the Resource Monad; monadic actions to define a behavior
12 -- of resource. The 'Rsrc' Monad is a kind of 'IO' Monad thus it
13 -- implements 'MonadIO' class, and it is a state machine as well.
15 -- Request Processing Flow:
17 -- 1. A client issues an HTTP request.
19 -- 2. If the URI of it matches to any resource, the corresponding
20 -- 'Rsrc' Monad starts running on a newly spawned thread.
22 -- 3. The 'Rsrc' Monad looks at request headers, find (or not find)
23 -- an entity, receive the request body (if any), send response
24 -- headers, and then send a response body. This process will be
27 -- 4. The 'Rsrc' Monad and its thread stops running. The client may
28 -- or may not be sending us the next request at this point.
30 -- 'Rsrc' Monad takes the following states. The initial state is
31 -- /Examining Request/ and the final state is /Done/.
33 -- [/Examining Request/] In this state, a 'Rsrc' looks at the
34 -- request header fields and thinks about the corresponding entity
35 -- for it. If there is a suitable entity, the 'Rsrc' tells the
36 -- system an entity tag and its last modification time
37 -- ('foundEntity'). If it found no entity, it tells the system so
38 -- ('foundNoEntity'). In case it is impossible to decide the
39 -- existence of entity, which is a typical case for POST requests,
40 -- 'Rsrc' does nothing in this state.
42 -- [/Receiving Body/] A 'Rsrc' asks the system to receive a request
43 -- body from the client. Before actually reading from the socket,
44 -- the system sends \"100 Continue\" to the client if need be. When
45 -- a 'Rsrc' transits to the next state without receiving all or part
46 -- of a request body, the system automatically discards it.
48 -- [/Deciding Header/] A 'Rsrc' makes a decision of response status
49 -- code and header fields. When it transits to the next state, the
50 -- system validates and completes the header fields and then sends
51 -- them to the client.
53 -- [/Sending Body/] In this state, a 'Rsrc' asks the system to write
54 -- some response body to the socket. When it transits to the next
55 -- state without writing any response body, the system automatically
56 -- completes it depending on the status code. (To be exact, such
57 -- completion only occurs when the 'Rsrc' transits to this state
58 -- without even declaring the \"Content-Type\" header field. See:
61 -- [/Done/] Everything is over. A 'Rsrc' can do nothing for the HTTP
62 -- interaction anymore.
64 -- Note that the state transition is one-way: for instance, it is an
65 -- error to try to read a request body after writing some
66 -- response. This limitation is for efficiency. We don't want to read
67 -- the entire request before starting 'Rsrc', nor we don't want to
68 -- postpone writing the entire response till the end of 'Rsrc'
70 module Network.HTTP.Lucu.Resource
77 -- * Getting request header
78 -- |These functions can be called regardless of the current state,
79 -- and they don't change the state of 'Rsrc'.
85 , getRemoteCertificate
97 , isEncodingAcceptable
101 -- * Finding an entity
102 -- |These functions can be called only in the /Examining Request/
103 -- state. They make the 'Rsrc' transit to the /Receiving Body/
111 -- * Receiving a request body
112 -- |These functions make the 'Rsrc' transit to the /Receiving
118 -- * Declaring response status and header fields
119 -- |These functions can be called at any time before transiting to
120 -- the /Sending Body/ state, but they themselves never causes any
121 -- state transitions.
128 -- ** Less frequently used functions
133 -- * Sending a response body
135 -- |These functions make the 'Rsrc' transit to the /Sending Body/
142 import Blaze.ByteString.Builder (Builder)
143 import qualified Blaze.ByteString.Builder as BB
144 import qualified Blaze.ByteString.Builder.Internal as BB
145 import Control.Applicative
148 import Control.Monad.IO.Class
149 import Control.Monad.Unicode
150 import Data.Ascii (Ascii, CIAscii)
151 import qualified Data.Ascii as A
152 import qualified Data.Attoparsec.Char8 as P
153 import Data.ByteString (ByteString)
154 import qualified Data.ByteString as Strict
155 import qualified Data.ByteString.Lazy as Lazy
156 import Data.Collections
157 import Data.List (intersperse, sort)
160 import Data.Monoid.Unicode
161 import Data.Text (Text)
162 import qualified Data.Text as T
164 import qualified Data.Time.HTTP as HTTP
165 import Network.HTTP.Lucu.Abortion
166 import Network.HTTP.Lucu.Authentication
167 import Network.HTTP.Lucu.Config
168 import Network.HTTP.Lucu.ContentCoding
169 import Network.HTTP.Lucu.ETag
170 import qualified Network.HTTP.Lucu.Headers as H
171 import Network.HTTP.Lucu.HttpVersion
172 import Network.HTTP.Lucu.Interaction
173 import Network.HTTP.Lucu.MultipartForm
174 import Network.HTTP.Lucu.Parser
175 import Network.HTTP.Lucu.Request
176 import Network.HTTP.Lucu.Resource.Internal
177 import Network.HTTP.Lucu.Response
178 import Network.HTTP.Lucu.MIMEType (MIMEType(..))
179 import qualified Network.HTTP.Lucu.MIMEType as MT
180 import Network.HTTP.Lucu.MIMEType.TH
181 import Network.HTTP.Lucu.Utils
182 import Network.Socket hiding (accept)
183 import Network.URI hiding (path)
184 import Prelude hiding (any, drop, lookup, reverse)
185 import Prelude.Unicode
187 -- |Get the string representation of the address of remote host. If
188 -- you want a 'SockAddr' instead of 'HostName', use 'getRemoteAddr'.
189 getRemoteAddr' ∷ Rsrc HostName
190 getRemoteAddr' = liftIO ∘ toNM =≪ getRemoteAddr
192 toNM ∷ SockAddr → IO HostName
193 toNM = (fromJust ∘ fst <$>) ∘ getNameInfo [NI_NUMERICHOST] True False
195 -- |Resolve an address to the remote host.
196 getRemoteHost ∷ Rsrc (Maybe HostName)
197 getRemoteHost = liftIO ∘ getHN =≪ getRemoteAddr
199 getHN ∷ SockAddr → IO (Maybe HostName)
200 getHN = (fst <$>) ∘ getNameInfo [] True False
202 -- |Get the 'Method' value of the request.
203 getMethod ∷ Rsrc Method
204 getMethod = reqMethod <$> getRequest
206 -- |Get the URI of the request.
207 getRequestURI ∷ Rsrc URI
208 getRequestURI = reqURI <$> getRequest
210 -- |Get the HTTP version of the request.
211 getRequestVersion ∷ Rsrc HttpVersion
212 getRequestVersion = reqVersion <$> getRequest
214 -- |This is an analogy of CGI PATH_INFO. 'getPathInfo' always returns
215 -- @[]@ if the corresponding
216 -- 'Network.HTTP.Lucu.Resource.Tree.Resource' is not greedy. See:
219 -- Note that the returned path components are URI-decoded.
220 getPathInfo ∷ Rsrc [Strict.ByteString]
221 getPathInfo = do rsrcPath ← getResourcePath
222 reqPath ← uriPathSegments <$> getRequestURI
223 return $ drop (length rsrcPath) reqPath
225 -- |Assume the query part of request URI as
226 -- application\/x-www-form-urlencoded, and parse it into pairs of
227 -- @(name, formData)@. This function doesn't read the request
229 getQueryForm ∷ Rsrc [(Strict.ByteString, FormData)]
230 getQueryForm = parse' <$> getRequestURI
232 parse' = map toPairWithFormData ∘
233 parseWWWFormURLEncoded ∘
239 toPairWithFormData ∷ (ByteString, ByteString) → (Strict.ByteString, FormData)
240 toPairWithFormData (name, value)
241 = let fd = FormData {
243 , fdMIMEType = [mimeType| text/plain |]
244 , fdContent = Lazy.fromChunks [value]
248 -- |@'getHeader' name@ returns the value of the request header field
249 -- @name@. Comparison of header name is case-insensitive. Note that
250 -- this function is not intended to be used so frequently: there
251 -- should be functions like 'getContentType' for every common headers.
252 getHeader ∷ CIAscii → Rsrc (Maybe Ascii)
254 = H.getHeader name <$> getRequest
256 -- |Return the list of 'MIMEType' enumerated on the value of request
257 -- header \"Accept\", or @[]@ if absent.
258 getAccept ∷ Rsrc [MIMEType]
260 = do acceptM ← getHeader "Accept"
265 → case P.parseOnly (finishOff MT.mimeTypeList) (A.toByteString accept) of
267 Left _ → abort $ mkAbortion' BadRequest
268 $ "Unparsable Accept: " ⊕ A.toText accept
270 -- |Return the list of @(contentCoding, qvalue)@ enumerated on the
271 -- value of request header \"Accept-Encoding\". The list is sorted in
272 -- descending order by qvalue.
273 getAcceptEncoding ∷ Rsrc [(CIAscii, Maybe Double)]
275 = do accEncM ← getHeader "Accept-Encoding"
278 -- HTTP/1.0 には Accept-Encoding が無い場合の規定が無い
279 -- ので安全の爲 identity が指定された事にする。HTTP/1.1
280 -- の場合は何でも受け入れて良い事になってゐるので "*" が
282 → do ver ← getRequestVersion
284 HttpVersion 1 0 → return [("identity", Nothing)]
285 HttpVersion 1 1 → return [("*" , Nothing)]
286 _ → abort $ mkAbortion' InternalServerError
287 "getAcceptEncoding: unknown HTTP version"
291 return [("identity", Nothing)]
293 case P.parseOnly (finishOff acceptEncodingList) (A.toByteString ae) of
294 Right xs → return $ map toTuple $ reverse $ sort xs
295 Left _ → abort $ mkAbortion' BadRequest
296 $ "Unparsable Accept-Encoding: " ⊕ A.toText ae
298 toTuple (AcceptEncoding {..})
299 = (aeEncoding, aeQValue)
301 -- |Return 'True' iff a given content-coding is acceptable by the
303 isEncodingAcceptable ∷ CIAscii → Rsrc 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 ∷ Rsrc (Maybe MIMEType)
312 = do cTypeM ← getHeader "Content-Type"
317 → case P.parseOnly (finishOff MT.mimeType) (A.toByteString cType) of
318 Right t → return $ Just t
319 Left _ → abort $ mkAbortion' BadRequest
320 $ "Unparsable Content-Type: " ⊕ A.toText cType
322 -- |Return the value of request header \"Authorization\" as
324 getAuthorization ∷ Rsrc (Maybe AuthCredential)
326 = do authM ← getHeader "Authorization"
331 → case P.parseOnly (finishOff authCredential) (A.toByteString auth) of
332 Right ac → return $ Just ac
333 Left _ → return Nothing
335 -- |Tell the system that the 'Rsrc' found an entity for the request
336 -- URI. If this is a GET or HEAD request, a found entity means a datum
337 -- to be replied. If this is a PUT or DELETE request, it means a datum
338 -- which was stored for the URI until now. For POST requests it raises
341 -- 'foundEntity' performs \"If-Match\" test or \"If-None-Match\" test
342 -- whenever possible, and if those tests fail, it immediately aborts
343 -- with status \"412 Precondition Failed\" or \"304 Not Modified\"
344 -- depending on the situation.
346 -- If the request method is either GET or HEAD, 'foundEntity'
347 -- automatically puts \"ETag\" and \"Last-Modified\" headers into the
349 foundEntity ∷ ETag → UTCTime → Rsrc ()
350 foundEntity tag timeStamp
351 = do driftTo ExaminingRequest
354 when (method ≡ GET ∨ method ≡ HEAD)
355 $ setHeader "Last-Modified" (HTTP.toAscii timeStamp)
358 $ mkAbortion' InternalServerError
359 "foundEntity: this is a POST request."
362 driftTo ReceivingBody
364 -- |Tell the system that the 'Rsrc' found an entity for the request
365 -- URI. The only difference from 'foundEntity' is that 'foundETag'
366 -- doesn't (nor can't) put \"Last-Modified\" header into the response.
368 -- Using this function is discouraged. You should use 'foundEntity'
369 -- whenever possible.
370 foundETag ∷ ETag → Rsrc ()
372 = do driftTo ExaminingRequest
375 when (method ≡ GET ∨ method ≡ HEAD)
381 $ mkAbortion' InternalServerError
382 "Illegal computation of foundETag for POST request."
384 -- If-Match があればそれを見る。
385 ifMatch ← getHeader "If-Match"
390 → if value ≡ "*" then
393 case P.parseOnly (finishOff eTagList) (A.toByteString value) of
395 -- tags の中に一致するものが無ければ
396 -- PreconditionFailed で終了。
397 → when ((¬) (any (≡ tag) tags))
399 $ mkAbortion' PreconditionFailed
400 $ "The entity tag doesn't match: " ⊕ A.toText value
402 → abort $ mkAbortion' BadRequest
403 $ "Unparsable If-Match: " ⊕ A.toText value
405 let statusForNoneMatch
406 = if method ≡ GET ∨ method ≡ HEAD then
407 fromStatusCode NotModified
409 fromStatusCode PreconditionFailed
411 -- If-None-Match があればそれを見る。
412 ifNoneMatch ← getHeader "If-None-Match"
417 → if value ≡ "*" then
418 abort $ mkAbortion' statusForNoneMatch
419 $ "The entity tag matches: *"
421 case P.parseOnly (finishOff eTagList) (A.toByteString value) of
423 → when (any (≡ tag) tags)
425 $ mkAbortion' statusForNoneMatch
426 $ "The entity tag matches: " ⊕ A.toText value
428 → abort $ mkAbortion' BadRequest
429 $ "Unparsable If-None-Match: " ⊕ A.toText value
431 driftTo ReceivingBody
433 -- |Tell the system that the 'Rsrc' found an entity for the
434 -- request URI. The only difference from 'foundEntity' is that
435 -- 'foundTimeStamp' performs \"If-Modified-Since\" test or
436 -- \"If-Unmodified-Since\" test instead of \"If-Match\" test or
437 -- \"If-None-Match\" test. Be aware that any tests based on a last
438 -- modification time are unsafe because it is possible to mess up such
439 -- tests by modifying the entity twice in a second.
441 -- Using this function is discouraged. You should use 'foundEntity'
442 -- whenever possible.
443 foundTimeStamp ∷ UTCTime → Rsrc ()
444 foundTimeStamp timeStamp
445 = do driftTo ExaminingRequest
448 when (method ≡ GET ∨ method ≡ HEAD)
449 $ setHeader "Last-Modified" (HTTP.toAscii timeStamp)
452 $ mkAbortion' InternalServerError
453 "Illegal call of foundTimeStamp for POST request."
455 let statusForIfModSince
456 = if method ≡ GET ∨ method ≡ HEAD then
457 fromStatusCode NotModified
459 fromStatusCode PreconditionFailed
461 ifModSince ← getHeader "If-Modified-Since"
463 Just str → case HTTP.fromAscii str of
465 → when (timeStamp ≤ lastTime)
467 $ mkAbortion' statusForIfModSince
468 $ "The entity has not been modified since " ⊕ A.toText str
470 → abort $ mkAbortion' BadRequest
471 $ "Malformed If-Modified-Since: " ⊕ T.pack e
474 ifUnmodSince ← getHeader "If-Unmodified-Since"
476 Just str → case HTTP.fromAscii str of
478 → when (timeStamp > lastTime)
480 $ mkAbortion' PreconditionFailed
481 $ "The entity has not been modified since " ⊕ A.toText str
483 → abort $ mkAbortion' BadRequest
484 $ "Malformed If-Unmodified-Since: " ⊕ T.pack e
487 driftTo ReceivingBody
489 -- |@'foundNoEntity' mStr@ tells the system that the 'Rsrc' found no
490 -- entity for the request URI. @mStr@ is an optional error message to
491 -- be replied to the client.
493 -- If the request method is PUT, 'foundNoEntity' performs \"If-Match\"
494 -- test and when that fails it aborts with status \"412 Precondition
495 -- Failed\". If the request method is GET, HEAD, POST or DELETE,
496 -- 'foundNoEntity' always aborts with status \"404 Not Found\".
497 foundNoEntity ∷ Maybe Text → Rsrc ()
499 = do driftTo ExaminingRequest
504 $ mkAbortion NotFound [] msgM
506 -- エンティティが存在しないと云ふ事は、"*" も含めたどのやうな
507 -- If-Match: 條件も滿たさない。
508 ifMatch ← getHeader "If-Match"
509 when (ifMatch ≢ Nothing)
511 $ mkAbortion PreconditionFailed [] msgM
513 driftTo ReceivingBody
515 -- |'foundNoEntity'' is the same as @'foundNoEntity' 'Nothing'@.
516 foundNoEntity' ∷ Rsrc ()
517 {-# INLINE foundNoEntity' #-}
518 foundNoEntity' = foundNoEntity Nothing
520 -- |@'getChunks' limit@ attemts to read the entire request body up to
521 -- @limit@ bytes, and then make the 'Rsrc' transit to the /Deciding
522 -- Header/ state. When the actual size of the body is larger than
523 -- @limit@ bytes, 'getChunks' immediately aborts with status \"413
524 -- Request Entity Too Large\". When the request has no body, it
525 -- returns an empty string.
527 -- When the @limit@ is 'Nothing', 'getChunks' uses the default
528 -- limitation value ('cnfMaxEntityLength') instead.
530 -- 'getChunks' returns a lazy 'Lazy.ByteString' but it's not really
531 -- lazy: reading from the socket just happens at the computation of
532 -- 'getChunks', not at the evaluation of the 'Lazy.ByteString'.
533 getChunks ∷ Maybe Int → Rsrc Lazy.ByteString
535 | n < 0 = fail ("getChunks: limit must not be negative: " ⧺ show n)
537 | otherwise = getChunks' n
539 = getConfig ≫= getChunks ∘ Just ∘ cnfMaxEntityLength
541 getChunks' ∷ Int → Rsrc Lazy.ByteString
542 getChunks' limit = go limit (∅)
544 go ∷ Int → Builder → Rsrc Lazy.ByteString
545 go 0 _ = do chunk ← getChunk 1
546 if Strict.null chunk then
549 abort $ mkAbortion' RequestEntityTooLarge
550 $ "Request body must be smaller than "
551 ⊕ T.pack (show limit)
553 go !n !b = do c ← getChunk $ min n BB.defaultBufferSize
554 if Strict.null c then
556 return $ BB.toLazyByteString b
558 do let n' = n - Strict.length c
559 xs' = b ⊕ BB.fromByteString c
562 -- |@'getForm' limit@ attempts to read the request body with
563 -- 'getChunks' and parse it as @application\/x-www-form-urlencoded@ or
564 -- @multipart\/form-data@. If the request header \"Content-Type\" is
565 -- neither of them, 'getForm' aborts with status \"415 Unsupported
566 -- Media Type\". If the request has no \"Content-Type\", it aborts
567 -- with \"400 Bad Request\".
569 -- Note that there are currently a few limitations on parsing
570 -- @multipart/form-data@. See: 'parseMultipartFormData'
571 getForm ∷ Maybe Int → Rsrc [(Strict.ByteString, FormData)]
573 = do cTypeM ← getContentType
576 → abort $ mkAbortion' BadRequest "Missing Content-Type"
577 Just (MIMEType "application" "x-www-form-urlencoded" _)
578 → readWWWFormURLEncoded
579 Just (MIMEType "multipart" "form-data" params)
580 → readMultipartFormData params
582 → abort $ mkAbortion' UnsupportedMediaType
585 $ A.toAsciiBuilder "Unsupported media type: "
586 ⊕ MT.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 $ mkAbortion' BadRequest "Malformed x-www-form-urlencoded"
598 readMultipartFormData m
599 = case lookup "boundary" m of
601 → abort $ mkAbortion' BadRequest "Missing boundary of multipart/form-data"
603 → do src ← getChunks limit
604 b ← case A.fromText boundary of
606 Nothing → abort $ mkAbortion' BadRequest
607 $ "Malformed boundary: " ⊕ boundary
608 case parseMultipartFormData b src of
609 Right xs → return $ map (first A.toByteString) xs
610 Left err → abort $ mkAbortion' BadRequest $ T.pack err
612 -- |@'redirect' code uri@ declares the response status as @code@ and
613 -- \"Location\" header field as @uri@. The @code@ must satisfy
614 -- 'isRedirection' or it raises an error.
615 redirect ∷ StatusCode sc ⇒ sc → URI → Rsrc ()
617 = do when (sc ≈ NotModified ∨ (¬) (isRedirection sc))
619 $ mkAbortion' InternalServerError
622 $ A.toAsciiBuilder "Attempted to redirect with status "
627 -- |@'setContentType' mType@ declares the response header
628 -- \"Content-Type\" as @mType@. Declaring \"Content-Type\" is
629 -- mandatory for sending a response body.
630 setContentType ∷ MIMEType → Rsrc ()
632 = setHeader "Content-Type" ∘ A.fromAsciiBuilder ∘ MT.printMIMEType
634 -- |@'setLocation' uri@ declares the response header \"Location\" as
635 -- @uri@. You usually don't need to call this function directly.
636 setLocation ∷ URI → Rsrc ()
638 = case A.fromChars uriStr of
639 Just a → setHeader "Location" a
640 Nothing → abort $ mkAbortion' InternalServerError
641 $ "Malformed URI: " ⊕ T.pack uriStr
643 uriStr = uriToString id uri ""
645 -- |@'setContentEncoding' codings@ declares the response header
646 -- \"Content-Encoding\" as @codings@.
647 setContentEncoding ∷ [CIAscii] → Rsrc ()
648 setContentEncoding codings
649 = do ver ← getRequestVersion
651 HttpVersion 1 0 → return (toAB ∘ unnormalizeCoding)
652 HttpVersion 1 1 → return toAB
653 _ → abort $ mkAbortion' InternalServerError
654 "setContentEncoding: Unknown HTTP version"
655 setHeader "Content-Encoding"
658 $ intersperse (A.toAsciiBuilder ", ")
661 toAB = A.toAsciiBuilder ∘ A.fromCIAscii
663 -- |@'setWWWAuthenticate' challenge@ declares the response header
664 -- \"WWW-Authenticate\" as @challenge@.
665 setWWWAuthenticate ∷ AuthChallenge → Rsrc ()
666 setWWWAuthenticate = setHeader "WWW-Authenticate" ∘ printAuthChallenge
668 -- |Write a chunk in 'Strict.ByteString' to the response body. You
669 -- must first declare the response header \"Content-Type\" before
670 -- applying this function. See: 'setContentType'
671 putChunk ∷ Strict.ByteString → Rsrc ()
672 putChunk = putBuilder ∘ BB.fromByteString
674 -- |Write a chunk in lazy 'Lazy.ByteString' to the response body. It
675 -- can be safely applied to an infinitely long 'Lazy.ByteString'.
677 -- Note that you must first declare the response header
678 -- \"Content-Type\" before applying this function. See:
680 putChunks ∷ Lazy.ByteString → Rsrc ()
681 putChunks = putBuilder ∘ BB.fromLazyByteString