Network/HTTP/Lucu/Resource.hs

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