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