Network/HTTP/Lucu/Resource.hs

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