Network/HTTP/Lucu/Resource.hs

   1 {-# LANGUAGE
   2     CPP
   3   , BangPatterns
   4   , GeneralizedNewtypeDeriving
   5   , DoAndIfThenElse
   6   , OverloadedStrings
   7   , QuasiQuotes
   8   , RecordWildCards
   9   , UnicodeSyntax
  10   #-}
  11 -- |This is the Resource Monad; monadic actions to define a behavior
  12 -- of resource. The 'Rsrc' Monad is a kind of 'IO' Monad thus it
  13 -- implements 'MonadIO' class, and it is a state machine as well.
  14 --
  15 -- Request Processing Flow:
  16 --
  17 --   1. A client issues an HTTP request.
  18 --
  19 --   2. If the URI of it matches to any resource, the corresponding
  20 --      'Rsrc' Monad starts running on a newly spawned thread.
  21 --
  22 --   3. The 'Rsrc' Monad looks at request headers, find (or not find)
  23 --      an entity, receive the request body (if any), send response
  24 --      headers, and then send a response body. This process will be
  25 --      discussed later.
  26 --
  27 --   4. The 'Rsrc' Monad and its thread stops running. The client may
  28 --      or may not be sending us the next request at this point.
  29 --
  30 -- 'Rsrc' Monad takes the following states. The initial state is
  31 -- /Examining Request/ and the final state is /Done/.
  32 --
  33 --   [/Examining Request/] In this state, a 'Rsrc' looks at the
  34 --   request header fields and thinks about the corresponding entity
  35 --   for it. If there is a suitable entity, the 'Rsrc' tells the
  36 --   system an entity tag and its last modification time
  37 --   ('foundEntity'). If it found no entity, it tells the system so
  38 --   ('foundNoEntity'). In case it is impossible to decide the
  39 --   existence of entity, which is a typical case for POST requests,
  40 --   'Rsrc' does nothing in this state.
  41 --
  42 --   [/Receiving Body/] A 'Rsrc' asks the system to receive a request
  43 --   body from the client. Before actually reading from the socket,
  44 --   the system sends \"100 Continue\" to the client if need be. When
  45 --   a 'Rsrc' transits to the next state without receiving all or part
  46 --   of a request body, the system automatically discards it.
  47 --
  48 --   [/Deciding Header/] A 'Rsrc' makes a decision of response status
  49 --   code and header fields. When it transits to the next state, the
  50 --   system validates and completes the header fields and then sends
  51 --   them to the client.
  52 --
  53 --   [/Sending Body/] In this state, a 'Rsrc' asks the system to write
  54 --   some response body to the socket. When it transits to the next
  55 --   state without writing any response body, the system automatically
  56 --   completes it depending on the status code. (To be exact, such
  57 --   completion only occurs when the 'Rsrc' transits to this state
  58 --   without even declaring the \"Content-Type\" header field. See:
  59 --   'setContentType')
  60 --
  61 --   [/Done/] Everything is over. A 'Rsrc' can do nothing for the HTTP
  62 --   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 'Rsrc', nor we don't want to
  68 -- postpone writing the entire response till the end of 'Rsrc'
  69 -- computation.
  70 module Network.HTTP.Lucu.Resource
  71     (
  72     -- * Types
  73       Resource(..)
  74     , emptyResource
  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)
 152 import qualified Data.Ascii as A
 153 import qualified Data.Attoparsec.Char8 as P
 154 import Data.ByteString (ByteString)
 155 import qualified Data.ByteString as Strict
 156 import qualified Data.ByteString.Lazy as Lazy
 157 import Data.Collections
 158 import Data.List (intersperse, sort)
 159 import Data.Maybe
 160 import Data.Monoid
 161 import Data.Monoid.Unicode
 162 import Data.Text (Text)
 163 import qualified Data.Text as T
 164 import Data.Time
 165 import qualified Data.Time.HTTP as HTTP
 166 import Network.HTTP.Lucu.Abortion
 167 import Network.HTTP.Lucu.Authentication
 168 import Network.HTTP.Lucu.Config
 169 import Network.HTTP.Lucu.ContentCoding
 170 import Network.HTTP.Lucu.ETag
 171 import qualified Network.HTTP.Lucu.Headers as H
 172 import Network.HTTP.Lucu.HttpVersion
 173 import Network.HTTP.Lucu.Interaction
 174 import Network.HTTP.Lucu.MultipartForm
 175 import Network.HTTP.Lucu.Parser
 176 import Network.HTTP.Lucu.Request
 177 import Network.HTTP.Lucu.Resource.Internal
 178 import Network.HTTP.Lucu.Response
 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 hiding (any, drop, lookup, reverse)
 186 import Prelude.Unicode
 187
 188 -- |Get the string representation of the address of remote host. If
 189 -- you want a 'SockAddr' instead of 'HostName', use 'getRemoteAddr'.
 190 getRemoteAddr' ∷ Rsrc HostName
 191 getRemoteAddr' = liftIO ∘ toNM =≪ getRemoteAddr
 192     where
 193       toNM ∷ SockAddr → IO HostName
 194       toNM = (fromJust ∘ fst <$>) ∘ getNameInfo [NI_NUMERICHOST] True False
 195
 196 -- |Resolve an address to the remote host.
 197 getRemoteHost ∷ Rsrc (Maybe HostName)
 198 getRemoteHost = liftIO ∘ getHN =≪ getRemoteAddr
 199     where
 200       getHN ∷ SockAddr → IO (Maybe HostName)
 201       getHN = (fst <$>) ∘ getNameInfo [] True False
 202
 203 -- |Get the 'Method' value of the request.
 204 getMethod ∷ Rsrc Method
 205 getMethod = reqMethod <$> getRequest
 206
 207 -- |Get the URI of the request.
 208 getRequestURI ∷ Rsrc URI
 209 getRequestURI = reqURI <$> getRequest
 210
 211 -- |Get the HTTP version of the request.
 212 getRequestVersion ∷ Rsrc HttpVersion
 213 getRequestVersion = reqVersion <$> getRequest
 214
 215 -- |This is an analogy of CGI PATH_INFO. 'getPathInfo' always returns
 216 -- @[]@ if the corresponding
 217 -- 'Network.HTTP.Lucu.Resource.Tree.Resource' is not greedy. See:
 218 -- 'getResourcePath'
 219 --
 220 -- Note that the returned path components are URI-decoded.
 221 getPathInfo ∷ Rsrc [Strict.ByteString]
 222 getPathInfo = do rsrcPath ← getResourcePath
 223                  reqPath  ← uriPathSegments <$> getRequestURI
 224                  return $ drop (length rsrcPath) reqPath
 225
 226 -- |Assume the query part of request URI as
 227 -- application\/x-www-form-urlencoded, and parse it into pairs of
 228 -- @(name, formData)@. This function doesn't read the request
 229 -- body.
 230 getQueryForm ∷ Rsrc [(Strict.ByteString, FormData)]
 231 getQueryForm = parse' <$> getRequestURI
 232     where
 233       parse' = map toPairWithFormData ∘
 234                parseWWWFormURLEncoded ∘
 235                fromJust ∘
 236                A.fromChars ∘
 237                drop 1 ∘
 238                uriQuery
 239
 240 toPairWithFormData ∷ (ByteString, ByteString) → (Strict.ByteString, FormData)
 241 toPairWithFormData (name, value)
 242     = let fd = FormData {
 243                  fdFileName = Nothing
 244                , fdMIMEType = [mimeType| text/plain |]
 245                , fdContent  = Lazy.fromChunks [value]
 246                }
 247       in (name, fd)
 248
 249 -- |@'getHeader' name@ returns the value of the request header field
 250 -- @name@. Comparison of header name is case-insensitive. Note that
 251 -- this function is not intended to be used so frequently: there
 252 -- should be functions like 'getContentType' for every common headers.
 253 getHeader ∷ CIAscii → Rsrc (Maybe Ascii)
 254 getHeader name
 255     = H.getHeader name <$> getRequest
 256
 257 -- |Return the list of 'MIMEType' enumerated on the value of request
 258 -- header \"Accept\", or @[]@ if absent.
 259 getAccept ∷ Rsrc [MIMEType]
 260 getAccept
 261     = do acceptM ← getHeader "Accept"
 262          case acceptM of
 263            Nothing
 264                → return []
 265            Just accept
 266                → case P.parseOnly (finishOff MT.mimeTypeList) (A.toByteString accept) of
 267                     Right xs → return xs
 268                     Left  _  → abort $ mkAbortion' BadRequest
 269                                      $ "Unparsable Accept: " ⊕ A.toText accept
 270
 271 -- |Return the list of @(contentCoding, qvalue)@ enumerated on the
 272 -- value of request header \"Accept-Encoding\". The list is sorted in
 273 -- descending order by qvalue.
 274 getAcceptEncoding ∷ Rsrc [(CIAscii, Maybe Double)]
 275 getAcceptEncoding
 276     = do accEncM ← getHeader "Accept-Encoding"
 277          case accEncM of
 278            Nothing
 279                -- HTTP/1.0 には Accept-Encoding が無い場合の規定が無い
 280                -- ので安全の爲 identity が指定された事にする。HTTP/1.1
 281                -- の場合は何でも受け入れて良い事になってゐるので "*" が
 282                -- 指定された事にする。
 283                → do ver ← getRequestVersion
 284                     case ver of
 285                       HttpVersion 1 0 → return [("identity", Nothing)]
 286                       HttpVersion 1 1 → return [("*"       , Nothing)]
 287                       _               → abort $ mkAbortion' InternalServerError
 288                                                 "getAcceptEncoding: unknown HTTP version"
 289            Just ae
 290                → if ae ≡ "" then
 291                       -- identity のみが許される。
 292                       return [("identity", Nothing)]
 293                  else
 294                      case P.parseOnly (finishOff acceptEncodingList) (A.toByteString ae) of
 295                        Right xs → return $ map toTuple $ reverse $ sort xs
 296                        Left  _  → abort $ mkAbortion' BadRequest
 297                                         $ "Unparsable Accept-Encoding: " ⊕ A.toText ae
 298     where
 299       toTuple (AcceptEncoding {..})
 300           = (aeEncoding, aeQValue)
 301
 302 -- |Return 'True' iff a given content-coding is acceptable by the
 303 -- client.
 304 isEncodingAcceptable ∷ CIAscii → Rsrc Bool
 305 isEncodingAcceptable encoding = any doesMatch <$> getAcceptEncoding
 306     where
 307       doesMatch ∷ (CIAscii, Maybe Double) → Bool
 308       doesMatch (e, q) = (e ≡ "*" ∨ e ≡ encoding) ∧ q ≢ Just 0
 309
 310 -- |Return the value of request header \"Content-Type\" as 'MIMEType'.
 311 getContentType ∷ Rsrc (Maybe MIMEType)
 312 getContentType
 313     = do cTypeM ← getHeader "Content-Type"
 314          case cTypeM of
 315            Nothing
 316                → return Nothing
 317            Just cType
 318                → case P.parseOnly (finishOff MT.mimeType) (A.toByteString cType) of
 319                     Right t → return $ Just t
 320                     Left  _ → abort $ mkAbortion' BadRequest
 321                                     $ "Unparsable Content-Type: " ⊕ A.toText cType
 322
 323 -- |Return the value of request header \"Authorization\" as
 324 -- 'AuthCredential'.
 325 getAuthorization ∷ Rsrc (Maybe AuthCredential)
 326 getAuthorization
 327     = do authM ← getHeader "Authorization"
 328          case authM of
 329            Nothing
 330                → return Nothing
 331            Just auth
 332                → case P.parseOnly (finishOff authCredential) (A.toByteString auth) of
 333                     Right ac → return $ Just ac
 334                     Left  _  → return Nothing
 335
 336 -- |Tell the system that the 'Rsrc' found an entity for the request
 337 -- URI. If this is a GET or HEAD request, a found entity means a datum
 338 -- to be replied. If this is a PUT or DELETE request, it means a datum
 339 -- which was stored for the URI until now. For POST requests it raises
 340 -- an error.
 341 --
 342 -- 'foundEntity' performs \"If-Match\" test or \"If-None-Match\" test
 343 -- whenever possible, and if those tests fail, it immediately aborts
 344 -- with status \"412 Precondition Failed\" or \"304 Not Modified\"
 345 -- depending on the situation.
 346 --
 347 -- If the request method is either GET or HEAD, 'foundEntity'
 348 -- automatically puts \"ETag\" and \"Last-Modified\" headers into the
 349 -- response.
 350 foundEntity ∷ ETag → UTCTime → Rsrc ()
 351 foundEntity tag timeStamp
 352     = do driftTo ExaminingRequest
 353
 354          method ← getMethod
 355          when (method ≡ GET ∨ method ≡ HEAD)
 356              $ setHeader "Last-Modified" (HTTP.toAscii timeStamp)
 357          when (method ≡ POST)
 358              $ abort
 359              $ mkAbortion' InternalServerError
 360                "foundEntity: this is a POST request."
 361          foundETag tag
 362
 363          driftTo ReceivingBody
 364
 365 -- |Tell the system that the 'Rsrc' found an entity for the request
 366 -- URI. The only difference from 'foundEntity' is that 'foundETag'
 367 -- doesn't (nor can't) put \"Last-Modified\" header into the response.
 368 --
 369 -- Using this function is discouraged. You should use 'foundEntity'
 370 -- whenever possible.
 371 foundETag ∷ ETag → Rsrc ()
 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 'Rsrc' 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 → Rsrc ()
 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 call 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          ifModSince ← getHeader "If-Modified-Since"
 463          case ifModSince of
 464            Just str → case HTTP.fromAscii str of
 465                          Right lastTime
 466                              → when (timeStamp ≤ lastTime)
 467                                $ abort
 468                                $ mkAbortion' statusForIfModSince
 469                                $ "The entity has not been modified since " ⊕ A.toText str
 470                          Left e
 471                              → abort $ mkAbortion' BadRequest
 472                                      $ "Malformed If-Modified-Since: " ⊕ T.pack e
 473            Nothing  → return ()
 474
 475          ifUnmodSince ← getHeader "If-Unmodified-Since"
 476          case ifUnmodSince of
 477            Just str → case HTTP.fromAscii str of
 478                          Right lastTime
 479                              → when (timeStamp > lastTime)
 480                                $ abort
 481                                $ mkAbortion' PreconditionFailed
 482                                $ "The entity has not been modified since " ⊕ A.toText str
 483                          Left e
 484                              → abort $ mkAbortion' BadRequest
 485                                      $ "Malformed If-Unmodified-Since: " ⊕ T.pack e
 486            Nothing  → return ()
 487
 488          driftTo ReceivingBody
 489
 490 -- |@'foundNoEntity' mStr@ tells the system that the 'Rsrc' found no
 491 -- entity for the request URI. @mStr@ is an optional error message to
 492 -- 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 → Rsrc ()
 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' ∷ Rsrc ()
 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 'Rsrc' transit to the /Deciding
 523 -- Header/ state. When the actual size of the body is larger than
 524 -- @limit@ bytes, 'getChunks' immediately aborts with status \"413
 525 -- 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 → Rsrc 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 → Rsrc Lazy.ByteString
 543 getChunks' limit = go limit (∅)
 544     where
 545       go ∷ Int → Builder → Rsrc 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 → Rsrc [(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 m
 600           = case 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 → Rsrc ()
 617 redirect sc uri
 618     = do when (sc ≈ 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 → Rsrc ()
 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 → Rsrc ()
 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] → Rsrc ()
 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 → Rsrc ()
 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 → Rsrc ()
 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 → Rsrc ()
 682 putChunks = putBuilder ∘ BB.fromLazyByteString