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 'Resource' 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 --      'Resource' Monad starts running on a newly spawned thread.
  21 --
  22 --   3. The 'Resource' Monad looks at request headers, find (or not
  23 --      find) an entity, receive the request body (if any), send
  24 --      response headers, and then send a response body. This process
  25 --      will be discussed later.
  26 --
  27 --   4. The 'Resource' Monad and its thread stops running. The client
  28 --      may or may not be sending us the next request at this point.
  29 --
  30 -- 'Resource' 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 'Resource' looks at the
  34 --   request header fields and thinks about the corresponding entity
  35 --   for it. If there is a suitable entity, the 'Resource' 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 --   'Resource' does nothing in this state.
  41 --
  42 --   [/Receiving Body/] A 'Resource' asks the system to receive a
  43 --   request body from the client. Before actually reading from the
  44 --   socket, the system sends \"100 Continue\" to the client if need
  45 --   be. When a 'Resource' transits to the next state without
  46 --   receiving all or part of a request body, the system automatically
  47 --   discards it.
  48 --
  49 --   [/Deciding Header/] A 'Resource' makes a decision of response
  50 --   status code and header fields. When it transits to the next
  51 --   state, the system validates and completes the header fields and
  52 --   then sends them to the client.
  53 --
  54 --   [/Sending Body/] In this state, a 'Resource' asks the system to
  55 --   write some response body to the socket. When it transits to the
  56 --   next state without writing any response body, the system
  57 --   automatically completes it depending on the status code. (To be
  58 --   exact, such completion only occurs when the 'Resource' transits
  59 --   to this state without even declaring the \"Content-Type\" header
  60 --   field. See: 'setContentType')
  61 --
  62 --   [/Done/] Everything is over. A 'Resource' can do nothing for the
  63 --   HTTP 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 'Resource', nor we don't want to
  69 -- postpone writing the entire response till the end of 'Resource'
  70 -- computation.
  71 module Network.HTTP.Lucu.Resource
  72     (
  73     -- * Types
  74       Resource
  75     , ResourceDef(..)
  76     , emptyResource
  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 'Resource'.
  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 'Resource' 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 'Resource' 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 'Resource' transit to the
 138     -- /Sending Body/ 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)
 153 import qualified Data.Ascii as A
 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.List (intersperse, sort)
 160 import Data.Maybe
 161 import Data.Monoid
 162 import Data.Monoid.Unicode
 163 import Data.Text (Text)
 164 import qualified Data.Text as T
 165 import Data.Time
 166 import qualified Data.Time.HTTP as HTTP
 167 import Network.HTTP.Lucu.Abortion
 168 import Network.HTTP.Lucu.Authentication
 169 import Network.HTTP.Lucu.Config
 170 import Network.HTTP.Lucu.ContentCoding
 171 import Network.HTTP.Lucu.ETag
 172 import qualified Network.HTTP.Lucu.Headers as H
 173 import Network.HTTP.Lucu.HttpVersion
 174 import Network.HTTP.Lucu.Interaction
 175 import Network.HTTP.Lucu.MultipartForm
 176 import Network.HTTP.Lucu.Parser
 177 import Network.HTTP.Lucu.Request
 178 import Network.HTTP.Lucu.Resource.Internal
 179 import Network.HTTP.Lucu.Response
 180 import Network.HTTP.Lucu.MIMEType (MIMEType(..))
 181 import qualified Network.HTTP.Lucu.MIMEType as MT
 182 import Network.HTTP.Lucu.MIMEType.TH
 183 import Network.HTTP.Lucu.Utils
 184 import Network.Socket hiding (accept)
 185 import Network.URI hiding (path)
 186 import Prelude hiding (any, drop, lookup, reverse)
 187 import Prelude.Unicode
 188
 189 -- |Get the string representation of the address of remote host. If
 190 -- you want a 'SockAddr' instead of 'HostName', use 'getRemoteAddr'.
 191 getRemoteAddr' ∷ Resource HostName
 192 getRemoteAddr' = liftIO ∘ toNM =≪ getRemoteAddr
 193     where
 194       toNM ∷ SockAddr → IO HostName
 195       toNM = (fromJust ∘ fst <$>) ∘ getNameInfo [NI_NUMERICHOST] True False
 196
 197 -- |Resolve an address to the remote host.
 198 getRemoteHost ∷ Resource (Maybe HostName)
 199 getRemoteHost = liftIO ∘ getHN =≪ getRemoteAddr
 200     where
 201       getHN ∷ SockAddr → IO (Maybe HostName)
 202       getHN = (fst <$>) ∘ getNameInfo [] True False
 203
 204 -- |Get the 'Method' value of the request.
 205 getMethod ∷ Resource Method
 206 getMethod = reqMethod <$> getRequest
 207
 208 -- |Get the URI of the request.
 209 getRequestURI ∷ Resource URI
 210 getRequestURI = reqURI <$> getRequest
 211
 212 -- |Get the HTTP version of the request.
 213 getRequestVersion ∷ Resource HttpVersion
 214 getRequestVersion = reqVersion <$> getRequest
 215
 216 -- |This is an analogy of CGI PATH_INFO. 'getPathInfo' always returns
 217 -- @[]@ if the corresponding
 218 -- 'Network.HTTP.Lucu.Resource.Tree.ResourceDef' is not greedy. See:
 219 -- 'getResourcePath'
 220 --
 221 -- Note that the returned path components are URI-decoded.
 222 getPathInfo ∷ Resource [Strict.ByteString]
 223 getPathInfo = do rsrcPath ← getResourcePath
 224                  reqPath  ← splitPathInfo <$> getRequestURI
 225                  return $ drop (length rsrcPath) reqPath
 226
 227 -- |Assume the query part of request URI as
 228 -- application\/x-www-form-urlencoded, and parse it into pairs of
 229 -- @(name, formData)@. This function doesn't read the request
 230 -- body.
 231 getQueryForm ∷ Resource [(Strict.ByteString, FormData)]
 232 getQueryForm = parse' <$> getRequestURI
 233     where
 234       parse' = map toPairWithFormData ∘
 235                parseWWWFormURLEncoded ∘
 236                fromJust ∘
 237                A.fromChars ∘
 238                drop 1 ∘
 239                uriQuery
 240
 241 toPairWithFormData ∷ (ByteString, ByteString) → (Strict.ByteString, FormData)
 242 toPairWithFormData (name, value)
 243     = let fd = FormData {
 244                  fdFileName = Nothing
 245                , fdMIMEType = [mimeType| text/plain |]
 246                , fdContent  = Lazy.fromChunks [value]
 247                }
 248       in (name, fd)
 249
 250 -- |@'getHeader' name@ returns the value of the request header field
 251 -- @name@. Comparison of header name is case-insensitive. Note that
 252 -- this function is not intended to be used so frequently: there
 253 -- should be functions like 'getContentType' for every common headers.
 254 getHeader ∷ CIAscii → Resource (Maybe Ascii)
 255 getHeader name
 256     = H.getHeader name <$> getRequest
 257
 258 -- |Return the list of 'MIMEType' enumerated on the value of request
 259 -- header \"Accept\", or @[]@ if absent.
 260 getAccept ∷ Resource [MIMEType]
 261 getAccept
 262     = do acceptM ← getHeader "Accept"
 263          case acceptM of
 264            Nothing
 265                → return []
 266            Just accept
 267                → case P.parseOnly (finishOff MT.mimeTypeList) (A.toByteString accept) of
 268                     Right xs → return xs
 269                     Left  _  → abort $ mkAbortion' BadRequest
 270                                      $ "Unparsable Accept: " ⊕ A.toText accept
 271
 272 -- |Return the list of @(contentCoding, qvalue)@ enumerated on the
 273 -- value of request header \"Accept-Encoding\". The list is sorted in
 274 -- descending order by qvalue.
 275 getAcceptEncoding ∷ Resource [(CIAscii, Maybe Double)]
 276 getAcceptEncoding
 277     = do accEncM ← getHeader "Accept-Encoding"
 278          case accEncM of
 279            Nothing
 280                -- HTTP/1.0 には Accept-Encoding が無い場合の規定が無い
 281                -- ので安全の爲 identity が指定された事にする。HTTP/1.1
 282                -- の場合は何でも受け入れて良い事になってゐるので "*" が
 283                -- 指定された事にする。
 284                → do ver ← getRequestVersion
 285                     case ver of
 286                       HttpVersion 1 0 → return [("identity", Nothing)]
 287                       HttpVersion 1 1 → return [("*"       , Nothing)]
 288                       _               → abort $ mkAbortion' InternalServerError
 289                                                 "getAcceptEncoding: unknown HTTP version"
 290            Just ae
 291                → if ae ≡ "" then
 292                       -- identity のみが許される。
 293                       return [("identity", Nothing)]
 294                  else
 295                      case P.parseOnly (finishOff acceptEncodingList) (A.toByteString ae) of
 296                        Right xs → return $ map toTuple $ reverse $ sort xs
 297                        Left  _  → abort $ mkAbortion' BadRequest
 298                                         $ "Unparsable Accept-Encoding: " ⊕ A.toText ae
 299     where
 300       toTuple (AcceptEncoding {..})
 301           = (aeEncoding, aeQValue)
 302
 303 -- |Return 'True' iff a given content-coding is acceptable by the
 304 -- client.
 305 isEncodingAcceptable ∷ CIAscii → Resource Bool
 306 isEncodingAcceptable encoding = any doesMatch <$> getAcceptEncoding
 307     where
 308       doesMatch ∷ (CIAscii, Maybe Double) → Bool
 309       doesMatch (e, q) = (e ≡ "*" ∨ e ≡ encoding) ∧ q ≢ Just 0
 310
 311 -- |Return the value of request header \"Content-Type\" as 'MIMEType'.
 312 getContentType ∷ Resource (Maybe MIMEType)
 313 getContentType
 314     = do cTypeM ← getHeader "Content-Type"
 315          case cTypeM of
 316            Nothing
 317                → return Nothing
 318            Just cType
 319                → case P.parseOnly (finishOff MT.mimeType) (A.toByteString cType) of
 320                     Right t → return $ Just t
 321                     Left  _ → abort $ mkAbortion' BadRequest
 322                                     $ "Unparsable Content-Type: " ⊕ A.toText cType
 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 (finishOff authCredential) (A.toByteString auth) of
 334                     Right ac → return $ Just ac
 335                     Left  _  → return Nothing
 336
 337 -- |Tell the system that the 'Resource' found an entity for the
 338 -- request URI. If this is a GET or HEAD request, a found entity means
 339 -- a datum to be replied. If this is a PUT or DELETE request, it means
 340 -- a datum which was stored for the URI until now. For POST requests
 341 -- it raises an error.
 342 --
 343 -- 'foundEntity' performs \"If-Match\" test or \"If-None-Match\" test
 344 -- whenever possible, and if those tests fail, it immediately aborts
 345 -- with status \"412 Precondition Failed\" or \"304 Not Modified\"
 346 -- depending on the situation.
 347 --
 348 -- If the request method is either GET or HEAD, 'foundEntity'
 349 -- automatically puts \"ETag\" and \"Last-Modified\" headers into the
 350 -- response.
 351 foundEntity ∷ ETag → UTCTime → Resource ()
 352 foundEntity tag timeStamp
 353     = do driftTo ExaminingRequest
 354
 355          method ← getMethod
 356          when (method ≡ GET ∨ method ≡ HEAD)
 357              $ setHeader "Last-Modified" (HTTP.toAscii timeStamp)
 358          when (method ≡ POST)
 359              $ abort
 360              $ mkAbortion' InternalServerError
 361                "foundEntity: this is a POST request."
 362          foundETag tag
 363
 364          driftTo ReceivingBody
 365
 366 -- |Tell the system that the 'Resource' found an entity for the
 367 -- request URI. The only difference from 'foundEntity' is that
 368 -- 'foundETag' doesn't (nor can't) put \"Last-Modified\" header into
 369 -- the response.
 370 --
 371 -- Using this function is discouraged. You should use 'foundEntity'
 372 -- whenever possible.
 373 foundETag ∷ ETag → Resource ()
 374 foundETag tag
 375     = do driftTo ExaminingRequest
 376
 377          method ← getMethod
 378          when (method ≡ GET ∨ method ≡ HEAD)
 379              $ setHeader "ETag"
 380              $ A.fromAsciiBuilder
 381              $ printETag tag
 382          when (method ≡ POST)
 383              $ abort
 384              $ mkAbortion' InternalServerError
 385                "Illegal computation of foundETag for POST request."
 386
 387          -- If-Match があればそれを見る。
 388          ifMatch ← getHeader "If-Match"
 389          case ifMatch of
 390            Nothing
 391                → return ()
 392            Just value
 393                → if value ≡ "*" then
 394                       return ()
 395                   else
 396                       case P.parseOnly (finishOff eTagList) (A.toByteString value) of
 397                         Right tags
 398                             -- tags の中に一致するものが無ければ
 399                             -- PreconditionFailed で終了。
 400                             → when ((¬) (any (≡ tag) tags))
 401                                   $ abort
 402                                   $ mkAbortion' PreconditionFailed
 403                                   $ "The entity tag doesn't match: " ⊕ A.toText value
 404                         Left _
 405                             → abort $ mkAbortion' BadRequest
 406                                     $ "Unparsable If-Match: " ⊕ A.toText value
 407
 408          let statusForNoneMatch
 409                  = if method ≡ GET ∨ method ≡ HEAD then
 410                        fromStatusCode NotModified
 411                    else
 412                        fromStatusCode PreconditionFailed
 413
 414          -- If-None-Match があればそれを見る。
 415          ifNoneMatch ← getHeader "If-None-Match"
 416          case ifNoneMatch of
 417            Nothing
 418                → return ()
 419            Just value
 420                → if value ≡ "*" then
 421                       abort $ mkAbortion' statusForNoneMatch
 422                             $ "The entity tag matches: *"
 423                   else
 424                       case P.parseOnly (finishOff eTagList) (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
 436 -- |Tell the system that the 'Resource' found an entity for the
 437 -- request URI. The only difference from 'foundEntity' is that
 438 -- 'foundTimeStamp' performs \"If-Modified-Since\" test or
 439 -- \"If-Unmodified-Since\" test instead of \"If-Match\" test or
 440 -- \"If-None-Match\" test. Be aware that any tests based on a last
 441 -- modification time are unsafe because it is possible to mess up such
 442 -- tests by modifying the entity twice in a second.
 443 --
 444 -- Using this function is discouraged. You should use 'foundEntity'
 445 -- whenever possible.
 446 foundTimeStamp ∷ UTCTime → Resource ()
 447 foundTimeStamp timeStamp
 448     = do driftTo ExaminingRequest
 449
 450          method ← getMethod
 451          when (method ≡ GET ∨ method ≡ HEAD)
 452              $ setHeader "Last-Modified" (HTTP.toAscii timeStamp)
 453          when (method ≡ POST)
 454              $ abort
 455              $ mkAbortion' InternalServerError
 456                "Illegal call of foundTimeStamp for POST request."
 457
 458          let statusForIfModSince
 459                  = if method ≡ GET ∨ method ≡ HEAD then
 460                        fromStatusCode NotModified
 461                    else
 462                        fromStatusCode PreconditionFailed
 463
 464          ifModSince ← getHeader "If-Modified-Since"
 465          case ifModSince of
 466            Just str → case HTTP.fromAscii str of
 467                          Right lastTime
 468                              → when (timeStamp ≤ lastTime)
 469                                $ abort
 470                                $ mkAbortion' statusForIfModSince
 471                                $ "The entity has not been modified since " ⊕ A.toText str
 472                          Left e
 473                              → abort $ mkAbortion' BadRequest
 474                                      $ "Malformed If-Modified-Since: " ⊕ T.pack e
 475            Nothing  → return ()
 476
 477          ifUnmodSince ← getHeader "If-Unmodified-Since"
 478          case ifUnmodSince of
 479            Just str → case HTTP.fromAscii str of
 480                          Right lastTime
 481                              → when (timeStamp > lastTime)
 482                                $ abort
 483                                $ mkAbortion' PreconditionFailed
 484                                $ "The entity has not been modified since " ⊕ A.toText str
 485                          Left e
 486                              → abort $ mkAbortion' BadRequest
 487                                      $ "Malformed If-Unmodified-Since: " ⊕ T.pack e
 488            Nothing  → return ()
 489
 490          driftTo ReceivingBody
 491
 492 -- |@'foundNoEntity' mStr@ tells the system that the 'Resource' found
 493 -- no entity for the request URI. @mStr@ is an optional error message
 494 -- to be replied to the client.
 495 --
 496 -- If the request method is PUT, 'foundNoEntity' performs \"If-Match\"
 497 -- test and when that fails it aborts with status \"412 Precondition
 498 -- Failed\". If the request method is GET, HEAD, POST or DELETE,
 499 -- 'foundNoEntity' always aborts with status \"404 Not Found\".
 500 foundNoEntity ∷ Maybe Text → Resource ()
 501 foundNoEntity msgM
 502     = do driftTo ExaminingRequest
 503
 504          method ← getMethod
 505          when (method ≢ PUT)
 506              $ abort
 507              $ mkAbortion NotFound [] msgM
 508
 509          -- エンティティが存在しないと云ふ事は、"*" も含めたどのやうな
 510          -- If-Match: 條件も滿たさない。
 511          ifMatch ← getHeader "If-Match"
 512          when (ifMatch ≢ Nothing)
 513              $ abort
 514              $ mkAbortion PreconditionFailed [] msgM
 515
 516          driftTo ReceivingBody
 517
 518 -- |'foundNoEntity'' is the same as @'foundNoEntity' 'Nothing'@.
 519 foundNoEntity' ∷ Resource ()
 520 {-# INLINE foundNoEntity' #-}
 521 foundNoEntity' = foundNoEntity Nothing
 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 'Lazy.ByteString' but it's not really
 534 -- lazy: 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 → Builder → 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 !b = do c ← getChunk $ min n BB.defaultBufferSize
 557                     if Strict.null c then
 558                         -- Got EOF
 559                         return $ BB.toLazyByteString b
 560                     else
 561                         do let n'  = n - Strict.length c
 562                                xs' = b ⊕ BB.fromByteString c
 563                            go n' xs'
 564
 565 -- |@'getForm' limit@ attempts to read the request body with
 566 -- 'getChunks' and parse it as @application\/x-www-form-urlencoded@ or
 567 -- @multipart\/form-data@. If the request header \"Content-Type\" is
 568 -- neither of them, 'getForm' aborts with status \"415 Unsupported
 569 -- Media Type\". If the request has no \"Content-Type\", it aborts
 570 -- with \"400 Bad Request\".
 571 --
 572 -- Note that there are currently a few limitations on parsing
 573 -- @multipart/form-data@. See: 'parseMultipartFormData'
 574 getForm ∷ Maybe Int → Resource [(Strict.ByteString, FormData)]
 575 getForm limit
 576     = do cTypeM ← getContentType
 577          case cTypeM of
 578            Nothing
 579                → abort $ mkAbortion' BadRequest "Missing Content-Type"
 580            Just (MIMEType "application" "x-www-form-urlencoded" _)
 581                → readWWWFormURLEncoded
 582            Just (MIMEType "multipart" "form-data" params)
 583                → readMultipartFormData params
 584            Just cType
 585                → abort $ mkAbortion' UnsupportedMediaType
 586                        $ A.toText
 587                        $ A.fromAsciiBuilder
 588                        $ A.toAsciiBuilder "Unsupported media type: "
 589                        ⊕ MT.printMIMEType cType
 590     where
 591       readWWWFormURLEncoded
 592           = (map toPairWithFormData ∘ parseWWWFormURLEncoded)
 593             <$>
 594             (bsToAscii =≪ getChunks limit)
 595
 596       bsToAscii bs
 597           = case A.fromByteString (Strict.concat (Lazy.toChunks bs)) of
 598               Just a  → return a
 599               Nothing → abort $ mkAbortion' BadRequest "Malformed x-www-form-urlencoded"
 600
 601       readMultipartFormData m
 602           = case lookup "boundary" m of
 603               Nothing
 604                   → abort $ mkAbortion' BadRequest "Missing boundary of multipart/form-data"
 605               Just boundary
 606                   → do src ← getChunks limit
 607                        b   ← case A.fromText boundary of
 608                                 Just b  → return b
 609                                 Nothing → abort $ mkAbortion' BadRequest
 610                                                 $ "Malformed boundary: " ⊕ boundary
 611                        case parseMultipartFormData b src of
 612                          Right xs → return $ map (first A.toByteString) xs
 613                          Left err → abort $ mkAbortion' BadRequest $ T.pack err
 614
 615 -- |@'redirect' code uri@ declares the response status as @code@ and
 616 -- \"Location\" header field as @uri@. The @code@ must satisfy
 617 -- 'isRedirection' or it raises an error.
 618 redirect ∷ StatusCode sc ⇒ sc → URI → Resource ()
 619 redirect sc uri
 620     = do when (sc ≈ NotModified ∨ (¬) (isRedirection sc))
 621              $ abort
 622              $ mkAbortion' InternalServerError
 623              $ A.toText
 624              $ A.fromAsciiBuilder
 625              $ A.toAsciiBuilder "Attempted to redirect with status "
 626              ⊕ printStatusCode sc
 627          setStatus sc
 628          setLocation uri
 629
 630 -- |@'setContentType' mType@ declares the response header
 631 -- \"Content-Type\" as @mType@. Declaring \"Content-Type\" is
 632 -- mandatory for sending a response body.
 633 setContentType ∷ MIMEType → Resource ()
 634 setContentType
 635     = setHeader "Content-Type" ∘ A.fromAsciiBuilder ∘ MT.printMIMEType
 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 → Resource ()
 640 setLocation uri
 641     = case A.fromChars uriStr of
 642         Just a  → setHeader "Location" a
 643         Nothing → abort $ mkAbortion' InternalServerError
 644                         $ "Malformed URI: " ⊕ T.pack uriStr
 645     where
 646       uriStr = uriToString id uri ""
 647
 648 -- |@'setContentEncoding' codings@ declares the response header
 649 -- \"Content-Encoding\" as @codings@.
 650 setContentEncoding ∷ [CIAscii] → Resource ()
 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              $ A.fromAsciiBuilder
 660              $ mconcat
 661              $ intersperse (A.toAsciiBuilder ", ")
 662              $ map tr codings
 663     where
 664       toAB = A.toAsciiBuilder ∘ A.fromCIAscii
 665
 666 -- |@'setWWWAuthenticate' challenge@ declares the response header
 667 -- \"WWW-Authenticate\" as @challenge@.
 668 setWWWAuthenticate ∷ AuthChallenge → Resource ()
 669 setWWWAuthenticate = setHeader "WWW-Authenticate" ∘ printAuthChallenge
 670
 671 -- |Write a chunk in 'Strict.ByteString' to the response body. You
 672 -- must first declare the response header \"Content-Type\" before
 673 -- applying this function. See: 'setContentType'
 674 putChunk ∷ Strict.ByteString → Resource ()
 675 putChunk = putBuilder ∘ BB.fromByteString
 676
 677 -- |Write a chunk in lazy 'Lazy.ByteString' to the response body. It
 678 -- can be safely applied to an infinitely long 'Lazy.ByteString'.
 679 --
 680 -- Note that you must first declare the response header
 681 -- \"Content-Type\" before applying this function. See:
 682 -- 'setContentType'
 683 putChunks ∷ Lazy.ByteString → Resource ()
 684 putChunks = putBuilder ∘ BB.fromLazyByteString