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.Request
173 import Network.HTTP.Lucu.Resource.Internal
174 import Network.HTTP.Lucu.Response
175 import Network.HTTP.Lucu.MIMEType
176 import Network.HTTP.Lucu.Utils
177 import Network.Socket hiding (accept)
178 import Network.URI hiding (path)
179 import Prelude.Unicode
181 -- |Get the string representation of the address of remote host. If
182 -- you want a 'SockAddr' instead of 'HostName', use 'getRemoteAddr'.
183 getRemoteAddr' ∷ Resource HostName
184 getRemoteAddr' = liftIO ∘ toNM =≪ getRemoteAddr
186 toNM ∷ SockAddr → IO HostName
187 toNM = (fromJust ∘ fst <$>) ∘ getNameInfo [NI_NUMERICHOST] True False
189 -- |Resolve an address to the remote host.
190 getRemoteHost ∷ Resource (Maybe HostName)
191 getRemoteHost = liftIO ∘ getHN =≪ getRemoteAddr
193 getHN ∷ SockAddr → IO (Maybe HostName)
194 getHN = (fst <$>) ∘ getNameInfo [] True False
196 -- |Get the 'Method' value of the request.
197 getMethod ∷ Resource Method
198 getMethod = reqMethod <$> getRequest
200 -- |Get the URI of the request.
201 getRequestURI ∷ Resource URI
202 getRequestURI = reqURI <$> getRequest
204 -- |Get the HTTP version of the request.
205 getRequestVersion ∷ Resource HttpVersion
206 getRequestVersion = reqVersion <$> getRequest
208 -- |This is an analogy of CGI PATH_INFO. 'getPathInfo' always returns
209 -- @[]@ if the corresponding
210 -- 'Network.HTTP.Lucu.Resource.Tree.ResourceDef' is not greedy. See:
213 -- Note that the returned path components are URI-decoded.
214 getPathInfo ∷ Resource [Strict.ByteString]
215 getPathInfo = do rsrcPath ← getResourcePath
216 reqPath ← splitPathInfo <$> getRequestURI
217 return $ drop (length rsrcPath) reqPath
219 -- |Assume the query part of request URI as
220 -- application\/x-www-form-urlencoded, and parse it into pairs of
221 -- @(name, formData)@. This function doesn't read the request
223 getQueryForm ∷ Resource [(Strict.ByteString, FormData)]
224 getQueryForm = parse' <$> getRequestURI
226 parse' = map toPairWithFormData ∘
227 parseWWWFormURLEncoded ∘
233 toPairWithFormData ∷ (ByteString, ByteString) → (Strict.ByteString, FormData)
234 toPairWithFormData (name, value)
235 = let fd = FormData {
237 , fdMIMEType = parseMIMEType "text/plain"
238 , fdContent = Lazy.fromChunks [value]
242 -- |@'getHeader' name@ returns the value of the request header field
243 -- @name@. Comparison of header name is case-insensitive. Note that
244 -- this function is not intended to be used so frequently: there
245 -- should be functions like 'getContentType' for every common headers.
246 getHeader ∷ CIAscii → Resource (Maybe Ascii)
248 = H.getHeader name <$> getRequest
250 -- |Return the list of 'MIMEType' enumerated on the value of request
251 -- header \"Accept\", or @[]@ if absent.
252 getAccept ∷ Resource [MIMEType]
254 = do acceptM ← getHeader "Accept"
259 → case P.parseOnly p (A.toByteString accept) of
261 Left _ → abort $ mkAbortion' BadRequest
262 $ "Unparsable Accept: " ⊕ A.toText accept
264 p = do xs ← mimeTypeList
268 -- |Return the list of @(contentCoding, qvalue)@ enumerated on the
269 -- value of request header \"Accept-Encoding\". The list is sorted in
270 -- descending order by qvalue.
271 getAcceptEncoding ∷ Resource [(CIAscii, Maybe Double)]
273 = do accEncM ← getHeader "Accept-Encoding"
276 -- HTTP/1.0 には Accept-Encoding が無い場合の規定が無い
277 -- ので安全の爲 identity が指定された事にする。HTTP/1.1
278 -- の場合は何でも受け入れて良い事になってゐるので "*" が
280 → do ver ← getRequestVersion
282 HttpVersion 1 0 → return [("identity", Nothing)]
283 HttpVersion 1 1 → return [("*" , Nothing)]
284 _ → abort $ mkAbortion' InternalServerError
285 "getAcceptEncoding: unknown HTTP version"
289 return [("identity", Nothing)]
291 case P.parseOnly p (A.toByteString ae) of
292 Right xs → return $ map toTuple $ reverse $ sort xs
293 Left _ → abort $ mkAbortion' BadRequest
294 $ "Unparsable Accept-Encoding: " ⊕ A.toText ae
296 p = do xs ← acceptEncodingList
300 toTuple (AcceptEncoding {..})
301 = (aeEncoding, aeQValue)
303 -- |Return 'True' iff a given content-coding is acceptable by the
305 isEncodingAcceptable ∷ CIAscii → Resource 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 ∷ Resource (Maybe MIMEType)
314 = do cTypeM ← getHeader "Content-Type"
319 → case P.parseOnly p (A.toByteString cType) of
320 Right t → return $ Just t
321 Left _ → abort $ mkAbortion' BadRequest
322 $ "Unparsable Content-Type: " ⊕ A.toText cType
328 -- |Return the value of request header \"Authorization\" as
330 getAuthorization ∷ Resource (Maybe AuthCredential)
332 = do authM ← getHeader "Authorization"
337 → case P.parseOnly p (A.toByteString auth) of
338 Right ac → return $ Just ac
339 Left _ → return Nothing
341 p = do ac ← authCredential
345 -- |Tell the system that the 'Resource' found an entity for the
346 -- request URI. If this is a GET or HEAD request, a found entity means
347 -- a datum to be replied. If this is a PUT or DELETE request, it means
348 -- a datum which was stored for the URI until now. For POST requests
349 -- it raises an error.
351 -- 'foundEntity' performs \"If-Match\" test or \"If-None-Match\" test
352 -- whenever possible, and if those tests fail, it immediately aborts
353 -- with status \"412 Precondition Failed\" or \"304 Not Modified\"
354 -- depending on the situation.
356 -- If the request method is either GET or HEAD, 'foundEntity'
357 -- automatically puts \"ETag\" and \"Last-Modified\" headers into the
359 foundEntity ∷ ETag → UTCTime → Resource ()
360 foundEntity tag timeStamp
361 = do driftTo ExaminingRequest
364 when (method ≡ GET ∨ method ≡ HEAD)
365 $ setHeader "Last-Modified" (HTTP.toAscii timeStamp)
368 $ mkAbortion' InternalServerError
369 "foundEntity: this is a POST request."
372 driftTo ReceivingBody
374 -- |Tell the system that the 'Resource' found an entity for the
375 -- request URI. The only difference from 'foundEntity' is that
376 -- 'foundETag' doesn't (nor can't) put \"Last-Modified\" header into
379 -- Using this function is discouraged. You should use 'foundEntity'
380 -- whenever possible.
381 foundETag ∷ ETag → Resource ()
383 = do driftTo ExaminingRequest
386 when (method ≡ GET ∨ method ≡ HEAD)
392 $ mkAbortion' InternalServerError
393 "Illegal computation of foundETag for POST request."
395 -- If-Match があればそれを見る。
396 ifMatch ← getHeader "If-Match"
399 Just value → if value ≡ "*" then
402 case P.parseOnly p (A.toByteString value) of
404 -- tags の中に一致するものが無ければ
405 -- PreconditionFailed で終了。
406 → when ((¬) (any (≡ tag) tags))
408 $ mkAbortion' PreconditionFailed
409 $ "The entity tag doesn't match: " ⊕ A.toText value
411 → abort $ mkAbortion' BadRequest
412 $ "Unparsable If-Match: " ⊕ A.toText value
414 let statusForNoneMatch
415 = if method ≡ GET ∨ method ≡ HEAD then
420 -- If-None-Match があればそれを見る。
421 ifNoneMatch ← getHeader "If-None-Match"
424 Just value → if value ≡ "*" then
425 abort $ mkAbortion' statusForNoneMatch
426 $ "The entity tag matches: *"
428 case P.parseOnly p (A.toByteString value) of
430 → when (any (≡ tag) tags)
432 $ mkAbortion' statusForNoneMatch
433 $ "The entity tag matches: " ⊕ A.toText value
435 → abort $ mkAbortion' BadRequest
436 $ "Unparsable If-None-Match: " ⊕ A.toText value
438 driftTo ReceivingBody
444 -- |Tell the system that the 'Resource' found an entity for the
445 -- request URI. The only difference from 'foundEntity' is that
446 -- 'foundTimeStamp' performs \"If-Modified-Since\" test or
447 -- \"If-Unmodified-Since\" test instead of \"If-Match\" test or
448 -- \"If-None-Match\" test. Be aware that any tests based on a last
449 -- modification time are unsafe because it is possible to mess up such
450 -- tests by modifying the entity twice in a second.
452 -- Using this function is discouraged. You should use 'foundEntity'
453 -- whenever possible.
454 foundTimeStamp ∷ UTCTime → Resource ()
455 foundTimeStamp timeStamp
456 = do driftTo ExaminingRequest
459 when (method ≡ GET ∨ method ≡ HEAD)
460 $ setHeader "Last-Modified" (HTTP.toAscii timeStamp)
463 $ mkAbortion' InternalServerError
464 "Illegal computation of foundTimeStamp for POST request."
466 let statusForIfModSince
467 = if method ≡ GET ∨ method ≡ HEAD then
472 -- If-Modified-Since があればそれを見る。
473 ifModSince ← getHeader "If-Modified-Since"
475 Just str → case HTTP.fromAscii str of
477 → when (timeStamp ≤ lastTime)
479 $ mkAbortion' statusForIfModSince
480 $ "The entity has not been modified since " ⊕ A.toText str
482 → return () -- 不正な時刻は無視
485 -- If-Unmodified-Since があればそれを見る。
486 ifUnmodSince ← getHeader "If-Unmodified-Since"
488 Just str → case HTTP.fromAscii str of
490 → when (timeStamp > lastTime)
492 $ mkAbortion' PreconditionFailed
493 $ "The entity has not been modified since " ⊕ A.toText str
495 → return () -- 不正な時刻は無視
498 driftTo ReceivingBody
500 -- |@'foundNoEntity' mStr@ tells the system that the 'Resource' found
501 -- no entity for the request URI. @mStr@ is an optional error message
502 -- to be replied to the client.
504 -- If the request method is PUT, 'foundNoEntity' performs \"If-Match\"
505 -- test and when that fails it aborts with status \"412 Precondition
506 -- Failed\". If the request method is GET, HEAD, POST or DELETE,
507 -- 'foundNoEntity' always aborts with status \"404 Not Found\".
508 foundNoEntity ∷ Maybe Text → Resource ()
510 = do driftTo ExaminingRequest
515 $ mkAbortion NotFound [] msgM
517 -- エンティティが存在しないと云ふ事は、"*" も含めたどのやうな
518 -- If-Match: 條件も滿たさない。
519 ifMatch ← getHeader "If-Match"
520 when (ifMatch ≢ Nothing)
522 $ mkAbortion PreconditionFailed [] msgM
524 driftTo ReceivingBody
526 -- |'foundNoEntity'' is the same as @'foundNoEntity' 'Nothing'@.
527 foundNoEntity' ∷ Resource ()
528 {-# INLINE foundNoEntity' #-}
529 foundNoEntity' = foundNoEntity Nothing
531 -- |@'getChunks' limit@ attemts to read the entire request body up to
532 -- @limit@ bytes, and then make the 'Resource' transit to the
533 -- /Deciding Header/ state. When the actual size of the body is larger
534 -- than @limit@ bytes, 'getChunks' immediately aborts with status
535 -- \"413 Request Entity Too Large\". When the request has no body, it
536 -- returns an empty string.
538 -- When the @limit@ is 'Nothing', 'getChunks' uses the default
539 -- limitation value ('cnfMaxEntityLength') instead.
541 -- 'getChunks' returns a lazy 'Lazy.ByteString' but it's not really
542 -- lazy: reading from the socket just happens at the computation of
543 -- 'getChunks', not at the evaluation of the 'Lazy.ByteString'.
544 getChunks ∷ Maybe Int → Resource Lazy.ByteString
546 | n < 0 = fail ("getChunks: limit must not be negative: " ⧺ show n)
548 | otherwise = getChunks' n
550 = getConfig ≫= getChunks ∘ Just ∘ cnfMaxEntityLength
552 getChunks' ∷ Int → Resource Lazy.ByteString
553 getChunks' limit = go limit (∅)
555 go ∷ Int → Builder → Resource Lazy.ByteString
556 go 0 _ = do chunk ← getChunk 1
557 if Strict.null chunk then
560 abort $ mkAbortion' RequestEntityTooLarge
561 $ "Request body must be smaller than "
562 ⊕ T.pack (show limit)
564 go !n !b = do c ← getChunk $ min n BB.defaultBufferSize
565 if Strict.null c then
567 return $ BB.toLazyByteString b
569 do let n' = n - Strict.length c
570 xs' = b ⊕ BB.fromByteString c
573 -- |@'getForm' limit@ attempts to read the request body with
574 -- 'getChunks' and parse it as @application\/x-www-form-urlencoded@ or
575 -- @multipart\/form-data@. If the request header \"Content-Type\" is
576 -- neither of them, 'getForm' aborts with status \"415 Unsupported
577 -- Media Type\". If the request has no \"Content-Type\", it aborts
578 -- with \"400 Bad Request\".
580 -- Note that there are currently a few limitations on parsing
581 -- @multipart/form-data@. See: 'parseMultipartFormData'
582 getForm ∷ Maybe Int → Resource [(Strict.ByteString, FormData)]
584 = do cTypeM ← getContentType
587 → abort $ mkAbortion' BadRequest "Missing Content-Type"
588 Just (MIMEType "application" "x-www-form-urlencoded" _)
589 → readWWWFormURLEncoded
590 Just (MIMEType "multipart" "form-data" params)
591 → readMultipartFormData params
593 → abort $ mkAbortion' UnsupportedMediaType
596 $ A.toAsciiBuilder "Unsupported media type: "
597 ⊕ printMIMEType cType
599 readWWWFormURLEncoded
600 = (map toPairWithFormData ∘ parseWWWFormURLEncoded)
602 (bsToAscii =≪ getChunks limit)
605 = case A.fromByteString (Strict.concat (Lazy.toChunks bs)) of
607 Nothing → abort $ mkAbortion' BadRequest "Malformed x-www-form-urlencoded"
609 readMultipartFormData params
610 = case M.lookup "boundary" params of
612 → abort $ mkAbortion' BadRequest "Missing boundary of multipart/form-data"
614 → do src ← getChunks limit
615 b ← case A.fromText boundary of
617 Nothing → abort $ mkAbortion' BadRequest
618 $ "Malformed boundary: " ⊕ boundary
619 case parseMultipartFormData b src of
620 Right xs → return $ map (first A.toByteString) xs
621 Left err → abort $ mkAbortion' BadRequest $ T.pack err
623 -- |@'redirect' code uri@ declares the response status as @code@ and
624 -- \"Location\" header field as @uri@. The @code@ must satisfy
625 -- 'isRedirection' or it raises an error.
626 redirect ∷ StatusCode → URI → Resource ()
628 = do when (code ≡ NotModified ∨ not (isRedirection code))
630 $ mkAbortion' InternalServerError
633 $ A.toAsciiBuilder "Attempted to redirect with status "
634 ⊕ printStatusCode code
638 -- |@'setContentType' mType@ declares the response header
639 -- \"Content-Type\" as @mType@. Declaring \"Content-Type\" is
640 -- mandatory for sending a response body.
641 setContentType ∷ MIMEType → Resource ()
643 = setHeader "Content-Type" ∘ A.fromAsciiBuilder ∘ printMIMEType
645 -- |@'setLocation' uri@ declares the response header \"Location\" as
646 -- @uri@. You usually don't need to call this function directly.
647 setLocation ∷ URI → Resource ()
649 = case A.fromChars uriStr of
650 Just a → setHeader "Location" a
651 Nothing → abort $ mkAbortion' InternalServerError
652 $ "Malformed URI: " ⊕ T.pack uriStr
654 uriStr = uriToString id uri ""
656 -- |@'setContentEncoding' codings@ declares the response header
657 -- \"Content-Encoding\" as @codings@.
658 setContentEncoding ∷ [CIAscii] → Resource ()
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 (A.toAsciiBuilder ", ")
672 toAB = A.toAsciiBuilder ∘ A.fromCIAscii
674 -- |@'setWWWAuthenticate' challenge@ declares the response header
675 -- \"WWW-Authenticate\" as @challenge@.
676 setWWWAuthenticate ∷ AuthChallenge → Resource ()
677 setWWWAuthenticate = setHeader "WWW-Authenticate" ∘ printAuthChallenge
679 -- |Write a chunk in 'Strict.ByteString' to the response body. You
680 -- must first declare the response header \"Content-Type\" before
681 -- applying this function. See: 'setContentType'
682 putChunk ∷ Strict.ByteString → Resource ()
683 putChunk = putBuilder ∘ BB.fromByteString
685 -- |Write a chunk in lazy 'Lazy.ByteString' to the response body. It
686 -- can be safely applied to an infinitely long 'Lazy.ByteString'.
688 -- Note that you must first declare the response header
689 -- \"Content-Type\" before applying this function. See:
691 putChunks ∷ Lazy.ByteString → Resource ()
692 putChunks = putBuilder ∘ BB.fromLazyByteString