5 , GeneralizedNewtypeDeriving
13 -- |This is the Resource Monad; monadic actions to define a behavior
14 -- of resource. The 'Rsrc' Monad is a kind of 'IO' Monad thus it
15 -- implements 'MonadIO' class, and it is a state machine as well.
17 -- Request Processing Flow:
19 -- 1. A client issues an HTTP request.
21 -- 2. If the URI of it matches to any resource, the corresponding
22 -- 'Rsrc' Monad starts running on a newly spawned thread.
24 -- 3. The 'Rsrc' Monad looks at request headers, find (or not find)
25 -- an entity, receive the request body (if any), send response
26 -- headers, and then send a response body. This process will be
29 -- 4. The 'Rsrc' Monad and its thread stops running. The client may
30 -- or may not be sending us the next request at this point.
32 -- 'Rsrc' Monad takes the following states. The initial state is
33 -- /Examining Request/ and the final state is /Done/.
35 -- [/Examining Request/] In this state, a 'Rsrc' looks at the
36 -- request header fields and thinks about the corresponding entity
37 -- for it. If there is a suitable entity, the 'Rsrc' tells the
38 -- system an entity tag and its last modification time
39 -- ('foundEntity'). If it found no entity, it tells the system so
40 -- ('foundNoEntity'). In case it is impossible to decide the
41 -- existence of entity, which is a typical case for POST requests,
42 -- 'Rsrc' does nothing in this state.
44 -- [/Receiving Body/] A 'Rsrc' asks the system to receive a request
45 -- body from the client. Before actually reading from the socket,
46 -- the system sends \"100 Continue\" to the client if need be. When
47 -- a 'Rsrc' transits to the next state without receiving all or part
48 -- of a request body, the system automatically discards it.
50 -- [/Deciding Header/] A 'Rsrc' makes a decision of response status
51 -- code and header fields. When it transits to the next state, the
52 -- system validates and completes the header fields and then sends
53 -- them to the client.
55 -- [/Sending Body/] In this state, a 'Rsrc' asks the system to write
56 -- some response body to the socket. When it transits to the next
57 -- state without writing any response body, the system automatically
58 -- completes it depending on the status code. (To be exact, such
59 -- completion only occurs when the 'Rsrc' transits to this state
60 -- without even declaring the \"Content-Type\" header field. See:
63 -- [/Done/] Everything is over. A 'Rsrc' can do nothing for the HTTP
64 -- interaction anymore.
66 -- Note that the state transition is one-way: for instance, it is an
67 -- error to try to read a request body after writing some
68 -- response. This limitation is for efficiency. We don't want to read
69 -- the entire request before starting 'Rsrc', nor we don't want to
70 -- postpone writing the entire response till the end of 'Rsrc'
72 module Network.HTTP.Lucu.Resource
79 -- * Getting request header
80 -- |These functions can be called regardless of the current state,
81 -- and they don't change the state of 'Rsrc'.
87 , getRemoteCertificate
99 , isEncodingAcceptable
103 -- * Finding an entity
104 -- |These functions can be called only in the /Examining Request/
105 -- state. They make the 'Rsrc' transit to the /Receiving Body/
113 -- * Receiving a request body
114 -- |These functions make the 'Rsrc' transit to the /Receiving
120 -- * Declaring response status and header fields
121 -- |These functions can be called at any time before transiting to
122 -- the /Sending Body/ state, but they themselves never causes any
123 -- state transitions.
130 -- ** Less frequently used functions
135 -- * Sending a response body
137 -- |These functions make the 'Rsrc' transit to the /Sending Body/
144 import Blaze.ByteString.Builder (Builder)
145 import qualified Blaze.ByteString.Builder as BB
146 import qualified Blaze.ByteString.Builder.Internal as BB
147 import Control.Applicative
150 import Control.Monad.IO.Class
151 import Control.Monad.Unicode
152 import Data.Ascii (Ascii, CIAscii, AsciiBuilder)
154 import qualified Data.Attoparsec.Char8 as P
155 import Data.ByteString (ByteString)
156 import qualified Data.ByteString as Strict
157 import qualified Data.ByteString.Lazy as Lazy
158 import Data.Collections
159 import Data.Convertible.Base
160 import Data.Convertible.Instances.Text ()
161 import Data.Convertible.Utils
163 import Data.List (intersperse, sort)
166 import Data.Monoid.Unicode
169 import Data.Text (Text)
171 import Data.Time.Format.HTTP
172 import Network.HTTP.Lucu.Abortion
173 import Network.HTTP.Lucu.Authentication
174 import Network.HTTP.Lucu.Config
175 import Network.HTTP.Lucu.ContentCoding
176 import Network.HTTP.Lucu.ETag
177 import qualified Network.HTTP.Lucu.Headers as H
178 import Network.HTTP.Lucu.HttpVersion
179 import Network.HTTP.Lucu.Interaction
180 import Network.HTTP.Lucu.MultipartForm
181 import Network.HTTP.Lucu.Parser
182 import Network.HTTP.Lucu.Request
183 import Network.HTTP.Lucu.Resource.Internal
184 import Network.HTTP.Lucu.Response
185 import Network.HTTP.Lucu.Response.StatusCode
186 import Network.HTTP.Lucu.MIMEType
187 import Network.HTTP.Lucu.Utils
188 import Network.Socket hiding (accept)
189 import Network.URI hiding (path)
190 import Prelude hiding (any, drop, lookup, reverse)
191 import Prelude.Unicode
193 -- |Get the string representation of the address of remote host. If
194 -- you want a 'SockAddr' instead of 'HostName', use 'getRemoteAddr'.
195 getRemoteAddr' ∷ Rsrc HostName
196 getRemoteAddr' = liftIO ∘ toNM =≪ getRemoteAddr
198 toNM ∷ SockAddr → IO HostName
199 toNM = (fromJust ∘ fst <$>) ∘ getNameInfo [NI_NUMERICHOST] True False
201 -- |Resolve an address to the remote host.
202 getRemoteHost ∷ Rsrc (Maybe HostName)
203 getRemoteHost = liftIO ∘ getHN =≪ getRemoteAddr
205 getHN ∷ SockAddr → IO (Maybe HostName)
206 getHN = (fst <$>) ∘ getNameInfo [] True False
208 -- |Get the 'Method' value of the request.
209 getMethod ∷ Rsrc Method
210 getMethod = reqMethod <$> getRequest
212 -- |Get the URI of the request.
213 getRequestURI ∷ Rsrc URI
214 getRequestURI = reqURI <$> getRequest
216 -- |Get the HTTP version of the request.
217 getRequestVersion ∷ Rsrc HttpVersion
218 getRequestVersion = reqVersion <$> getRequest
220 -- |This is an analogy of CGI PATH_INFO. 'getPathInfo' always returns
221 -- @[]@ if the corresponding 'Resource' is not greedy. See
222 -- 'getResourcePath'.
224 -- Note that the returned path components are URI-decoded.
225 getPathInfo ∷ Rsrc [Strict.ByteString]
226 getPathInfo = do rsrcPath ← getResourcePath
227 reqPath ← uriPathSegments <$> getRequestURI
228 return $ drop (length rsrcPath) reqPath
230 -- |Assume the query part of request URI as
231 -- application\/x-www-form-urlencoded, and parse it into pairs of
232 -- @(name, formData)@. This function doesn't read the request
234 getQueryForm ∷ Rsrc [(Strict.ByteString, FormData)]
235 getQueryForm = parse' <$> getRequestURI
237 parse' = map toPairWithFormData ∘
238 parseWWWFormURLEncoded ∘
243 toPairWithFormData ∷ (ByteString, ByteString) → (Strict.ByteString, FormData)
244 toPairWithFormData (name, value)
245 = let fd = FormData {
247 , fdMIMEType = [mimeType| text/plain |]
248 , fdContent = Lazy.fromChunks [value]
252 -- |@'getHeader' name@ returns the value of the request header field
253 -- @name@. Comparison of header name is case-insensitive. Note that
254 -- this function is not intended to be used so frequently: there
255 -- should be functions like 'getContentType' for every common headers.
256 getHeader ∷ CIAscii → Rsrc (Maybe Ascii)
258 = H.getHeader name <$> getRequest
260 -- |Return the list of 'MIMEType' enumerated on the value of request
261 -- header \"Accept\", or @[]@ if absent.
262 getAccept ∷ Rsrc [MIMEType]
264 = do acceptM ← getHeader "Accept"
269 → case P.parseOnly (finishOff def) (cs accept) of
271 Left _ → abort $ mkAbortion' BadRequest
272 $ "Unparsable Accept: " ⊕ cs accept
274 -- |Return the list of @(contentCoding, qvalue)@ enumerated on the
275 -- value of request header \"Accept-Encoding\". The list is sorted in
276 -- descending order by qvalue.
277 getAcceptEncoding ∷ Rsrc [(CIAscii, Maybe Double)]
279 = do accEncM ← getHeader "Accept-Encoding"
282 -- HTTP/1.0 には Accept-Encoding が無い場合の規定が無い
283 -- ので安全の爲 identity が指定された事にする。HTTP/1.1
284 -- の場合は何でも受け入れて良い事になってゐるので "*" が
286 → do ver ← getRequestVersion
288 HttpVersion 1 0 → return [("identity", Nothing)]
289 HttpVersion 1 1 → return [("*" , Nothing)]
290 _ → abort $ mkAbortion' InternalServerError
291 "getAcceptEncoding: unknown HTTP version"
295 return [("identity", Nothing)]
297 case P.parseOnly (finishOff def) (cs ae) of
298 Right xs → return $ map toTuple $ reverse $ sort xs
299 Left _ → abort $ mkAbortion' BadRequest
300 $ "Unparsable Accept-Encoding: " ⊕ cs ae
302 toTuple (AcceptEncoding {..})
303 = (aeEncoding, aeQValue)
305 -- |Return 'True' iff a given content-coding is acceptable by the
307 isEncodingAcceptable ∷ CIAscii → Rsrc Bool
308 isEncodingAcceptable encoding = any doesMatch <$> getAcceptEncoding
310 doesMatch ∷ (CIAscii, Maybe Double) → Bool
311 doesMatch (e, q) = (e ≡ "*" ∨ e ≡ encoding) ∧ q ≢ Just 0
313 -- |Return the value of request header \"Content-Type\" as 'MIMEType'.
314 getContentType ∷ Rsrc (Maybe MIMEType)
316 = do cTypeM ← getHeader "Content-Type"
321 → case P.parseOnly (finishOff def) (cs cType) of
322 Right t → return $ Just t
323 Left _ → abort $ mkAbortion' BadRequest
324 $ "Unparsable Content-Type: " ⊕ cs cType
326 -- |Return the value of request header \"Authorization\" as
328 getAuthorization ∷ Rsrc (Maybe AuthCredential)
330 = do authM ← getHeader "Authorization"
335 → case P.parseOnly (finishOff def) (cs auth) of
336 Right ac → return $ Just ac
337 Left _ → return Nothing
339 -- |Tell the system that the 'Rsrc' found an entity for the request
340 -- URI. If this is a GET or HEAD request, a found entity means a datum
341 -- to be replied. If this is a PUT or DELETE request, it means a datum
342 -- which was stored for the URI until now. For POST requests it raises
345 -- 'foundEntity' performs \"If-Match\" test or \"If-None-Match\" test
346 -- whenever possible, and if those tests fail, it immediately aborts
347 -- with status \"412 Precondition Failed\" or \"304 Not Modified\"
348 -- depending on the situation.
350 -- If the request method is either GET or HEAD, 'foundEntity'
351 -- automatically puts \"ETag\" and \"Last-Modified\" headers into the
353 foundEntity ∷ ETag → UTCTime → Rsrc ()
354 foundEntity tag timeStamp
355 = do driftTo ExaminingRequest
358 when (method ≡ GET ∨ method ≡ HEAD)
359 $ setHeader "Last-Modified"
364 $ mkAbortion' InternalServerError
365 "foundEntity: this is a POST request."
368 driftTo ReceivingBody
370 -- |Tell the system that the 'Rsrc' found an entity for the request
371 -- URI. The only difference from 'foundEntity' is that 'foundETag'
372 -- doesn't (nor can't) put \"Last-Modified\" header into the response.
374 -- Using this function is discouraged. You should use 'foundEntity'
375 -- whenever possible.
376 foundETag ∷ ETag → Rsrc ()
378 = do driftTo ExaminingRequest
381 when (method ≡ GET ∨ method ≡ HEAD)
386 $ mkAbortion' InternalServerError
387 "Illegal computation of foundETag for POST request."
389 -- If-Match があればそれを見る。
390 ifMatch ← getHeader "If-Match"
395 → if value ≡ "*" then
398 case P.parseOnly (finishOff def) (cs value) of
400 → abort $ mkAbortion' BadRequest
403 -- tags の中に一致するものが無ければ
404 -- PreconditionFailed で終了。
405 → when ((¬) (any (≡ tag) tags))
407 $ mkAbortion' PreconditionFailed
408 $ "The entity tag doesn't match: " ⊕ cs value
410 → abort $ mkAbortion' BadRequest
411 $ "Unparsable If-Match: " ⊕ cs value
413 let statusForNoneMatch
414 = if method ≡ GET ∨ method ≡ HEAD then
415 fromStatusCode NotModified
417 fromStatusCode PreconditionFailed
419 -- If-None-Match があればそれを見る。
420 ifNoneMatch ← getHeader "If-None-Match"
425 → if value ≡ "*" then
426 abort $ mkAbortion' statusForNoneMatch
427 $ "The entity tag matches: *"
429 case P.parseOnly (finishOff def) (cs value) of
431 → abort $ mkAbortion' BadRequest
432 $ "Empty If-None-Match"
434 → when (any (≡ tag) tags)
436 $ mkAbortion' statusForNoneMatch
437 $ "The entity tag matches: " ⊕ cs value
439 → abort $ mkAbortion' BadRequest
440 $ "Unparsable If-None-Match: " ⊕ cs value
442 driftTo ReceivingBody
444 -- |Tell the system that the 'Rsrc' 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 → Rsrc ()
455 foundTimeStamp timeStamp
456 = do driftTo ExaminingRequest
459 when (method ≡ GET ∨ method ≡ HEAD)
460 $ setHeader "Last-Modified"
465 $ mkAbortion' InternalServerError
466 "Illegal call of foundTimeStamp for POST request."
468 let statusForIfModSince
469 = if method ≡ GET ∨ method ≡ HEAD then
470 fromStatusCode NotModified
472 fromStatusCode PreconditionFailed
474 ifModSince ← getHeader "If-Modified-Since"
476 Just str → case fromAttempt $ ca (Tagged str ∷ Tagged HTTP Ascii) of
478 → when (timeStamp ≤ lastTime)
480 $ mkAbortion' statusForIfModSince
481 $ "The entity has not been modified since " ⊕ cs str
483 → abort $ mkAbortion' BadRequest
484 $ "Malformed If-Modified-Since: " ⊕ cs str
487 ifUnmodSince ← getHeader "If-Unmodified-Since"
489 Just str → case fromAttempt $ ca (Tagged str ∷ Tagged HTTP Ascii) of
491 → when (timeStamp > lastTime)
493 $ mkAbortion' PreconditionFailed
494 $ "The entity has not been modified since " ⊕ cs str
496 → abort $ mkAbortion' BadRequest
497 $ "Malformed If-Unmodified-Since: " ⊕ cs str
500 driftTo ReceivingBody
502 -- |@'foundNoEntity' mStr@ tells the system that the 'Rsrc' found no
503 -- entity for the request URI. @mStr@ is an optional error message to
504 -- be replied to the client.
506 -- If the request method is PUT, 'foundNoEntity' performs \"If-Match\"
507 -- test and when that fails it aborts with status \"412 Precondition
508 -- Failed\". If the request method is GET, HEAD, POST or DELETE,
509 -- 'foundNoEntity' always aborts with status \"404 Not Found\".
510 foundNoEntity ∷ Maybe Text → Rsrc ()
512 = do driftTo ExaminingRequest
517 $ mkAbortion NotFound [] msgM
519 -- エンティティが存在しないと云ふ事は、"*" も含めたどのやうな
520 -- If-Match: 條件も滿たさない。
521 ifMatch ← getHeader "If-Match"
522 when (ifMatch ≢ Nothing)
524 $ mkAbortion PreconditionFailed [] msgM
526 driftTo ReceivingBody
528 -- |'foundNoEntity'' is the same as @'foundNoEntity' 'Nothing'@.
529 foundNoEntity' ∷ Rsrc ()
530 {-# INLINE foundNoEntity' #-}
531 foundNoEntity' = foundNoEntity Nothing
533 -- |@'getChunks' limit@ attemts to read the entire request body up to
534 -- @limit@ bytes, and then make the 'Rsrc' transit to the /Deciding
535 -- Header/ state. When the actual size of the body is larger than
536 -- @limit@ bytes, 'getChunks' immediately aborts with status \"413
537 -- Request Entity Too Large\". When the request has no body, it
538 -- returns an empty string.
540 -- When the @limit@ is 'Nothing', 'getChunks' uses the default
541 -- limitation value ('cnfMaxEntityLength') instead.
543 -- 'getChunks' returns a lazy 'Lazy.ByteString' but it's not really
544 -- lazy: reading from the socket just happens at the computation of
545 -- 'getChunks', not at the evaluation of the 'Lazy.ByteString'.
546 getChunks ∷ Maybe Int → Rsrc Lazy.ByteString
548 | n < 0 = fail ("getChunks: limit must not be negative: " ⧺ show n)
550 | otherwise = getChunks' n
552 = getConfig ≫= getChunks ∘ Just ∘ cnfMaxEntityLength
554 getChunks' ∷ Int → Rsrc Lazy.ByteString
555 getChunks' limit = go limit (∅)
557 go ∷ Int → Builder → Rsrc Lazy.ByteString
558 go 0 _ = do chunk ← getChunk 1
559 if Strict.null chunk then
562 abort $ mkAbortion' RequestEntityTooLarge
563 $ "Request body must be smaller than "
566 go !n !b = do c ← getChunk $ min n BB.defaultBufferSize
567 if Strict.null c then
569 return $ BB.toLazyByteString b
571 do let n' = n - Strict.length c
572 xs' = b ⊕ BB.fromByteString c
575 -- |@'getForm' limit@ attempts to read the request body with
576 -- 'getChunks' and parse it as @application\/x-www-form-urlencoded@ or
577 -- @multipart\/form-data@. If the request header \"Content-Type\" is
578 -- neither of them, 'getForm' aborts with status \"415 Unsupported
579 -- Media Type\". If the request has no \"Content-Type\", it aborts
580 -- with \"400 Bad Request\".
582 -- Note that there are currently a few limitations on parsing
583 -- @multipart/form-data@. See: 'parseMultipartFormData'
584 getForm ∷ Maybe Int → Rsrc [(Strict.ByteString, FormData)]
586 = do cTypeM ← getContentType
589 → abort $ mkAbortion' BadRequest "Missing Content-Type"
590 Just (MIMEType "application" "x-www-form-urlencoded" _)
591 → readWWWFormURLEncoded
592 Just (MIMEType "multipart" "form-data" params)
593 → readMultipartFormData params
595 → abort $ mkAbortion' UnsupportedMediaType
597 $ ("Unsupported media type: " ∷ Ascii)
600 readWWWFormURLEncoded
601 = (map toPairWithFormData ∘ parseWWWFormURLEncoded)
603 (bsToAscii =≪ getChunks limit)
606 = case convertAttemptVia ((⊥) ∷ ByteString) bs of
608 Failure e → abort $ mkAbortion' BadRequest $ cs (show e)
610 readMultipartFormData m
611 = case lookup "boundary" m of
613 → abort $ mkAbortion' BadRequest "Missing boundary of multipart/form-data"
615 → do src ← getChunks limit
616 b ← case ca boundary of
618 Failure _ → abort $ mkAbortion' BadRequest
619 $ "Malformed boundary: " ⊕ boundary
620 case parseMultipartFormData b src of
621 Right xs → return $ map (first cs) xs
622 Left err → abort $ mkAbortion' BadRequest $ cs err
624 -- |@'redirect' code uri@ declares the response status as @code@ and
625 -- \"Location\" header field as @uri@. The @code@ must satisfy
626 -- 'isRedirection' or it raises an error.
627 redirect ∷ StatusCode sc ⇒ sc → URI → Rsrc ()
628 redirect (fromStatusCode → sc) uri
629 = do when (sc ≡ cs NotModified ∨ (¬) (isRedirection sc))
631 $ mkAbortion' InternalServerError
633 $ ("Attempted to redirect with status " ∷ Ascii)
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 → Rsrc ()
642 setContentType = setHeader "Content-Type" ∘ cs
644 -- |@'setLocation' uri@ declares the response header \"Location\" as
645 -- @uri@. You usually don't need to call this function directly.
646 setLocation ∷ URI → Rsrc ()
649 Success a → setHeader "Location" a
650 Failure e → abort $ mkAbortion' InternalServerError
653 uriStr = uriToString id uri ""
655 -- |@'setContentEncoding' codings@ declares the response header
656 -- \"Content-Encoding\" as @codings@.
657 setContentEncoding ∷ [CIAscii] → Rsrc ()
658 setContentEncoding codings
659 = do ver ← getRequestVersion
661 HttpVersion 1 0 → return (toAB ∘ unnormalizeCoding)
662 HttpVersion 1 1 → return toAB
663 _ → abort $ mkAbortion' InternalServerError
664 "setContentEncoding: Unknown HTTP version"
665 setHeader "Content-Encoding"
668 $ intersperse (cs (", " ∷ Ascii))
671 toAB ∷ ConvertSuccess α AsciiBuilder ⇒ α → AsciiBuilder
674 -- |@'setWWWAuthenticate' challenge@ declares the response header
675 -- \"WWW-Authenticate\" as @challenge@.
676 setWWWAuthenticate ∷ AuthChallenge → Rsrc ()
677 setWWWAuthenticate = setHeader "WWW-Authenticate" ∘ cs
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 → Rsrc ()
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 → Rsrc ()
692 putChunks = putBuilder ∘ BB.fromLazyByteString