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