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.MIMEParams
177 import Network.HTTP.Lucu.MIMEType
178 import Network.HTTP.Lucu.Utils
179 import Network.Socket hiding (accept)
180 import Network.URI hiding (path)
181 import Prelude.Unicode
183 -- |Get the string representation of the address of remote host. If
184 -- you want a 'SockAddr' instead of 'HostName', use 'getRemoteAddr'.
185 getRemoteAddr' ∷ Resource HostName
186 getRemoteAddr' = liftIO ∘ toNM =≪ getRemoteAddr
188 toNM ∷ SockAddr → IO HostName
189 toNM = (fromJust ∘ fst <$>) ∘ getNameInfo [NI_NUMERICHOST] True False
191 -- |Resolve an address to the remote host.
192 getRemoteHost ∷ Resource (Maybe HostName)
193 getRemoteHost = liftIO ∘ getHN =≪ getRemoteAddr
195 getHN ∷ SockAddr → IO (Maybe HostName)
196 getHN = (fst <$>) ∘ getNameInfo [] True False
198 -- |Get the 'Method' value of the request.
199 getMethod ∷ Resource Method
200 getMethod = reqMethod <$> getRequest
202 -- |Get the URI of the request.
203 getRequestURI ∷ Resource URI
204 getRequestURI = reqURI <$> getRequest
206 -- |Get the HTTP version of the request.
207 getRequestVersion ∷ Resource HttpVersion
208 getRequestVersion = reqVersion <$> getRequest
210 -- |This is an analogy of CGI PATH_INFO. 'getPathInfo' always returns
211 -- @[]@ if the corresponding
212 -- 'Network.HTTP.Lucu.Resource.Tree.ResourceDef' is not greedy. See:
215 -- Note that the returned path components are URI-decoded.
216 getPathInfo ∷ Resource [Strict.ByteString]
217 getPathInfo = do rsrcPath ← getResourcePath
218 reqPath ← splitPathInfo <$> getRequestURI
219 return $ drop (length rsrcPath) reqPath
221 -- |Assume the query part of request URI as
222 -- application\/x-www-form-urlencoded, and parse it into pairs of
223 -- @(name, formData)@. This function doesn't read the request
225 getQueryForm ∷ Resource [(Strict.ByteString, FormData)]
226 getQueryForm = parse' <$> getRequestURI
228 parse' = map toPairWithFormData ∘
229 parseWWWFormURLEncoded ∘
235 toPairWithFormData ∷ (ByteString, ByteString) → (Strict.ByteString, FormData)
236 toPairWithFormData (name, value)
237 = let fd = FormData {
239 , fdMIMEType = parseMIMEType "text/plain"
240 , fdContent = Lazy.fromChunks [value]
244 -- |@'getHeader' name@ returns the value of the request header field
245 -- @name@. Comparison of header name is case-insensitive. Note that
246 -- this function is not intended to be used so frequently: there
247 -- should be functions like 'getContentType' for every common headers.
248 getHeader ∷ CIAscii → Resource (Maybe Ascii)
250 = H.getHeader name <$> getRequest
252 -- |Return the list of 'MIMEType' enumerated on the value of request
253 -- header \"Accept\", or @[]@ if absent.
254 getAccept ∷ Resource [MIMEType]
256 = do acceptM ← getHeader "Accept"
261 → case P.parseOnly (finishOff mimeTypeList) (A.toByteString accept) of
263 Left _ → abort $ mkAbortion' BadRequest
264 $ "Unparsable Accept: " ⊕ A.toText accept
266 -- |Return the list of @(contentCoding, qvalue)@ enumerated on the
267 -- value of request header \"Accept-Encoding\". The list is sorted in
268 -- descending order by qvalue.
269 getAcceptEncoding ∷ Resource [(CIAscii, Maybe Double)]
271 = do accEncM ← getHeader "Accept-Encoding"
274 -- HTTP/1.0 には Accept-Encoding が無い場合の規定が無い
275 -- ので安全の爲 identity が指定された事にする。HTTP/1.1
276 -- の場合は何でも受け入れて良い事になってゐるので "*" が
278 → do ver ← getRequestVersion
280 HttpVersion 1 0 → return [("identity", Nothing)]
281 HttpVersion 1 1 → return [("*" , Nothing)]
282 _ → abort $ mkAbortion' InternalServerError
283 "getAcceptEncoding: unknown HTTP version"
287 return [("identity", Nothing)]
289 case P.parseOnly (finishOff acceptEncodingList) (A.toByteString ae) of
290 Right xs → return $ map toTuple $ reverse $ sort xs
291 Left _ → abort $ mkAbortion' BadRequest
292 $ "Unparsable Accept-Encoding: " ⊕ A.toText ae
294 toTuple (AcceptEncoding {..})
295 = (aeEncoding, aeQValue)
297 -- |Return 'True' iff a given content-coding is acceptable by the
299 isEncodingAcceptable ∷ CIAscii → Resource Bool
300 isEncodingAcceptable encoding = any doesMatch <$> getAcceptEncoding
302 doesMatch ∷ (CIAscii, Maybe Double) → Bool
303 doesMatch (e, q) = (e ≡ "*" ∨ e ≡ encoding) ∧ q ≢ Just 0
305 -- |Return the value of request header \"Content-Type\" as 'MIMEType'.
306 getContentType ∷ Resource (Maybe MIMEType)
308 = do cTypeM ← getHeader "Content-Type"
313 → case P.parseOnly (finishOff mimeType) (A.toByteString cType) of
314 Right t → return $ Just t
315 Left _ → abort $ mkAbortion' BadRequest
316 $ "Unparsable Content-Type: " ⊕ A.toText cType
318 -- |Return the value of request header \"Authorization\" as
320 getAuthorization ∷ Resource (Maybe AuthCredential)
322 = do authM ← getHeader "Authorization"
327 → case P.parseOnly (finishOff authCredential) (A.toByteString auth) of
328 Right ac → return $ Just ac
329 Left _ → return Nothing
331 -- |Tell the system that the 'Resource' found an entity for the
332 -- request URI. If this is a GET or HEAD request, a found entity means
333 -- a datum to be replied. If this is a PUT or DELETE request, it means
334 -- a datum which was stored for the URI until now. For POST requests
335 -- it raises an error.
337 -- 'foundEntity' performs \"If-Match\" test or \"If-None-Match\" test
338 -- whenever possible, and if those tests fail, it immediately aborts
339 -- with status \"412 Precondition Failed\" or \"304 Not Modified\"
340 -- depending on the situation.
342 -- If the request method is either GET or HEAD, 'foundEntity'
343 -- automatically puts \"ETag\" and \"Last-Modified\" headers into the
345 foundEntity ∷ ETag → UTCTime → Resource ()
346 foundEntity tag timeStamp
347 = do driftTo ExaminingRequest
350 when (method ≡ GET ∨ method ≡ HEAD)
351 $ setHeader "Last-Modified" (HTTP.toAscii timeStamp)
354 $ mkAbortion' InternalServerError
355 "foundEntity: this is a POST request."
358 driftTo ReceivingBody
360 -- |Tell the system that the 'Resource' found an entity for the
361 -- request URI. The only difference from 'foundEntity' is that
362 -- 'foundETag' doesn't (nor can't) put \"Last-Modified\" header into
365 -- Using this function is discouraged. You should use 'foundEntity'
366 -- whenever possible.
367 foundETag ∷ ETag → Resource ()
369 = do driftTo ExaminingRequest
372 when (method ≡ GET ∨ method ≡ HEAD)
378 $ mkAbortion' InternalServerError
379 "Illegal computation of foundETag for POST request."
381 -- If-Match があればそれを見る。
382 ifMatch ← getHeader "If-Match"
387 → if value ≡ "*" then
390 case P.parseOnly (finishOff eTagList) (A.toByteString value) of
392 -- tags の中に一致するものが無ければ
393 -- PreconditionFailed で終了。
394 → when ((¬) (any (≡ tag) tags))
396 $ mkAbortion' PreconditionFailed
397 $ "The entity tag doesn't match: " ⊕ A.toText value
399 → abort $ mkAbortion' BadRequest
400 $ "Unparsable If-Match: " ⊕ A.toText value
402 let statusForNoneMatch
403 = if method ≡ GET ∨ method ≡ HEAD then
408 -- If-None-Match があればそれを見る。
409 ifNoneMatch ← getHeader "If-None-Match"
414 → if value ≡ "*" then
415 abort $ mkAbortion' statusForNoneMatch
416 $ "The entity tag matches: *"
418 case P.parseOnly (finishOff eTagList) (A.toByteString value) of
420 → when (any (≡ tag) tags)
422 $ mkAbortion' statusForNoneMatch
423 $ "The entity tag matches: " ⊕ A.toText value
425 → abort $ mkAbortion' BadRequest
426 $ "Unparsable If-None-Match: " ⊕ A.toText value
428 driftTo ReceivingBody
430 -- |Tell the system that the 'Resource' found an entity for the
431 -- request URI. The only difference from 'foundEntity' is that
432 -- 'foundTimeStamp' performs \"If-Modified-Since\" test or
433 -- \"If-Unmodified-Since\" test instead of \"If-Match\" test or
434 -- \"If-None-Match\" test. Be aware that any tests based on a last
435 -- modification time are unsafe because it is possible to mess up such
436 -- tests by modifying the entity twice in a second.
438 -- Using this function is discouraged. You should use 'foundEntity'
439 -- whenever possible.
440 foundTimeStamp ∷ UTCTime → Resource ()
441 foundTimeStamp timeStamp
442 = do driftTo ExaminingRequest
445 when (method ≡ GET ∨ method ≡ HEAD)
446 $ setHeader "Last-Modified" (HTTP.toAscii timeStamp)
449 $ mkAbortion' InternalServerError
450 "Illegal computation of foundTimeStamp for POST request."
452 let statusForIfModSince
453 = if method ≡ GET ∨ method ≡ HEAD then
458 -- If-Modified-Since があればそれを見る。
459 ifModSince ← getHeader "If-Modified-Since"
461 Just str → case HTTP.fromAscii str of
463 → when (timeStamp ≤ lastTime)
465 $ mkAbortion' statusForIfModSince
466 $ "The entity has not been modified since " ⊕ A.toText str
468 → return () -- 不正な時刻は無視
471 -- If-Unmodified-Since があればそれを見る。
472 ifUnmodSince ← getHeader "If-Unmodified-Since"
474 Just str → case HTTP.fromAscii str of
476 → when (timeStamp > lastTime)
478 $ mkAbortion' PreconditionFailed
479 $ "The entity has not been modified since " ⊕ A.toText str
481 → return () -- 不正な時刻は無視
484 driftTo ReceivingBody
486 -- |@'foundNoEntity' mStr@ tells the system that the 'Resource' found
487 -- no entity for the request URI. @mStr@ is an optional error message
488 -- to be replied to the client.
490 -- If the request method is PUT, 'foundNoEntity' performs \"If-Match\"
491 -- test and when that fails it aborts with status \"412 Precondition
492 -- Failed\". If the request method is GET, HEAD, POST or DELETE,
493 -- 'foundNoEntity' always aborts with status \"404 Not Found\".
494 foundNoEntity ∷ Maybe Text → Resource ()
496 = do driftTo ExaminingRequest
501 $ mkAbortion NotFound [] msgM
503 -- エンティティが存在しないと云ふ事は、"*" も含めたどのやうな
504 -- If-Match: 條件も滿たさない。
505 ifMatch ← getHeader "If-Match"
506 when (ifMatch ≢ Nothing)
508 $ mkAbortion PreconditionFailed [] msgM
510 driftTo ReceivingBody
512 -- |'foundNoEntity'' is the same as @'foundNoEntity' 'Nothing'@.
513 foundNoEntity' ∷ Resource ()
514 {-# INLINE foundNoEntity' #-}
515 foundNoEntity' = foundNoEntity Nothing
517 -- |@'getChunks' limit@ attemts to read the entire request body up to
518 -- @limit@ bytes, and then make the 'Resource' transit to the
519 -- /Deciding Header/ state. When the actual size of the body is larger
520 -- than @limit@ bytes, 'getChunks' immediately aborts with status
521 -- \"413 Request Entity Too Large\". When the request has no body, it
522 -- returns an empty string.
524 -- When the @limit@ is 'Nothing', 'getChunks' uses the default
525 -- limitation value ('cnfMaxEntityLength') instead.
527 -- 'getChunks' returns a lazy 'Lazy.ByteString' but it's not really
528 -- lazy: reading from the socket just happens at the computation of
529 -- 'getChunks', not at the evaluation of the 'Lazy.ByteString'.
530 getChunks ∷ Maybe Int → Resource Lazy.ByteString
532 | n < 0 = fail ("getChunks: limit must not be negative: " ⧺ show n)
534 | otherwise = getChunks' n
536 = getConfig ≫= getChunks ∘ Just ∘ cnfMaxEntityLength
538 getChunks' ∷ Int → Resource Lazy.ByteString
539 getChunks' limit = go limit (∅)
541 go ∷ Int → Builder → Resource Lazy.ByteString
542 go 0 _ = do chunk ← getChunk 1
543 if Strict.null chunk then
546 abort $ mkAbortion' RequestEntityTooLarge
547 $ "Request body must be smaller than "
548 ⊕ T.pack (show limit)
550 go !n !b = do c ← getChunk $ min n BB.defaultBufferSize
551 if Strict.null c then
553 return $ BB.toLazyByteString b
555 do let n' = n - Strict.length c
556 xs' = b ⊕ BB.fromByteString c
559 -- |@'getForm' limit@ attempts to read the request body with
560 -- 'getChunks' and parse it as @application\/x-www-form-urlencoded@ or
561 -- @multipart\/form-data@. If the request header \"Content-Type\" is
562 -- neither of them, 'getForm' aborts with status \"415 Unsupported
563 -- Media Type\". If the request has no \"Content-Type\", it aborts
564 -- with \"400 Bad Request\".
566 -- Note that there are currently a few limitations on parsing
567 -- @multipart/form-data@. See: 'parseMultipartFormData'
568 getForm ∷ Maybe Int → Resource [(Strict.ByteString, FormData)]
570 = do cTypeM ← getContentType
573 → abort $ mkAbortion' BadRequest "Missing Content-Type"
574 Just (MIMEType "application" "x-www-form-urlencoded" _)
575 → readWWWFormURLEncoded
576 Just (MIMEType "multipart" "form-data" params)
577 → readMultipartFormData params
579 → abort $ mkAbortion' UnsupportedMediaType
582 $ A.toAsciiBuilder "Unsupported media type: "
583 ⊕ printMIMEType cType
585 readWWWFormURLEncoded
586 = (map toPairWithFormData ∘ parseWWWFormURLEncoded)
588 (bsToAscii =≪ getChunks limit)
591 = case A.fromByteString (Strict.concat (Lazy.toChunks bs)) of
593 Nothing → abort $ mkAbortion' BadRequest "Malformed x-www-form-urlencoded"
595 readMultipartFormData (MIMEParams m)
596 = case M.lookup "boundary" m of
598 → abort $ mkAbortion' BadRequest "Missing boundary of multipart/form-data"
600 → do src ← getChunks limit
601 b ← case A.fromText boundary of
603 Nothing → abort $ mkAbortion' BadRequest
604 $ "Malformed boundary: " ⊕ boundary
605 case parseMultipartFormData b src of
606 Right xs → return $ map (first A.toByteString) xs
607 Left err → abort $ mkAbortion' BadRequest $ T.pack err
609 -- |@'redirect' code uri@ declares the response status as @code@ and
610 -- \"Location\" header field as @uri@. The @code@ must satisfy
611 -- 'isRedirection' or it raises an error.
612 redirect ∷ StatusCode → URI → Resource ()
614 = do when (code ≡ NotModified ∨ not (isRedirection code))
616 $ mkAbortion' InternalServerError
619 $ A.toAsciiBuilder "Attempted to redirect with status "
620 ⊕ printStatusCode code
624 -- |@'setContentType' mType@ declares the response header
625 -- \"Content-Type\" as @mType@. Declaring \"Content-Type\" is
626 -- mandatory for sending a response body.
627 setContentType ∷ MIMEType → Resource ()
629 = setHeader "Content-Type" ∘ A.fromAsciiBuilder ∘ printMIMEType
631 -- |@'setLocation' uri@ declares the response header \"Location\" as
632 -- @uri@. You usually don't need to call this function directly.
633 setLocation ∷ URI → Resource ()
635 = case A.fromChars uriStr of
636 Just a → setHeader "Location" a
637 Nothing → abort $ mkAbortion' InternalServerError
638 $ "Malformed URI: " ⊕ T.pack uriStr
640 uriStr = uriToString id uri ""
642 -- |@'setContentEncoding' codings@ declares the response header
643 -- \"Content-Encoding\" as @codings@.
644 setContentEncoding ∷ [CIAscii] → Resource ()
645 setContentEncoding codings
646 = do ver ← getRequestVersion
648 HttpVersion 1 0 → return (toAB ∘ unnormalizeCoding)
649 HttpVersion 1 1 → return toAB
650 _ → abort $ mkAbortion' InternalServerError
651 "setContentEncoding: Unknown HTTP version"
652 setHeader "Content-Encoding"
655 $ intersperse (A.toAsciiBuilder ", ")
658 toAB = A.toAsciiBuilder ∘ A.fromCIAscii
660 -- |@'setWWWAuthenticate' challenge@ declares the response header
661 -- \"WWW-Authenticate\" as @challenge@.
662 setWWWAuthenticate ∷ AuthChallenge → Resource ()
663 setWWWAuthenticate = setHeader "WWW-Authenticate" ∘ printAuthChallenge
665 -- |Write a chunk in 'Strict.ByteString' to the response body. You
666 -- must first declare the response header \"Content-Type\" before
667 -- applying this function. See: 'setContentType'
668 putChunk ∷ Strict.ByteString → Resource ()
669 putChunk = putBuilder ∘ BB.fromByteString
671 -- |Write a chunk in lazy 'Lazy.ByteString' to the response body. It
672 -- can be safely applied to an infinitely long 'Lazy.ByteString'.
674 -- Note that you must first declare the response header
675 -- \"Content-Type\" before applying this function. See:
677 putChunks ∷ Lazy.ByteString → Resource ()
678 putChunks = putBuilder ∘ BB.fromLazyByteString