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