5 , GeneralizedNewtypeDeriving
12 -- |This is the Resource Monad; monadic actions to define a behavior
13 -- of resource. The 'Rsrc' Monad is a kind of 'IO' Monad thus it
14 -- implements 'MonadIO' class, and it is a state machine as well.
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 -- 'Rsrc' Monad starts running on a newly spawned thread.
23 -- 3. The 'Rsrc' Monad looks at request headers, find (or not find)
24 -- an entity, receive the request body (if any), send response
25 -- headers, and then send a response body. This process will be
28 -- 4. The 'Rsrc' Monad and its thread stops running. The client may
29 -- or may not be sending us the next request at this point.
31 -- 'Rsrc' 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 'Rsrc' looks at the
35 -- request header fields and thinks about the corresponding entity
36 -- for it. If there is a suitable entity, the 'Rsrc' tells the
37 -- system an entity tag and its last modification time
38 -- ('foundEntity'). If it found no entity, it tells the system so
39 -- ('foundNoEntity'). In case it is impossible to decide the
40 -- existence of entity, which is a typical case for POST requests,
41 -- 'Rsrc' does nothing in this state.
43 -- [/Receiving Body/] A 'Rsrc' asks the system to receive a request
44 -- body from the client. Before actually reading from the socket,
45 -- the system sends \"100 Continue\" to the client if need be. When
46 -- a 'Rsrc' transits to the next state without receiving all or part
47 -- of a request body, the system automatically discards it.
49 -- [/Deciding Header/] A 'Rsrc' makes a decision of response status
50 -- code and header fields. When it transits to the next state, the
51 -- system validates and completes the header fields and then sends
52 -- them to the client.
54 -- [/Sending Body/] In this state, a 'Rsrc' asks the system to write
55 -- some response body to the socket. When it transits to the next
56 -- state without writing any response body, the system automatically
57 -- completes it depending on the status code. (To be exact, such
58 -- completion only occurs when the 'Rsrc' transits to this state
59 -- without even declaring the \"Content-Type\" header field. See:
62 -- [/Done/] Everything is over. A 'Rsrc' can do nothing for the HTTP
63 -- interaction anymore.
65 -- Note that the state transition is one-way: for instance, it is an
66 -- error to try to read a request body after writing some
67 -- response. This limitation is for efficiency. We don't want to read
68 -- the entire request before starting 'Rsrc', nor we don't want to
69 -- postpone writing the entire response till the end of 'Rsrc'
71 module Network.HTTP.Lucu.Resource
78 -- * Getting request header
79 -- |These functions can be called regardless of the current state,
80 -- and they don't change the state of 'Rsrc'.
86 , getRemoteCertificate
98 , isEncodingAcceptable
102 -- * Finding an entity
103 -- |These functions can be called only in the /Examining Request/
104 -- state. They make the 'Rsrc' transit to the /Receiving Body/
112 -- * Receiving a request body
113 -- |These functions make the 'Rsrc' transit to the /Receiving
119 -- * Declaring response status and header fields
120 -- |These functions can be called at any time before transiting to
121 -- the /Sending Body/ state, but they themselves never causes any
122 -- state transitions.
129 -- ** Less frequently used functions
134 -- * Sending a response body
136 -- |These functions make the 'Rsrc' transit to the /Sending Body/
143 import Blaze.ByteString.Builder (Builder)
144 import qualified Blaze.ByteString.Builder as BB
145 import qualified Blaze.ByteString.Builder.Internal as BB
146 import Control.Applicative
149 import Control.Monad.IO.Class
150 import Control.Monad.Unicode
151 import Data.Ascii (Ascii, CIAscii, AsciiBuilder)
153 import qualified Data.Attoparsec.Char8 as P
154 import Data.Attoparsec.Parsable
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
162 import Data.List (intersperse, sort)
165 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.MIMEType
185 import Network.HTTP.Lucu.Utils
186 import Network.Socket hiding (accept)
187 import Network.URI hiding (path)
188 import Prelude hiding (any, drop, lookup, reverse)
189 import Prelude.Unicode
191 -- |Get the string representation of the address of remote host. If
192 -- you want a 'SockAddr' instead of 'HostName', use 'getRemoteAddr'.
193 getRemoteAddr' ∷ Rsrc HostName
194 getRemoteAddr' = liftIO ∘ toNM =≪ getRemoteAddr
196 toNM ∷ SockAddr → IO HostName
197 toNM = (fromJust ∘ fst <$>) ∘ getNameInfo [NI_NUMERICHOST] True False
199 -- |Resolve an address to the remote host.
200 getRemoteHost ∷ Rsrc (Maybe HostName)
201 getRemoteHost = liftIO ∘ getHN =≪ getRemoteAddr
203 getHN ∷ SockAddr → IO (Maybe HostName)
204 getHN = (fst <$>) ∘ getNameInfo [] True False
206 -- |Get the 'Method' value of the request.
207 getMethod ∷ Rsrc Method
208 getMethod = reqMethod <$> getRequest
210 -- |Get the URI of the request.
211 getRequestURI ∷ Rsrc URI
212 getRequestURI = reqURI <$> getRequest
214 -- |Get the HTTP version of the request.
215 getRequestVersion ∷ Rsrc HttpVersion
216 getRequestVersion = reqVersion <$> getRequest
218 -- |This is an analogy of CGI PATH_INFO. 'getPathInfo' always returns
219 -- @[]@ if the corresponding 'Resource' is not greedy. See
220 -- 'getResourcePath'.
222 -- Note that the returned path components are URI-decoded.
223 getPathInfo ∷ Rsrc [Strict.ByteString]
224 getPathInfo = do rsrcPath ← getResourcePath
225 reqPath ← uriPathSegments <$> getRequestURI
226 return $ drop (length rsrcPath) reqPath
228 -- |Assume the query part of request URI as
229 -- application\/x-www-form-urlencoded, and parse it into pairs of
230 -- @(name, formData)@. This function doesn't read the request
232 getQueryForm ∷ Rsrc [(Strict.ByteString, FormData)]
233 getQueryForm = parse' <$> getRequestURI
235 parse' = map toPairWithFormData ∘
236 parseWWWFormURLEncoded ∘
241 toPairWithFormData ∷ (ByteString, ByteString) → (Strict.ByteString, FormData)
242 toPairWithFormData (name, value)
243 = let fd = FormData {
245 , fdMIMEType = [mimeType| text/plain |]
246 , fdContent = Lazy.fromChunks [value]
250 -- |@'getHeader' name@ returns the value of the request header field
251 -- @name@. Comparison of header name is case-insensitive. Note that
252 -- this function is not intended to be used so frequently: there
253 -- should be functions like 'getContentType' for every common headers.
254 getHeader ∷ CIAscii → Rsrc (Maybe Ascii)
256 = H.getHeader name <$> getRequest
258 -- |Return the list of 'MIMEType' enumerated on the value of request
259 -- header \"Accept\", or @[]@ if absent.
260 getAccept ∷ Rsrc [MIMEType]
262 = do acceptM ← getHeader "Accept"
267 → case P.parseOnly (finishOff parser) (cs accept) of
269 Left _ → abort $ mkAbortion' BadRequest
270 $ "Unparsable Accept: " ⊕ cs accept
272 -- |Return the list of @(contentCoding, qvalue)@ enumerated on the
273 -- value of request header \"Accept-Encoding\". The list is sorted in
274 -- descending order by qvalue.
275 getAcceptEncoding ∷ Rsrc [(CIAscii, Maybe Double)]
277 = do accEncM ← getHeader "Accept-Encoding"
280 -- HTTP/1.0 には Accept-Encoding が無い場合の規定が無い
281 -- ので安全の爲 identity が指定された事にする。HTTP/1.1
282 -- の場合は何でも受け入れて良い事になってゐるので "*" が
284 → do ver ← getRequestVersion
286 HttpVersion 1 0 → return [("identity", Nothing)]
287 HttpVersion 1 1 → return [("*" , Nothing)]
288 _ → abort $ mkAbortion' InternalServerError
289 "getAcceptEncoding: unknown HTTP version"
293 return [("identity", Nothing)]
295 case P.parseOnly (finishOff parser) (cs ae) of
296 Right xs → return $ map toTuple $ reverse $ sort xs
297 Left _ → abort $ mkAbortion' BadRequest
298 $ "Unparsable Accept-Encoding: " ⊕ cs ae
300 toTuple (AcceptEncoding {..})
301 = (aeEncoding, aeQValue)
303 -- |Return 'True' iff a given content-coding is acceptable by the
305 isEncodingAcceptable ∷ CIAscii → Rsrc Bool
306 isEncodingAcceptable encoding = any doesMatch <$> getAcceptEncoding
308 doesMatch ∷ (CIAscii, Maybe Double) → Bool
309 doesMatch (e, q) = (e ≡ "*" ∨ e ≡ encoding) ∧ q ≢ Just 0
311 -- |Return the value of request header \"Content-Type\" as 'MIMEType'.
312 getContentType ∷ Rsrc (Maybe MIMEType)
314 = do cTypeM ← getHeader "Content-Type"
319 → case P.parseOnly (finishOff parser) (cs cType) of
320 Right t → return $ Just t
321 Left _ → abort $ mkAbortion' BadRequest
322 $ "Unparsable Content-Type: " ⊕ cs cType
324 -- |Return the value of request header \"Authorization\" as
326 getAuthorization ∷ Rsrc (Maybe AuthCredential)
328 = do authM ← getHeader "Authorization"
333 → case P.parseOnly (finishOff parser) (cs auth) of
334 Right ac → return $ Just ac
335 Left _ → return Nothing
337 -- |Tell the system that the 'Rsrc' found an entity for the request
338 -- URI. If this is a GET or HEAD request, a found entity means a datum
339 -- to be replied. If this is a PUT or DELETE request, it means a datum
340 -- which was stored for the URI until now. For POST requests it raises
343 -- 'foundEntity' performs \"If-Match\" test or \"If-None-Match\" test
344 -- whenever possible, and if those tests fail, it immediately aborts
345 -- with status \"412 Precondition Failed\" or \"304 Not Modified\"
346 -- depending on the situation.
348 -- If the request method is either GET or HEAD, 'foundEntity'
349 -- automatically puts \"ETag\" and \"Last-Modified\" headers into the
351 foundEntity ∷ ETag → UTCTime → Rsrc ()
352 foundEntity tag timeStamp
353 = do driftTo ExaminingRequest
356 when (method ≡ GET ∨ method ≡ HEAD)
357 $ setHeader "Last-Modified"
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 parser) (cs value) of
398 -- tags の中に一致するものが無ければ
399 -- PreconditionFailed で終了。
400 → when ((¬) (any (≡ tag) (tags ∷ [ETag])))
402 $ mkAbortion' PreconditionFailed
403 $ "The entity tag doesn't match: " ⊕ cs value
405 → abort $ mkAbortion' BadRequest
406 $ "Unparsable If-Match: " ⊕ cs value
408 let statusForNoneMatch
409 = if method ≡ GET ∨ method ≡ HEAD then
410 fromStatusCode NotModified
412 fromStatusCode PreconditionFailed
414 -- If-None-Match があればそれを見る。
415 ifNoneMatch ← getHeader "If-None-Match"
420 → if value ≡ "*" then
421 abort $ mkAbortion' statusForNoneMatch
422 $ "The entity tag matches: *"
424 case P.parseOnly (finishOff parser) (cs value) of
426 → when (any (≡ tag) (tags ∷ [ETag]))
428 $ mkAbortion' statusForNoneMatch
429 $ "The entity tag matches: " ⊕ cs value
431 → abort $ mkAbortion' BadRequest
432 $ "Unparsable If-None-Match: " ⊕ cs value
434 driftTo ReceivingBody
436 -- |Tell the system that the 'Rsrc' found an entity for the
437 -- request URI. The only difference from 'foundEntity' is that
438 -- 'foundTimeStamp' performs \"If-Modified-Since\" test or
439 -- \"If-Unmodified-Since\" test instead of \"If-Match\" test or
440 -- \"If-None-Match\" test. Be aware that any tests based on a last
441 -- modification time are unsafe because it is possible to mess up such
442 -- tests by modifying the entity twice in a second.
444 -- Using this function is discouraged. You should use 'foundEntity'
445 -- whenever possible.
446 foundTimeStamp ∷ UTCTime → Rsrc ()
447 foundTimeStamp timeStamp
448 = do driftTo ExaminingRequest
451 when (method ≡ GET ∨ method ≡ HEAD)
452 $ setHeader "Last-Modified"
457 $ mkAbortion' InternalServerError
458 "Illegal call of foundTimeStamp for POST request."
460 let statusForIfModSince
461 = if method ≡ GET ∨ method ≡ HEAD then
462 fromStatusCode NotModified
464 fromStatusCode PreconditionFailed
466 ifModSince ← getHeader "If-Modified-Since"
468 Just str → case fromAttempt $ ca (Tagged str ∷ Tagged HTTP Ascii) of
470 → when (timeStamp ≤ lastTime)
472 $ mkAbortion' statusForIfModSince
473 $ "The entity has not been modified since " ⊕ cs str
475 → abort $ mkAbortion' BadRequest
476 $ "Malformed If-Modified-Since: " ⊕ cs str
479 ifUnmodSince ← getHeader "If-Unmodified-Since"
481 Just str → case fromAttempt $ ca (Tagged str ∷ Tagged HTTP Ascii) of
483 → when (timeStamp > lastTime)
485 $ mkAbortion' PreconditionFailed
486 $ "The entity has not been modified since " ⊕ cs str
488 → abort $ mkAbortion' BadRequest
489 $ "Malformed If-Unmodified-Since: " ⊕ cs str
492 driftTo ReceivingBody
494 -- |@'foundNoEntity' mStr@ tells the system that the 'Rsrc' found no
495 -- entity for the request URI. @mStr@ is an optional error message to
496 -- 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 → Rsrc ()
504 = do driftTo ExaminingRequest
509 $ mkAbortion NotFound [] msgM
511 -- エンティティが存在しないと云ふ事は、"*" も含めたどのやうな
512 -- If-Match: 條件も滿たさない。
513 ifMatch ← getHeader "If-Match"
514 when (ifMatch ≢ Nothing)
516 $ mkAbortion PreconditionFailed [] msgM
518 driftTo ReceivingBody
520 -- |'foundNoEntity'' is the same as @'foundNoEntity' 'Nothing'@.
521 foundNoEntity' ∷ Rsrc ()
522 {-# INLINE foundNoEntity' #-}
523 foundNoEntity' = foundNoEntity Nothing
525 -- |@'getChunks' limit@ attemts to read the entire request body up to
526 -- @limit@ bytes, and then make the 'Rsrc' transit to the /Deciding
527 -- Header/ state. When the actual size of the body is larger than
528 -- @limit@ bytes, 'getChunks' immediately aborts with status \"413
529 -- Request Entity Too Large\". When the request has no body, it
530 -- returns an empty string.
532 -- When the @limit@ is 'Nothing', 'getChunks' uses the default
533 -- limitation value ('cnfMaxEntityLength') instead.
535 -- 'getChunks' returns a lazy 'Lazy.ByteString' but it's not really
536 -- lazy: reading from the socket just happens at the computation of
537 -- 'getChunks', not at the evaluation of the 'Lazy.ByteString'.
538 getChunks ∷ Maybe Int → Rsrc Lazy.ByteString
540 | n < 0 = fail ("getChunks: limit must not be negative: " ⧺ show n)
542 | otherwise = getChunks' n
544 = getConfig ≫= getChunks ∘ Just ∘ cnfMaxEntityLength
546 getChunks' ∷ Int → Rsrc Lazy.ByteString
547 getChunks' limit = go limit (∅)
549 go ∷ Int → Builder → Rsrc Lazy.ByteString
550 go 0 _ = do chunk ← getChunk 1
551 if Strict.null chunk then
554 abort $ mkAbortion' RequestEntityTooLarge
555 $ "Request body must be smaller than "
558 go !n !b = do c ← getChunk $ min n BB.defaultBufferSize
559 if Strict.null c then
561 return $ BB.toLazyByteString b
563 do let n' = n - Strict.length c
564 xs' = b ⊕ BB.fromByteString c
567 -- |@'getForm' limit@ attempts to read the request body with
568 -- 'getChunks' and parse it as @application\/x-www-form-urlencoded@ or
569 -- @multipart\/form-data@. If the request header \"Content-Type\" is
570 -- neither of them, 'getForm' aborts with status \"415 Unsupported
571 -- Media Type\". If the request has no \"Content-Type\", it aborts
572 -- with \"400 Bad Request\".
574 -- Note that there are currently a few limitations on parsing
575 -- @multipart/form-data@. See: 'parseMultipartFormData'
576 getForm ∷ Maybe Int → Rsrc [(Strict.ByteString, FormData)]
578 = do cTypeM ← getContentType
581 → abort $ mkAbortion' BadRequest "Missing Content-Type"
582 Just (MIMEType "application" "x-www-form-urlencoded" _)
583 → readWWWFormURLEncoded
584 Just (MIMEType "multipart" "form-data" params)
585 → readMultipartFormData params
587 → abort $ mkAbortion' UnsupportedMediaType
589 $ ("Unsupported media type: " ∷ Ascii)
592 readWWWFormURLEncoded
593 = (map toPairWithFormData ∘ parseWWWFormURLEncoded)
595 (bsToAscii =≪ getChunks limit)
598 = case convertAttemptVia ((⊥) ∷ ByteString) bs of
600 Failure e → abort $ mkAbortion' BadRequest $ cs (show e)
602 readMultipartFormData m
603 = case lookup "boundary" m of
605 → abort $ mkAbortion' BadRequest "Missing boundary of multipart/form-data"
607 → do src ← getChunks limit
608 b ← case ca boundary of
610 Failure _ → abort $ mkAbortion' BadRequest
611 $ "Malformed boundary: " ⊕ boundary
612 case parseMultipartFormData b src of
613 Right xs → return $ map (first cs) xs
614 Left err → abort $ mkAbortion' BadRequest $ cs err
616 -- |@'redirect' code uri@ declares the response status as @code@ and
617 -- \"Location\" header field as @uri@. The @code@ must satisfy
618 -- 'isRedirection' or it raises an error.
619 redirect ∷ StatusCode sc ⇒ sc → URI → Rsrc ()
621 = do when (sc ≈ NotModified ∨ (¬) (isRedirection sc))
623 $ mkAbortion' InternalServerError
625 $ ("Attempted to redirect with status " ∷ Ascii)
626 ⊕ cs (fromStatusCode sc)
630 -- |@'setContentType' mType@ declares the response header
631 -- \"Content-Type\" as @mType@. Declaring \"Content-Type\" is
632 -- mandatory for sending a response body.
633 setContentType ∷ MIMEType → Rsrc ()
634 setContentType = setHeader "Content-Type" ∘ cs
636 -- |@'setLocation' uri@ declares the response header \"Location\" as
637 -- @uri@. You usually don't need to call this function directly.
638 setLocation ∷ URI → Rsrc ()
641 Success a → setHeader "Location" a
642 Failure e → abort $ mkAbortion' InternalServerError
645 uriStr = uriToString id uri ""
647 -- |@'setContentEncoding' codings@ declares the response header
648 -- \"Content-Encoding\" as @codings@.
649 setContentEncoding ∷ [CIAscii] → Rsrc ()
650 setContentEncoding codings
651 = do ver ← getRequestVersion
653 HttpVersion 1 0 → return (toAB ∘ unnormalizeCoding)
654 HttpVersion 1 1 → return toAB
655 _ → abort $ mkAbortion' InternalServerError
656 "setContentEncoding: Unknown HTTP version"
657 setHeader "Content-Encoding"
660 $ intersperse (cs (", " ∷ Ascii))
663 toAB ∷ ConvertSuccess α AsciiBuilder ⇒ α → AsciiBuilder
666 -- |@'setWWWAuthenticate' challenge@ declares the response header
667 -- \"WWW-Authenticate\" as @challenge@.
668 setWWWAuthenticate ∷ AuthChallenge → Rsrc ()
669 setWWWAuthenticate = setHeader "WWW-Authenticate" ∘ cs
671 -- |Write a chunk in 'Strict.ByteString' to the response body. You
672 -- must first declare the response header \"Content-Type\" before
673 -- applying this function. See 'setContentType'.
674 putChunk ∷ Strict.ByteString → Rsrc ()
675 putChunk = putBuilder ∘ BB.fromByteString
677 -- |Write a chunk in lazy 'Lazy.ByteString' to the response body. It
678 -- can be safely applied to an infinitely long 'Lazy.ByteString'.
680 -- Note that you must first declare the response header
681 -- \"Content-Type\" before applying this function. See
683 putChunks ∷ Lazy.ByteString → Rsrc ()
684 putChunks = putBuilder ∘ BB.fromLazyByteString