3 , GeneralizedNewtypeDeriving
10 -- |This is the Resource Monad; monadic actions to define a behavior
11 -- of resource. The 'Resource' Monad is a kind of 'IO' Monad thus it
12 -- implements 'MonadIO' class, and it is a state machine as well.
14 -- Request Processing Flow:
16 -- 1. A client issues an HTTP request.
18 -- 2. If the URI of it matches to any resource, the corresponding
19 -- 'Resource' Monad starts running on a newly spawned thread.
21 -- 3. The 'Resource' Monad looks at request headers, find (or not
22 -- find) an entity, receive the request body (if any), send
23 -- response headers, and then send a response body. This process
24 -- will be discussed later.
26 -- 4. The 'Resource' Monad and its thread stops running. The client
27 -- may or may not be sending us the next request at this point.
29 -- 'Resource' Monad takes the following states. The initial state is
30 -- /Examining Request/ and the final state is /Done/.
32 -- [/Examining Request/] In this state, a 'Resource' looks at the
33 -- request header fields and thinks about the corresponding entity
34 -- for it. If there is a suitable entity, the 'Resource' tells the
35 -- system an entity tag and its last modification time
36 -- ('foundEntity'). If it found no entity, it tells the system so
37 -- ('foundNoEntity'). In case it is impossible to decide the
38 -- existence of entity, which is a typical case for POST requests,
39 -- 'Resource' does nothing in this state.
41 -- [/Receiving Body/] A 'Resource' asks the system to receive a
42 -- request body from the client. Before actually reading from the
43 -- socket, the system sends \"100 Continue\" to the client if need
44 -- be. When a 'Resource' transits to the next state without
45 -- receiving all or part of a request body, the system automatically
48 -- [/Deciding Header/] A 'Resource' makes a decision of response
49 -- status code and header fields. When it transits to the next
50 -- state, the system validates and completes the header fields and
51 -- then sends them to the client.
53 -- [/Sending Body/] In this state, a 'Resource' asks the system to
54 -- write some response body to the socket. When it transits to the
55 -- next state without writing any response body, the system
56 -- automatically completes it depending on the status code. (To be
57 -- exact, such completion only occurs when the 'Resource' transits
58 -- to this state without even declaring the \"Content-Type\" header
59 -- field. See: 'setContentType')
61 -- [/Done/] Everything is over. A 'Resource' can do nothing for the
62 -- HTTP 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 'Resource', nor we don't want to
68 -- postpone writing the entire response till the end of 'Resource'
70 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 'Resource'.
85 , getRemoteCertificate
96 , isEncodingAcceptable
100 -- * Finding an entity
101 -- |These functions can be called only in the /Examining Request/
102 -- state. They make the 'Resource' transit to the /Receiving Body/
110 -- * Receiving a request body
111 -- |These functions make the 'Resource' transit to the /Receiving
117 -- * Declaring response status and header fields
118 -- |These functions can be called at any time before transiting to
119 -- the /Sending Body/ state, but they themselves never causes any
120 -- state transitions.
127 -- ** Less frequently used functions
132 -- * Sending a response body
134 -- |These functions make the 'Resource' transit to the
135 -- /Sending Body/ state.
141 import Blaze.ByteString.Builder (Builder)
142 import qualified Blaze.ByteString.Builder as BB
143 import qualified Blaze.ByteString.Builder.Internal as BB
144 import Control.Applicative
147 import Control.Monad.IO.Class
148 import Control.Monad.Unicode
149 import Data.Ascii (Ascii, CIAscii)
150 import qualified Data.Ascii as A
151 import qualified Data.Attoparsec.Char8 as P
152 import Data.ByteString (ByteString)
153 import qualified Data.ByteString as Strict
154 import qualified Data.ByteString.Lazy as Lazy
156 import qualified Data.Map as M
159 import Data.Monoid.Unicode
160 import Data.Text (Text)
161 import qualified Data.Text as T
163 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.MIMEParams
179 import Network.HTTP.Lucu.MIMEType (MIMEType(..))
180 import qualified Network.HTTP.Lucu.MIMEType as MT
181 import Network.HTTP.Lucu.MIMEType.TH
182 import Network.HTTP.Lucu.Utils
183 import Network.Socket hiding (accept)
184 import Network.URI hiding (path)
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' ∷ Resource 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 ∷ Resource (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 ∷ Resource Method
204 getMethod = reqMethod <$> getRequest
206 -- |Get the URI of the request.
207 getRequestURI ∷ Resource URI
208 getRequestURI = reqURI <$> getRequest
210 -- |Get the HTTP version of the request.
211 getRequestVersion ∷ Resource 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.ResourceDef' is not greedy. See:
219 -- Note that the returned path components are URI-decoded.
220 getPathInfo ∷ Resource [Strict.ByteString]
221 getPathInfo = do rsrcPath ← getResourcePath
222 reqPath ← splitPathInfo <$> 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 ∷ Resource [(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 → Resource (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 ∷ Resource [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 ∷ Resource [(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 → Resource 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 ∷ Resource (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 ∷ Resource (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 'Resource' found an entity for the
336 -- request URI. If this is a GET or HEAD request, a found entity means
337 -- a datum to be replied. If this is a PUT or DELETE request, it means
338 -- a datum which was stored for the URI until now. For POST requests
339 -- it raises an error.
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 → Resource ()
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 'Resource' found an entity for the
365 -- request URI. The only difference from 'foundEntity' is that
366 -- 'foundETag' doesn't (nor can't) put \"Last-Modified\" header into
369 -- Using this function is discouraged. You should use 'foundEntity'
370 -- whenever possible.
371 foundETag ∷ ETag → Resource ()
373 = do driftTo ExaminingRequest
376 when (method ≡ GET ∨ method ≡ HEAD)
382 $ mkAbortion' InternalServerError
383 "Illegal computation of foundETag for POST request."
385 -- If-Match があればそれを見る。
386 ifMatch ← getHeader "If-Match"
391 → if value ≡ "*" then
394 case P.parseOnly (finishOff eTagList) (A.toByteString value) of
396 -- tags の中に一致するものが無ければ
397 -- PreconditionFailed で終了。
398 → when ((¬) (any (≡ tag) tags))
400 $ mkAbortion' PreconditionFailed
401 $ "The entity tag doesn't match: " ⊕ A.toText value
403 → abort $ mkAbortion' BadRequest
404 $ "Unparsable If-Match: " ⊕ A.toText value
406 let statusForNoneMatch
407 = if method ≡ GET ∨ method ≡ HEAD then
408 fromStatusCode NotModified
410 fromStatusCode PreconditionFailed
412 -- If-None-Match があればそれを見る。
413 ifNoneMatch ← getHeader "If-None-Match"
418 → if value ≡ "*" then
419 abort $ mkAbortion' statusForNoneMatch
420 $ "The entity tag matches: *"
422 case P.parseOnly (finishOff eTagList) (A.toByteString value) of
424 → when (any (≡ tag) tags)
426 $ mkAbortion' statusForNoneMatch
427 $ "The entity tag matches: " ⊕ A.toText value
429 → abort $ mkAbortion' BadRequest
430 $ "Unparsable If-None-Match: " ⊕ A.toText value
432 driftTo ReceivingBody
434 -- |Tell the system that the 'Resource' found an entity for the
435 -- request URI. The only difference from 'foundEntity' is that
436 -- 'foundTimeStamp' performs \"If-Modified-Since\" test or
437 -- \"If-Unmodified-Since\" test instead of \"If-Match\" test or
438 -- \"If-None-Match\" test. Be aware that any tests based on a last
439 -- modification time are unsafe because it is possible to mess up such
440 -- tests by modifying the entity twice in a second.
442 -- Using this function is discouraged. You should use 'foundEntity'
443 -- whenever possible.
444 foundTimeStamp ∷ UTCTime → Resource ()
445 foundTimeStamp timeStamp
446 = do driftTo ExaminingRequest
449 when (method ≡ GET ∨ method ≡ HEAD)
450 $ setHeader "Last-Modified" (HTTP.toAscii timeStamp)
453 $ mkAbortion' InternalServerError
454 "Illegal computation of foundTimeStamp for POST request."
456 let statusForIfModSince
457 = if method ≡ GET ∨ method ≡ HEAD then
458 fromStatusCode NotModified
460 fromStatusCode PreconditionFailed
462 -- If-Modified-Since があればそれを見る。
463 ifModSince ← getHeader "If-Modified-Since"
465 Just str → case HTTP.fromAscii str of
467 → when (timeStamp ≤ lastTime)
469 $ mkAbortion' statusForIfModSince
470 $ "The entity has not been modified since " ⊕ A.toText str
472 → return () -- 不正な時刻は無視
475 -- If-Unmodified-Since があればそれを見る。
476 ifUnmodSince ← getHeader "If-Unmodified-Since"
478 Just str → case HTTP.fromAscii str of
480 → when (timeStamp > lastTime)
482 $ mkAbortion' PreconditionFailed
483 $ "The entity has not been modified since " ⊕ A.toText str
485 → return () -- 不正な時刻は無視
488 driftTo ReceivingBody
490 -- |@'foundNoEntity' mStr@ tells the system that the 'Resource' found
491 -- no entity for the request URI. @mStr@ is an optional error message
492 -- to be replied to the client.
494 -- If the request method is PUT, 'foundNoEntity' performs \"If-Match\"
495 -- test and when that fails it aborts with status \"412 Precondition
496 -- Failed\". If the request method is GET, HEAD, POST or DELETE,
497 -- 'foundNoEntity' always aborts with status \"404 Not Found\".
498 foundNoEntity ∷ Maybe Text → Resource ()
500 = do driftTo ExaminingRequest
505 $ mkAbortion NotFound [] msgM
507 -- エンティティが存在しないと云ふ事は、"*" も含めたどのやうな
508 -- If-Match: 條件も滿たさない。
509 ifMatch ← getHeader "If-Match"
510 when (ifMatch ≢ Nothing)
512 $ mkAbortion PreconditionFailed [] msgM
514 driftTo ReceivingBody
516 -- |'foundNoEntity'' is the same as @'foundNoEntity' 'Nothing'@.
517 foundNoEntity' ∷ Resource ()
518 {-# INLINE foundNoEntity' #-}
519 foundNoEntity' = foundNoEntity Nothing
521 -- |@'getChunks' limit@ attemts to read the entire request body up to
522 -- @limit@ bytes, and then make the 'Resource' transit to the
523 -- /Deciding Header/ state. When the actual size of the body is larger
524 -- than @limit@ bytes, 'getChunks' immediately aborts with status
525 -- \"413 Request Entity Too Large\". When the request has no body, it
526 -- returns an empty string.
528 -- When the @limit@ is 'Nothing', 'getChunks' uses the default
529 -- limitation value ('cnfMaxEntityLength') instead.
531 -- 'getChunks' returns a lazy 'Lazy.ByteString' but it's not really
532 -- lazy: reading from the socket just happens at the computation of
533 -- 'getChunks', not at the evaluation of the 'Lazy.ByteString'.
534 getChunks ∷ Maybe Int → Resource Lazy.ByteString
536 | n < 0 = fail ("getChunks: limit must not be negative: " ⧺ show n)
538 | otherwise = getChunks' n
540 = getConfig ≫= getChunks ∘ Just ∘ cnfMaxEntityLength
542 getChunks' ∷ Int → Resource Lazy.ByteString
543 getChunks' limit = go limit (∅)
545 go ∷ Int → Builder → Resource Lazy.ByteString
546 go 0 _ = do chunk ← getChunk 1
547 if Strict.null chunk then
550 abort $ mkAbortion' RequestEntityTooLarge
551 $ "Request body must be smaller than "
552 ⊕ T.pack (show limit)
554 go !n !b = do c ← getChunk $ min n BB.defaultBufferSize
555 if Strict.null c then
557 return $ BB.toLazyByteString b
559 do let n' = n - Strict.length c
560 xs' = b ⊕ BB.fromByteString c
563 -- |@'getForm' limit@ attempts to read the request body with
564 -- 'getChunks' and parse it as @application\/x-www-form-urlencoded@ or
565 -- @multipart\/form-data@. If the request header \"Content-Type\" is
566 -- neither of them, 'getForm' aborts with status \"415 Unsupported
567 -- Media Type\". If the request has no \"Content-Type\", it aborts
568 -- with \"400 Bad Request\".
570 -- Note that there are currently a few limitations on parsing
571 -- @multipart/form-data@. See: 'parseMultipartFormData'
572 getForm ∷ Maybe Int → Resource [(Strict.ByteString, FormData)]
574 = do cTypeM ← getContentType
577 → abort $ mkAbortion' BadRequest "Missing Content-Type"
578 Just (MIMEType "application" "x-www-form-urlencoded" _)
579 → readWWWFormURLEncoded
580 Just (MIMEType "multipart" "form-data" params)
581 → readMultipartFormData params
583 → abort $ mkAbortion' UnsupportedMediaType
586 $ A.toAsciiBuilder "Unsupported media type: "
587 ⊕ MT.printMIMEType cType
589 readWWWFormURLEncoded
590 = (map toPairWithFormData ∘ parseWWWFormURLEncoded)
592 (bsToAscii =≪ getChunks limit)
595 = case A.fromByteString (Strict.concat (Lazy.toChunks bs)) of
597 Nothing → abort $ mkAbortion' BadRequest "Malformed x-www-form-urlencoded"
599 readMultipartFormData (MIMEParams m)
600 = case M.lookup "boundary" m of
602 → abort $ mkAbortion' BadRequest "Missing boundary of multipart/form-data"
604 → do src ← getChunks limit
605 b ← case A.fromText boundary of
607 Nothing → abort $ mkAbortion' BadRequest
608 $ "Malformed boundary: " ⊕ boundary
609 case parseMultipartFormData b src of
610 Right xs → return $ map (first A.toByteString) xs
611 Left err → abort $ mkAbortion' BadRequest $ T.pack err
613 -- |@'redirect' code uri@ declares the response status as @code@ and
614 -- \"Location\" header field as @uri@. The @code@ must satisfy
615 -- 'isRedirection' or it raises an error.
616 redirect ∷ StatusCode sc ⇒ sc → URI → Resource ()
618 = do when (cast sc ≡ Just NotModified ∨ (¬) (isRedirection sc))
620 $ mkAbortion' InternalServerError
623 $ A.toAsciiBuilder "Attempted to redirect with status "
628 -- |@'setContentType' mType@ declares the response header
629 -- \"Content-Type\" as @mType@. Declaring \"Content-Type\" is
630 -- mandatory for sending a response body.
631 setContentType ∷ MIMEType → Resource ()
633 = setHeader "Content-Type" ∘ A.fromAsciiBuilder ∘ MT.printMIMEType
635 -- |@'setLocation' uri@ declares the response header \"Location\" as
636 -- @uri@. You usually don't need to call this function directly.
637 setLocation ∷ URI → Resource ()
639 = case A.fromChars uriStr of
640 Just a → setHeader "Location" a
641 Nothing → abort $ mkAbortion' InternalServerError
642 $ "Malformed URI: " ⊕ T.pack uriStr
644 uriStr = uriToString id uri ""
646 -- |@'setContentEncoding' codings@ declares the response header
647 -- \"Content-Encoding\" as @codings@.
648 setContentEncoding ∷ [CIAscii] → Resource ()
649 setContentEncoding codings
650 = do ver ← getRequestVersion
652 HttpVersion 1 0 → return (toAB ∘ unnormalizeCoding)
653 HttpVersion 1 1 → return toAB
654 _ → abort $ mkAbortion' InternalServerError
655 "setContentEncoding: Unknown HTTP version"
656 setHeader "Content-Encoding"
659 $ intersperse (A.toAsciiBuilder ", ")
662 toAB = A.toAsciiBuilder ∘ A.fromCIAscii
664 -- |@'setWWWAuthenticate' challenge@ declares the response header
665 -- \"WWW-Authenticate\" as @challenge@.
666 setWWWAuthenticate ∷ AuthChallenge → Resource ()
667 setWWWAuthenticate = setHeader "WWW-Authenticate" ∘ printAuthChallenge
669 -- |Write a chunk in 'Strict.ByteString' to the response body. You
670 -- must first declare the response header \"Content-Type\" before
671 -- applying this function. See: 'setContentType'
672 putChunk ∷ Strict.ByteString → Resource ()
673 putChunk = putBuilder ∘ BB.fromByteString
675 -- |Write a chunk in lazy 'Lazy.ByteString' to the response body. It
676 -- can be safely applied to an infinitely long 'Lazy.ByteString'.
678 -- Note that you must first declare the response header
679 -- \"Content-Type\" before applying this function. See:
681 putChunks ∷ Lazy.ByteString → Resource ()
682 putChunks = putBuilder ∘ BB.fromLazyByteString