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.Default
 162 import Data.List (intersperse, sort)
 163 import Data.Maybe
 164 import Data.Monoid
 165 import Data.Monoid.Unicode
 166 import Data.Proxy
 167 import Data.Tagged
 168 import Data.Text (Text)
 169 import Data.Time
 170 import Data.Time.Format.HTTP
 171 import Network.HTTP.Lucu.Abortion
 172 import Network.HTTP.Lucu.Authentication
 173 import Network.HTTP.Lucu.Config
 174 import Network.HTTP.Lucu.ContentCoding
 175 import Network.HTTP.Lucu.ETag
 176 import qualified Network.HTTP.Lucu.Headers as H
 177 import Network.HTTP.Lucu.HttpVersion
 178 import Network.HTTP.Lucu.Interaction
 179 import Network.HTTP.Lucu.MultipartForm
 180 import Network.HTTP.Lucu.Parser
 181 import Network.HTTP.Lucu.Request
 182 import Network.HTTP.Lucu.Resource.Internal
 183 import Network.HTTP.Lucu.Response
 184 import Network.HTTP.Lucu.MIMEType
 185 import Network.HTTP.Lucu.Utils
 186 import Network.Socket hiding (accept)
 187 import Network.URI hiding (path)
 188 import Prelude hiding (any, drop, lookup, reverse)
 189 import Prelude.Unicode
 190
 191 -- |Get the string representation of the address of remote host. If
 192 -- you want a 'SockAddr' instead of 'HostName', use 'getRemoteAddr'.
 193 getRemoteAddr' ∷ Rsrc HostName
 194 getRemoteAddr' = liftIO ∘ toNM =≪ getRemoteAddr
 195     where
 196       toNM ∷ SockAddr → IO HostName
 197       toNM = (fromJust ∘ fst <$>) ∘ getNameInfo [NI_NUMERICHOST] True False
 198
 199 -- |Resolve an address to the remote host.
 200 getRemoteHost ∷ Rsrc (Maybe HostName)
 201 getRemoteHost = liftIO ∘ getHN =≪ getRemoteAddr
 202     where
 203       getHN ∷ SockAddr → IO (Maybe HostName)
 204       getHN = (fst <$>) ∘ getNameInfo [] True False
 205
 206 -- |Get the 'Method' value of the request.
 207 getMethod ∷ Rsrc Method
 208 getMethod = reqMethod <$> getRequest
 209
 210 -- |Get the URI of the request.
 211 getRequestURI ∷ Rsrc URI
 212 getRequestURI = reqURI <$> getRequest
 213
 214 -- |Get the HTTP version of the request.
 215 getRequestVersion ∷ Rsrc HttpVersion
 216 getRequestVersion = reqVersion <$> getRequest
 217
 218 -- |This is an analogy of CGI PATH_INFO. 'getPathInfo' always returns
 219 -- @[]@ if the corresponding 'Resource' is not greedy. See
 220 -- 'getResourcePath'.
 221 --
 222 -- Note that the returned path components are URI-decoded.
 223 getPathInfo ∷ Rsrc [Strict.ByteString]
 224 getPathInfo = do rsrcPath ← getResourcePath
 225                  reqPath  ← uriPathSegments <$> getRequestURI
 226                  return $ drop (length rsrcPath) reqPath
 227
 228 -- |Assume the query part of request URI as
 229 -- application\/x-www-form-urlencoded, and parse it into pairs of
 230 -- @(name, formData)@. This function doesn't read the request
 231 -- body.
 232 getQueryForm ∷ Rsrc [(Strict.ByteString, FormData)]
 233 getQueryForm = parse' <$> getRequestURI
 234     where
 235       parse' = map toPairWithFormData ∘
 236                parseWWWFormURLEncoded ∘
 237                convertUnsafe ∘
 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 → Rsrc (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 ∷ Rsrc [MIMEType]
 261 getAccept
 262     = do acceptM ← getHeader "Accept"
 263          case acceptM of
 264            Nothing
 265                → return []
 266            Just accept
 267                → case P.parseOnly (finishOff def) (cs accept) of
 268                     Right xs → return xs
 269                     Left  _  → abort $ mkAbortion' BadRequest
 270                                      $ "Unparsable Accept: " ⊕ cs 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 ∷ Rsrc [(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 def) (cs ae) of
 296                        Right xs → return $ map toTuple $ reverse $ sort xs
 297                        Left  _  → abort $ mkAbortion' BadRequest
 298                                         $ "Unparsable Accept-Encoding: " ⊕ cs 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 → Rsrc 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 ∷ Rsrc (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 def) (cs cType) of
 320                     Right t → return $ Just t
 321                     Left  _ → abort $ mkAbortion' BadRequest
 322                                     $ "Unparsable Content-Type: " ⊕ cs cType
 323
 324 -- |Return the value of request header \"Authorization\" as
 325 -- 'AuthCredential'.
 326 getAuthorization ∷ Rsrc (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 def) (cs auth) of
 334                     Right ac → return $ Just ac
 335                     Left  _  → return Nothing
 336
 337 -- |Tell the system that the 'Rsrc' found an entity for the request
 338 -- URI. If this is a GET or HEAD request, a found entity means a datum
 339 -- to be replied. If this is a PUT or DELETE request, it means a datum
 340 -- which was stored for the URI until now. For POST requests it raises
 341 -- 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 → Rsrc ()
 352 foundEntity tag timeStamp
 353     = do driftTo ExaminingRequest
 354
 355          method ← getMethod
 356          when (method ≡ GET ∨ method ≡ HEAD)
 357              $ setHeader "Last-Modified"
 358              $ flip proxy http
 359              $ cs timeStamp
 360          when (method ≡ POST)
 361              $ abort
 362              $ mkAbortion' InternalServerError
 363                "foundEntity: this is a POST request."
 364          foundETag tag
 365
 366          driftTo ReceivingBody
 367
 368 -- |Tell the system that the 'Rsrc' found an entity for the request
 369 -- URI. The only difference from 'foundEntity' is that 'foundETag'
 370 -- doesn't (nor can't) put \"Last-Modified\" header into the response.
 371 --
 372 -- Using this function is discouraged. You should use 'foundEntity'
 373 -- whenever possible.
 374 foundETag ∷ ETag → Rsrc ()
 375 foundETag tag
 376     = do driftTo ExaminingRequest
 377
 378          method ← getMethod
 379          when (method ≡ GET ∨ method ≡ HEAD)
 380              $ setHeader "ETag"
 381              $ cs 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 def) (cs value) of
 397                         Right []
 398                             → abort $ mkAbortion' BadRequest
 399                                     $ "Empty If-Match"
 400                         Right tags
 401                             -- tags の中に一致するものが無ければ
 402                             -- PreconditionFailed で終了。
 403                             → when ((¬) (any (≡ tag) tags))
 404                                   $ abort
 405                                   $ mkAbortion' PreconditionFailed
 406                                   $ "The entity tag doesn't match: " ⊕ cs value
 407                         Left _
 408                             → abort $ mkAbortion' BadRequest
 409                                     $ "Unparsable If-Match: " ⊕ cs value
 410
 411          let statusForNoneMatch
 412                  = if method ≡ GET ∨ method ≡ HEAD then
 413                        fromStatusCode NotModified
 414                    else
 415                        fromStatusCode PreconditionFailed
 416
 417          -- If-None-Match があればそれを見る。
 418          ifNoneMatch ← getHeader "If-None-Match"
 419          case ifNoneMatch of
 420            Nothing
 421                → return ()
 422            Just value
 423                → if value ≡ "*" then
 424                       abort $ mkAbortion' statusForNoneMatch
 425                             $ "The entity tag matches: *"
 426                   else
 427                       case P.parseOnly (finishOff def) (cs value) of
 428                         Right []
 429                             → abort $ mkAbortion' BadRequest
 430                                     $ "Empty If-None-Match"
 431                         Right tags
 432                             → when (any (≡ tag) tags)
 433                                   $ abort
 434                                   $ mkAbortion' statusForNoneMatch
 435                                   $ "The entity tag matches: " ⊕ cs value
 436                         Left _
 437                             → abort $ mkAbortion' BadRequest
 438                                     $ "Unparsable If-None-Match: " ⊕ cs value
 439
 440          driftTo ReceivingBody
 441
 442 -- |Tell the system that the 'Rsrc' found an entity for the
 443 -- request URI. The only difference from 'foundEntity' is that
 444 -- 'foundTimeStamp' performs \"If-Modified-Since\" test or
 445 -- \"If-Unmodified-Since\" test instead of \"If-Match\" test or
 446 -- \"If-None-Match\" test. Be aware that any tests based on a last
 447 -- modification time are unsafe because it is possible to mess up such
 448 -- tests by modifying the entity twice in a second.
 449 --
 450 -- Using this function is discouraged. You should use 'foundEntity'
 451 -- whenever possible.
 452 foundTimeStamp ∷ UTCTime → Rsrc ()
 453 foundTimeStamp timeStamp
 454     = do driftTo ExaminingRequest
 455
 456          method ← getMethod
 457          when (method ≡ GET ∨ method ≡ HEAD)
 458              $ setHeader "Last-Modified"
 459              $ flip proxy http
 460              $ cs timeStamp
 461          when (method ≡ POST)
 462              $ abort
 463              $ mkAbortion' InternalServerError
 464                "Illegal call of foundTimeStamp for POST request."
 465
 466          let statusForIfModSince
 467                  = if method ≡ GET ∨ method ≡ HEAD then
 468                        fromStatusCode NotModified
 469                    else
 470                        fromStatusCode PreconditionFailed
 471
 472          ifModSince ← getHeader "If-Modified-Since"
 473          case ifModSince of
 474            Just str → case fromAttempt $ ca (Tagged str ∷ Tagged HTTP Ascii) of
 475                          Just lastTime
 476                              → when (timeStamp ≤ lastTime)
 477                                $ abort
 478                                $ mkAbortion' statusForIfModSince
 479                                $ "The entity has not been modified since " ⊕ cs str
 480                          Nothing
 481                              → abort $ mkAbortion' BadRequest
 482                                      $ "Malformed If-Modified-Since: " ⊕ cs str
 483            Nothing  → return ()
 484
 485          ifUnmodSince ← getHeader "If-Unmodified-Since"
 486          case ifUnmodSince of
 487            Just str → case fromAttempt $ ca (Tagged str ∷ Tagged HTTP Ascii) of
 488                          Just lastTime
 489                              → when (timeStamp > lastTime)
 490                                $ abort
 491                                $ mkAbortion' PreconditionFailed
 492                                $ "The entity has not been modified since " ⊕ cs str
 493                          Nothing
 494                              → abort $ mkAbortion' BadRequest
 495                                      $ "Malformed If-Unmodified-Since: " ⊕ cs str
 496            Nothing  → return ()
 497
 498          driftTo ReceivingBody
 499
 500 -- |@'foundNoEntity' mStr@ tells the system that the 'Rsrc' found no
 501 -- entity for the request URI. @mStr@ is an optional error message to
 502 -- be replied to the client.
 503 --
 504 -- If the request method is PUT, 'foundNoEntity' performs \"If-Match\"
 505 -- test and when that fails it aborts with status \"412 Precondition
 506 -- Failed\". If the request method is GET, HEAD, POST or DELETE,
 507 -- 'foundNoEntity' always aborts with status \"404 Not Found\".
 508 foundNoEntity ∷ Maybe Text → Rsrc ()
 509 foundNoEntity msgM
 510     = do driftTo ExaminingRequest
 511
 512          method ← getMethod
 513          when (method ≢ PUT)
 514              $ abort
 515              $ mkAbortion NotFound [] msgM
 516
 517          -- エンティティが存在しないと云ふ事は、"*" も含めたどのやうな
 518          -- If-Match: 條件も滿たさない。
 519          ifMatch ← getHeader "If-Match"
 520          when (ifMatch ≢ Nothing)
 521              $ abort
 522              $ mkAbortion PreconditionFailed [] msgM
 523
 524          driftTo ReceivingBody
 525
 526 -- |'foundNoEntity'' is the same as @'foundNoEntity' 'Nothing'@.
 527 foundNoEntity' ∷ Rsrc ()
 528 {-# INLINE foundNoEntity' #-}
 529 foundNoEntity' = foundNoEntity Nothing
 530
 531 -- |@'getChunks' limit@ attemts to read the entire request body up to
 532 -- @limit@ bytes, and then make the 'Rsrc' transit to the /Deciding
 533 -- Header/ state. When the actual size of the body is larger than
 534 -- @limit@ bytes, 'getChunks' immediately aborts with status \"413
 535 -- Request Entity Too Large\". When the request has no body, it
 536 -- returns an empty string.
 537 --
 538 -- When the @limit@ is 'Nothing', 'getChunks' uses the default
 539 -- limitation value ('cnfMaxEntityLength') instead.
 540 --
 541 -- 'getChunks' returns a lazy 'Lazy.ByteString' but it's not really
 542 -- lazy: reading from the socket just happens at the computation of
 543 -- 'getChunks', not at the evaluation of the 'Lazy.ByteString'.
 544 getChunks ∷ Maybe Int → Rsrc Lazy.ByteString
 545 getChunks (Just n)
 546     | n < 0     = fail ("getChunks: limit must not be negative: " ⧺ show n)
 547     | n ≡ 0     = return (∅)
 548     | otherwise = getChunks' n
 549 getChunks Nothing
 550     = getConfig ≫= getChunks ∘ Just ∘ cnfMaxEntityLength
 551
 552 getChunks' ∷ Int → Rsrc Lazy.ByteString
 553 getChunks' limit = go limit (∅)
 554     where
 555       go ∷ Int → Builder → Rsrc Lazy.ByteString
 556       go  0  _ = do chunk ← getChunk 1
 557                     if Strict.null chunk then
 558                         return (∅)
 559                     else
 560                         abort $ mkAbortion' RequestEntityTooLarge
 561                               $ "Request body must be smaller than "
 562                               ⊕ cs (show limit)
 563                               ⊕ " bytes."
 564       go !n !b = do c ← getChunk $ min n BB.defaultBufferSize
 565                     if Strict.null c then
 566                         -- Got EOF
 567                         return $ BB.toLazyByteString b
 568                     else
 569                         do let n'  = n - Strict.length c
 570                                xs' = b ⊕ BB.fromByteString c
 571                            go n' xs'
 572
 573 -- |@'getForm' limit@ attempts to read the request body with
 574 -- 'getChunks' and parse it as @application\/x-www-form-urlencoded@ or
 575 -- @multipart\/form-data@. If the request header \"Content-Type\" is
 576 -- neither of them, 'getForm' aborts with status \"415 Unsupported
 577 -- Media Type\". If the request has no \"Content-Type\", it aborts
 578 -- with \"400 Bad Request\".
 579 --
 580 -- Note that there are currently a few limitations on parsing
 581 -- @multipart/form-data@. See: 'parseMultipartFormData'
 582 getForm ∷ Maybe Int → Rsrc [(Strict.ByteString, FormData)]
 583 getForm limit
 584     = do cTypeM ← getContentType
 585          case cTypeM of
 586            Nothing
 587                → abort $ mkAbortion' BadRequest "Missing Content-Type"
 588            Just (MIMEType "application" "x-www-form-urlencoded" _)
 589                → readWWWFormURLEncoded
 590            Just (MIMEType "multipart" "form-data" params)
 591                → readMultipartFormData params
 592            Just cType
 593                → abort $ mkAbortion' UnsupportedMediaType
 594                        $ cs
 595                        $ ("Unsupported media type: " ∷ Ascii)
 596                        ⊕ cs cType
 597     where
 598       readWWWFormURLEncoded
 599           = (map toPairWithFormData ∘ parseWWWFormURLEncoded)
 600             <$>
 601             (bsToAscii =≪ getChunks limit)
 602
 603       bsToAscii bs
 604           = case convertAttemptVia ((⊥) ∷ ByteString) bs of
 605               Success a → return a
 606               Failure e → abort $ mkAbortion' BadRequest $ cs (show e)
 607
 608       readMultipartFormData m
 609           = case lookup "boundary" m of
 610               Nothing
 611                   → abort $ mkAbortion' BadRequest "Missing boundary of multipart/form-data"
 612               Just boundary
 613                   → do src ← getChunks limit
 614                        b   ← case ca boundary of
 615                                 Success b → return b
 616                                 Failure _ → abort $ mkAbortion' BadRequest
 617                                                   $ "Malformed boundary: " ⊕ boundary
 618                        case parseMultipartFormData b src of
 619                          Right xs → return $ map (first cs) xs
 620                          Left err → abort $ mkAbortion' BadRequest $ cs err
 621
 622 -- |@'redirect' code uri@ declares the response status as @code@ and
 623 -- \"Location\" header field as @uri@. The @code@ must satisfy
 624 -- 'isRedirection' or it raises an error.
 625 redirect ∷ StatusCode sc ⇒ sc → URI → Rsrc ()
 626 redirect sc uri
 627     = do when (sc ≈ NotModified ∨ (¬) (isRedirection sc))
 628              $ abort
 629              $ mkAbortion' InternalServerError
 630              $ cs
 631              $ ("Attempted to redirect with status " ∷ Ascii)
 632              ⊕ cs (fromStatusCode sc)
 633          setStatus sc
 634          setLocation uri
 635
 636 -- |@'setContentType' mType@ declares the response header
 637 -- \"Content-Type\" as @mType@. Declaring \"Content-Type\" is
 638 -- mandatory for sending a response body.
 639 setContentType ∷ MIMEType → Rsrc ()
 640 setContentType = setHeader "Content-Type" ∘ cs
 641
 642 -- |@'setLocation' uri@ declares the response header \"Location\" as
 643 -- @uri@. You usually don't need to call this function directly.
 644 setLocation ∷ URI → Rsrc ()
 645 setLocation uri
 646     = case ca uriStr of
 647         Success a → setHeader "Location" a
 648         Failure e → abort $ mkAbortion' InternalServerError
 649                           $ cs (show e)
 650     where
 651       uriStr = uriToString id uri ""
 652
 653 -- |@'setContentEncoding' codings@ declares the response header
 654 -- \"Content-Encoding\" as @codings@.
 655 setContentEncoding ∷ [CIAscii] → Rsrc ()
 656 setContentEncoding codings
 657     = do ver ← getRequestVersion
 658          tr  ← case ver of
 659                   HttpVersion 1 0 → return (toAB ∘ unnormalizeCoding)
 660                   HttpVersion 1 1 → return toAB
 661                   _               → abort $ mkAbortion' InternalServerError
 662                                             "setContentEncoding: Unknown HTTP version"
 663          setHeader "Content-Encoding"
 664              $ cs
 665              $ mconcat
 666              $ intersperse (cs (", " ∷ Ascii))
 667              $ map tr codings
 668     where
 669       toAB ∷ ConvertSuccess α AsciiBuilder ⇒ α → AsciiBuilder
 670       toAB = cs
 671
 672 -- |@'setWWWAuthenticate' challenge@ declares the response header
 673 -- \"WWW-Authenticate\" as @challenge@.
 674 setWWWAuthenticate ∷ AuthChallenge → Rsrc ()
 675 setWWWAuthenticate = setHeader "WWW-Authenticate" ∘ cs
 676
 677 -- |Write a chunk in 'Strict.ByteString' to the response body. You
 678 -- must first declare the response header \"Content-Type\" before
 679 -- applying this function. See 'setContentType'.
 680 putChunk ∷ Strict.ByteString → Rsrc ()
 681 putChunk = putBuilder ∘ BB.fromByteString
 682
 683 -- |Write a chunk in lazy 'Lazy.ByteString' to the response body. It
 684 -- can be safely applied to an infinitely long 'Lazy.ByteString'.
 685 --
 686 -- Note that you must first declare the response header
 687 -- \"Content-Type\" before applying this function. See
 688 -- 'setContentType'.
 689 putChunks ∷ Lazy.ByteString → Rsrc ()
 690 putChunks = putBuilder ∘ BB.fromLazyByteString