Network/HTTP/Lucu/Resource.hs

   1 {-# LANGUAGE
   2     BangPatterns
   3   , GeneralizedNewtypeDeriving
   4   , DoAndIfThenElse
   5   , OverloadedStrings
   6   , QuasiQuotes
   7   , RecordWildCards
   8   , UnicodeSyntax
   9   #-}
  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.
  13 --
  14 -- Request Processing Flow:
  15 --
  16 --   1. A client issues an HTTP request.
  17 --
  18 --   2. If the URI of it matches to any resource, the corresponding
  19 --      'Resource' Monad starts running on a newly spawned thread.
  20 --
  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.
  25 --
  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.
  28 --
  29 -- 'Resource' Monad takes the following states. The initial state is
  30 -- /Examining Request/ and the final state is /Done/.
  31 --
  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.
  40 --
  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
  46 --   discards it.
  47 --
  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.
  52 --
  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')
  60 --
  61 --   [/Done/] Everything is over. A 'Resource' can do nothing for the
  62 --   HTTP interaction anymore.
  63 --
  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'
  69 -- computation.
  70 module Network.HTTP.Lucu.Resource
  71     (
  72     -- * Types
  73       Resource
  74     , ResourceDef(..)
  75     , emptyResource
  76     , FormData(..)
  77
  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'.
  81     , getConfig
  82     , getRemoteAddr
  83     , getRemoteAddr'
  84     , getRemoteHost
  85     , getRemoteCertificate
  86     , getRequest
  87     , getMethod
  88     , getRequestURI
  89     , getRequestVersion
  90     , getResourcePath
  91     , getPathInfo
  92     , getQueryForm
  93     , getHeader
  94     , getAccept
  95     , getAcceptEncoding
  96     , isEncodingAcceptable
  97     , getContentType
  98     , getAuthorization
  99
 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/
 103     -- state.
 104     , foundEntity
 105     , foundETag
 106     , foundTimeStamp
 107     , foundNoEntity
 108     , foundNoEntity'
 109
 110     -- * Receiving a request body
 111     -- |These functions make the 'Resource' transit to the /Receiving
 112     -- Body/ state.
 113     , getChunk
 114     , getChunks
 115     , getForm
 116
 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.
 121     , setStatus
 122     , redirect
 123     , setContentType
 124     , setContentEncoding
 125     , setWWWAuthenticate
 126
 127     -- ** Less frequently used functions
 128     , setLocation
 129     , setHeader
 130     , deleteHeader
 131
 132     -- * Sending a response body
 133
 134     -- |These functions make the 'Resource' transit to the
 135     -- /Sending Body/ state.
 136     , putChunk
 137     , putChunks
 138     , putBuilder
 139     )
 140     where
 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
 145 import Control.Arrow
 146 import Control.Monad
 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
 155 import Data.List
 156 import qualified Data.Map as M
 157 import Data.Maybe
 158 import Data.Monoid
 159 import Data.Monoid.Unicode
 160 import Data.Text (Text)
 161 import qualified Data.Text as T
 162 import Data.Time
 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
 185
 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
 190     where
 191       toNM ∷ SockAddr → IO HostName
 192       toNM = (fromJust ∘ fst <$>) ∘ getNameInfo [NI_NUMERICHOST] True False
 193
 194 -- |Resolve an address to the remote host.
 195 getRemoteHost ∷ Resource (Maybe HostName)
 196 getRemoteHost = liftIO ∘ getHN =≪ getRemoteAddr
 197     where
 198       getHN ∷ SockAddr → IO (Maybe HostName)
 199       getHN = (fst <$>) ∘ getNameInfo [] True False
 200
 201 -- |Get the 'Method' value of the request.
 202 getMethod ∷ Resource Method
 203 getMethod = reqMethod <$> getRequest
 204
 205 -- |Get the URI of the request.
 206 getRequestURI ∷ Resource URI
 207 getRequestURI = reqURI <$> getRequest
 208
 209 -- |Get the HTTP version of the request.
 210 getRequestVersion ∷ Resource HttpVersion
 211 getRequestVersion = reqVersion <$> getRequest
 212
 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:
 216 -- 'getResourcePath'
 217 --
 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
 223
 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
 227 -- body.
 228 getQueryForm ∷ Resource [(Strict.ByteString, FormData)]
 229 getQueryForm = parse' <$> getRequestURI
 230     where
 231       parse' = map toPairWithFormData ∘
 232                parseWWWFormURLEncoded ∘
 233                fromJust ∘
 234                A.fromChars ∘
 235                drop 1 ∘
 236                uriQuery
 237
 238 toPairWithFormData ∷ (ByteString, ByteString) → (Strict.ByteString, FormData)
 239 toPairWithFormData (name, value)
 240     = let fd = FormData {
 241                  fdFileName = Nothing
 242                , fdMIMEType = [mimeType| text/plain |]
 243                , fdContent  = Lazy.fromChunks [value]
 244                }
 245       in (name, fd)
 246
 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)
 252 getHeader name
 253     = H.getHeader name <$> getRequest
 254
 255 -- |Return the list of 'MIMEType' enumerated on the value of request
 256 -- header \"Accept\", or @[]@ if absent.
 257 getAccept ∷ Resource [MIMEType]
 258 getAccept
 259     = do acceptM ← getHeader "Accept"
 260          case acceptM of
 261            Nothing
 262                → return []
 263            Just accept
 264                → case P.parseOnly (finishOff MT.mimeTypeList) (A.toByteString accept) of
 265                     Right xs → return xs
 266                     Left  _  → abort $ mkAbortion' BadRequest
 267                                      $ "Unparsable Accept: " ⊕ A.toText accept
 268
 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)]
 273 getAcceptEncoding
 274     = do accEncM ← getHeader "Accept-Encoding"
 275          case accEncM of
 276            Nothing
 277                -- HTTP/1.0 には Accept-Encoding が無い場合の規定が無い
 278                -- ので安全の爲 identity が指定された事にする。HTTP/1.1
 279                -- の場合は何でも受け入れて良い事になってゐるので "*" が
 280                -- 指定された事にする。
 281                → do ver ← getRequestVersion
 282                     case ver of
 283                       HttpVersion 1 0 → return [("identity", Nothing)]
 284                       HttpVersion 1 1 → return [("*"       , Nothing)]
 285                       _               → abort $ mkAbortion' InternalServerError
 286                                                 "getAcceptEncoding: unknown HTTP version"
 287            Just ae
 288                → if ae ≡ "" then
 289                       -- identity のみが許される。
 290                       return [("identity", Nothing)]
 291                  else
 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
 296     where
 297       toTuple (AcceptEncoding {..})
 298           = (aeEncoding, aeQValue)
 299
 300 -- |Return 'True' iff a given content-coding is acceptable by the
 301 -- client.
 302 isEncodingAcceptable ∷ CIAscii → Resource Bool
 303 isEncodingAcceptable encoding = any doesMatch <$> getAcceptEncoding
 304     where
 305       doesMatch ∷ (CIAscii, Maybe Double) → Bool
 306       doesMatch (e, q) = (e ≡ "*" ∨ e ≡ encoding) ∧ q ≢ Just 0
 307
 308 -- |Return the value of request header \"Content-Type\" as 'MIMEType'.
 309 getContentType ∷ Resource (Maybe MIMEType)
 310 getContentType
 311     = do cTypeM ← getHeader "Content-Type"
 312          case cTypeM of
 313            Nothing
 314                → return Nothing
 315            Just cType
 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
 320
 321 -- |Return the value of request header \"Authorization\" as
 322 -- 'AuthCredential'.
 323 getAuthorization ∷ Resource (Maybe AuthCredential)
 324 getAuthorization
 325     = do authM ← getHeader "Authorization"
 326          case authM of
 327            Nothing
 328                → return Nothing
 329            Just auth
 330                → case P.parseOnly (finishOff authCredential) (A.toByteString auth) of
 331                     Right ac → return $ Just ac
 332                     Left  _  → return Nothing
 333
 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.
 339 --
 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.
 344 --
 345 -- If the request method is either GET or HEAD, 'foundEntity'
 346 -- automatically puts \"ETag\" and \"Last-Modified\" headers into the
 347 -- response.
 348 foundEntity ∷ ETag → UTCTime → Resource ()
 349 foundEntity tag timeStamp
 350     = do driftTo ExaminingRequest
 351
 352          method ← getMethod
 353          when (method ≡ GET ∨ method ≡ HEAD)
 354              $ setHeader "Last-Modified" (HTTP.toAscii timeStamp)
 355          when (method ≡ POST)
 356              $ abort
 357              $ mkAbortion' InternalServerError
 358                "foundEntity: this is a POST request."
 359          foundETag tag
 360
 361          driftTo ReceivingBody
 362
 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
 366 -- the response.
 367 --
 368 -- Using this function is discouraged. You should use 'foundEntity'
 369 -- whenever possible.
 370 foundETag ∷ ETag → Resource ()
 371 foundETag tag
 372     = do driftTo ExaminingRequest
 373
 374          method ← getMethod
 375          when (method ≡ GET ∨ method ≡ HEAD)
 376              $ setHeader "ETag"
 377              $ A.fromAsciiBuilder
 378              $ printETag tag
 379          when (method ≡ POST)
 380              $ abort
 381              $ mkAbortion' InternalServerError
 382                "Illegal computation of foundETag for POST request."
 383
 384          -- If-Match があればそれを見る。
 385          ifMatch ← getHeader "If-Match"
 386          case ifMatch of
 387            Nothing
 388                → return ()
 389            Just value
 390                → if value ≡ "*" then
 391                       return ()
 392                   else
 393                       case P.parseOnly (finishOff eTagList) (A.toByteString value) of
 394                         Right tags
 395                             -- tags の中に一致するものが無ければ
 396                             -- PreconditionFailed で終了。
 397                             → when ((¬) (any (≡ tag) tags))
 398                                   $ abort
 399                                   $ mkAbortion' PreconditionFailed
 400                                   $ "The entity tag doesn't match: " ⊕ A.toText value
 401                         Left _
 402                             → abort $ mkAbortion' BadRequest
 403                                     $ "Unparsable If-Match: " ⊕ A.toText value
 404
 405          let statusForNoneMatch
 406                  = if method ≡ GET ∨ method ≡ HEAD then
 407                        fromStatusCode NotModified
 408                    else
 409                        fromStatusCode PreconditionFailed
 410
 411          -- If-None-Match があればそれを見る。
 412          ifNoneMatch ← getHeader "If-None-Match"
 413          case ifNoneMatch of
 414            Nothing
 415                → return ()
 416            Just value
 417                → if value ≡ "*" then
 418                       abort $ mkAbortion' statusForNoneMatch
 419                             $ "The entity tag matches: *"
 420                   else
 421                       case P.parseOnly (finishOff eTagList) (A.toByteString value) of
 422                         Right tags
 423                             → when (any (≡ tag) tags)
 424                                   $ abort
 425                                   $ mkAbortion' statusForNoneMatch
 426                                   $ "The entity tag matches: " ⊕ A.toText value
 427                         Left _
 428                             → abort $ mkAbortion' BadRequest
 429                                     $ "Unparsable If-None-Match: " ⊕ A.toText value
 430
 431          driftTo ReceivingBody
 432
 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.
 440 --
 441 -- Using this function is discouraged. You should use 'foundEntity'
 442 -- whenever possible.
 443 foundTimeStamp ∷ UTCTime → Resource ()
 444 foundTimeStamp timeStamp
 445     = do driftTo ExaminingRequest
 446
 447          method ← getMethod
 448          when (method ≡ GET ∨ method ≡ HEAD)
 449              $ setHeader "Last-Modified" (HTTP.toAscii timeStamp)
 450          when (method ≡ POST)
 451              $ abort
 452              $ mkAbortion' InternalServerError
 453                "Illegal computation of foundTimeStamp for POST request."
 454
 455          let statusForIfModSince
 456                  = if method ≡ GET ∨ method ≡ HEAD then
 457                        fromStatusCode NotModified
 458                    else
 459                        fromStatusCode PreconditionFailed
 460
 461          -- If-Modified-Since があればそれを見る。
 462          ifModSince ← getHeader "If-Modified-Since"
 463          case ifModSince of
 464            Just str → case HTTP.fromAscii str of
 465                          Right lastTime
 466                              → when (timeStamp ≤ lastTime)
 467                                $ abort
 468                                $ mkAbortion' statusForIfModSince
 469                                $ "The entity has not been modified since " ⊕ A.toText str
 470                          Left _
 471                              → return () -- 不正な時刻は無視
 472            Nothing  → return ()
 473
 474          -- If-Unmodified-Since があればそれを見る。
 475          ifUnmodSince ← getHeader "If-Unmodified-Since"
 476          case ifUnmodSince of
 477            Just str → case HTTP.fromAscii str of
 478                          Right lastTime
 479                              → when (timeStamp > lastTime)
 480                                $ abort
 481                                $ mkAbortion' PreconditionFailed
 482                                $ "The entity has not been modified since " ⊕ A.toText str
 483                          Left _
 484                              → return () -- 不正な時刻は無視
 485            Nothing  → return ()
 486
 487          driftTo ReceivingBody
 488
 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.
 492 --
 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 ()
 498 foundNoEntity msgM
 499     = do driftTo ExaminingRequest
 500
 501          method ← getMethod
 502          when (method ≢ PUT)
 503              $ abort
 504              $ mkAbortion NotFound [] msgM
 505
 506          -- エンティティが存在しないと云ふ事は、"*" も含めたどのやうな
 507          -- If-Match: 條件も滿たさない。
 508          ifMatch ← getHeader "If-Match"
 509          when (ifMatch ≢ Nothing)
 510              $ abort
 511              $ mkAbortion PreconditionFailed [] msgM
 512
 513          driftTo ReceivingBody
 514
 515 -- |'foundNoEntity'' is the same as @'foundNoEntity' 'Nothing'@.
 516 foundNoEntity' ∷ Resource ()
 517 {-# INLINE foundNoEntity' #-}
 518 foundNoEntity' = foundNoEntity Nothing
 519
 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.
 526 --
 527 -- When the @limit@ is 'Nothing', 'getChunks' uses the default
 528 -- limitation value ('cnfMaxEntityLength') instead.
 529 --
 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
 534 getChunks (Just n)
 535     | n < 0     = fail ("getChunks: limit must not be negative: " ⧺ show n)
 536     | n ≡ 0     = return (∅)
 537     | otherwise = getChunks' n
 538 getChunks Nothing
 539     = getConfig ≫= getChunks ∘ Just ∘ cnfMaxEntityLength
 540
 541 getChunks' ∷ Int → Resource Lazy.ByteString
 542 getChunks' limit = go limit (∅)
 543     where
 544       go ∷ Int → Builder → Resource Lazy.ByteString
 545       go  0  _ = do chunk ← getChunk 1
 546                     if Strict.null chunk then
 547                         return (∅)
 548                     else
 549                         abort $ mkAbortion' RequestEntityTooLarge
 550                               $ "Request body must be smaller than "
 551                               ⊕ T.pack (show limit)
 552                               ⊕ " bytes."
 553       go !n !b = do c ← getChunk $ min n BB.defaultBufferSize
 554                     if Strict.null c then
 555                         -- Got EOF
 556                         return $ BB.toLazyByteString b
 557                     else
 558                         do let n'  = n - Strict.length c
 559                                xs' = b ⊕ BB.fromByteString c
 560                            go n' xs'
 561
 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\".
 568 --
 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)]
 572 getForm limit
 573     = do cTypeM ← getContentType
 574          case cTypeM of
 575            Nothing
 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
 581            Just cType
 582                → abort $ mkAbortion' UnsupportedMediaType
 583                        $ A.toText
 584                        $ A.fromAsciiBuilder
 585                        $ A.toAsciiBuilder "Unsupported media type: "
 586                        ⊕ MT.printMIMEType cType
 587     where
 588       readWWWFormURLEncoded
 589           = (map toPairWithFormData ∘ parseWWWFormURLEncoded)
 590             <$>
 591             (bsToAscii =≪ getChunks limit)
 592
 593       bsToAscii bs
 594           = case A.fromByteString (Strict.concat (Lazy.toChunks bs)) of
 595               Just a  → return a
 596               Nothing → abort $ mkAbortion' BadRequest "Malformed x-www-form-urlencoded"
 597
 598       readMultipartFormData (MIMEParams m)
 599           = case M.lookup "boundary" m of
 600               Nothing
 601                   → abort $ mkAbortion' BadRequest "Missing boundary of multipart/form-data"
 602               Just boundary
 603                   → do src ← getChunks limit
 604                        b   ← case A.fromText boundary of
 605                                 Just b  → return b
 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
 611
 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 ()
 616 redirect sc uri
 617     = do when (sc ≈ NotModified ∨ (¬) (isRedirection sc))
 618              $ abort
 619              $ mkAbortion' InternalServerError
 620              $ A.toText
 621              $ A.fromAsciiBuilder
 622              $ A.toAsciiBuilder "Attempted to redirect with status "
 623              ⊕ printStatusCode sc
 624          setStatus sc
 625          setLocation uri
 626
 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 ()
 631 setContentType
 632     = setHeader "Content-Type" ∘ A.fromAsciiBuilder ∘ MT.printMIMEType
 633
 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 ()
 637 setLocation uri
 638     = case A.fromChars uriStr of
 639         Just a  → setHeader "Location" a
 640         Nothing → abort $ mkAbortion' InternalServerError
 641                         $ "Malformed URI: " ⊕ T.pack uriStr
 642     where
 643       uriStr = uriToString id uri ""
 644
 645 -- |@'setContentEncoding' codings@ declares the response header
 646 -- \"Content-Encoding\" as @codings@.
 647 setContentEncoding ∷ [CIAscii] → Resource ()
 648 setContentEncoding codings
 649     = do ver ← getRequestVersion
 650          tr  ← case ver of
 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"
 656              $ A.fromAsciiBuilder
 657              $ mconcat
 658              $ intersperse (A.toAsciiBuilder ", ")
 659              $ map tr codings
 660     where
 661       toAB = A.toAsciiBuilder ∘ A.fromCIAscii
 662
 663 -- |@'setWWWAuthenticate' challenge@ declares the response header
 664 -- \"WWW-Authenticate\" as @challenge@.
 665 setWWWAuthenticate ∷ AuthChallenge → Resource ()
 666 setWWWAuthenticate = setHeader "WWW-Authenticate" ∘ printAuthChallenge
 667
 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
 673
 674 -- |Write a chunk in lazy 'Lazy.ByteString' to the response body. It
 675 -- can be safely applied to an infinitely long 'Lazy.ByteString'.
 676 --
 677 -- Note that you must first declare the response header
 678 -- \"Content-Type\" before applying this function. See:
 679 -- 'setContentType'
 680 putChunks ∷ Lazy.ByteString → Resource ()
 681 putChunks = putBuilder ∘ BB.fromLazyByteString