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