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     , Rsrc
  75     , FormData(..)
  76
  77     -- * Getting request header
  78     -- |These functions can be called regardless of the current state,
  79     -- and they don't change the state of 'Rsrc'.
  80     , getConfig
  81     , getRemoteAddr
  82     , getRemoteAddr'
  83     , getRemoteHost
  84 #if defined(HAVE_SSL)
  85     , getRemoteCertificate
  86 #endif
  87     , getRequest
  88     , getMethod
  89     , getRequestURI
  90     , getRequestVersion
  91     , getResourcePath
  92     , getPathInfo
  93     , getQueryForm
  94     , getHeader
  95     , getAccept
  96     , getAcceptEncoding
  97     , isEncodingAcceptable
  98     , getContentType
  99     , getAuthorization
 100
 101     -- * Finding an entity
 102     -- |These functions can be called only in the /Examining Request/
 103     -- state. They make the 'Rsrc' transit to the /Receiving Body/
 104     -- state.
 105     , foundEntity
 106     , foundETag
 107     , foundTimeStamp
 108     , foundNoEntity
 109     , foundNoEntity'
 110
 111     -- * Receiving a request body
 112     -- |These functions make the 'Rsrc' transit to the /Receiving
 113     -- Body/ state.
 114     , getChunk
 115     , getChunks
 116     , getForm
 117
 118     -- * Declaring response status and header fields
 119     -- |These functions can be called at any time before transiting to
 120     -- the /Sending Body/ state, but they themselves never causes any
 121     -- state transitions.
 122     , setStatus
 123     , redirect
 124     , setContentType
 125     , setContentEncoding
 126     , setWWWAuthenticate
 127
 128     -- ** Less frequently used functions
 129     , setLocation
 130     , setHeader
 131     , deleteHeader
 132
 133     -- * Sending a response body
 134
 135     -- |These functions make the 'Rsrc' transit to the /Sending Body/
 136     -- state.
 137     , putChunk
 138     , putChunks
 139     , putBuilder
 140     )
 141     where
 142 import Blaze.ByteString.Builder (Builder)
 143 import qualified Blaze.ByteString.Builder as BB
 144 import qualified Blaze.ByteString.Builder.Internal as BB
 145 import Control.Applicative
 146 import Control.Arrow
 147 import Control.Monad
 148 import Control.Monad.IO.Class
 149 import Control.Monad.Unicode
 150 import Data.Ascii (Ascii, CIAscii)
 151 import qualified Data.Ascii as A
 152 import Data.Attempt
 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.Convertible.Base
 159 import Data.List (intersperse, sort)
 160 import Data.Maybe
 161 import Data.Monoid
 162 import Data.Monoid.Unicode
 163 import Data.Proxy
 164 import Data.Tagged
 165 import Data.Text (Text)
 166 import qualified Data.Text as T
 167 import Data.Time
 168 import Data.Time.Format.HTTP
 169 import Network.HTTP.Lucu.Abortion
 170 import Network.HTTP.Lucu.Authentication
 171 import Network.HTTP.Lucu.Config
 172 import Network.HTTP.Lucu.ContentCoding
 173 import Network.HTTP.Lucu.ETag
 174 import qualified Network.HTTP.Lucu.Headers as H
 175 import Network.HTTP.Lucu.HttpVersion
 176 import Network.HTTP.Lucu.Interaction
 177 import Network.HTTP.Lucu.MultipartForm
 178 import Network.HTTP.Lucu.Parser
 179 import Network.HTTP.Lucu.Request
 180 import Network.HTTP.Lucu.Resource.Internal
 181 import Network.HTTP.Lucu.Response
 182 import Network.HTTP.Lucu.MIMEType (MIMEType(..))
 183 import qualified Network.HTTP.Lucu.MIMEType as MT
 184 import Network.HTTP.Lucu.MIMEType.TH
 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                fromJust ∘
 238                A.fromChars ∘
 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 MT.mimeTypeList) (A.toByteString accept) of
 269                     Right xs → return xs
 270                     Left  _  → abort $ mkAbortion' BadRequest
 271                                      $ "Unparsable Accept: " ⊕ A.toText 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 acceptEncodingList) (A.toByteString ae) of
 297                        Right xs → return $ map toTuple $ reverse $ sort xs
 298                        Left  _  → abort $ mkAbortion' BadRequest
 299                                         $ "Unparsable Accept-Encoding: " ⊕ A.toText 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 MT.mimeType) (A.toByteString cType) of
 321                     Right t → return $ Just t
 322                     Left  _ → abort $ mkAbortion' BadRequest
 323                                     $ "Unparsable Content-Type: " ⊕ A.toText 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 authCredential) (A.toByteString 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              $ flip proxy http
 360              $ cs timeStamp
 361          when (method ≡ POST)
 362              $ abort
 363              $ mkAbortion' InternalServerError
 364                "foundEntity: this is a POST request."
 365          foundETag tag
 366
 367          driftTo ReceivingBody
 368
 369 -- |Tell the system that the 'Rsrc' found an entity for the request
 370 -- URI. The only difference from 'foundEntity' is that 'foundETag'
 371 -- doesn't (nor can't) put \"Last-Modified\" header into the response.
 372 --
 373 -- Using this function is discouraged. You should use 'foundEntity'
 374 -- whenever possible.
 375 foundETag ∷ ETag → Rsrc ()
 376 foundETag tag
 377     = do driftTo ExaminingRequest
 378
 379          method ← getMethod
 380          when (method ≡ GET ∨ method ≡ HEAD)
 381              $ setHeader "ETag"
 382              $ A.fromAsciiBuilder
 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 eTagList) (A.toByteString value) of
 399                         Right tags
 400                             -- tags の中に一致するものが無ければ
 401                             -- PreconditionFailed で終了。
 402                             → when ((¬) (any (≡ tag) tags))
 403                                   $ abort
 404                                   $ mkAbortion' PreconditionFailed
 405                                   $ "The entity tag doesn't match: " ⊕ A.toText value
 406                         Left _
 407                             → abort $ mkAbortion' BadRequest
 408                                     $ "Unparsable If-Match: " ⊕ A.toText value
 409
 410          let statusForNoneMatch
 411                  = if method ≡ GET ∨ method ≡ HEAD then
 412                        fromStatusCode NotModified
 413                    else
 414                        fromStatusCode PreconditionFailed
 415
 416          -- If-None-Match があればそれを見る。
 417          ifNoneMatch ← getHeader "If-None-Match"
 418          case ifNoneMatch of
 419            Nothing
 420                → return ()
 421            Just value
 422                → if value ≡ "*" then
 423                       abort $ mkAbortion' statusForNoneMatch
 424                             $ "The entity tag matches: *"
 425                   else
 426                       case P.parseOnly (finishOff eTagList) (A.toByteString value) of
 427                         Right tags
 428                             → when (any (≡ tag) tags)
 429                                   $ abort
 430                                   $ mkAbortion' statusForNoneMatch
 431                                   $ "The entity tag matches: " ⊕ A.toText value
 432                         Left _
 433                             → abort $ mkAbortion' BadRequest
 434                                     $ "Unparsable If-None-Match: " ⊕ A.toText value
 435
 436          driftTo ReceivingBody
 437
 438 -- |Tell the system that the 'Rsrc' found an entity for the
 439 -- request URI. The only difference from 'foundEntity' is that
 440 -- 'foundTimeStamp' performs \"If-Modified-Since\" test or
 441 -- \"If-Unmodified-Since\" test instead of \"If-Match\" test or
 442 -- \"If-None-Match\" test. Be aware that any tests based on a last
 443 -- modification time are unsafe because it is possible to mess up such
 444 -- tests by modifying the entity twice in a second.
 445 --
 446 -- Using this function is discouraged. You should use 'foundEntity'
 447 -- whenever possible.
 448 foundTimeStamp ∷ UTCTime → Rsrc ()
 449 foundTimeStamp timeStamp
 450     = do driftTo ExaminingRequest
 451
 452          method ← getMethod
 453          when (method ≡ GET ∨ method ≡ HEAD)
 454              $ setHeader "Last-Modified"
 455              $ flip proxy http
 456              $ cs timeStamp
 457          when (method ≡ POST)
 458              $ abort
 459              $ mkAbortion' InternalServerError
 460                "Illegal call of foundTimeStamp for POST request."
 461
 462          let statusForIfModSince
 463                  = if method ≡ GET ∨ method ≡ HEAD then
 464                        fromStatusCode NotModified
 465                    else
 466                        fromStatusCode PreconditionFailed
 467
 468          ifModSince ← getHeader "If-Modified-Since"
 469          case ifModSince of
 470            Just str → case fromAttempt $ ca (Tagged str ∷ Tagged HTTP Ascii) of
 471                          Just lastTime
 472                              → when (timeStamp ≤ lastTime)
 473                                $ abort
 474                                $ mkAbortion' statusForIfModSince
 475                                $ "The entity has not been modified since " ⊕ A.toText str
 476                          Nothing
 477                              → abort $ mkAbortion' BadRequest
 478                                      $ "Malformed If-Modified-Since: " ⊕ A.toText str
 479            Nothing  → return ()
 480
 481          ifUnmodSince ← getHeader "If-Unmodified-Since"
 482          case ifUnmodSince of
 483            Just str → case fromAttempt $ ca (Tagged str ∷ Tagged HTTP Ascii) of
 484                          Just lastTime
 485                              → when (timeStamp > lastTime)
 486                                $ abort
 487                                $ mkAbortion' PreconditionFailed
 488                                $ "The entity has not been modified since " ⊕ A.toText str
 489                          Nothing
 490                              → abort $ mkAbortion' BadRequest
 491                                      $ "Malformed If-Unmodified-Since: " ⊕ A.toText str
 492            Nothing  → return ()
 493
 494          driftTo ReceivingBody
 495
 496 -- |@'foundNoEntity' mStr@ tells the system that the 'Rsrc' found no
 497 -- entity for the request URI. @mStr@ is an optional error message to
 498 -- be replied to the client.
 499 --
 500 -- If the request method is PUT, 'foundNoEntity' performs \"If-Match\"
 501 -- test and when that fails it aborts with status \"412 Precondition
 502 -- Failed\". If the request method is GET, HEAD, POST or DELETE,
 503 -- 'foundNoEntity' always aborts with status \"404 Not Found\".
 504 foundNoEntity ∷ Maybe Text → Rsrc ()
 505 foundNoEntity msgM
 506     = do driftTo ExaminingRequest
 507
 508          method ← getMethod
 509          when (method ≢ PUT)
 510              $ abort
 511              $ mkAbortion NotFound [] msgM
 512
 513          -- エンティティが存在しないと云ふ事は、"*" も含めたどのやうな
 514          -- If-Match: 條件も滿たさない。
 515          ifMatch ← getHeader "If-Match"
 516          when (ifMatch ≢ Nothing)
 517              $ abort
 518              $ mkAbortion PreconditionFailed [] msgM
 519
 520          driftTo ReceivingBody
 521
 522 -- |'foundNoEntity'' is the same as @'foundNoEntity' 'Nothing'@.
 523 foundNoEntity' ∷ Rsrc ()
 524 {-# INLINE foundNoEntity' #-}
 525 foundNoEntity' = foundNoEntity Nothing
 526
 527 -- |@'getChunks' limit@ attemts to read the entire request body up to
 528 -- @limit@ bytes, and then make the 'Rsrc' transit to the /Deciding
 529 -- Header/ state. When the actual size of the body is larger than
 530 -- @limit@ bytes, 'getChunks' immediately aborts with status \"413
 531 -- Request Entity Too Large\". When the request has no body, it
 532 -- returns an empty string.
 533 --
 534 -- When the @limit@ is 'Nothing', 'getChunks' uses the default
 535 -- limitation value ('cnfMaxEntityLength') instead.
 536 --
 537 -- 'getChunks' returns a lazy 'Lazy.ByteString' but it's not really
 538 -- lazy: reading from the socket just happens at the computation of
 539 -- 'getChunks', not at the evaluation of the 'Lazy.ByteString'.
 540 getChunks ∷ Maybe Int → Rsrc Lazy.ByteString
 541 getChunks (Just n)
 542     | n < 0     = fail ("getChunks: limit must not be negative: " ⧺ show n)
 543     | n ≡ 0     = return (∅)
 544     | otherwise = getChunks' n
 545 getChunks Nothing
 546     = getConfig ≫= getChunks ∘ Just ∘ cnfMaxEntityLength
 547
 548 getChunks' ∷ Int → Rsrc Lazy.ByteString
 549 getChunks' limit = go limit (∅)
 550     where
 551       go ∷ Int → Builder → Rsrc Lazy.ByteString
 552       go  0  _ = do chunk ← getChunk 1
 553                     if Strict.null chunk then
 554                         return (∅)
 555                     else
 556                         abort $ mkAbortion' RequestEntityTooLarge
 557                               $ "Request body must be smaller than "
 558                               ⊕ T.pack (show limit)
 559                               ⊕ " bytes."
 560       go !n !b = do c ← getChunk $ min n BB.defaultBufferSize
 561                     if Strict.null c then
 562                         -- Got EOF
 563                         return $ BB.toLazyByteString b
 564                     else
 565                         do let n'  = n - Strict.length c
 566                                xs' = b ⊕ BB.fromByteString c
 567                            go n' xs'
 568
 569 -- |@'getForm' limit@ attempts to read the request body with
 570 -- 'getChunks' and parse it as @application\/x-www-form-urlencoded@ or
 571 -- @multipart\/form-data@. If the request header \"Content-Type\" is
 572 -- neither of them, 'getForm' aborts with status \"415 Unsupported
 573 -- Media Type\". If the request has no \"Content-Type\", it aborts
 574 -- with \"400 Bad Request\".
 575 --
 576 -- Note that there are currently a few limitations on parsing
 577 -- @multipart/form-data@. See: 'parseMultipartFormData'
 578 getForm ∷ Maybe Int → Rsrc [(Strict.ByteString, FormData)]
 579 getForm limit
 580     = do cTypeM ← getContentType
 581          case cTypeM of
 582            Nothing
 583                → abort $ mkAbortion' BadRequest "Missing Content-Type"
 584            Just (MIMEType "application" "x-www-form-urlencoded" _)
 585                → readWWWFormURLEncoded
 586            Just (MIMEType "multipart" "form-data" params)
 587                → readMultipartFormData params
 588            Just cType
 589                → abort $ mkAbortion' UnsupportedMediaType
 590                        $ A.toText
 591                        $ A.fromAsciiBuilder
 592                        $ A.toAsciiBuilder "Unsupported media type: "
 593                        ⊕ MT.printMIMEType cType
 594     where
 595       readWWWFormURLEncoded
 596           = (map toPairWithFormData ∘ parseWWWFormURLEncoded)
 597             <$>
 598             (bsToAscii =≪ getChunks limit)
 599
 600       bsToAscii bs
 601           = case A.fromByteString (Strict.concat (Lazy.toChunks bs)) of
 602               Just a  → return a
 603               Nothing → abort $ mkAbortion' BadRequest "Malformed x-www-form-urlencoded"
 604
 605       readMultipartFormData m
 606           = case lookup "boundary" m of
 607               Nothing
 608                   → abort $ mkAbortion' BadRequest "Missing boundary of multipart/form-data"
 609               Just boundary
 610                   → do src ← getChunks limit
 611                        b   ← case A.fromText boundary of
 612                                 Just b  → return b
 613                                 Nothing → abort $ mkAbortion' BadRequest
 614                                                 $ "Malformed boundary: " ⊕ boundary
 615                        case parseMultipartFormData b src of
 616                          Right xs → return $ map (first A.toByteString) xs
 617                          Left err → abort $ mkAbortion' BadRequest $ T.pack err
 618
 619 -- |@'redirect' code uri@ declares the response status as @code@ and
 620 -- \"Location\" header field as @uri@. The @code@ must satisfy
 621 -- 'isRedirection' or it raises an error.
 622 redirect ∷ StatusCode sc ⇒ sc → URI → Rsrc ()
 623 redirect sc uri
 624     = do when (sc ≈ NotModified ∨ (¬) (isRedirection sc))
 625              $ abort
 626              $ mkAbortion' InternalServerError
 627              $ A.toText
 628              $ A.fromAsciiBuilder
 629              $ A.toAsciiBuilder "Attempted to redirect with status "
 630              ⊕ printStatusCode sc
 631          setStatus sc
 632          setLocation uri
 633
 634 -- |@'setContentType' mType@ declares the response header
 635 -- \"Content-Type\" as @mType@. Declaring \"Content-Type\" is
 636 -- mandatory for sending a response body.
 637 setContentType ∷ MIMEType → Rsrc ()
 638 setContentType
 639     = setHeader "Content-Type" ∘ A.fromAsciiBuilder ∘ MT.printMIMEType
 640
 641 -- |@'setLocation' uri@ declares the response header \"Location\" as
 642 -- @uri@. You usually don't need to call this function directly.
 643 setLocation ∷ URI → Rsrc ()
 644 setLocation uri
 645     = case A.fromChars uriStr of
 646         Just a  → setHeader "Location" a
 647         Nothing → abort $ mkAbortion' InternalServerError
 648                         $ "Malformed URI: " ⊕ T.pack uriStr
 649     where
 650       uriStr = uriToString id uri ""
 651
 652 -- |@'setContentEncoding' codings@ declares the response header
 653 -- \"Content-Encoding\" as @codings@.
 654 setContentEncoding ∷ [CIAscii] → Rsrc ()
 655 setContentEncoding codings
 656     = do ver ← getRequestVersion
 657          tr  ← case ver of
 658                   HttpVersion 1 0 → return (toAB ∘ unnormalizeCoding)
 659                   HttpVersion 1 1 → return toAB
 660                   _               → abort $ mkAbortion' InternalServerError
 661                                             "setContentEncoding: Unknown HTTP version"
 662          setHeader "Content-Encoding"
 663              $ A.fromAsciiBuilder
 664              $ mconcat
 665              $ intersperse (A.toAsciiBuilder ", ")
 666              $ map tr codings
 667     where
 668       toAB = A.toAsciiBuilder ∘ A.fromCIAscii
 669
 670 -- |@'setWWWAuthenticate' challenge@ declares the response header
 671 -- \"WWW-Authenticate\" as @challenge@.
 672 setWWWAuthenticate ∷ AuthChallenge → Rsrc ()
 673 setWWWAuthenticate = setHeader "WWW-Authenticate" ∘ cs
 674
 675 -- |Write a chunk in 'Strict.ByteString' to the response body. You
 676 -- must first declare the response header \"Content-Type\" before
 677 -- applying this function. See 'setContentType'.
 678 putChunk ∷ Strict.ByteString → Rsrc ()
 679 putChunk = putBuilder ∘ BB.fromByteString
 680
 681 -- |Write a chunk in lazy 'Lazy.ByteString' to the response body. It
 682 -- can be safely applied to an infinitely long 'Lazy.ByteString'.
 683 --
 684 -- Note that you must first declare the response header
 685 -- \"Content-Type\" before applying this function. See
 686 -- 'setContentType'.
 687 putChunks ∷ Lazy.ByteString → Rsrc ()
 688 putChunks = putBuilder ∘ BB.fromLazyByteString