Network/HTTP/Lucu/Resource.hs

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