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
153 import qualified Data.Attoparsec.Char8 as P
154 import Data.ByteString (ByteString)
155 import qualified Data.ByteString as Strict
156 import qualified Data.ByteString.Lazy as Lazy
157 import Data.Collections
158 import Data.Convertible.Base
159 import Data.List (intersperse, sort)
162 import Data.Monoid.Unicode
165 import Data.Text (Text)
166 import qualified Data.Text as T
168 import Data.Time.Format.HTTP
169 import Network.HTTP.Lucu.Abortion
170 import Network.HTTP.Lucu.Authentication
171 import Network.HTTP.Lucu.Config
172 import Network.HTTP.Lucu.ContentCoding
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.Parser
179 import Network.HTTP.Lucu.Request
180 import Network.HTTP.Lucu.Resource.Internal
181 import Network.HTTP.Lucu.Response
182 import Network.HTTP.Lucu.MIMEType (MIMEType(..))
183 import qualified Network.HTTP.Lucu.MIMEType as MT
184 import Network.HTTP.Lucu.MIMEType.TH
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 ∘
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 MT.mimeTypeList) (A.toByteString accept) of
270 Left _ → abort $ mkAbortion' BadRequest
271 $ "Unparsable Accept: " ⊕ A.toText 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 acceptEncodingList) (A.toByteString ae) of
297 Right xs → return $ map toTuple $ reverse $ sort xs
298 Left _ → abort $ mkAbortion' BadRequest
299 $ "Unparsable Accept-Encoding: " ⊕ A.toText 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 MT.mimeType) (A.toByteString cType) of
321 Right t → return $ Just t
322 Left _ → abort $ mkAbortion' BadRequest
323 $ "Unparsable Content-Type: " ⊕ A.toText 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 authCredential) (A.toByteString 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"
363 $ mkAbortion' InternalServerError
364 "foundEntity: this is a POST request."
367 driftTo ReceivingBody
369 -- |Tell the system that the 'Rsrc' found an entity for the request
370 -- URI. The only difference from 'foundEntity' is that 'foundETag'
371 -- doesn't (nor can't) put \"Last-Modified\" header into the response.
373 -- Using this function is discouraged. You should use 'foundEntity'
374 -- whenever possible.
375 foundETag ∷ ETag → Rsrc ()
377 = do driftTo ExaminingRequest
380 when (method ≡ GET ∨ method ≡ HEAD)
386 $ mkAbortion' InternalServerError
387 "Illegal computation of foundETag for POST request."
389 -- If-Match があればそれを見る。
390 ifMatch ← getHeader "If-Match"
395 → if value ≡ "*" then
398 case P.parseOnly (finishOff eTagList) (A.toByteString value) of
400 -- tags の中に一致するものが無ければ
401 -- PreconditionFailed で終了。
402 → when ((¬) (any (≡ tag) tags))
404 $ mkAbortion' PreconditionFailed
405 $ "The entity tag doesn't match: " ⊕ A.toText value
407 → abort $ mkAbortion' BadRequest
408 $ "Unparsable If-Match: " ⊕ A.toText value
410 let statusForNoneMatch
411 = if method ≡ GET ∨ method ≡ HEAD then
412 fromStatusCode NotModified
414 fromStatusCode PreconditionFailed
416 -- If-None-Match があればそれを見る。
417 ifNoneMatch ← getHeader "If-None-Match"
422 → if value ≡ "*" then
423 abort $ mkAbortion' statusForNoneMatch
424 $ "The entity tag matches: *"
426 case P.parseOnly (finishOff eTagList) (A.toByteString value) of
428 → when (any (≡ tag) tags)
430 $ mkAbortion' statusForNoneMatch
431 $ "The entity tag matches: " ⊕ A.toText value
433 → abort $ mkAbortion' BadRequest
434 $ "Unparsable If-None-Match: " ⊕ A.toText value
436 driftTo ReceivingBody
438 -- |Tell the system that the 'Rsrc' found an entity for the
439 -- request URI. The only difference from 'foundEntity' is that
440 -- 'foundTimeStamp' performs \"If-Modified-Since\" test or
441 -- \"If-Unmodified-Since\" test instead of \"If-Match\" test or
442 -- \"If-None-Match\" test. Be aware that any tests based on a last
443 -- modification time are unsafe because it is possible to mess up such
444 -- tests by modifying the entity twice in a second.
446 -- Using this function is discouraged. You should use 'foundEntity'
447 -- whenever possible.
448 foundTimeStamp ∷ UTCTime → Rsrc ()
449 foundTimeStamp timeStamp
450 = do driftTo ExaminingRequest
453 when (method ≡ GET ∨ method ≡ HEAD)
454 $ setHeader "Last-Modified"
459 $ mkAbortion' InternalServerError
460 "Illegal call of foundTimeStamp for POST request."
462 let statusForIfModSince
463 = if method ≡ GET ∨ method ≡ HEAD then
464 fromStatusCode NotModified
466 fromStatusCode PreconditionFailed
468 ifModSince ← getHeader "If-Modified-Since"
470 Just str → case fromAttempt $ ca (Tagged str ∷ Tagged HTTP Ascii) of
472 → when (timeStamp ≤ lastTime)
474 $ mkAbortion' statusForIfModSince
475 $ "The entity has not been modified since " ⊕ A.toText str
477 → abort $ mkAbortion' BadRequest
478 $ "Malformed If-Modified-Since: " ⊕ A.toText str
481 ifUnmodSince ← getHeader "If-Unmodified-Since"
483 Just str → case fromAttempt $ ca (Tagged str ∷ Tagged HTTP Ascii) of
485 → when (timeStamp > lastTime)
487 $ mkAbortion' PreconditionFailed
488 $ "The entity has not been modified since " ⊕ A.toText str
490 → abort $ mkAbortion' BadRequest
491 $ "Malformed If-Unmodified-Since: " ⊕ A.toText str
494 driftTo ReceivingBody
496 -- |@'foundNoEntity' mStr@ tells the system that the 'Rsrc' found no
497 -- entity for the request URI. @mStr@ is an optional error message to
498 -- be replied to the client.
500 -- If the request method is PUT, 'foundNoEntity' performs \"If-Match\"
501 -- test and when that fails it aborts with status \"412 Precondition
502 -- Failed\". If the request method is GET, HEAD, POST or DELETE,
503 -- 'foundNoEntity' always aborts with status \"404 Not Found\".
504 foundNoEntity ∷ Maybe Text → Rsrc ()
506 = do driftTo ExaminingRequest
511 $ mkAbortion NotFound [] msgM
513 -- エンティティが存在しないと云ふ事は、"*" も含めたどのやうな
514 -- If-Match: 條件も滿たさない。
515 ifMatch ← getHeader "If-Match"
516 when (ifMatch ≢ Nothing)
518 $ mkAbortion PreconditionFailed [] msgM
520 driftTo ReceivingBody
522 -- |'foundNoEntity'' is the same as @'foundNoEntity' 'Nothing'@.
523 foundNoEntity' ∷ Rsrc ()
524 {-# INLINE foundNoEntity' #-}
525 foundNoEntity' = foundNoEntity Nothing
527 -- |@'getChunks' limit@ attemts to read the entire request body up to
528 -- @limit@ bytes, and then make the 'Rsrc' transit to the /Deciding
529 -- Header/ state. When the actual size of the body is larger than
530 -- @limit@ bytes, 'getChunks' immediately aborts with status \"413
531 -- Request Entity Too Large\". When the request has no body, it
532 -- returns an empty string.
534 -- When the @limit@ is 'Nothing', 'getChunks' uses the default
535 -- limitation value ('cnfMaxEntityLength') instead.
537 -- 'getChunks' returns a lazy 'Lazy.ByteString' but it's not really
538 -- lazy: reading from the socket just happens at the computation of
539 -- 'getChunks', not at the evaluation of the 'Lazy.ByteString'.
540 getChunks ∷ Maybe Int → Rsrc Lazy.ByteString
542 | n < 0 = fail ("getChunks: limit must not be negative: " ⧺ show n)
544 | otherwise = getChunks' n
546 = getConfig ≫= getChunks ∘ Just ∘ cnfMaxEntityLength
548 getChunks' ∷ Int → Rsrc Lazy.ByteString
549 getChunks' limit = go limit (∅)
551 go ∷ Int → Builder → Rsrc Lazy.ByteString
552 go 0 _ = do chunk ← getChunk 1
553 if Strict.null chunk then
556 abort $ mkAbortion' RequestEntityTooLarge
557 $ "Request body must be smaller than "
558 ⊕ T.pack (show limit)
560 go !n !b = do c ← getChunk $ min n BB.defaultBufferSize
561 if Strict.null c then
563 return $ BB.toLazyByteString b
565 do let n' = n - Strict.length c
566 xs' = b ⊕ BB.fromByteString c
569 -- |@'getForm' limit@ attempts to read the request body with
570 -- 'getChunks' and parse it as @application\/x-www-form-urlencoded@ or
571 -- @multipart\/form-data@. If the request header \"Content-Type\" is
572 -- neither of them, 'getForm' aborts with status \"415 Unsupported
573 -- Media Type\". If the request has no \"Content-Type\", it aborts
574 -- with \"400 Bad Request\".
576 -- Note that there are currently a few limitations on parsing
577 -- @multipart/form-data@. See: 'parseMultipartFormData'
578 getForm ∷ Maybe Int → Rsrc [(Strict.ByteString, FormData)]
580 = do cTypeM ← getContentType
583 → abort $ mkAbortion' BadRequest "Missing Content-Type"
584 Just (MIMEType "application" "x-www-form-urlencoded" _)
585 → readWWWFormURLEncoded
586 Just (MIMEType "multipart" "form-data" params)
587 → readMultipartFormData params
589 → abort $ mkAbortion' UnsupportedMediaType
591 $ ("Unsupported media type: " ∷ Ascii)
594 readWWWFormURLEncoded
595 = (map toPairWithFormData ∘ parseWWWFormURLEncoded)
597 (bsToAscii =≪ getChunks limit)
600 = case A.fromByteString (Strict.concat (Lazy.toChunks bs)) of
602 Nothing → abort $ mkAbortion' BadRequest "Malformed x-www-form-urlencoded"
604 readMultipartFormData m
605 = case lookup "boundary" m of
607 → abort $ mkAbortion' BadRequest "Missing boundary of multipart/form-data"
609 → do src ← getChunks limit
610 b ← case A.fromText boundary of
612 Nothing → abort $ mkAbortion' BadRequest
613 $ "Malformed boundary: " ⊕ boundary
614 case parseMultipartFormData b src of
615 Right xs → return $ map (first A.toByteString) xs
616 Left err → abort $ mkAbortion' BadRequest $ T.pack err
618 -- |@'redirect' code uri@ declares the response status as @code@ and
619 -- \"Location\" header field as @uri@. The @code@ must satisfy
620 -- 'isRedirection' or it raises an error.
621 redirect ∷ StatusCode sc ⇒ sc → URI → Rsrc ()
623 = do when (sc ≈ NotModified ∨ (¬) (isRedirection sc))
625 $ mkAbortion' InternalServerError
628 $ A.toAsciiBuilder "Attempted to redirect with status "
633 -- |@'setContentType' mType@ declares the response header
634 -- \"Content-Type\" as @mType@. Declaring \"Content-Type\" is
635 -- mandatory for sending a response body.
636 setContentType ∷ MIMEType → Rsrc ()
637 setContentType = setHeader "Content-Type" ∘ cs
639 -- |@'setLocation' uri@ declares the response header \"Location\" as
640 -- @uri@. You usually don't need to call this function directly.
641 setLocation ∷ URI → Rsrc ()
643 = case A.fromChars uriStr of
644 Just a → setHeader "Location" a
645 Nothing → abort $ mkAbortion' InternalServerError
646 $ "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] → Rsrc ()
653 setContentEncoding codings
654 = do ver ← getRequestVersion
656 HttpVersion 1 0 → return (toAB ∘ unnormalizeCoding)
657 HttpVersion 1 1 → return toAB
658 _ → abort $ mkAbortion' InternalServerError
659 "setContentEncoding: Unknown HTTP version"
660 setHeader "Content-Encoding"
663 $ intersperse (A.toAsciiBuilder ", ")
666 toAB = A.toAsciiBuilder ∘ A.fromCIAscii
668 -- |@'setWWWAuthenticate' challenge@ declares the response header
669 -- \"WWW-Authenticate\" as @challenge@.
670 setWWWAuthenticate ∷ AuthChallenge → Rsrc ()
671 setWWWAuthenticate = setHeader "WWW-Authenticate" ∘ cs
673 -- |Write a chunk in 'Strict.ByteString' to the response body. You
674 -- must first declare the response header \"Content-Type\" before
675 -- applying this function. See 'setContentType'.
676 putChunk ∷ Strict.ByteString → Rsrc ()
677 putChunk = putBuilder ∘ BB.fromByteString
679 -- |Write a chunk in lazy 'Lazy.ByteString' to the response body. It
680 -- can be safely applied to an infinitely long 'Lazy.ByteString'.
682 -- Note that you must first declare the response header
683 -- \"Content-Type\" before applying this function. See
685 putChunks ∷ Lazy.ByteString → Rsrc ()
686 putChunks = putBuilder ∘ BB.fromLazyByteString