5 , GeneralizedNewtypeDeriving
13 -- |This is the Resource Monad; monadic actions to define a behavior
14 -- of resource. The 'Rsrc' Monad is a kind of 'IO' Monad thus it
15 -- implements 'MonadIO' class, and it is a state machine as well.
17 -- Request Processing Flow:
19 -- 1. A client issues an HTTP request.
21 -- 2. If the URI of it matches to any resource, the corresponding
22 -- 'Rsrc' Monad starts running on a newly spawned thread.
24 -- 3. The 'Rsrc' Monad looks at request headers, find (or not find)
25 -- an entity, receive the request body (if any), send response
26 -- headers, and then send a response body. This process will be
29 -- 4. The 'Rsrc' Monad and its thread stops running. The client may
30 -- or may not be sending us the next request at this point.
32 -- 'Rsrc' Monad takes the following states. The initial state is
33 -- /Examining Request/ and the final state is /Done/.
35 -- [/Examining Request/] In this state, a 'Rsrc' looks at the
36 -- request header fields and thinks about the corresponding entity
37 -- for it. If there is a suitable entity, the 'Rsrc' tells the
38 -- system an entity tag and its last modification time
39 -- ('foundEntity'). If it found no entity, it tells the system so
40 -- ('foundNoEntity'). In case it is impossible to decide the
41 -- existence of entity, which is a typical case for POST requests,
42 -- 'Rsrc' does nothing in this state.
44 -- [/Receiving Body/] A 'Rsrc' asks the system to receive a request
45 -- body from the client. Before actually reading from the socket,
46 -- the system sends \"100 Continue\" to the client if need be. When
47 -- a 'Rsrc' transits to the next state without receiving all or part
48 -- of a request body, the system automatically discards it.
50 -- [/Deciding Header/] A 'Rsrc' makes a decision of response status
51 -- code and header fields. When it transits to the next state, the
52 -- system validates and completes the header fields and then sends
53 -- them to the client.
55 -- [/Sending Body/] In this state, a 'Rsrc' asks the system to write
56 -- some response body to the socket. When it transits to the next
57 -- state without writing any response body, the system automatically
58 -- completes it depending on the status code. (To be exact, such
59 -- completion only occurs when the 'Rsrc' transits to this state
60 -- without even declaring the \"Content-Type\" header field. See:
63 -- [/Done/] Everything is over. A 'Rsrc' can do nothing for the HTTP
64 -- interaction anymore.
66 -- Note that the state transition is one-way: for instance, it is an
67 -- error to try to read a request body after writing some
68 -- response. This limitation is for efficiency. We don't want to read
69 -- the entire request before starting 'Rsrc', nor we don't want to
70 -- postpone writing the entire response till the end of 'Rsrc'
72 module Network.HTTP.Lucu.Resource
79 -- * Getting request header
80 -- |These functions can be called regardless of the current state,
81 -- and they don't change the state of 'Rsrc'.
87 , getRemoteCertificate
99 , isEncodingAcceptable
103 -- * Finding an entity
104 -- |These functions can be called only in the /Examining Request/
105 -- state. They make the 'Rsrc' transit to the /Receiving Body/
113 -- * Receiving a request body
114 -- |These functions make the 'Rsrc' transit to the /Receiving
120 -- * Declaring response status and header fields
121 -- |These functions can be called at any time before transiting to
122 -- the /Sending Body/ state, but they themselves never causes any
123 -- state transitions.
130 -- ** Less frequently used functions
135 -- * Sending a response body
137 -- |These functions make the 'Rsrc' transit to the /Sending Body/
144 import Blaze.ByteString.Builder (Builder)
145 import qualified Blaze.ByteString.Builder as BB
146 import qualified Blaze.ByteString.Builder.Internal as BB
147 import Control.Applicative
150 import Control.Monad.IO.Class
151 import Control.Monad.Unicode
152 import Data.Ascii (Ascii, CIAscii, AsciiBuilder)
154 import qualified Data.Attoparsec.Char8 as P
155 import Data.ByteString (ByteString)
156 import qualified Data.ByteString as Strict
157 import qualified Data.ByteString.Lazy as Lazy
158 import Data.Collections
159 import Data.Convertible.Base
160 import Data.Convertible.Instances.Text ()
161 import Data.Convertible.Utils
163 import Data.List (intersperse, sort)
166 import Data.Monoid.Unicode
168 import Data.Text (Text)
170 import Data.Time.Format.HTTP
171 import Network.HTTP.Lucu.Abortion
172 import Network.HTTP.Lucu.Authentication
173 import Network.HTTP.Lucu.Config
174 import Network.HTTP.Lucu.ContentCoding
175 import Network.HTTP.Lucu.ETag
176 import qualified Network.HTTP.Lucu.Headers as H
177 import Network.HTTP.Lucu.HttpVersion
178 import Network.HTTP.Lucu.Interaction
179 import Network.HTTP.Lucu.MultipartForm
180 import Network.HTTP.Lucu.Parser
181 import Network.HTTP.Lucu.Request
182 import Network.HTTP.Lucu.Resource.Internal
183 import Network.HTTP.Lucu.Response
184 import Network.HTTP.Lucu.Response.StatusCode
185 import Network.HTTP.Lucu.MIMEType
186 import Network.HTTP.Lucu.Utils
187 import Network.Socket hiding (accept)
188 import Network.URI hiding (path)
189 import Prelude hiding (any, drop, lookup, reverse)
190 import Prelude.Unicode
192 -- |Get the string representation of the address of remote host. If
193 -- you want a 'SockAddr' instead of 'HostName', use 'getRemoteAddr'.
194 getRemoteAddr' ∷ Rsrc HostName
195 getRemoteAddr' = liftIO ∘ toNM =≪ getRemoteAddr
197 toNM ∷ SockAddr → IO HostName
198 toNM = (fromJust ∘ fst <$>) ∘ getNameInfo [NI_NUMERICHOST] True False
200 -- |Resolve an address to the remote host.
201 getRemoteHost ∷ Rsrc (Maybe HostName)
202 getRemoteHost = liftIO ∘ getHN =≪ getRemoteAddr
204 getHN ∷ SockAddr → IO (Maybe HostName)
205 getHN = (fst <$>) ∘ getNameInfo [] True False
207 -- |Get the 'Method' value of the request.
208 getMethod ∷ Rsrc Method
209 getMethod = reqMethod <$> getRequest
211 -- |Get the URI of the request.
212 getRequestURI ∷ Rsrc URI
213 getRequestURI = reqURI <$> getRequest
215 -- |Get the HTTP version of the request.
216 getRequestVersion ∷ Rsrc HttpVersion
217 getRequestVersion = reqVersion <$> getRequest
219 -- |This is an analogy of CGI PATH_INFO. 'getPathInfo' always returns
220 -- @[]@ if the corresponding 'Resource' is not greedy. See
221 -- 'getResourcePath'.
223 -- Note that the returned path components are URI-decoded.
224 getPathInfo ∷ Rsrc [Strict.ByteString]
225 getPathInfo = do rsrcPath ← getResourcePath
226 reqPath ← uriPathSegments <$> getRequestURI
227 return $ drop (length rsrcPath) reqPath
229 -- |Assume the query part of request URI as
230 -- application\/x-www-form-urlencoded, and parse it into pairs of
231 -- @(name, formData)@. This function doesn't read the request
233 getQueryForm ∷ Rsrc [(Strict.ByteString, FormData)]
234 getQueryForm = parse' <$> getRequestURI
236 parse' = map toPairWithFormData ∘
237 parseWWWFormURLEncoded ∘
242 toPairWithFormData ∷ (ByteString, ByteString) → (Strict.ByteString, FormData)
243 toPairWithFormData (name, value)
244 = let fd = FormData {
246 , fdMIMEType = [mimeType| text/plain |]
247 , fdContent = Lazy.fromChunks [value]
251 -- |@'getHeader' name@ returns the value of the request header field
252 -- @name@. Comparison of header name is case-insensitive. Note that
253 -- this function is not intended to be used so frequently: there
254 -- should be functions like 'getContentType' for every common headers.
255 getHeader ∷ CIAscii → Rsrc (Maybe Ascii)
257 = H.getHeader name <$> getRequest
259 -- |Return the list of 'MIMEType' enumerated on the value of request
260 -- header \"Accept\", or @[]@ if absent.
261 getAccept ∷ Rsrc [MIMEType]
263 = do acceptM ← getHeader "Accept"
268 → case P.parseOnly (finishOff def) (cs accept) of
270 Left _ → abort $ mkAbortion' BadRequest
271 $ "Unparsable Accept: " ⊕ cs accept
273 -- |Return the list of @(contentCoding, qvalue)@ enumerated on the
274 -- value of request header \"Accept-Encoding\". The list is sorted in
275 -- descending order by qvalue.
276 getAcceptEncoding ∷ Rsrc [(CIAscii, Maybe Double)]
278 = do accEncM ← getHeader "Accept-Encoding"
281 -- HTTP/1.0 には Accept-Encoding が無い場合の規定が無い
282 -- ので安全の爲 identity が指定された事にする。HTTP/1.1
283 -- の場合は何でも受け入れて良い事になってゐるので "*" が
285 → do ver ← getRequestVersion
287 HttpVersion 1 0 → return [("identity", Nothing)]
288 HttpVersion 1 1 → return [("*" , Nothing)]
289 _ → abort $ mkAbortion' InternalServerError
290 "getAcceptEncoding: unknown HTTP version"
294 return [("identity", Nothing)]
296 case P.parseOnly (finishOff def) (cs ae) of
297 Right xs → return $ map toTuple $ reverse $ sort xs
298 Left _ → abort $ mkAbortion' BadRequest
299 $ "Unparsable Accept-Encoding: " ⊕ cs ae
301 toTuple (AcceptEncoding {..})
302 = (aeEncoding, aeQValue)
304 -- |Return 'True' iff a given content-coding is acceptable by the
306 isEncodingAcceptable ∷ CIAscii → Rsrc Bool
307 isEncodingAcceptable encoding = any doesMatch <$> getAcceptEncoding
309 doesMatch ∷ (CIAscii, Maybe Double) → Bool
310 doesMatch (e, q) = (e ≡ "*" ∨ e ≡ encoding) ∧ q ≢ Just 0
312 -- |Return the value of request header \"Content-Type\" as 'MIMEType'.
313 getContentType ∷ Rsrc (Maybe MIMEType)
315 = do cTypeM ← getHeader "Content-Type"
320 → case P.parseOnly (finishOff def) (cs cType) of
321 Right t → return $ Just t
322 Left _ → abort $ mkAbortion' BadRequest
323 $ "Unparsable Content-Type: " ⊕ cs cType
325 -- |Return the value of request header \"Authorization\" as
327 getAuthorization ∷ Rsrc (Maybe AuthCredential)
329 = do authM ← getHeader "Authorization"
334 → case P.parseOnly (finishOff def) (cs auth) of
335 Right ac → return $ Just ac
336 Left _ → return Nothing
338 -- |Tell the system that the 'Rsrc' found an entity for the request
339 -- URI. If this is a GET or HEAD request, a found entity means a datum
340 -- to be replied. If this is a PUT or DELETE request, it means a datum
341 -- which was stored for the URI until now. For POST requests it raises
344 -- 'foundEntity' performs \"If-Match\" test or \"If-None-Match\" test
345 -- whenever possible, and if those tests fail, it immediately aborts
346 -- with status \"412 Precondition Failed\" or \"304 Not Modified\"
347 -- depending on the situation.
349 -- If the request method is either GET or HEAD, 'foundEntity'
350 -- automatically puts \"ETag\" and \"Last-Modified\" headers into the
352 foundEntity ∷ ETag → UTCTime → Rsrc ()
353 foundEntity tag timeStamp
354 = do driftTo ExaminingRequest
357 when (method ≡ GET ∨ method ≡ HEAD)
358 $ setHeader "Last-Modified"
359 $ formatUTCTime timeStamp
362 $ mkAbortion' InternalServerError
363 "foundEntity: this is a POST request."
366 driftTo ReceivingBody
368 -- |Tell the system that the 'Rsrc' found an entity for the request
369 -- URI. The only difference from 'foundEntity' is that 'foundETag'
370 -- doesn't (nor can't) put \"Last-Modified\" header into the response.
372 -- Using this function is discouraged. You should use 'foundEntity'
373 -- whenever possible.
374 foundETag ∷ ETag → Rsrc ()
376 = do driftTo ExaminingRequest
379 when (method ≡ GET ∨ method ≡ HEAD)
384 $ mkAbortion' InternalServerError
385 "Illegal computation of foundETag for POST request."
387 -- If-Match があればそれを見る。
388 ifMatch ← getHeader "If-Match"
393 → if value ≡ "*" then
396 case P.parseOnly (finishOff def) (cs value) of
398 → abort $ mkAbortion' BadRequest
401 -- tags の中に一致するものが無ければ
402 -- PreconditionFailed で終了。
403 → when ((¬) (any (≡ tag) tags))
405 $ mkAbortion' PreconditionFailed
406 $ "The entity tag doesn't match: " ⊕ cs value
408 → abort $ mkAbortion' BadRequest
409 $ "Unparsable If-Match: " ⊕ cs value
411 let statusForNoneMatch
412 = if method ≡ GET ∨ method ≡ HEAD then
413 fromStatusCode NotModified
415 fromStatusCode PreconditionFailed
417 -- If-None-Match があればそれを見る。
418 ifNoneMatch ← getHeader "If-None-Match"
423 → if value ≡ "*" then
424 abort $ mkAbortion' statusForNoneMatch
425 $ "The entity tag matches: *"
427 case P.parseOnly (finishOff def) (cs value) of
429 → abort $ mkAbortion' BadRequest
430 $ "Empty If-None-Match"
432 → when (any (≡ tag) tags)
434 $ mkAbortion' statusForNoneMatch
435 $ "The entity tag matches: " ⊕ cs value
437 → abort $ mkAbortion' BadRequest
438 $ "Unparsable If-None-Match: " ⊕ cs value
440 driftTo ReceivingBody
442 -- |Tell the system that the 'Rsrc' found an entity for the
443 -- request URI. The only difference from 'foundEntity' is that
444 -- 'foundTimeStamp' performs \"If-Modified-Since\" test or
445 -- \"If-Unmodified-Since\" test instead of \"If-Match\" test or
446 -- \"If-None-Match\" test. Be aware that any tests based on a last
447 -- modification time are unsafe because it is possible to mess up such
448 -- tests by modifying the entity twice in a second.
450 -- Using this function is discouraged. You should use 'foundEntity'
451 -- whenever possible.
452 foundTimeStamp ∷ UTCTime → Rsrc ()
453 foundTimeStamp timeStamp
454 = do driftTo ExaminingRequest
457 when (method ≡ GET ∨ method ≡ HEAD)
458 $ setHeader "Last-Modified"
459 $ formatUTCTime timeStamp
462 $ mkAbortion' InternalServerError
463 "Illegal call of foundTimeStamp for POST request."
465 let statusForIfModSince
466 = if method ≡ GET ∨ method ≡ HEAD then
467 fromStatusCode NotModified
469 fromStatusCode PreconditionFailed
471 ifModSince ← getHeader "If-Modified-Since"
473 Just str → case untag' <$> (fromAttempt $ ca str) of
475 → when (timeStamp ≤ lastTime)
477 $ mkAbortion' statusForIfModSince
478 $ "The entity has not been modified since " ⊕ cs str
480 → abort $ mkAbortion' BadRequest
481 $ "Malformed If-Modified-Since: " ⊕ cs str
484 ifUnmodSince ← getHeader "If-Unmodified-Since"
486 Just str → case untag' <$> (fromAttempt $ ca str) of
488 → when (timeStamp > lastTime)
490 $ mkAbortion' PreconditionFailed
491 $ "The entity has not been modified since " ⊕ cs str
493 → abort $ mkAbortion' BadRequest
494 $ "Malformed If-Unmodified-Since: " ⊕ cs str
497 driftTo ReceivingBody
499 untag' ∷ Tagged HTTP α → α
500 {-# INLINE untag' #-}
503 -- |@'foundNoEntity' mStr@ tells the system that the 'Rsrc' found no
504 -- entity for the request URI. @mStr@ is an optional error message to
505 -- be replied to the client.
507 -- If the request method is PUT, 'foundNoEntity' performs \"If-Match\"
508 -- test and when that fails it aborts with status \"412 Precondition
509 -- Failed\". If the request method is GET, HEAD, POST or DELETE,
510 -- 'foundNoEntity' always aborts with status \"404 Not Found\".
511 foundNoEntity ∷ Maybe Text → Rsrc ()
513 = do driftTo ExaminingRequest
518 $ mkAbortion NotFound [] msgM
520 -- エンティティが存在しないと云ふ事は、"*" も含めたどのやうな
521 -- If-Match: 條件も滿たさない。
522 ifMatch ← getHeader "If-Match"
523 when (ifMatch ≢ Nothing)
525 $ mkAbortion PreconditionFailed [] msgM
527 driftTo ReceivingBody
529 -- |'foundNoEntity'' is the same as @'foundNoEntity' 'Nothing'@.
530 foundNoEntity' ∷ Rsrc ()
531 {-# INLINE foundNoEntity' #-}
532 foundNoEntity' = foundNoEntity Nothing
534 -- |@'getChunks' limit@ attemts to read the entire request body up to
535 -- @limit@ bytes, and then make the 'Rsrc' transit to the /Deciding
536 -- Header/ state. When the actual size of the body is larger than
537 -- @limit@ bytes, 'getChunks' immediately aborts with status \"413
538 -- Request Entity Too Large\". When the request has no body, it
539 -- returns an empty string.
541 -- When the @limit@ is 'Nothing', 'getChunks' uses the default
542 -- limitation value ('cnfMaxEntityLength') instead.
544 -- 'getChunks' returns a lazy 'Lazy.ByteString' but it's not really
545 -- lazy: reading from the socket just happens at the computation of
546 -- 'getChunks', not at the evaluation of the 'Lazy.ByteString'.
547 getChunks ∷ Maybe Int → Rsrc Lazy.ByteString
549 | n < 0 = fail ("getChunks: limit must not be negative: " ⧺ show n)
551 | otherwise = getChunks' n
553 = getConfig ≫= getChunks ∘ Just ∘ cnfMaxEntityLength
555 getChunks' ∷ Int → Rsrc Lazy.ByteString
556 getChunks' limit = go limit (∅)
558 go ∷ Int → Builder → Rsrc Lazy.ByteString
559 go 0 _ = do chunk ← getChunk 1
560 if Strict.null chunk then
563 abort $ mkAbortion' RequestEntityTooLarge
564 $ "Request body must be smaller than "
567 go !n !b = do c ← getChunk $ min n BB.defaultBufferSize
568 if Strict.null c then
570 return $ BB.toLazyByteString b
572 do let n' = n - Strict.length c
573 xs' = b ⊕ BB.fromByteString c
576 -- |@'getForm' limit@ attempts to read the request body with
577 -- 'getChunks' and parse it as @application\/x-www-form-urlencoded@ or
578 -- @multipart\/form-data@. If the request header \"Content-Type\" is
579 -- neither of them, 'getForm' aborts with status \"415 Unsupported
580 -- Media Type\". If the request has no \"Content-Type\", it aborts
581 -- with \"400 Bad Request\".
583 -- Note that there are currently a few limitations on parsing
584 -- @multipart/form-data@. See: 'parseMultipartFormData'
585 getForm ∷ Maybe Int → Rsrc [(Strict.ByteString, FormData)]
587 = do cTypeM ← getContentType
590 → abort $ mkAbortion' BadRequest "Missing Content-Type"
591 Just (MIMEType "application" "x-www-form-urlencoded" _)
592 → readWWWFormURLEncoded
593 Just (MIMEType "multipart" "form-data" params)
594 → readMultipartFormData params
596 → abort $ mkAbortion' UnsupportedMediaType
598 $ ("Unsupported media type: " ∷ Ascii)
601 readWWWFormURLEncoded
602 = (map toPairWithFormData ∘ parseWWWFormURLEncoded)
604 (bsToAscii =≪ getChunks limit)
607 = case convertAttemptVia ((⊥) ∷ ByteString) bs of
609 Failure e → abort $ mkAbortion' BadRequest $ cs (show e)
611 readMultipartFormData m
612 = case lookup "boundary" m of
614 → abort $ mkAbortion' BadRequest "Missing boundary of multipart/form-data"
616 → do src ← getChunks limit
617 b ← case ca boundary of
619 Failure _ → abort $ mkAbortion' BadRequest
620 $ "Malformed boundary: " ⊕ boundary
621 case parseMultipartFormData b src of
622 Right xs → return $ map (first cs) xs
623 Left err → abort $ mkAbortion' BadRequest $ cs err
625 -- |@'redirect' code uri@ declares the response status as @code@ and
626 -- \"Location\" header field as @uri@. The @code@ must satisfy
627 -- 'isRedirection' or it raises an error.
628 redirect ∷ StatusCode sc ⇒ sc → URI → Rsrc ()
629 redirect (fromStatusCode → sc) uri
630 = do when (sc ≡ cs NotModified ∨ (¬) (isRedirection sc))
632 $ mkAbortion' InternalServerError
634 $ ("Attempted to redirect with status " ∷ Ascii)
639 -- |@'setContentType' mType@ declares the response header
640 -- \"Content-Type\" as @mType@. Declaring \"Content-Type\" is
641 -- mandatory for sending a response body.
642 setContentType ∷ MIMEType → Rsrc ()
643 setContentType = setHeader "Content-Type" ∘ cs
645 -- |@'setLocation' uri@ declares the response header \"Location\" as
646 -- @uri@. You usually don't need to call this function directly.
647 setLocation ∷ URI → Rsrc ()
650 Success a → setHeader "Location" a
651 Failure e → abort $ mkAbortion' InternalServerError
654 uriStr = uriToString id uri ""
656 -- |@'setContentEncoding' codings@ declares the response header
657 -- \"Content-Encoding\" as @codings@.
658 setContentEncoding ∷ [CIAscii] → Rsrc ()
659 setContentEncoding codings
660 = do ver ← getRequestVersion
662 HttpVersion 1 0 → return (toAB ∘ unnormalizeCoding)
663 HttpVersion 1 1 → return toAB
664 _ → abort $ mkAbortion' InternalServerError
665 "setContentEncoding: Unknown HTTP version"
666 setHeader "Content-Encoding"
669 $ intersperse (cs (", " ∷ Ascii))
672 toAB ∷ ConvertSuccess α AsciiBuilder ⇒ α → AsciiBuilder
675 -- |@'setWWWAuthenticate' challenge@ declares the response header
676 -- \"WWW-Authenticate\" as @challenge@.
677 setWWWAuthenticate ∷ AuthChallenge → Rsrc ()
678 setWWWAuthenticate = setHeader "WWW-Authenticate" ∘ cs
680 -- |Write a chunk in 'Strict.ByteString' to the response body. You
681 -- must first declare the response header \"Content-Type\" before
682 -- applying this function. See 'setContentType'.
683 putChunk ∷ Strict.ByteString → Rsrc ()
684 putChunk = putBuilder ∘ BB.fromByteString
686 -- |Write a chunk in lazy 'Lazy.ByteString' to the response body. It
687 -- can be safely applied to an infinitely long 'Lazy.ByteString'.
689 -- Note that you must first declare the response header
690 -- \"Content-Type\" before applying this function. See
692 putChunks ∷ Lazy.ByteString → Rsrc ()
693 putChunks = putBuilder ∘ BB.fromLazyByteString