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
164 import Network.HTTP.Lucu.Abortion
165 import Network.HTTP.Lucu.Authentication
166 import Network.HTTP.Lucu.Config
167 import Network.HTTP.Lucu.ContentCoding
168 import Network.HTTP.Lucu.ETag
169 import qualified Network.HTTP.Lucu.Headers as H
170 import Network.HTTP.Lucu.HttpVersion
171 import Network.HTTP.Lucu.Interaction
172 import Network.HTTP.Lucu.MultipartForm
173 import Network.HTTP.Lucu.Parser
174 import Network.HTTP.Lucu.Request
175 import Network.HTTP.Lucu.Resource.Internal
176 import Network.HTTP.Lucu.Response
177 import Network.HTTP.Lucu.MIMEParams
178 import Network.HTTP.Lucu.MIMEType (MIMEType(..))
179 import qualified Network.HTTP.Lucu.MIMEType as MT
180 import Network.HTTP.Lucu.MIMEType.TH
181 import Network.HTTP.Lucu.Utils
182 import Network.Socket hiding (accept)
183 import Network.URI hiding (path)
184 import Prelude.Unicode
186 -- |Get the string representation of the address of remote host. If
187 -- you want a 'SockAddr' instead of 'HostName', use 'getRemoteAddr'.
188 getRemoteAddr' ∷ Resource HostName
189 getRemoteAddr' = liftIO ∘ toNM =≪ getRemoteAddr
191 toNM ∷ SockAddr → IO HostName
192 toNM = (fromJust ∘ fst <$>) ∘ getNameInfo [NI_NUMERICHOST] True False
194 -- |Resolve an address to the remote host.
195 getRemoteHost ∷ Resource (Maybe HostName)
196 getRemoteHost = liftIO ∘ getHN =≪ getRemoteAddr
198 getHN ∷ SockAddr → IO (Maybe HostName)
199 getHN = (fst <$>) ∘ getNameInfo [] True False
201 -- |Get the 'Method' value of the request.
202 getMethod ∷ Resource Method
203 getMethod = reqMethod <$> getRequest
205 -- |Get the URI of the request.
206 getRequestURI ∷ Resource URI
207 getRequestURI = reqURI <$> getRequest
209 -- |Get the HTTP version of the request.
210 getRequestVersion ∷ Resource HttpVersion
211 getRequestVersion = reqVersion <$> getRequest
213 -- |This is an analogy of CGI PATH_INFO. 'getPathInfo' always returns
214 -- @[]@ if the corresponding
215 -- 'Network.HTTP.Lucu.Resource.Tree.ResourceDef' is not greedy. See:
218 -- Note that the returned path components are URI-decoded.
219 getPathInfo ∷ Resource [Strict.ByteString]
220 getPathInfo = do rsrcPath ← getResourcePath
221 reqPath ← splitPathInfo <$> getRequestURI
222 return $ drop (length rsrcPath) reqPath
224 -- |Assume the query part of request URI as
225 -- application\/x-www-form-urlencoded, and parse it into pairs of
226 -- @(name, formData)@. This function doesn't read the request
228 getQueryForm ∷ Resource [(Strict.ByteString, FormData)]
229 getQueryForm = parse' <$> getRequestURI
231 parse' = map toPairWithFormData ∘
232 parseWWWFormURLEncoded ∘
238 toPairWithFormData ∷ (ByteString, ByteString) → (Strict.ByteString, FormData)
239 toPairWithFormData (name, value)
240 = let fd = FormData {
242 , fdMIMEType = [mimeType| text/plain |]
243 , fdContent = Lazy.fromChunks [value]
247 -- |@'getHeader' name@ returns the value of the request header field
248 -- @name@. Comparison of header name is case-insensitive. Note that
249 -- this function is not intended to be used so frequently: there
250 -- should be functions like 'getContentType' for every common headers.
251 getHeader ∷ CIAscii → Resource (Maybe Ascii)
253 = H.getHeader name <$> getRequest
255 -- |Return the list of 'MIMEType' enumerated on the value of request
256 -- header \"Accept\", or @[]@ if absent.
257 getAccept ∷ Resource [MIMEType]
259 = do acceptM ← getHeader "Accept"
264 → case P.parseOnly (finishOff MT.mimeTypeList) (A.toByteString accept) of
266 Left _ → abort $ mkAbortion' BadRequest
267 $ "Unparsable Accept: " ⊕ A.toText accept
269 -- |Return the list of @(contentCoding, qvalue)@ enumerated on the
270 -- value of request header \"Accept-Encoding\". The list is sorted in
271 -- descending order by qvalue.
272 getAcceptEncoding ∷ Resource [(CIAscii, Maybe Double)]
274 = do accEncM ← getHeader "Accept-Encoding"
277 -- HTTP/1.0 には Accept-Encoding が無い場合の規定が無い
278 -- ので安全の爲 identity が指定された事にする。HTTP/1.1
279 -- の場合は何でも受け入れて良い事になってゐるので "*" が
281 → do ver ← getRequestVersion
283 HttpVersion 1 0 → return [("identity", Nothing)]
284 HttpVersion 1 1 → return [("*" , Nothing)]
285 _ → abort $ mkAbortion' InternalServerError
286 "getAcceptEncoding: unknown HTTP version"
290 return [("identity", Nothing)]
292 case P.parseOnly (finishOff acceptEncodingList) (A.toByteString ae) of
293 Right xs → return $ map toTuple $ reverse $ sort xs
294 Left _ → abort $ mkAbortion' BadRequest
295 $ "Unparsable Accept-Encoding: " ⊕ A.toText ae
297 toTuple (AcceptEncoding {..})
298 = (aeEncoding, aeQValue)
300 -- |Return 'True' iff a given content-coding is acceptable by the
302 isEncodingAcceptable ∷ CIAscii → Resource Bool
303 isEncodingAcceptable encoding = any doesMatch <$> getAcceptEncoding
305 doesMatch ∷ (CIAscii, Maybe Double) → Bool
306 doesMatch (e, q) = (e ≡ "*" ∨ e ≡ encoding) ∧ q ≢ Just 0
308 -- |Return the value of request header \"Content-Type\" as 'MIMEType'.
309 getContentType ∷ Resource (Maybe MIMEType)
311 = do cTypeM ← getHeader "Content-Type"
316 → case P.parseOnly (finishOff MT.mimeType) (A.toByteString cType) of
317 Right t → return $ Just t
318 Left _ → abort $ mkAbortion' BadRequest
319 $ "Unparsable Content-Type: " ⊕ A.toText cType
321 -- |Return the value of request header \"Authorization\" as
323 getAuthorization ∷ Resource (Maybe AuthCredential)
325 = do authM ← getHeader "Authorization"
330 → case P.parseOnly (finishOff authCredential) (A.toByteString auth) of
331 Right ac → return $ Just ac
332 Left _ → return Nothing
334 -- |Tell the system that the 'Resource' found an entity for the
335 -- request URI. If this is a GET or HEAD request, a found entity means
336 -- a datum to be replied. If this is a PUT or DELETE request, it means
337 -- a datum which was stored for the URI until now. For POST requests
338 -- it raises an error.
340 -- 'foundEntity' performs \"If-Match\" test or \"If-None-Match\" test
341 -- whenever possible, and if those tests fail, it immediately aborts
342 -- with status \"412 Precondition Failed\" or \"304 Not Modified\"
343 -- depending on the situation.
345 -- If the request method is either GET or HEAD, 'foundEntity'
346 -- automatically puts \"ETag\" and \"Last-Modified\" headers into the
348 foundEntity ∷ ETag → UTCTime → Resource ()
349 foundEntity tag timeStamp
350 = do driftTo ExaminingRequest
353 when (method ≡ GET ∨ method ≡ HEAD)
354 $ setHeader "Last-Modified" (HTTP.toAscii timeStamp)
357 $ mkAbortion' InternalServerError
358 "foundEntity: this is a POST request."
361 driftTo ReceivingBody
363 -- |Tell the system that the 'Resource' found an entity for the
364 -- request URI. The only difference from 'foundEntity' is that
365 -- 'foundETag' doesn't (nor can't) put \"Last-Modified\" header into
368 -- Using this function is discouraged. You should use 'foundEntity'
369 -- whenever possible.
370 foundETag ∷ ETag → Resource ()
372 = do driftTo ExaminingRequest
375 when (method ≡ GET ∨ method ≡ HEAD)
381 $ mkAbortion' InternalServerError
382 "Illegal computation of foundETag for POST request."
384 -- If-Match があればそれを見る。
385 ifMatch ← getHeader "If-Match"
390 → if value ≡ "*" then
393 case P.parseOnly (finishOff eTagList) (A.toByteString value) of
395 -- tags の中に一致するものが無ければ
396 -- PreconditionFailed で終了。
397 → when ((¬) (any (≡ tag) tags))
399 $ mkAbortion' PreconditionFailed
400 $ "The entity tag doesn't match: " ⊕ A.toText value
402 → abort $ mkAbortion' BadRequest
403 $ "Unparsable If-Match: " ⊕ A.toText value
405 let statusForNoneMatch
406 = if method ≡ GET ∨ method ≡ HEAD then
407 fromStatusCode NotModified
409 fromStatusCode PreconditionFailed
411 -- If-None-Match があればそれを見る。
412 ifNoneMatch ← getHeader "If-None-Match"
417 → if value ≡ "*" then
418 abort $ mkAbortion' statusForNoneMatch
419 $ "The entity tag matches: *"
421 case P.parseOnly (finishOff eTagList) (A.toByteString value) of
423 → when (any (≡ tag) tags)
425 $ mkAbortion' statusForNoneMatch
426 $ "The entity tag matches: " ⊕ A.toText value
428 → abort $ mkAbortion' BadRequest
429 $ "Unparsable If-None-Match: " ⊕ A.toText value
431 driftTo ReceivingBody
433 -- |Tell the system that the 'Resource' found an entity for the
434 -- request URI. The only difference from 'foundEntity' is that
435 -- 'foundTimeStamp' performs \"If-Modified-Since\" test or
436 -- \"If-Unmodified-Since\" test instead of \"If-Match\" test or
437 -- \"If-None-Match\" test. Be aware that any tests based on a last
438 -- modification time are unsafe because it is possible to mess up such
439 -- tests by modifying the entity twice in a second.
441 -- Using this function is discouraged. You should use 'foundEntity'
442 -- whenever possible.
443 foundTimeStamp ∷ UTCTime → Resource ()
444 foundTimeStamp timeStamp
445 = do driftTo ExaminingRequest
448 when (method ≡ GET ∨ method ≡ HEAD)
449 $ setHeader "Last-Modified" (HTTP.toAscii timeStamp)
452 $ mkAbortion' InternalServerError
453 "Illegal computation of foundTimeStamp for POST request."
455 let statusForIfModSince
456 = if method ≡ GET ∨ method ≡ HEAD then
457 fromStatusCode NotModified
459 fromStatusCode PreconditionFailed
461 -- If-Modified-Since があればそれを見る。
462 ifModSince ← getHeader "If-Modified-Since"
464 Just str → case HTTP.fromAscii str of
466 → when (timeStamp ≤ lastTime)
468 $ mkAbortion' statusForIfModSince
469 $ "The entity has not been modified since " ⊕ A.toText str
471 → return () -- 不正な時刻は無視
474 -- If-Unmodified-Since があればそれを見る。
475 ifUnmodSince ← getHeader "If-Unmodified-Since"
477 Just str → case HTTP.fromAscii str of
479 → when (timeStamp > lastTime)
481 $ mkAbortion' PreconditionFailed
482 $ "The entity has not been modified since " ⊕ A.toText str
484 → return () -- 不正な時刻は無視
487 driftTo ReceivingBody
489 -- |@'foundNoEntity' mStr@ tells the system that the 'Resource' found
490 -- no entity for the request URI. @mStr@ is an optional error message
491 -- to be replied to the client.
493 -- If the request method is PUT, 'foundNoEntity' performs \"If-Match\"
494 -- test and when that fails it aborts with status \"412 Precondition
495 -- Failed\". If the request method is GET, HEAD, POST or DELETE,
496 -- 'foundNoEntity' always aborts with status \"404 Not Found\".
497 foundNoEntity ∷ Maybe Text → Resource ()
499 = do driftTo ExaminingRequest
504 $ mkAbortion NotFound [] msgM
506 -- エンティティが存在しないと云ふ事は、"*" も含めたどのやうな
507 -- If-Match: 條件も滿たさない。
508 ifMatch ← getHeader "If-Match"
509 when (ifMatch ≢ Nothing)
511 $ mkAbortion PreconditionFailed [] msgM
513 driftTo ReceivingBody
515 -- |'foundNoEntity'' is the same as @'foundNoEntity' 'Nothing'@.
516 foundNoEntity' ∷ Resource ()
517 {-# INLINE foundNoEntity' #-}
518 foundNoEntity' = foundNoEntity Nothing
520 -- |@'getChunks' limit@ attemts to read the entire request body up to
521 -- @limit@ bytes, and then make the 'Resource' transit to the
522 -- /Deciding Header/ state. When the actual size of the body is larger
523 -- than @limit@ bytes, 'getChunks' immediately aborts with status
524 -- \"413 Request Entity Too Large\". When the request has no body, it
525 -- returns an empty string.
527 -- When the @limit@ is 'Nothing', 'getChunks' uses the default
528 -- limitation value ('cnfMaxEntityLength') instead.
530 -- 'getChunks' returns a lazy 'Lazy.ByteString' but it's not really
531 -- lazy: reading from the socket just happens at the computation of
532 -- 'getChunks', not at the evaluation of the 'Lazy.ByteString'.
533 getChunks ∷ Maybe Int → Resource Lazy.ByteString
535 | n < 0 = fail ("getChunks: limit must not be negative: " ⧺ show n)
537 | otherwise = getChunks' n
539 = getConfig ≫= getChunks ∘ Just ∘ cnfMaxEntityLength
541 getChunks' ∷ Int → Resource Lazy.ByteString
542 getChunks' limit = go limit (∅)
544 go ∷ Int → Builder → Resource Lazy.ByteString
545 go 0 _ = do chunk ← getChunk 1
546 if Strict.null chunk then
549 abort $ mkAbortion' RequestEntityTooLarge
550 $ "Request body must be smaller than "
551 ⊕ T.pack (show limit)
553 go !n !b = do c ← getChunk $ min n BB.defaultBufferSize
554 if Strict.null c then
556 return $ BB.toLazyByteString b
558 do let n' = n - Strict.length c
559 xs' = b ⊕ BB.fromByteString c
562 -- |@'getForm' limit@ attempts to read the request body with
563 -- 'getChunks' and parse it as @application\/x-www-form-urlencoded@ or
564 -- @multipart\/form-data@. If the request header \"Content-Type\" is
565 -- neither of them, 'getForm' aborts with status \"415 Unsupported
566 -- Media Type\". If the request has no \"Content-Type\", it aborts
567 -- with \"400 Bad Request\".
569 -- Note that there are currently a few limitations on parsing
570 -- @multipart/form-data@. See: 'parseMultipartFormData'
571 getForm ∷ Maybe Int → Resource [(Strict.ByteString, FormData)]
573 = do cTypeM ← getContentType
576 → abort $ mkAbortion' BadRequest "Missing Content-Type"
577 Just (MIMEType "application" "x-www-form-urlencoded" _)
578 → readWWWFormURLEncoded
579 Just (MIMEType "multipart" "form-data" params)
580 → readMultipartFormData params
582 → abort $ mkAbortion' UnsupportedMediaType
585 $ A.toAsciiBuilder "Unsupported media type: "
586 ⊕ MT.printMIMEType cType
588 readWWWFormURLEncoded
589 = (map toPairWithFormData ∘ parseWWWFormURLEncoded)
591 (bsToAscii =≪ getChunks limit)
594 = case A.fromByteString (Strict.concat (Lazy.toChunks bs)) of
596 Nothing → abort $ mkAbortion' BadRequest "Malformed x-www-form-urlencoded"
598 readMultipartFormData (MIMEParams m)
599 = case M.lookup "boundary" m of
601 → abort $ mkAbortion' BadRequest "Missing boundary of multipart/form-data"
603 → do src ← getChunks limit
604 b ← case A.fromText boundary of
606 Nothing → abort $ mkAbortion' BadRequest
607 $ "Malformed boundary: " ⊕ boundary
608 case parseMultipartFormData b src of
609 Right xs → return $ map (first A.toByteString) xs
610 Left err → abort $ mkAbortion' BadRequest $ T.pack err
612 -- |@'redirect' code uri@ declares the response status as @code@ and
613 -- \"Location\" header field as @uri@. The @code@ must satisfy
614 -- 'isRedirection' or it raises an error.
615 redirect ∷ StatusCode sc ⇒ sc → URI → Resource ()
617 = do when (sc ≈ NotModified ∨ (¬) (isRedirection sc))
619 $ mkAbortion' InternalServerError
622 $ A.toAsciiBuilder "Attempted to redirect with status "
627 -- |@'setContentType' mType@ declares the response header
628 -- \"Content-Type\" as @mType@. Declaring \"Content-Type\" is
629 -- mandatory for sending a response body.
630 setContentType ∷ MIMEType → Resource ()
632 = setHeader "Content-Type" ∘ A.fromAsciiBuilder ∘ MT.printMIMEType
634 -- |@'setLocation' uri@ declares the response header \"Location\" as
635 -- @uri@. You usually don't need to call this function directly.
636 setLocation ∷ URI → Resource ()
638 = case A.fromChars uriStr of
639 Just a → setHeader "Location" a
640 Nothing → abort $ mkAbortion' InternalServerError
641 $ "Malformed URI: " ⊕ T.pack uriStr
643 uriStr = uriToString id uri ""
645 -- |@'setContentEncoding' codings@ declares the response header
646 -- \"Content-Encoding\" as @codings@.
647 setContentEncoding ∷ [CIAscii] → Resource ()
648 setContentEncoding codings
649 = do ver ← getRequestVersion
651 HttpVersion 1 0 → return (toAB ∘ unnormalizeCoding)
652 HttpVersion 1 1 → return toAB
653 _ → abort $ mkAbortion' InternalServerError
654 "setContentEncoding: Unknown HTTP version"
655 setHeader "Content-Encoding"
658 $ intersperse (A.toAsciiBuilder ", ")
661 toAB = A.toAsciiBuilder ∘ A.fromCIAscii
663 -- |@'setWWWAuthenticate' challenge@ declares the response header
664 -- \"WWW-Authenticate\" as @challenge@.
665 setWWWAuthenticate ∷ AuthChallenge → Resource ()
666 setWWWAuthenticate = setHeader "WWW-Authenticate" ∘ printAuthChallenge
668 -- |Write a chunk in 'Strict.ByteString' to the response body. You
669 -- must first declare the response header \"Content-Type\" before
670 -- applying this function. See: 'setContentType'
671 putChunk ∷ Strict.ByteString → Resource ()
672 putChunk = putBuilder ∘ BB.fromByteString
674 -- |Write a chunk in lazy 'Lazy.ByteString' to the response body. It
675 -- can be safely applied to an infinitely long 'Lazy.ByteString'.
677 -- Note that you must first declare the response header
678 -- \"Content-Type\" before applying this function. See:
680 putChunks ∷ Lazy.ByteString → Resource ()
681 putChunks = putBuilder ∘ BB.fromLazyByteString