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