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