Network/HTTP/Lucu/Resource.hs

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