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     , ResourceDef(..)
  73     , emptyResource
  74     , FormData(..)
  75
  76     -- * Getting request header
  77     -- |These functions can be called regardless of the current state,
  78     -- and they don't change the state of 'Resource'.
  79     , getConfig
  80     , getRemoteAddr
  81     , getRemoteAddr'
  82     , getRemoteHost
  83     , getRemoteCertificate
  84     , getRequest
  85     , getMethod
  86     , getRequestURI
  87     , getRequestVersion
  88     , getResourcePath
  89     , getPathInfo
  90     , getQueryForm
  91     , getHeader
  92     , getAccept
  93     , getAcceptEncoding
  94     , isEncodingAcceptable
  95     , getContentType
  96     , getAuthorization
  97
  98     -- * Finding an entity
  99     -- |These functions can be called only in the /Examining Request/
 100     -- state. They make the 'Resource' transit to the /Receiving Body/
 101     -- state.
 102     , foundEntity
 103     , foundETag
 104     , foundTimeStamp
 105     , foundNoEntity
 106
 107     -- * Receiving a request body
 108     -- |These functions make the 'Resource' transit to the /Receiving
 109     -- Body/ state.
 110     , getChunk
 111     , getChunks
 112     , getForm
 113
 114     -- * Declaring response status and header fields
 115     -- |These functions can be called at any time before transiting to
 116     -- the /Sending Body/ state, but they themselves never causes any
 117     -- state transitions.
 118     , setStatus
 119     , redirect
 120     , setContentType
 121     , setContentEncoding
 122     , setWWWAuthenticate
 123
 124     -- ** Less frequently used functions
 125     , setLocation
 126     , setHeader
 127     , deleteHeader
 128
 129     -- * Sending a response body
 130     -- |These functions make the 'Resource' transit to the /Sending
 131     -- Body/ state.
 132     , putChunk
 133     , putChunks
 134     , putBuilder
 135     )
 136     where
 137 import qualified Blaze.ByteString.Builder.ByteString as BB
 138 import Control.Applicative
 139 import Control.Monad
 140 import Control.Monad.IO.Class
 141 import Control.Monad.Unicode
 142 import Data.Ascii (Ascii, CIAscii)
 143 import qualified Data.Ascii as A
 144 import qualified Data.Attoparsec.Char8 as P
 145 import qualified Data.Attoparsec.Lazy  as LP
 146 import Data.ByteString (ByteString)
 147 import qualified Data.ByteString as Strict
 148 import qualified Data.ByteString.Lazy as Lazy
 149 import qualified Data.ByteString.Lazy.Internal as Lazy
 150 import Data.Foldable (toList)
 151 import Data.List
 152 import qualified Data.Map as M
 153 import Data.Maybe
 154 import Data.Monoid.Unicode
 155 import Data.Sequence (Seq)
 156 import Data.Sequence.Unicode hiding ((∅))
 157 import Data.Text (Text)
 158 import qualified Data.Text as T
 159 import qualified Data.Text.Encoding as T
 160 import Data.Time
 161 import qualified Data.Time.HTTP as HTTP
 162 import Network.HTTP.Lucu.Abortion
 163 import Network.HTTP.Lucu.Authentication
 164 import Network.HTTP.Lucu.Config
 165 import Network.HTTP.Lucu.ContentCoding
 166 import Network.HTTP.Lucu.ETag
 167 import qualified Network.HTTP.Lucu.Headers as H
 168 import Network.HTTP.Lucu.HttpVersion
 169 import Network.HTTP.Lucu.Interaction
 170 import Network.HTTP.Lucu.MultipartForm
 171 import Network.HTTP.Lucu.Request
 172 import Network.HTTP.Lucu.Resource.Internal
 173 import Network.HTTP.Lucu.Response
 174 import Network.HTTP.Lucu.MIMEType
 175 import Network.HTTP.Lucu.Utils
 176 import Network.Socket hiding (accept)
 177 import Network.URI hiding (path)
 178 import Prelude.Unicode
 179
 180 -- |Get the string representation of the address of remote host. If
 181 -- you want a 'SockAddr' instead of 'HostName', use 'getRemoteAddr'.
 182 getRemoteAddr' ∷ Resource HostName
 183 getRemoteAddr'
 184     = do sa ← getRemoteAddr
 185          (fromJust ∘ fst) <$> (liftIO $ getNameInfo [NI_NUMERICHOST] True False sa)
 186
 187 -- |Resolve an address to the remote host.
 188 getRemoteHost ∷ Resource (Maybe HostName)
 189 getRemoteHost
 190     = do sa ← getRemoteAddr
 191          fst <$> (liftIO $ getNameInfo [] True False sa)
 192
 193 -- |Get the 'Method' value of the request.
 194 getMethod ∷ Resource Method
 195 getMethod = reqMethod <$> getRequest
 196
 197 -- |Get the URI of the request.
 198 getRequestURI ∷ Resource URI
 199 getRequestURI = reqURI <$> getRequest
 200
 201 -- |Get the HTTP version of the request.
 202 getRequestVersion ∷ Resource HttpVersion
 203 getRequestVersion = reqVersion <$> getRequest
 204
 205 -- |This is an analogy of CGI PATH_INFO. 'getPathInfo' always returns
 206 -- @[]@ if the corresponding
 207 -- 'Network.HTTP.Lucu.Resource.Tree.ResourceDef' is not greedy. See
 208 -- 'getResourcePath'.
 209 --
 210 -- Note that the returned path components are URI-decoded.
 211 getPathInfo ∷ Resource [Strict.ByteString]
 212 getPathInfo = do rsrcPath ← getResourcePath
 213                  reqPath  ← splitPathInfo <$> getRequestURI
 214                  return $ drop (length rsrcPath) reqPath
 215
 216 -- |Assume the query part of request URI as
 217 -- application\/x-www-form-urlencoded, and parse it into pairs of
 218 -- @(name, formData)@. This function doesn't read the request
 219 -- body. Field names are decoded in UTF-8 for an hardly avoidable
 220 -- reason. See 'getForm'.
 221 getQueryForm ∷ Resource [(Text, FormData)]
 222 getQueryForm = parse' <$> getRequestURI
 223     where
 224       parse' = map toPairWithFormData ∘
 225                parseWWWFormURLEncoded ∘
 226                fromJust ∘
 227                A.fromChars ∘
 228                drop 1 ∘
 229                uriQuery
 230
 231 toPairWithFormData ∷ (ByteString, ByteString) → (Text, FormData)
 232 toPairWithFormData (name, value)
 233     = let fd = FormData {
 234                  fdFileName = Nothing
 235                , fdContent  = Lazy.fromChunks [value]
 236                }
 237       in (T.decodeUtf8 name, fd)
 238
 239 -- |@'getHeader' name@ returns the value of the request header field
 240 -- @name@. Comparison of header name is case-insensitive. Note that
 241 -- this function is not intended to be used so frequently: there
 242 -- should be actions like 'getContentType' for every common headers.
 243 getHeader ∷ CIAscii → Resource (Maybe Ascii)
 244 getHeader name
 245     = H.getHeader name <$> getRequest
 246
 247 -- |Return the list of 'MIMEType' enumerated on the value of request
 248 -- header \"Accept\", or @[]@ if absent.
 249 getAccept ∷ Resource [MIMEType]
 250 getAccept
 251     = do acceptM ← getHeader "Accept"
 252          case acceptM of
 253            Nothing
 254                → return []
 255            Just accept
 256                → case P.parseOnly p (A.toByteString accept) of
 257                     Right xs → return xs
 258                     Left  _  → abort BadRequest []
 259                                (Just $ "Unparsable Accept: " ⊕ A.toText accept)
 260     where
 261       p = do xs ← mimeTypeListP
 262              P.endOfInput
 263              return xs
 264
 265 -- |Return the list of @(contentCoding, qvalue)@ enumerated on the
 266 -- value of request header \"Accept-Encoding\". The list is sorted in
 267 -- descending order by qvalue.
 268 getAcceptEncoding ∷ Resource [(CIAscii, Maybe Double)]
 269 getAcceptEncoding
 270     = do accEncM ← getHeader "Accept-Encoding"
 271          case accEncM of
 272            Nothing
 273                -- HTTP/1.0 には Accept-Encoding が無い場合の規定が無い
 274                -- ので安全の爲 identity が指定された事にする。HTTP/1.1
 275                -- の場合は何でも受け入れて良い事になってゐるので "*" が
 276                -- 指定された事にする。
 277                → do ver ← getRequestVersion
 278                     case ver of
 279                       HttpVersion 1 0 → return [("identity", Nothing)]
 280                       HttpVersion 1 1 → return [("*"       , Nothing)]
 281                       _               → abort InternalServerError []
 282                                         (Just "getAcceptEncoding: unknown HTTP version")
 283            Just ae
 284                → if ae ≡ "" then
 285                       -- identity のみが許される。
 286                       return [("identity", Nothing)]
 287                  else
 288                      case P.parseOnly p (A.toByteString ae) of
 289                        Right xs → return $ map toTuple $ reverse $ sort xs
 290                        Left  _  → abort BadRequest []
 291                                   (Just $ "Unparsable Accept-Encoding: " ⊕ A.toText ae)
 292     where
 293       p = do xs ← acceptEncodingListP
 294              P.endOfInput
 295              return xs
 296
 297       toTuple (AcceptEncoding {..})
 298           = (aeEncoding, aeQValue)
 299
 300 -- |Return 'True' iff a given content-coding is acceptable.
 301 isEncodingAcceptable ∷ CIAscii → Resource Bool
 302 isEncodingAcceptable encoding = any doesMatch <$> getAcceptEncoding
 303     where
 304       doesMatch ∷ (CIAscii, Maybe Double) → Bool
 305       doesMatch (e, q) = (e ≡ "*" ∨ e ≡ encoding) ∧ q ≢ Just 0
 306
 307 -- |Return the value of request header \"Content-Type\" as 'MIMEType'.
 308 getContentType ∷ Resource (Maybe MIMEType)
 309 getContentType
 310     = do cTypeM ← getHeader "Content-Type"
 311          case cTypeM of
 312            Nothing
 313                → return Nothing
 314            Just cType
 315                → case P.parseOnly p (A.toByteString cType) of
 316                     Right t → return $ Just t
 317                     Left  _ → abort BadRequest []
 318                               (Just $ "Unparsable Content-Type: " ⊕ A.toText cType)
 319     where
 320       p = do t ← mimeTypeP
 321              P.endOfInput
 322              return t
 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 p (A.toByteString auth) of
 334                     Right ac → return $ Just ac
 335                     Left  _  → return Nothing
 336     where
 337       p = do ac ← authCredentialP
 338              P.endOfInput
 339              return ac
 340
 341 -- |Tell the system that the 'Resource' found an entity for the
 342 -- request URI. If this is a GET or HEAD request, a found entity means
 343 -- a datum to be replied. If this is a PUT or DELETE request, it means
 344 -- a datum which was stored for the URI until now. For POST requests
 345 -- it raises an error.
 346 --
 347 -- 'foundEntity' performs \"If-Match\" test or \"If-None-Match\" test
 348 -- whenever possible, and if those tests fail, it immediately aborts
 349 -- with status \"412 Precondition Failed\" or \"304 Not Modified\"
 350 -- depending on the situation.
 351 --
 352 -- If the request method is either GET or HEAD, 'foundEntity'
 353 -- automatically puts \"ETag\" and \"Last-Modified\" headers into the
 354 -- response.
 355 foundEntity ∷ ETag → UTCTime → Resource ()
 356 foundEntity tag timeStamp
 357     = do driftTo ExaminingRequest
 358
 359          method ← getMethod
 360          when (method ≡ GET ∨ method ≡ HEAD)
 361              $ setHeader "Last-Modified" (HTTP.toAscii timeStamp)
 362          when (method ≡ POST)
 363              $ abort InternalServerError []
 364                (Just "foundEntity: this is a POST request.")
 365          foundETag tag
 366
 367          driftTo ReceivingBody
 368
 369 -- |Tell the system that the 'Resource' found an entity for the
 370 -- request URI. The only difference from 'foundEntity' is that
 371 -- 'foundETag' doesn't (nor can't) put \"Last-Modified\" header into
 372 -- the response.
 373 --
 374 -- Using this function is discouraged. You should use 'foundEntity'
 375 -- whenever possible.
 376 foundETag ∷ ETag → Resource ()
 377 foundETag tag
 378     = do driftTo ExaminingRequest
 379
 380          method ← getMethod
 381          when (method ≡ GET ∨ method ≡ HEAD)
 382              $ setHeader "ETag"
 383              $ A.fromAsciiBuilder
 384              $ printETag tag
 385          when (method ≡ POST)
 386              $ abort InternalServerError []
 387              $ Just "Illegal computation of foundETag for POST request."
 388
 389          -- If-Match があればそれを見る。
 390          ifMatch ← getHeader "If-Match"
 391          case ifMatch of
 392            Nothing    → return ()
 393            Just value → if value ≡ "*" then
 394                             return ()
 395                         else
 396                             case P.parseOnly p (A.toByteString value) of
 397                               Right tags
 398                                   -- tags の中に一致するものが無ければ
 399                                   -- PreconditionFailed で終了。
 400                                   → when ((¬) (any (≡ tag) tags))
 401                                         $ abort PreconditionFailed []
 402                                         $ Just
 403                                         $ "The entity tag doesn't match: " ⊕ A.toText value
 404                               Left _
 405                                   → abort BadRequest []
 406                                     $ Just
 407                                     $ "Unparsable If-Match: " ⊕ A.toText value
 408
 409          let statusForNoneMatch
 410                  = if method ≡ GET ∨ method ≡ HEAD then
 411                        NotModified
 412                    else
 413                        PreconditionFailed
 414
 415          -- If-None-Match があればそれを見る。
 416          ifNoneMatch ← getHeader "If-None-Match"
 417          case ifNoneMatch of
 418            Nothing    → return ()
 419            Just value → if value ≡ "*" then
 420                             abort statusForNoneMatch [] (Just "The entity tag matches: *")
 421                         else
 422                             case P.parseOnly p (A.toByteString value) of
 423                               Right tags
 424                                   → when (any (≡ tag) tags)
 425                                         $ abort statusForNoneMatch []
 426                                         $ Just
 427                                         $ "The entity tag matches: " ⊕ A.toText value
 428                               Left _
 429                                   → abort BadRequest []
 430                                     $ Just
 431                                     $ "Unparsable If-None-Match: " ⊕ A.toText value
 432
 433          driftTo ReceivingBody
 434     where
 435       p = do xs ← eTagListP
 436              P.endOfInput
 437              return xs
 438
 439 -- |Tell the system that the 'Resource' found an entity for the
 440 -- request URI. The only difference from 'foundEntity' is that
 441 -- 'foundTimeStamp' performs \"If-Modified-Since\" test or
 442 -- \"If-Unmodified-Since\" test instead of \"If-Match\" test or
 443 -- \"If-None-Match\" test. Be aware that any tests based on a last
 444 -- modification time are unsafe because it is possible to mess up such
 445 -- tests by modifying the entity twice in a second.
 446 --
 447 -- Using this function is discouraged. You should use 'foundEntity'
 448 -- whenever possible.
 449 foundTimeStamp ∷ UTCTime → Resource ()
 450 foundTimeStamp timeStamp
 451     = do driftTo ExaminingRequest
 452
 453          method ← getMethod
 454          when (method ≡ GET ∨ method ≡ HEAD)
 455              $ setHeader "Last-Modified" (HTTP.toAscii timeStamp)
 456          when (method ≡ POST)
 457              $ abort InternalServerError []
 458                (Just "Illegal computation of foundTimeStamp for POST request.")
 459
 460          let statusForIfModSince
 461                  = if method ≡ GET ∨ method ≡ HEAD then
 462                        NotModified
 463                    else
 464                        PreconditionFailed
 465
 466          -- If-Modified-Since があればそれを見る。
 467          ifModSince ← getHeader "If-Modified-Since"
 468          case ifModSince of
 469            Just str → case HTTP.fromAscii str of
 470                          Right lastTime
 471                              → when (timeStamp ≤ lastTime)
 472                                $ abort statusForIfModSince []
 473                                  (Just $ "The entity has not been modified since " ⊕ A.toText str)
 474                          Left _
 475                              → return () -- 不正な時刻は無視
 476            Nothing  → return ()
 477
 478          -- If-Unmodified-Since があればそれを見る。
 479          ifUnmodSince ← getHeader "If-Unmodified-Since"
 480          case ifUnmodSince of
 481            Just str → case HTTP.fromAscii str of
 482                          Right lastTime
 483                              → when (timeStamp > lastTime)
 484                                $ abort PreconditionFailed []
 485                                  (Just $ "The entity has not been modified since " ⊕ A.toText str)
 486                          Left _
 487                              → return () -- 不正な時刻は無視
 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 NotFound [] msgM
 507
 508          -- エンティティが存在しないと云ふ事は、"*" も含めたどのやうな
 509          -- If-Match: 條件も滿たさない。
 510          ifMatch ← getHeader "If-Match"
 511          when (ifMatch ≢ Nothing)
 512              $ abort PreconditionFailed [] msgM
 513
 514          driftTo ReceivingBody
 515
 516
 517 -- |@'getChunks' limit@ attemts to read the entire request body up to
 518 -- @limit@ bytes, and then make the 'Resource' transit to the
 519 -- /Deciding Header/ state. When the actual size of the body is larger
 520 -- than @limit@ bytes, 'getChunks' immediately aborts with status
 521 -- \"413 Request Entity Too Large\". When the request has no body, it
 522 -- returns an empty string.
 523 --
 524 -- When the @limit@ is 'Nothing', 'getChunks' uses the default
 525 -- limitation value ('cnfMaxEntityLength') instead.
 526 --
 527 -- 'getChunks' returns a 'Lazy.ByteString' but it's not really lazy:
 528 -- reading from the socket just happens at the computation of
 529 -- 'getChunks', not at the evaluation of the 'Lazy.ByteString'.
 530 getChunks ∷ Maybe Int → Resource Lazy.ByteString
 531 getChunks (Just n)
 532     | n < 0     = fail ("getChunks: limit must not be negative: " ⧺ show n)
 533     | n ≡ 0     = return (∅)
 534     | otherwise = getChunks' n
 535 getChunks Nothing
 536     = getConfig ≫= getChunks ∘ Just ∘ cnfMaxEntityLength
 537
 538 getChunks' ∷ Int → Resource Lazy.ByteString
 539 getChunks' limit = go limit (∅)
 540     where
 541       go ∷ Int → Seq Strict.ByteString → Resource Lazy.ByteString
 542       go 0 _  = abort RequestEntityTooLarge []
 543                 (Just $ "Request body must be smaller than "
 544                         ⊕ T.pack (show limit) ⊕ " bytes.")
 545       go n xs = do let n'  = min n Lazy.defaultChunkSize
 546                    chunk ← getChunk n'
 547                    if Strict.null chunk then
 548                        -- Got EOF
 549                        return $ Lazy.fromChunks $ toList xs
 550                    else
 551                        do let n'' = n' - Strict.length chunk
 552                               xs' = xs ⊳ chunk
 553                           go n'' xs'
 554
 555 -- |@'getForm' limit@ attempts to read the request body with
 556 -- 'getChunks' and parse it as @application\/x-www-form-urlencoded@ or
 557 -- @multipart\/form-data@. If the request header \"Content-Type\" is
 558 -- neither of them, 'getForm' aborts with status \"415 Unsupported
 559 -- Media Type\". If the request has no \"Content-Type\", it aborts
 560 -- with \"400 Bad Request\".
 561 --
 562 -- Field names in @multipart\/form-data@ will be precisely decoded in
 563 -- accordance with RFC 2231. On the other hand,
 564 -- @application\/x-www-form-urlencoded@ says nothing about character
 565 -- encodings for field names, so they'll always be decoded in
 566 -- UTF-8. (This could be a bad design, but I can't think of any better
 567 -- idea.)
 568 getForm ∷ Maybe Int → Resource [(Text, FormData)]
 569 getForm limit
 570     = do cTypeM ← getContentType
 571          case cTypeM of
 572            Nothing
 573                → abort BadRequest [] (Just "Missing Content-Type")
 574            Just (MIMEType "application" "x-www-form-urlencoded" _)
 575                → readWWWFormURLEncoded
 576            Just (MIMEType "multipart" "form-data" params)
 577                → readMultipartFormData params
 578            Just cType
 579                → abort UnsupportedMediaType []
 580                  $ Just
 581                  $ A.toText
 582                  $ A.fromAsciiBuilder
 583                  $ A.toAsciiBuilder "Unsupported media type: "
 584                  ⊕ printMIMEType cType
 585     where
 586       readWWWFormURLEncoded
 587           = (map toPairWithFormData ∘ parseWWWFormURLEncoded)
 588             <$>
 589             (bsToAscii =≪ getChunks limit)
 590
 591       bsToAscii bs
 592           = case A.fromByteString (Strict.concat (Lazy.toChunks bs)) of
 593               Just a  → return a
 594               Nothing → abort BadRequest [] (Just "Malformed x-www-form-urlencoded")
 595
 596       readMultipartFormData params
 597           = do case M.lookup "boundary" params of
 598                  Nothing
 599                      → abort BadRequest [] (Just "Missing boundary of multipart/form-data")
 600                  Just boundary
 601                      → do src ← getChunks limit
 602                           b   ← case A.fromText boundary of
 603                                    Just b  → return b
 604                                    Nothing → abort BadRequest []
 605                                              (Just $ "Malformed boundary: " ⊕ boundary)
 606                           case LP.parse (p b) src of
 607                             LP.Done _ formList
 608                                 → return formList
 609                             _   → abort BadRequest [] (Just "Unparsable multipart/form-data")
 610           where
 611             p b = do xs ← multipartFormP b
 612                      P.endOfInput
 613                      return xs
 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 → URI → Resource ()
 619 redirect code uri
 620     = do when (code ≡ NotModified ∨ not (isRedirection code))
 621              $ abort InternalServerError []
 622              $ Just
 623              $ A.toText
 624              $ A.fromAsciiBuilder
 625              $ A.toAsciiBuilder "Attempted to redirect with status "
 626              ⊕ printStatusCode code
 627          setStatus code
 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 ∘ 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 InternalServerError []
 644                   (Just $ "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 InternalServerError []
 657                                     (Just "setContentEncoding: Unknown HTTP version")
 658          setHeader "Content-Encoding"
 659                    (A.fromAsciiBuilder $ joinWith ", " $ map tr codings)
 660     where
 661       toAB = A.toAsciiBuilder ∘ A.fromCIAscii
 662
 663 -- |@'setWWWAuthenticate' challenge@ declares the response header
 664 -- \"WWW-Authenticate\" as @challenge@.
 665 setWWWAuthenticate ∷ AuthChallenge → Resource ()
 666 setWWWAuthenticate = setHeader "WWW-Authenticate" ∘ printAuthChallenge
 667
 668 -- |Write a chunk in 'Strict.ByteString' to the response body. You
 669 -- must first declare the response header \"Content-Type\" before
 670 -- applying this function. See 'setContentType'.
 671 putChunk ∷ Strict.ByteString → Resource ()
 672 putChunk = putBuilder ∘ BB.fromByteString
 673
 674 -- |Write a chunk in 'Lazy.ByteString' to the response body. It is
 675 -- safe to apply this function to an infinitely long
 676 -- 'Lazy.ByteString'.
 677 --
 678 -- Note that you must first declare the response header
 679 -- \"Content-Type\" before applying this function. See
 680 -- 'setContentType'.
 681 putChunks ∷ Lazy.ByteString → Resource ()
 682 putChunks = putBuilder ∘ BB.fromLazyByteString