2 GeneralizedNewtypeDeriving
8 -- |This is the Resource Monad; monadic actions to define a behavior
9 -- of resource. The 'Resource' Monad is a kind of 'IO' Monad thus it
10 -- implements 'MonadIO' class, and it is a state machine as well.
12 -- Request Processing Flow:
14 -- 1. A client issues an HTTP request.
16 -- 2. If the URI of it matches to any resource, the corresponding
17 -- 'Resource' Monad starts running on a newly spawned thread.
19 -- 3. The 'Resource' Monad looks at request headers, find (or not
20 -- find) an entity, receive the request body (if any), send
21 -- response headers, and then send a response body. This process
22 -- will be discussed later.
24 -- 4. The 'Resource' Monad and its thread stops running. The client
25 -- may or may not be sending us the next request at this point.
27 -- 'Resource' Monad takes the following states. The initial state is
28 -- /Examining Request/ and the final state is /Done/.
30 -- [/Examining Request/] In this state, a 'Resource' looks at the
31 -- request header fields and thinks about a corresponding entity for
32 -- it. If there is a suitable entity, the 'Resource' tells the
33 -- system an entity tag and its last modification time
34 -- ('foundEntity'). If it found no entity, it tells the system so
35 -- ('foundNoEntity'). In case it is impossible to decide the
36 -- existence of entity, which is a typical case for POST requests,
37 -- 'Resource' does nothing in this state.
39 -- [/Receiving Body/] A 'Resource' asks the system to receive a
40 -- request body from the client. Before actually reading from the
41 -- socket, the system sends \"100 Continue\" to the client if need
42 -- be. When a 'Resource' transits to the next state without
43 -- receiving all or part of a request body, the system automatically
44 -- receives and discards it.
46 -- [/Deciding Header/] A 'Resource' makes a decision of status code
47 -- and response header fields. When it transits to the next state,
48 -- the system validates and completes the response header fields and
49 -- then sends them to the client.
51 -- [/Sending Body/] In this state, a 'Resource' asks the system to
52 -- write some response body to the socket. When it transits to the
53 -- next state without writing any response body, the system
54 -- automatically completes it depending on the status code. (To be
55 -- exact, such completion only occurs when the 'Resource' transits
56 -- to this state without even declaring the \"Content-Type\" header
57 -- field. See 'setContentType'.)
59 -- [/Done/] Everything is over. A 'Resource' can do nothing for the
60 -- HTTP interaction anymore.
62 -- Note that the state transition is one-way: for instance, it is an
63 -- error to try to read a request body after writing some
64 -- response. This limitation is for efficiency. We don't want to read
65 -- the entire request before starting 'Resource', nor we don't want to
66 -- postpone writing the entire response till the end of 'Resource'
68 module Network.HTTP.Lucu.Resource
76 -- * Getting request header
77 -- |These functions can be called regardless of the current state,
78 -- and they don't change the state of 'Resource'.
83 , getRemoteCertificate
94 , isEncodingAcceptable
98 -- * Finding an entity
99 -- |These functions can be called only in the /Examining Request/
100 -- state. They make the 'Resource' transit to the /Receiving Body/
107 -- * Receiving a request body
108 -- |These functions make the 'Resource' transit to the /Receiving
114 -- * Declaring response status and header fields
115 -- |These functions can be called at any time before transiting to
116 -- the /Sending Body/ state, but they themselves never causes any
117 -- state transitions.
124 -- ** Less frequently used functions
129 -- * Sending a response body
130 -- |These functions make the 'Resource' transit to the /Sending
137 import qualified Blaze.ByteString.Builder.ByteString as BB
138 import Control.Applicative
140 import Control.Monad.IO.Class
141 import Control.Monad.Unicode
142 import Data.Ascii (Ascii, CIAscii)
143 import qualified Data.Ascii as A
144 import qualified Data.Attoparsec.Char8 as P
145 import qualified Data.Attoparsec.Lazy as LP
146 import Data.ByteString (ByteString)
147 import qualified Data.ByteString as Strict
148 import qualified Data.ByteString.Lazy as Lazy
149 import qualified Data.ByteString.Lazy.Internal as Lazy
150 import Data.Foldable (toList)
152 import qualified Data.Map as M
154 import Data.Monoid.Unicode
155 import Data.Sequence (Seq)
156 import Data.Sequence.Unicode hiding ((∅))
157 import Data.Text (Text)
158 import qualified Data.Text as T
159 import qualified Data.Text.Encoding as T
161 import qualified Data.Time.HTTP as HTTP
162 import Network.HTTP.Lucu.Abortion
163 import Network.HTTP.Lucu.Authorization
164 import Network.HTTP.Lucu.Config
165 import Network.HTTP.Lucu.ContentCoding
166 import Network.HTTP.Lucu.ETag
167 import qualified Network.HTTP.Lucu.Headers as H
168 import Network.HTTP.Lucu.HttpVersion
169 import Network.HTTP.Lucu.Interaction
170 import Network.HTTP.Lucu.MultipartForm
171 import Network.HTTP.Lucu.Request
172 import Network.HTTP.Lucu.Resource.Internal
173 import Network.HTTP.Lucu.Response
174 import Network.HTTP.Lucu.MIMEType
175 import Network.HTTP.Lucu.Utils
176 import Network.Socket hiding (accept)
177 import Network.URI hiding (path)
178 import Prelude.Unicode
180 -- |Get the string representation of the address of remote host. If
181 -- you want a 'SockAddr' instead of 'HostName', use 'getRemoteAddr'.
182 getRemoteAddr' ∷ Resource HostName
184 = do sa ← getRemoteAddr
185 (fromJust ∘ fst) <$> (liftIO $ getNameInfo [NI_NUMERICHOST] True False sa)
187 -- |Resolve an address to the remote host.
188 getRemoteHost ∷ Resource (Maybe HostName)
190 = do sa ← getRemoteAddr
191 fst <$> (liftIO $ getNameInfo [] True False sa)
193 -- |Get the 'Method' value of the request.
194 getMethod ∷ Resource Method
195 getMethod = reqMethod <$> getRequest
197 -- |Get the URI of the request.
198 getRequestURI ∷ Resource URI
199 getRequestURI = reqURI <$> getRequest
201 -- |Get the HTTP version of the request.
202 getRequestVersion ∷ Resource HttpVersion
203 getRequestVersion = reqVersion <$> getRequest
205 -- |This is an analogy of CGI PATH_INFO. 'getPathInfo' always returns
206 -- @[]@ if the corresponding
207 -- 'Network.HTTP.Lucu.Resource.Tree.ResourceDef' is not greedy. See
208 -- 'getResourcePath'.
210 -- Note that the returned path components are URI-decoded.
211 getPathInfo ∷ Resource [Strict.ByteString]
212 getPathInfo = do rsrcPath ← getResourcePath
213 reqPath ← splitPathInfo <$> getRequestURI
214 return $ drop (length rsrcPath) reqPath
216 -- |Assume the query part of request URI as
217 -- application\/x-www-form-urlencoded, and parse it into pairs of
218 -- @(name, formData)@. This function doesn't read the request
219 -- body. Field names are decoded in UTF-8 for an hardly avoidable
220 -- reason. See 'getForm'.
221 getQueryForm ∷ Resource [(Text, FormData)]
222 getQueryForm = parse' <$> getRequestURI
224 parse' = map toPairWithFormData ∘
225 parseWWWFormURLEncoded ∘
231 toPairWithFormData ∷ (ByteString, ByteString) → (Text, FormData)
232 toPairWithFormData (name, value)
233 = let fd = FormData {
235 , fdContent = Lazy.fromChunks [value]
237 in (T.decodeUtf8 name, fd)
239 -- |@'getHeader' name@ returns the value of the request header field
240 -- @name@. Comparison of header name is case-insensitive. Note that
241 -- this function is not intended to be used so frequently: there
242 -- should be actions like 'getContentType' for every common headers.
243 getHeader ∷ CIAscii → Resource (Maybe Ascii)
245 = H.getHeader name <$> getRequest
247 -- |Return the list of 'MIMEType' enumerated on the value of request
248 -- header \"Accept\", or @[]@ if absent.
249 getAccept ∷ Resource [MIMEType]
251 = do acceptM ← getHeader "Accept"
256 → case P.parseOnly p (A.toByteString accept) of
258 Left _ → abort BadRequest []
259 (Just $ "Unparsable Accept: " ⊕ A.toText accept)
261 p = do xs ← mimeTypeListP
265 -- |Return the list of @(contentCoding, qvalue)@ enumerated on the
266 -- value of request header \"Accept-Encoding\". The list is sorted in
267 -- descending order by qvalue.
268 getAcceptEncoding ∷ Resource [(CIAscii, Maybe Double)]
270 = do accEncM ← getHeader "Accept-Encoding"
273 -- HTTP/1.0 には Accept-Encoding が無い場合の規定が無い
274 -- ので安全の爲 identity が指定された事にする。HTTP/1.1
275 -- の場合は何でも受け入れて良い事になってゐるので "*" が
277 → do ver ← getRequestVersion
279 HttpVersion 1 0 → return [("identity", Nothing)]
280 HttpVersion 1 1 → return [("*" , Nothing)]
281 _ → abort InternalServerError []
282 (Just "getAcceptEncoding: unknown HTTP version")
286 return [("identity", Nothing)]
288 case P.parseOnly p (A.toByteString ae) of
289 Right xs → return $ map toTuple $ reverse $ sort xs
290 Left _ → abort BadRequest []
291 (Just $ "Unparsable Accept-Encoding: " ⊕ A.toText ae)
293 p = do xs ← acceptEncodingListP
297 toTuple (AcceptEncoding {..})
298 = (aeEncoding, aeQValue)
300 -- |Return 'True' iff a given content-coding is acceptable.
301 isEncodingAcceptable ∷ CIAscii → Resource Bool
302 isEncodingAcceptable encoding = any doesMatch <$> getAcceptEncoding
304 doesMatch ∷ (CIAscii, Maybe Double) → Bool
305 doesMatch (e, q) = (e ≡ "*" ∨ e ≡ encoding) ∧ q ≢ Just 0
307 -- |Return the value of request header \"Content-Type\" as 'MIMEType'.
308 getContentType ∷ Resource (Maybe MIMEType)
310 = do cTypeM ← getHeader "Content-Type"
315 → case P.parseOnly p (A.toByteString cType) of
316 Right t → return $ Just t
317 Left _ → abort BadRequest []
318 (Just $ "Unparsable Content-Type: " ⊕ A.toText cType)
324 -- |Return the value of request header \"Authorization\" as
326 getAuthorization ∷ Resource (Maybe AuthCredential)
328 = do authM ← getHeader "Authorization"
333 → case P.parseOnly p (A.toByteString auth) of
334 Right ac → return $ Just ac
335 Left _ → return Nothing
337 p = do ac ← authCredentialP
341 -- |Tell the system that the 'Resource' found an entity for the
342 -- request URI. If this is a GET or HEAD request, a found entity means
343 -- a datum to be replied. If this is a PUT or DELETE request, it means
344 -- a datum which was stored for the URI until now. For POST requests
345 -- it raises an error.
347 -- 'foundEntity' performs \"If-Match\" test or \"If-None-Match\" test
348 -- whenever possible, and if those tests fail, it immediately aborts
349 -- with status \"412 Precondition Failed\" or \"304 Not Modified\"
350 -- depending on the situation.
352 -- If the request method is either GET or HEAD, 'foundEntity'
353 -- automatically puts \"ETag\" and \"Last-Modified\" headers into the
355 foundEntity ∷ ETag → UTCTime → Resource ()
356 foundEntity tag timeStamp
357 = do driftTo ExaminingRequest
360 when (method ≡ GET ∨ method ≡ HEAD)
361 $ setHeader "Last-Modified" (HTTP.toAscii timeStamp)
363 $ abort InternalServerError []
364 (Just "foundEntity: this is a POST request.")
367 driftTo ReceivingBody
369 -- |Tell the system that the 'Resource' found an entity for the
370 -- request URI. The only difference from 'foundEntity' is that
371 -- 'foundETag' doesn't (nor can't) put \"Last-Modified\" header into
374 -- Using this function is discouraged. You should use 'foundEntity'
375 -- whenever possible.
376 foundETag ∷ ETag → Resource ()
378 = do driftTo ExaminingRequest
381 when (method ≡ GET ∨ method ≡ HEAD)
386 $ abort InternalServerError []
387 $ Just "Illegal computation of foundETag for POST request."
389 -- If-Match があればそれを見る。
390 ifMatch ← getHeader "If-Match"
393 Just value → if value ≡ "*" then
396 case P.parseOnly p (A.toByteString value) of
398 -- tags の中に一致するものが無ければ
399 -- PreconditionFailed で終了。
400 → when ((¬) (any (≡ tag) tags))
401 $ abort PreconditionFailed []
403 $ "The entity tag doesn't match: " ⊕ A.toText value
405 → abort BadRequest []
407 $ "Unparsable If-Match: " ⊕ A.toText value
409 let statusForNoneMatch
410 = if method ≡ GET ∨ method ≡ HEAD then
415 -- If-None-Match があればそれを見る。
416 ifNoneMatch ← getHeader "If-None-Match"
419 Just value → if value ≡ "*" then
420 abort statusForNoneMatch [] (Just "The entity tag matches: *")
422 case P.parseOnly p (A.toByteString value) of
424 → when (any (≡ tag) tags)
425 $ abort statusForNoneMatch []
427 $ "The entity tag matches: " ⊕ A.toText value
429 → abort BadRequest []
431 $ "Unparsable If-None-Match: " ⊕ A.toText value
433 driftTo ReceivingBody
435 p = do xs ← eTagListP
439 -- |Tell the system that the 'Resource' found an entity for the
440 -- request URI. The only difference from 'foundEntity' is that
441 -- 'foundTimeStamp' performs \"If-Modified-Since\" test or
442 -- \"If-Unmodified-Since\" test instead of \"If-Match\" test or
443 -- \"If-None-Match\" test. Be aware that any tests based on a last
444 -- modification time are unsafe because it is possible to mess up such
445 -- tests by modifying the entity twice in a second.
447 -- Using this function is discouraged. You should use 'foundEntity'
448 -- whenever possible.
449 foundTimeStamp ∷ UTCTime → Resource ()
450 foundTimeStamp timeStamp
451 = do driftTo ExaminingRequest
454 when (method ≡ GET ∨ method ≡ HEAD)
455 $ setHeader "Last-Modified" (HTTP.toAscii timeStamp)
457 $ abort InternalServerError []
458 (Just "Illegal computation of foundTimeStamp for POST request.")
460 let statusForIfModSince
461 = if method ≡ GET ∨ method ≡ HEAD then
466 -- If-Modified-Since があればそれを見る。
467 ifModSince ← getHeader "If-Modified-Since"
469 Just str → case HTTP.fromAscii str of
471 → when (timeStamp ≤ lastTime)
472 $ abort statusForIfModSince []
473 (Just $ "The entity has not been modified since " ⊕ A.toText str)
475 → return () -- 不正な時刻は無視
478 -- If-Unmodified-Since があればそれを見る。
479 ifUnmodSince ← getHeader "If-Unmodified-Since"
481 Just str → case HTTP.fromAscii str of
483 → when (timeStamp > lastTime)
484 $ abort PreconditionFailed []
485 (Just $ "The entity has not been modified since " ⊕ A.toText str)
487 → return () -- 不正な時刻は無視
490 driftTo ReceivingBody
492 -- |@'foundNoEntity' mStr@ tells the system that the 'Resource' found
493 -- no entity for the request URI. @mStr@ is an optional error message
494 -- to be replied to the client.
496 -- If the request method is PUT, 'foundNoEntity' performs \"If-Match\"
497 -- test and when that fails it aborts with status \"412 Precondition
498 -- Failed\". If the request method is GET, HEAD, POST or DELETE,
499 -- 'foundNoEntity' always aborts with status \"404 Not Found\".
500 foundNoEntity ∷ Maybe Text → Resource ()
502 = do driftTo ExaminingRequest
506 $ abort NotFound [] msgM
508 -- エンティティが存在しないと云ふ事は、"*" も含めたどのやうな
509 -- If-Match: 條件も滿たさない。
510 ifMatch ← getHeader "If-Match"
511 when (ifMatch ≢ Nothing)
512 $ abort PreconditionFailed [] msgM
514 driftTo ReceivingBody
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.ByteString' but it's not really lazy:
528 -- 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 → Seq Strict.ByteString → Resource Lazy.ByteString
542 go 0 _ = abort RequestEntityTooLarge []
543 (Just $ "Request body must be smaller than "
544 ⊕ T.pack (show limit) ⊕ " bytes.")
545 go n xs = do let n' = min n Lazy.defaultChunkSize
547 if Strict.null chunk then
549 return $ Lazy.fromChunks $ toList xs
551 do let n'' = n' - Strict.length chunk
555 -- |@'getForm' limit@ attempts to read the request body with
556 -- 'getChunks' and parse it as @application\/x-www-form-urlencoded@ or
557 -- @multipart\/form-data@. If the request header \"Content-Type\" is
558 -- neither of them, 'getForm' aborts with status \"415 Unsupported
559 -- Media Type\". If the request has no \"Content-Type\", it aborts
560 -- with \"400 Bad Request\".
562 -- Field names in @multipart\/form-data@ will be precisely decoded in
563 -- accordance with RFC 2231. On the other hand,
564 -- @application\/x-www-form-urlencoded@ says nothing about character
565 -- encodings for field names, so they'll always be decoded in
566 -- UTF-8. (This could be a bad design, but I can't think of any better
568 getForm ∷ Maybe Int → Resource [(Text, FormData)]
570 = do cTypeM ← getContentType
573 → abort BadRequest [] (Just "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 UnsupportedMediaType []
583 $ A.toAsciiBuilder "Unsupported media type: "
584 ⊕ printMIMEType cType
586 readWWWFormURLEncoded
587 = (map toPairWithFormData ∘ parseWWWFormURLEncoded)
589 (bsToAscii =≪ getChunks limit)
592 = case A.fromByteString (Strict.concat (Lazy.toChunks bs)) of
594 Nothing → abort BadRequest [] (Just "Malformed x-www-form-urlencoded")
596 readMultipartFormData params
597 = do case M.lookup "boundary" params of
599 → abort BadRequest [] (Just "Missing boundary of multipart/form-data")
601 → do src ← getChunks limit
602 b ← case A.fromText boundary of
604 Nothing → abort BadRequest []
605 (Just $ "Malformed boundary: " ⊕ boundary)
606 case LP.parse (p b) src of
609 _ → abort BadRequest [] (Just "Unparsable multipart/form-data")
611 p b = do xs ← multipartFormP b
615 -- |@'redirect' code uri@ declares the response status as @code@ and
616 -- \"Location\" header field as @uri@. The @code@ must satisfy
617 -- 'isRedirection' or it raises an error.
618 redirect ∷ StatusCode → URI → Resource ()
620 = do when (code ≡ NotModified ∨ not (isRedirection code))
621 $ abort InternalServerError []
625 $ A.toAsciiBuilder "Attempted to redirect with status "
626 ⊕ printStatusCode code
630 -- |@'setContentType' mType@ declares the response header
631 -- \"Content-Type\" as @mType@. Declaring \"Content-Type\" is
632 -- mandatory for sending a response body.
633 setContentType ∷ MIMEType → Resource ()
635 = setHeader "Content-Type" ∘ A.fromAsciiBuilder ∘ printMIMEType
637 -- |@'setLocation' uri@ declares the response header \"Location\" as
638 -- @uri@. You usually don't need to call this function directly.
639 setLocation ∷ URI → Resource ()
641 = case A.fromChars uriStr of
642 Just a → setHeader "Location" a
643 Nothing → abort InternalServerError []
644 (Just $ "Malformed URI: " ⊕ T.pack uriStr)
646 uriStr = uriToString id uri ""
648 -- |@'setContentEncoding' codings@ declares the response header
649 -- \"Content-Encoding\" as @codings@.
650 setContentEncoding ∷ [CIAscii] → Resource ()
651 setContentEncoding codings
652 = do ver ← getRequestVersion
654 HttpVersion 1 0 → return (toAB ∘ unnormalizeCoding)
655 HttpVersion 1 1 → return toAB
656 _ → abort InternalServerError []
657 (Just "setContentEncoding: Unknown HTTP version")
658 setHeader "Content-Encoding"
659 (A.fromAsciiBuilder $ joinWith ", " $ map tr codings)
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.ByteString' to the response body. It is
675 -- safe to apply this function to an infinitely long
676 -- '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