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