Network/HTTP/Lucu/Resource.hs

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