Network/HTTP/Lucu/Resource.hs

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