3 , GeneralizedNewtypeDeriving
9 -- |This is the Resource Monad; monadic actions to define a behavior
10 -- of resource. The 'Resource' Monad is a kind of 'IO' Monad thus it
11 -- implements 'MonadIO' class, and it is a state machine as well.
13 -- Request Processing Flow:
15 -- 1. A client issues an HTTP request.
17 -- 2. If the URI of it matches to any resource, the corresponding
18 -- 'Resource' Monad starts running on a newly spawned thread.
20 -- 3. The 'Resource' Monad looks at request headers, find (or not
21 -- find) an entity, receive the request body (if any), send
22 -- response headers, and then send a response body. This process
23 -- will be discussed later.
25 -- 4. The 'Resource' Monad and its thread stops running. The client
26 -- may or may not be sending us the next request at this point.
28 -- 'Resource' Monad takes the following states. The initial state is
29 -- /Examining Request/ and the final state is /Done/.
31 -- [/Examining Request/] In this state, a 'Resource' looks at the
32 -- request header fields and thinks about the corresponding entity
33 -- for it. If there is a suitable entity, the 'Resource' tells the
34 -- system an entity tag and its last modification time
35 -- ('foundEntity'). If it found no entity, it tells the system so
36 -- ('foundNoEntity'). In case it is impossible to decide the
37 -- existence of entity, which is a typical case for POST requests,
38 -- 'Resource' does nothing in this state.
40 -- [/Receiving Body/] A 'Resource' asks the system to receive a
41 -- request body from the client. Before actually reading from the
42 -- socket, the system sends \"100 Continue\" to the client if need
43 -- be. When a 'Resource' transits to the next state without
44 -- receiving all or part of a request body, the system automatically
47 -- [/Deciding Header/] A 'Resource' makes a decision of response
48 -- status code and header fields. When it transits to the next
49 -- state, the system validates and completes the header fields and
50 -- then sends them to the client.
52 -- [/Sending Body/] In this state, a 'Resource' asks the system to
53 -- write some response body to the socket. When it transits to the
54 -- next state without writing any response body, the system
55 -- automatically completes it depending on the status code. (To be
56 -- exact, such completion only occurs when the 'Resource' transits
57 -- to this state without even declaring the \"Content-Type\" header
58 -- field. See: 'setContentType')
60 -- [/Done/] Everything is over. A 'Resource' can do nothing for the
61 -- HTTP interaction anymore.
63 -- Note that the state transition is one-way: for instance, it is an
64 -- error to try to read a request body after writing some
65 -- response. This limitation is for efficiency. We don't want to read
66 -- the entire request before starting 'Resource', nor we don't want to
67 -- postpone writing the entire response till the end of 'Resource'
69 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 'Resource'.
84 , getRemoteCertificate
95 , isEncodingAcceptable
99 -- * Finding an entity
100 -- |These functions can be called only in the /Examining Request/
101 -- state. They make the 'Resource' transit to the /Receiving Body/
109 -- * Receiving a request body
110 -- |These functions make the 'Resource' transit to the /Receiving
116 -- * Declaring response status and header fields
117 -- |These functions can be called at any time before transiting to
118 -- the /Sending Body/ state, but they themselves never causes any
119 -- state transitions.
126 -- ** Less frequently used functions
131 -- * Sending a response body
133 -- |These functions make the 'Resource' transit to the
134 -- /Sending Body/ state.
140 import Blaze.ByteString.Builder (Builder)
141 import qualified Blaze.ByteString.Builder as BB
142 import qualified Blaze.ByteString.Builder.Internal as BB
143 import Control.Applicative
146 import Control.Monad.IO.Class
147 import Control.Monad.Unicode
148 import Data.Ascii (Ascii, CIAscii)
149 import qualified Data.Ascii as A
150 import qualified Data.Attoparsec.Char8 as P
151 import Data.ByteString (ByteString)
152 import qualified Data.ByteString as Strict
153 import qualified Data.ByteString.Lazy as Lazy
155 import qualified Data.Map as M
158 import Data.Monoid.Unicode
159 import Data.Text (Text)
160 import qualified Data.Text as T
162 import qualified Data.Time.HTTP as HTTP
163 import Network.HTTP.Lucu.Abortion
164 import Network.HTTP.Lucu.Authentication
165 import Network.HTTP.Lucu.Config
166 import Network.HTTP.Lucu.ContentCoding
167 import Network.HTTP.Lucu.ETag
168 import qualified Network.HTTP.Lucu.Headers as H
169 import Network.HTTP.Lucu.HttpVersion
170 import Network.HTTP.Lucu.Interaction
171 import Network.HTTP.Lucu.MultipartForm
172 import Network.HTTP.Lucu.Parser
173 import Network.HTTP.Lucu.Request
174 import Network.HTTP.Lucu.Resource.Internal
175 import Network.HTTP.Lucu.Response
176 import Network.HTTP.Lucu.MIMEType
177 import Network.HTTP.Lucu.Utils
178 import Network.Socket hiding (accept)
179 import Network.URI hiding (path)
180 import Prelude.Unicode
182 -- |Get the string representation of the address of remote host. If
183 -- you want a 'SockAddr' instead of 'HostName', use 'getRemoteAddr'.
184 getRemoteAddr' ∷ Resource HostName
185 getRemoteAddr' = liftIO ∘ toNM =≪ getRemoteAddr
187 toNM ∷ SockAddr → IO HostName
188 toNM = (fromJust ∘ fst <$>) ∘ getNameInfo [NI_NUMERICHOST] True False
190 -- |Resolve an address to the remote host.
191 getRemoteHost ∷ Resource (Maybe HostName)
192 getRemoteHost = liftIO ∘ getHN =≪ getRemoteAddr
194 getHN ∷ SockAddr → IO (Maybe HostName)
195 getHN = (fst <$>) ∘ getNameInfo [] True False
197 -- |Get the 'Method' value of the request.
198 getMethod ∷ Resource Method
199 getMethod = reqMethod <$> getRequest
201 -- |Get the URI of the request.
202 getRequestURI ∷ Resource URI
203 getRequestURI = reqURI <$> getRequest
205 -- |Get the HTTP version of the request.
206 getRequestVersion ∷ Resource HttpVersion
207 getRequestVersion = reqVersion <$> getRequest
209 -- |This is an analogy of CGI PATH_INFO. 'getPathInfo' always returns
210 -- @[]@ if the corresponding
211 -- 'Network.HTTP.Lucu.Resource.Tree.ResourceDef' is not greedy. See:
214 -- Note that the returned path components are URI-decoded.
215 getPathInfo ∷ Resource [Strict.ByteString]
216 getPathInfo = do rsrcPath ← getResourcePath
217 reqPath ← splitPathInfo <$> getRequestURI
218 return $ drop (length rsrcPath) reqPath
220 -- |Assume the query part of request URI as
221 -- application\/x-www-form-urlencoded, and parse it into pairs of
222 -- @(name, formData)@. This function doesn't read the request
224 getQueryForm ∷ Resource [(Strict.ByteString, FormData)]
225 getQueryForm = parse' <$> getRequestURI
227 parse' = map toPairWithFormData ∘
228 parseWWWFormURLEncoded ∘
234 toPairWithFormData ∷ (ByteString, ByteString) → (Strict.ByteString, FormData)
235 toPairWithFormData (name, value)
236 = let fd = FormData {
238 , fdMIMEType = parseMIMEType "text/plain"
239 , fdContent = Lazy.fromChunks [value]
243 -- |@'getHeader' name@ returns the value of the request header field
244 -- @name@. Comparison of header name is case-insensitive. Note that
245 -- this function is not intended to be used so frequently: there
246 -- should be functions like 'getContentType' for every common headers.
247 getHeader ∷ CIAscii → Resource (Maybe Ascii)
249 = H.getHeader name <$> getRequest
251 -- |Return the list of 'MIMEType' enumerated on the value of request
252 -- header \"Accept\", or @[]@ if absent.
253 getAccept ∷ Resource [MIMEType]
255 = do acceptM ← getHeader "Accept"
260 → case P.parseOnly (finishOff mimeTypeList) (A.toByteString accept) of
262 Left _ → abort $ mkAbortion' BadRequest
263 $ "Unparsable Accept: " ⊕ A.toText accept
265 -- |Return the list of @(contentCoding, qvalue)@ enumerated on the
266 -- value of request header \"Accept-Encoding\". The list is sorted in
267 -- descending order by qvalue.
268 getAcceptEncoding ∷ Resource [(CIAscii, Maybe Double)]
270 = do accEncM ← getHeader "Accept-Encoding"
273 -- HTTP/1.0 には Accept-Encoding が無い場合の規定が無い
274 -- ので安全の爲 identity が指定された事にする。HTTP/1.1
275 -- の場合は何でも受け入れて良い事になってゐるので "*" が
277 → do ver ← getRequestVersion
279 HttpVersion 1 0 → return [("identity", Nothing)]
280 HttpVersion 1 1 → return [("*" , Nothing)]
281 _ → abort $ mkAbortion' InternalServerError
282 "getAcceptEncoding: unknown HTTP version"
286 return [("identity", Nothing)]
288 case P.parseOnly (finishOff acceptEncodingList) (A.toByteString ae) of
289 Right xs → return $ map toTuple $ reverse $ sort xs
290 Left _ → abort $ mkAbortion' BadRequest
291 $ "Unparsable Accept-Encoding: " ⊕ A.toText ae
293 toTuple (AcceptEncoding {..})
294 = (aeEncoding, aeQValue)
296 -- |Return 'True' iff a given content-coding is acceptable by the
298 isEncodingAcceptable ∷ CIAscii → Resource Bool
299 isEncodingAcceptable encoding = any doesMatch <$> getAcceptEncoding
301 doesMatch ∷ (CIAscii, Maybe Double) → Bool
302 doesMatch (e, q) = (e ≡ "*" ∨ e ≡ encoding) ∧ q ≢ Just 0
304 -- |Return the value of request header \"Content-Type\" as 'MIMEType'.
305 getContentType ∷ Resource (Maybe MIMEType)
307 = do cTypeM ← getHeader "Content-Type"
312 → case P.parseOnly (finishOff mimeType) (A.toByteString cType) of
313 Right t → return $ Just t
314 Left _ → abort $ mkAbortion' BadRequest
315 $ "Unparsable Content-Type: " ⊕ A.toText cType
317 -- |Return the value of request header \"Authorization\" as
319 getAuthorization ∷ Resource (Maybe AuthCredential)
321 = do authM ← getHeader "Authorization"
326 → case P.parseOnly (finishOff authCredential) (A.toByteString auth) of
327 Right ac → return $ Just ac
328 Left _ → return Nothing
330 -- |Tell the system that the 'Resource' found an entity for the
331 -- request URI. If this is a GET or HEAD request, a found entity means
332 -- a datum to be replied. If this is a PUT or DELETE request, it means
333 -- a datum which was stored for the URI until now. For POST requests
334 -- it raises an error.
336 -- 'foundEntity' performs \"If-Match\" test or \"If-None-Match\" test
337 -- whenever possible, and if those tests fail, it immediately aborts
338 -- with status \"412 Precondition Failed\" or \"304 Not Modified\"
339 -- depending on the situation.
341 -- If the request method is either GET or HEAD, 'foundEntity'
342 -- automatically puts \"ETag\" and \"Last-Modified\" headers into the
344 foundEntity ∷ ETag → UTCTime → Resource ()
345 foundEntity tag timeStamp
346 = do driftTo ExaminingRequest
349 when (method ≡ GET ∨ method ≡ HEAD)
350 $ setHeader "Last-Modified" (HTTP.toAscii timeStamp)
353 $ mkAbortion' InternalServerError
354 "foundEntity: this is a POST request."
357 driftTo ReceivingBody
359 -- |Tell the system that the 'Resource' found an entity for the
360 -- request URI. The only difference from 'foundEntity' is that
361 -- 'foundETag' doesn't (nor can't) put \"Last-Modified\" header into
364 -- Using this function is discouraged. You should use 'foundEntity'
365 -- whenever possible.
366 foundETag ∷ ETag → Resource ()
368 = do driftTo ExaminingRequest
371 when (method ≡ GET ∨ method ≡ HEAD)
377 $ mkAbortion' InternalServerError
378 "Illegal computation of foundETag for POST request."
380 -- If-Match があればそれを見る。
381 ifMatch ← getHeader "If-Match"
386 → if value ≡ "*" then
389 case P.parseOnly (finishOff eTagList) (A.toByteString value) of
391 -- tags の中に一致するものが無ければ
392 -- PreconditionFailed で終了。
393 → when ((¬) (any (≡ tag) tags))
395 $ mkAbortion' PreconditionFailed
396 $ "The entity tag doesn't match: " ⊕ A.toText value
398 → abort $ mkAbortion' BadRequest
399 $ "Unparsable If-Match: " ⊕ A.toText value
401 let statusForNoneMatch
402 = if method ≡ GET ∨ method ≡ HEAD then
407 -- If-None-Match があればそれを見る。
408 ifNoneMatch ← getHeader "If-None-Match"
413 → if value ≡ "*" then
414 abort $ mkAbortion' statusForNoneMatch
415 $ "The entity tag matches: *"
417 case P.parseOnly (finishOff eTagList) (A.toByteString value) of
419 → when (any (≡ tag) tags)
421 $ mkAbortion' statusForNoneMatch
422 $ "The entity tag matches: " ⊕ A.toText value
424 → abort $ mkAbortion' BadRequest
425 $ "Unparsable If-None-Match: " ⊕ A.toText value
427 driftTo ReceivingBody
429 -- |Tell the system that the 'Resource' found an entity for the
430 -- request URI. The only difference from 'foundEntity' is that
431 -- 'foundTimeStamp' performs \"If-Modified-Since\" test or
432 -- \"If-Unmodified-Since\" test instead of \"If-Match\" test or
433 -- \"If-None-Match\" test. Be aware that any tests based on a last
434 -- modification time are unsafe because it is possible to mess up such
435 -- tests by modifying the entity twice in a second.
437 -- Using this function is discouraged. You should use 'foundEntity'
438 -- whenever possible.
439 foundTimeStamp ∷ UTCTime → Resource ()
440 foundTimeStamp timeStamp
441 = do driftTo ExaminingRequest
444 when (method ≡ GET ∨ method ≡ HEAD)
445 $ setHeader "Last-Modified" (HTTP.toAscii timeStamp)
448 $ mkAbortion' InternalServerError
449 "Illegal computation of foundTimeStamp for POST request."
451 let statusForIfModSince
452 = if method ≡ GET ∨ method ≡ HEAD then
457 -- If-Modified-Since があればそれを見る。
458 ifModSince ← getHeader "If-Modified-Since"
460 Just str → case HTTP.fromAscii str of
462 → when (timeStamp ≤ lastTime)
464 $ mkAbortion' statusForIfModSince
465 $ "The entity has not been modified since " ⊕ A.toText str
467 → return () -- 不正な時刻は無視
470 -- If-Unmodified-Since があればそれを見る。
471 ifUnmodSince ← getHeader "If-Unmodified-Since"
473 Just str → case HTTP.fromAscii str of
475 → when (timeStamp > lastTime)
477 $ mkAbortion' PreconditionFailed
478 $ "The entity has not been modified since " ⊕ A.toText str
480 → return () -- 不正な時刻は無視
483 driftTo ReceivingBody
485 -- |@'foundNoEntity' mStr@ tells the system that the 'Resource' found
486 -- no entity for the request URI. @mStr@ is an optional error message
487 -- to be replied to the client.
489 -- If the request method is PUT, 'foundNoEntity' performs \"If-Match\"
490 -- test and when that fails it aborts with status \"412 Precondition
491 -- Failed\". If the request method is GET, HEAD, POST or DELETE,
492 -- 'foundNoEntity' always aborts with status \"404 Not Found\".
493 foundNoEntity ∷ Maybe Text → Resource ()
495 = do driftTo ExaminingRequest
500 $ mkAbortion NotFound [] msgM
502 -- エンティティが存在しないと云ふ事は、"*" も含めたどのやうな
503 -- If-Match: 條件も滿たさない。
504 ifMatch ← getHeader "If-Match"
505 when (ifMatch ≢ Nothing)
507 $ mkAbortion PreconditionFailed [] msgM
509 driftTo ReceivingBody
511 -- |'foundNoEntity'' is the same as @'foundNoEntity' 'Nothing'@.
512 foundNoEntity' ∷ Resource ()
513 {-# INLINE foundNoEntity' #-}
514 foundNoEntity' = foundNoEntity Nothing
516 -- |@'getChunks' limit@ attemts to read the entire request body up to
517 -- @limit@ bytes, and then make the 'Resource' transit to the
518 -- /Deciding Header/ state. When the actual size of the body is larger
519 -- than @limit@ bytes, 'getChunks' immediately aborts with status
520 -- \"413 Request Entity Too Large\". When the request has no body, it
521 -- returns an empty string.
523 -- When the @limit@ is 'Nothing', 'getChunks' uses the default
524 -- limitation value ('cnfMaxEntityLength') instead.
526 -- 'getChunks' returns a lazy 'Lazy.ByteString' but it's not really
527 -- lazy: reading from the socket just happens at the computation of
528 -- 'getChunks', not at the evaluation of the 'Lazy.ByteString'.
529 getChunks ∷ Maybe Int → Resource Lazy.ByteString
531 | n < 0 = fail ("getChunks: limit must not be negative: " ⧺ show n)
533 | otherwise = getChunks' n
535 = getConfig ≫= getChunks ∘ Just ∘ cnfMaxEntityLength
537 getChunks' ∷ Int → Resource Lazy.ByteString
538 getChunks' limit = go limit (∅)
540 go ∷ Int → Builder → Resource Lazy.ByteString
541 go 0 _ = do chunk ← getChunk 1
542 if Strict.null chunk then
545 abort $ mkAbortion' RequestEntityTooLarge
546 $ "Request body must be smaller than "
547 ⊕ T.pack (show limit)
549 go !n !b = do c ← getChunk $ min n BB.defaultBufferSize
550 if Strict.null c then
552 return $ BB.toLazyByteString b
554 do let n' = n - Strict.length c
555 xs' = b ⊕ BB.fromByteString c
558 -- |@'getForm' limit@ attempts to read the request body with
559 -- 'getChunks' and parse it as @application\/x-www-form-urlencoded@ or
560 -- @multipart\/form-data@. If the request header \"Content-Type\" is
561 -- neither of them, 'getForm' aborts with status \"415 Unsupported
562 -- Media Type\". If the request has no \"Content-Type\", it aborts
563 -- with \"400 Bad Request\".
565 -- Note that there are currently a few limitations on parsing
566 -- @multipart/form-data@. See: 'parseMultipartFormData'
567 getForm ∷ Maybe Int → Resource [(Strict.ByteString, FormData)]
569 = do cTypeM ← getContentType
572 → abort $ mkAbortion' BadRequest "Missing Content-Type"
573 Just (MIMEType "application" "x-www-form-urlencoded" _)
574 → readWWWFormURLEncoded
575 Just (MIMEType "multipart" "form-data" params)
576 → readMultipartFormData params
578 → abort $ mkAbortion' UnsupportedMediaType
581 $ A.toAsciiBuilder "Unsupported media type: "
582 ⊕ printMIMEType cType
584 readWWWFormURLEncoded
585 = (map toPairWithFormData ∘ parseWWWFormURLEncoded)
587 (bsToAscii =≪ getChunks limit)
590 = case A.fromByteString (Strict.concat (Lazy.toChunks bs)) of
592 Nothing → abort $ mkAbortion' BadRequest "Malformed x-www-form-urlencoded"
594 readMultipartFormData params
595 = case M.lookup "boundary" params of
597 → abort $ mkAbortion' BadRequest "Missing boundary of multipart/form-data"
599 → do src ← getChunks limit
600 b ← case A.fromText boundary of
602 Nothing → abort $ mkAbortion' BadRequest
603 $ "Malformed boundary: " ⊕ boundary
604 case parseMultipartFormData b src of
605 Right xs → return $ map (first A.toByteString) xs
606 Left err → abort $ mkAbortion' BadRequest $ T.pack err
608 -- |@'redirect' code uri@ declares the response status as @code@ and
609 -- \"Location\" header field as @uri@. The @code@ must satisfy
610 -- 'isRedirection' or it raises an error.
611 redirect ∷ StatusCode → URI → Resource ()
613 = do when (code ≡ NotModified ∨ not (isRedirection code))
615 $ mkAbortion' InternalServerError
618 $ A.toAsciiBuilder "Attempted to redirect with status "
619 ⊕ printStatusCode code
623 -- |@'setContentType' mType@ declares the response header
624 -- \"Content-Type\" as @mType@. Declaring \"Content-Type\" is
625 -- mandatory for sending a response body.
626 setContentType ∷ MIMEType → Resource ()
628 = setHeader "Content-Type" ∘ A.fromAsciiBuilder ∘ printMIMEType
630 -- |@'setLocation' uri@ declares the response header \"Location\" as
631 -- @uri@. You usually don't need to call this function directly.
632 setLocation ∷ URI → Resource ()
634 = case A.fromChars uriStr of
635 Just a → setHeader "Location" a
636 Nothing → abort $ mkAbortion' InternalServerError
637 $ "Malformed URI: " ⊕ T.pack uriStr
639 uriStr = uriToString id uri ""
641 -- |@'setContentEncoding' codings@ declares the response header
642 -- \"Content-Encoding\" as @codings@.
643 setContentEncoding ∷ [CIAscii] → Resource ()
644 setContentEncoding codings
645 = do ver ← getRequestVersion
647 HttpVersion 1 0 → return (toAB ∘ unnormalizeCoding)
648 HttpVersion 1 1 → return toAB
649 _ → abort $ mkAbortion' InternalServerError
650 "setContentEncoding: Unknown HTTP version"
651 setHeader "Content-Encoding"
654 $ intersperse (A.toAsciiBuilder ", ")
657 toAB = A.toAsciiBuilder ∘ A.fromCIAscii
659 -- |@'setWWWAuthenticate' challenge@ declares the response header
660 -- \"WWW-Authenticate\" as @challenge@.
661 setWWWAuthenticate ∷ AuthChallenge → Resource ()
662 setWWWAuthenticate = setHeader "WWW-Authenticate" ∘ printAuthChallenge
664 -- |Write a chunk in 'Strict.ByteString' to the response body. You
665 -- must first declare the response header \"Content-Type\" before
666 -- applying this function. See: 'setContentType'
667 putChunk ∷ Strict.ByteString → Resource ()
668 putChunk = putBuilder ∘ BB.fromByteString
670 -- |Write a chunk in lazy 'Lazy.ByteString' to the response body. It
671 -- can be safely applied to an infinitely long 'Lazy.ByteString'.
673 -- Note that you must first declare the response header
674 -- \"Content-Type\" before applying this function. See:
676 putChunks ∷ Lazy.ByteString → Resource ()
677 putChunks = putBuilder ∘ BB.fromLazyByteString