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   #-}
  12 -- |This is the Resource Monad; monadic actions to define a behavior
  13 -- of resource. The 'Rsrc' Monad is a kind of 'IO' Monad thus it
  14 -- implements 'MonadIO' class, and it is a state machine as well.
  15 --
  16 -- Request Processing Flow:
  17 --
  18 --   1. A client issues an HTTP request.
  19 --
  20 --   2. If the URI of it matches to any resource, the corresponding
  21 --      'Rsrc' Monad starts running on a newly spawned thread.
  22 --
  23 --   3. The 'Rsrc' Monad looks at request headers, find (or not find)
  24 --      an entity, receive the request body (if any), send response
  25 --      headers, and then send a response body. This process will be
  26 --      discussed later.
  27 --
  28 --   4. The 'Rsrc' Monad and its thread stops running. The client may
  29 --      or may not be sending us the next request at this point.
  30 --
  31 -- 'Rsrc' Monad takes the following states. The initial state is
  32 -- /Examining Request/ and the final state is /Done/.
  33 --
  34 --   [/Examining Request/] In this state, a 'Rsrc' looks at the
  35 --   request header fields and thinks about the corresponding entity
  36 --   for it. If there is a suitable entity, the 'Rsrc' tells the
  37 --   system an entity tag and its last modification time
  38 --   ('foundEntity'). If it found no entity, it tells the system so
  39 --   ('foundNoEntity'). In case it is impossible to decide the
  40 --   existence of entity, which is a typical case for POST requests,
  41 --   'Rsrc' does nothing in this state.
  42 --
  43 --   [/Receiving Body/] A 'Rsrc' asks the system to receive a request
  44 --   body from the client. Before actually reading from the socket,
  45 --   the system sends \"100 Continue\" to the client if need be. When
  46 --   a 'Rsrc' transits to the next state without receiving all or part
  47 --   of a request body, the system automatically discards it.
  48 --
  49 --   [/Deciding Header/] A 'Rsrc' makes a decision of response status
  50 --   code and header fields. When it transits to the next state, the
  51 --   system validates and completes the header fields and then sends
  52 --   them to the client.
  53 --
  54 --   [/Sending Body/] In this state, a 'Rsrc' asks the system to write
  55 --   some response body to the socket. When it transits to the next
  56 --   state without writing any response body, the system automatically
  57 --   completes it depending on the status code. (To be exact, such
  58 --   completion only occurs when the 'Rsrc' transits to this state
  59 --   without even declaring the \"Content-Type\" header field. See:
  60 --   'setContentType')
  61 --
  62 --   [/Done/] Everything is over. A 'Rsrc' can do nothing for the HTTP
  63 --   interaction anymore.
  64 --
  65 -- Note that the state transition is one-way: for instance, it is an
  66 -- error to try to read a request body after writing some
  67 -- response. This limitation is for efficiency. We don't want to read
  68 -- the entire request before starting 'Rsrc', nor we don't want to
  69 -- postpone writing the entire response till the end of 'Rsrc'
  70 -- computation.
  71 module Network.HTTP.Lucu.Resource
  72     (
  73     -- * Types
  74       Resource(..)
  75     , Rsrc
  76     , FormData(..)
  77
  78     -- * Getting request header
  79     -- |These functions can be called regardless of the current state,
  80     -- and they don't change the state of 'Rsrc'.
  81     , getConfig
  82     , getRemoteAddr
  83     , getRemoteAddr'
  84     , getRemoteHost
  85 #if defined(HAVE_SSL)
  86     , getRemoteCertificate
  87 #endif
  88     , getRequest
  89     , getMethod
  90     , getRequestURI
  91     , getRequestVersion
  92     , getResourcePath
  93     , getPathInfo
  94     , getQueryForm
  95     , getHeader
  96     , getAccept
  97     , getAcceptEncoding
  98     , isEncodingAcceptable
  99     , getContentType
 100     , getAuthorization
 101
 102     -- * Finding an entity
 103     -- |These functions can be called only in the /Examining Request/
 104     -- state. They make the 'Rsrc' transit to the /Receiving Body/
 105     -- state.
 106     , foundEntity
 107     , foundETag
 108     , foundTimeStamp
 109     , foundNoEntity
 110     , foundNoEntity'
 111
 112     -- * Receiving a request body
 113     -- |These functions make the 'Rsrc' transit to the /Receiving
 114     -- Body/ state.
 115     , getChunk
 116     , getChunks
 117     , getForm
 118
 119     -- * Declaring response status and header fields
 120     -- |These functions can be called at any time before transiting to
 121     -- the /Sending Body/ state, but they themselves never causes any
 122     -- state transitions.
 123     , setStatus
 124     , redirect
 125     , setContentType
 126     , setContentEncoding
 127     , setWWWAuthenticate
 128
 129     -- ** Less frequently used functions
 130     , setLocation
 131     , setHeader
 132     , deleteHeader
 133
 134     -- * Sending a response body
 135
 136     -- |These functions make the 'Rsrc' transit to the /Sending Body/
 137     -- state.
 138     , putChunk
 139     , putChunks
 140     , putBuilder
 141     )
 142     where
 143 import Blaze.ByteString.Builder (Builder)
 144 import qualified Blaze.ByteString.Builder as BB
 145 import qualified Blaze.ByteString.Builder.Internal as BB
 146 import Control.Applicative
 147 import Control.Arrow
 148 import Control.Monad
 149 import Control.Monad.IO.Class
 150 import Control.Monad.Unicode
 151 import Data.Ascii (Ascii, CIAscii, AsciiBuilder)
 152 import Data.Attempt
 153 import qualified Data.Attoparsec.Char8 as P
 154 import Data.ByteString (ByteString)
 155 import qualified Data.ByteString as Strict
 156 import qualified Data.ByteString.Lazy as Lazy
 157 import Data.Collections
 158 import Data.Convertible.Base
 159 import Data.Convertible.Instances.Text ()
 160 import Data.Convertible.Utils
 161 import Data.List (intersperse, sort)
 162 import Data.Maybe
 163 import Data.Monoid
 164 import Data.Monoid.Unicode
 165 import Data.Proxy
 166 import Data.Tagged
 167 import Data.Text (Text)
 168 import Data.Time
 169 import Data.Time.Format.HTTP
 170 import Network.HTTP.Lucu.Abortion
 171 import Network.HTTP.Lucu.Authentication
 172 import Network.HTTP.Lucu.Config
 173 import Network.HTTP.Lucu.ContentCoding
 174 import Network.HTTP.Lucu.ETag
 175 import qualified Network.HTTP.Lucu.Headers as H
 176 import Network.HTTP.Lucu.HttpVersion
 177 import Network.HTTP.Lucu.Interaction
 178 import Network.HTTP.Lucu.MultipartForm
 179 import Network.HTTP.Lucu.Parser
 180 import Network.HTTP.Lucu.Request
 181 import Network.HTTP.Lucu.Resource.Internal
 182 import Network.HTTP.Lucu.Response
 183 import Network.HTTP.Lucu.MIMEType (MIMEType(..))
 184 import qualified Network.HTTP.Lucu.MIMEType as MT
 185 import Network.HTTP.Lucu.MIMEType.TH
 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 MT.mimeTypeList) (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 acceptEncodingList) (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 MT.mimeType) (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 authCredential) (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 eTagList) (cs value) of
 398                         Right tags
 399                             -- tags の中に一致するものが無ければ
 400                             -- PreconditionFailed で終了。
 401                             → when ((¬) (any (≡ tag) tags))
 402                                   $ abort
 403                                   $ mkAbortion' PreconditionFailed
 404                                   $ "The entity tag doesn't match: " ⊕ cs value
 405                         Left _
 406                             → abort $ mkAbortion' BadRequest
 407                                     $ "Unparsable If-Match: " ⊕ cs value
 408
 409          let statusForNoneMatch
 410                  = if method ≡ GET ∨ method ≡ HEAD then
 411                        fromStatusCode NotModified
 412                    else
 413                        fromStatusCode PreconditionFailed
 414
 415          -- If-None-Match があればそれを見る。
 416          ifNoneMatch ← getHeader "If-None-Match"
 417          case ifNoneMatch of
 418            Nothing
 419                → return ()
 420            Just value
 421                → if value ≡ "*" then
 422                       abort $ mkAbortion' statusForNoneMatch
 423                             $ "The entity tag matches: *"
 424                   else
 425                       case P.parseOnly (finishOff eTagList) (cs value) of
 426                         Right tags
 427                             → when (any (≡ tag) tags)
 428                                   $ abort
 429                                   $ mkAbortion' statusForNoneMatch
 430                                   $ "The entity tag matches: " ⊕ cs value
 431                         Left _
 432                             → abort $ mkAbortion' BadRequest
 433                                     $ "Unparsable If-None-Match: " ⊕ cs value
 434
 435          driftTo ReceivingBody
 436
 437 -- |Tell the system that the 'Rsrc' 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 → Rsrc ()
 448 foundTimeStamp timeStamp
 449     = do driftTo ExaminingRequest
 450
 451          method ← getMethod
 452          when (method ≡ GET ∨ method ≡ HEAD)
 453              $ setHeader "Last-Modified"
 454              $ flip proxy http
 455              $ cs timeStamp
 456          when (method ≡ POST)
 457              $ abort
 458              $ mkAbortion' InternalServerError
 459                "Illegal call of foundTimeStamp for POST request."
 460
 461          let statusForIfModSince
 462                  = if method ≡ GET ∨ method ≡ HEAD then
 463                        fromStatusCode NotModified
 464                    else
 465                        fromStatusCode PreconditionFailed
 466
 467          ifModSince ← getHeader "If-Modified-Since"
 468          case ifModSince of
 469            Just str → case fromAttempt $ ca (Tagged str ∷ Tagged HTTP Ascii) of
 470                          Just lastTime
 471                              → when (timeStamp ≤ lastTime)
 472                                $ abort
 473                                $ mkAbortion' statusForIfModSince
 474                                $ "The entity has not been modified since " ⊕ cs str
 475                          Nothing
 476                              → abort $ mkAbortion' BadRequest
 477                                      $ "Malformed If-Modified-Since: " ⊕ cs str
 478            Nothing  → return ()
 479
 480          ifUnmodSince ← getHeader "If-Unmodified-Since"
 481          case ifUnmodSince of
 482            Just str → case fromAttempt $ ca (Tagged str ∷ Tagged HTTP Ascii) of
 483                          Just lastTime
 484                              → when (timeStamp > lastTime)
 485                                $ abort
 486                                $ mkAbortion' PreconditionFailed
 487                                $ "The entity has not been modified since " ⊕ cs str
 488                          Nothing
 489                              → abort $ mkAbortion' BadRequest
 490                                      $ "Malformed If-Unmodified-Since: " ⊕ cs str
 491            Nothing  → return ()
 492
 493          driftTo ReceivingBody
 494
 495 -- |@'foundNoEntity' mStr@ tells the system that the 'Rsrc' found no
 496 -- entity for the request URI. @mStr@ is an optional error message to
 497 -- be replied to the client.
 498 --
 499 -- If the request method is PUT, 'foundNoEntity' performs \"If-Match\"
 500 -- test and when that fails it aborts with status \"412 Precondition
 501 -- Failed\". If the request method is GET, HEAD, POST or DELETE,
 502 -- 'foundNoEntity' always aborts with status \"404 Not Found\".
 503 foundNoEntity ∷ Maybe Text → Rsrc ()
 504 foundNoEntity msgM
 505     = do driftTo ExaminingRequest
 506
 507          method ← getMethod
 508          when (method ≢ PUT)
 509              $ abort
 510              $ mkAbortion NotFound [] msgM
 511
 512          -- エンティティが存在しないと云ふ事は、"*" も含めたどのやうな
 513          -- If-Match: 條件も滿たさない。
 514          ifMatch ← getHeader "If-Match"
 515          when (ifMatch ≢ Nothing)
 516              $ abort
 517              $ mkAbortion PreconditionFailed [] msgM
 518
 519          driftTo ReceivingBody
 520
 521 -- |'foundNoEntity'' is the same as @'foundNoEntity' 'Nothing'@.
 522 foundNoEntity' ∷ Rsrc ()
 523 {-# INLINE foundNoEntity' #-}
 524 foundNoEntity' = foundNoEntity Nothing
 525
 526 -- |@'getChunks' limit@ attemts to read the entire request body up to
 527 -- @limit@ bytes, and then make the 'Rsrc' transit to the /Deciding
 528 -- Header/ state. When the actual size of the body is larger than
 529 -- @limit@ bytes, 'getChunks' immediately aborts with status \"413
 530 -- Request Entity Too Large\". When the request has no body, it
 531 -- returns an empty string.
 532 --
 533 -- When the @limit@ is 'Nothing', 'getChunks' uses the default
 534 -- limitation value ('cnfMaxEntityLength') instead.
 535 --
 536 -- 'getChunks' returns a lazy 'Lazy.ByteString' but it's not really
 537 -- lazy: reading from the socket just happens at the computation of
 538 -- 'getChunks', not at the evaluation of the 'Lazy.ByteString'.
 539 getChunks ∷ Maybe Int → Rsrc Lazy.ByteString
 540 getChunks (Just n)
 541     | n < 0     = fail ("getChunks: limit must not be negative: " ⧺ show n)
 542     | n ≡ 0     = return (∅)
 543     | otherwise = getChunks' n
 544 getChunks Nothing
 545     = getConfig ≫= getChunks ∘ Just ∘ cnfMaxEntityLength
 546
 547 getChunks' ∷ Int → Rsrc Lazy.ByteString
 548 getChunks' limit = go limit (∅)
 549     where
 550       go ∷ Int → Builder → Rsrc Lazy.ByteString
 551       go  0  _ = do chunk ← getChunk 1
 552                     if Strict.null chunk then
 553                         return (∅)
 554                     else
 555                         abort $ mkAbortion' RequestEntityTooLarge
 556                               $ "Request body must be smaller than "
 557                               ⊕ cs (show limit)
 558                               ⊕ " bytes."
 559       go !n !b = do c ← getChunk $ min n BB.defaultBufferSize
 560                     if Strict.null c then
 561                         -- Got EOF
 562                         return $ BB.toLazyByteString b
 563                     else
 564                         do let n'  = n - Strict.length c
 565                                xs' = b ⊕ BB.fromByteString c
 566                            go n' xs'
 567
 568 -- |@'getForm' limit@ attempts to read the request body with
 569 -- 'getChunks' and parse it as @application\/x-www-form-urlencoded@ or
 570 -- @multipart\/form-data@. If the request header \"Content-Type\" is
 571 -- neither of them, 'getForm' aborts with status \"415 Unsupported
 572 -- Media Type\". If the request has no \"Content-Type\", it aborts
 573 -- with \"400 Bad Request\".
 574 --
 575 -- Note that there are currently a few limitations on parsing
 576 -- @multipart/form-data@. See: 'parseMultipartFormData'
 577 getForm ∷ Maybe Int → Rsrc [(Strict.ByteString, FormData)]
 578 getForm limit
 579     = do cTypeM ← getContentType
 580          case cTypeM of
 581            Nothing
 582                → abort $ mkAbortion' BadRequest "Missing Content-Type"
 583            Just (MIMEType "application" "x-www-form-urlencoded" _)
 584                → readWWWFormURLEncoded
 585            Just (MIMEType "multipart" "form-data" params)
 586                → readMultipartFormData params
 587            Just cType
 588                → abort $ mkAbortion' UnsupportedMediaType
 589                        $ cs
 590                        $ ("Unsupported media type: " ∷ Ascii)
 591                        ⊕ cs cType
 592     where
 593       readWWWFormURLEncoded
 594           = (map toPairWithFormData ∘ parseWWWFormURLEncoded)
 595             <$>
 596             (bsToAscii =≪ getChunks limit)
 597
 598       bsToAscii bs
 599           = case convertAttemptVia ((⊥) ∷ ByteString) bs of
 600               Success a → return a
 601               Failure e → abort $ mkAbortion' BadRequest $ cs (show e)
 602
 603       readMultipartFormData m
 604           = case lookup "boundary" m of
 605               Nothing
 606                   → abort $ mkAbortion' BadRequest "Missing boundary of multipart/form-data"
 607               Just boundary
 608                   → do src ← getChunks limit
 609                        b   ← case ca boundary of
 610                                 Success b → return b
 611                                 Failure _ → abort $ mkAbortion' BadRequest
 612                                                   $ "Malformed boundary: " ⊕ boundary
 613                        case parseMultipartFormData b src of
 614                          Right xs → return $ map (first cs) xs
 615                          Left err → abort $ mkAbortion' BadRequest $ cs err
 616
 617 -- |@'redirect' code uri@ declares the response status as @code@ and
 618 -- \"Location\" header field as @uri@. The @code@ must satisfy
 619 -- 'isRedirection' or it raises an error.
 620 redirect ∷ StatusCode sc ⇒ sc → URI → Rsrc ()
 621 redirect sc uri
 622     = do when (sc ≈ NotModified ∨ (¬) (isRedirection sc))
 623              $ abort
 624              $ mkAbortion' InternalServerError
 625              $ cs
 626              $ ("Attempted to redirect with status " ∷ Ascii)
 627              ⊕ cs (fromStatusCode sc)
 628          setStatus sc
 629          setLocation uri
 630
 631 -- |@'setContentType' mType@ declares the response header
 632 -- \"Content-Type\" as @mType@. Declaring \"Content-Type\" is
 633 -- mandatory for sending a response body.
 634 setContentType ∷ MIMEType → Rsrc ()
 635 setContentType = setHeader "Content-Type" ∘ cs
 636
 637 -- |@'setLocation' uri@ declares the response header \"Location\" as
 638 -- @uri@. You usually don't need to call this function directly.
 639 setLocation ∷ URI → Rsrc ()
 640 setLocation uri
 641     = case ca uriStr of
 642         Success a → setHeader "Location" a
 643         Failure e → abort $ mkAbortion' InternalServerError
 644                           $ cs (show e)
 645     where
 646       uriStr = uriToString id uri ""
 647
 648 -- |@'setContentEncoding' codings@ declares the response header
 649 -- \"Content-Encoding\" as @codings@.
 650 setContentEncoding ∷ [CIAscii] → Rsrc ()
 651 setContentEncoding codings
 652     = do ver ← getRequestVersion
 653          tr  ← case ver of
 654                   HttpVersion 1 0 → return (toAB ∘ unnormalizeCoding)
 655                   HttpVersion 1 1 → return toAB
 656                   _               → abort $ mkAbortion' InternalServerError
 657                                             "setContentEncoding: Unknown HTTP version"
 658          setHeader "Content-Encoding"
 659              $ cs
 660              $ mconcat
 661              $ intersperse (cs (", " ∷ Ascii))
 662              $ map tr codings
 663     where
 664       toAB ∷ ConvertSuccess α AsciiBuilder ⇒ α → AsciiBuilder
 665       toAB = cs
 666
 667 -- |@'setWWWAuthenticate' challenge@ declares the response header
 668 -- \"WWW-Authenticate\" as @challenge@.
 669 setWWWAuthenticate ∷ AuthChallenge → Rsrc ()
 670 setWWWAuthenticate = setHeader "WWW-Authenticate" ∘ cs
 671
 672 -- |Write a chunk in 'Strict.ByteString' to the response body. You
 673 -- must first declare the response header \"Content-Type\" before
 674 -- applying this function. See 'setContentType'.
 675 putChunk ∷ Strict.ByteString → Rsrc ()
 676 putChunk = putBuilder ∘ BB.fromByteString
 677
 678 -- |Write a chunk in lazy 'Lazy.ByteString' to the response body. It
 679 -- can be safely applied to an infinitely long 'Lazy.ByteString'.
 680 --
 681 -- Note that you must first declare the response header
 682 -- \"Content-Type\" before applying this function. See
 683 -- 'setContentType'.
 684 putChunks ∷ Lazy.ByteString → Rsrc ()
 685 putChunks = putBuilder ∘ BB.fromLazyByteString