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 the corresponding entity
  32 --   for 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 --   discards it.
  45 --
  46 --   [/Deciding Header/] A 'Resource' makes a decision of response
  47 --   status code and header fields. When it transits to the next
  48 --   state, the system validates and completes the 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     , foundNoEntity'
 107
 108     -- * Receiving a request body
 109     -- |These functions make the 'Resource' transit to the /Receiving
 110     -- Body/ state.
 111     , getChunk
 112     , getChunks
 113     , getForm
 114
 115     -- * Declaring response status and header fields
 116     -- |These functions can be called at any time before transiting to
 117     -- the /Sending Body/ state, but they themselves never causes any
 118     -- state transitions.
 119     , setStatus
 120     , redirect
 121     , setContentType
 122     , setContentEncoding
 123     , setWWWAuthenticate
 124
 125     -- ** Less frequently used functions
 126     , setLocation
 127     , setHeader
 128     , deleteHeader
 129
 130     -- * Sending a response body
 131
 132     -- |These functions make the 'Resource' transit to the
 133     -- /Sending Body/ state.
 134     , putChunk
 135     , putChunks
 136     , putBuilder
 137     )
 138     where
 139 import qualified Blaze.ByteString.Builder.ByteString as BB
 140 import Control.Applicative
 141 import Control.Monad
 142 import Control.Monad.IO.Class
 143 import Control.Monad.Unicode
 144 import Data.Ascii (Ascii, CIAscii)
 145 import qualified Data.Ascii as A
 146 import qualified Data.Attoparsec.Char8 as P
 147 import qualified Data.Attoparsec.Lazy  as LP
 148 import Data.ByteString (ByteString)
 149 import qualified Data.ByteString as Strict
 150 import qualified Data.ByteString.Lazy as Lazy
 151 import qualified Data.ByteString.Lazy.Internal as Lazy
 152 import Data.Foldable (toList)
 153 import Data.List
 154 import qualified Data.Map as M
 155 import Data.Maybe
 156 import Data.Monoid.Unicode
 157 import Data.Sequence (Seq)
 158 import Data.Sequence.Unicode hiding ((∅))
 159 import Data.Text (Text)
 160 import qualified Data.Text as T
 161 import qualified Data.Text.Encoding as T
 162 import Data.Time
 163 import qualified Data.Time.HTTP as HTTP
 164 import Network.HTTP.Lucu.Abortion
 165 import Network.HTTP.Lucu.Authentication
 166 import Network.HTTP.Lucu.Config
 167 import Network.HTTP.Lucu.ContentCoding
 168 import Network.HTTP.Lucu.ETag
 169 import qualified Network.HTTP.Lucu.Headers as H
 170 import Network.HTTP.Lucu.HttpVersion
 171 import Network.HTTP.Lucu.Interaction
 172 import Network.HTTP.Lucu.MultipartForm
 173 import Network.HTTP.Lucu.Request
 174 import Network.HTTP.Lucu.Resource.Internal
 175 import Network.HTTP.Lucu.Response
 176 import Network.HTTP.Lucu.MIMEType
 177 import Network.HTTP.Lucu.Utils
 178 import Network.Socket hiding (accept)
 179 import Network.URI hiding (path)
 180 import Prelude.Unicode
 181
 182 -- |Get the string representation of the address of remote host. If
 183 -- you want a 'SockAddr' instead of 'HostName', use 'getRemoteAddr'.
 184 getRemoteAddr' ∷ Resource HostName
 185 getRemoteAddr'
 186     = do sa ← getRemoteAddr
 187          (fromJust ∘ fst) <$> (liftIO $ getNameInfo [NI_NUMERICHOST] True False sa)
 188
 189 -- |Resolve an address to the remote host.
 190 getRemoteHost ∷ Resource (Maybe HostName)
 191 getRemoteHost
 192     = do sa ← getRemoteAddr
 193          fst <$> (liftIO $ getNameInfo [] True False sa)
 194
 195 -- |Get the 'Method' value of the request.
 196 getMethod ∷ Resource Method
 197 getMethod = reqMethod <$> getRequest
 198
 199 -- |Get the URI of the request.
 200 getRequestURI ∷ Resource URI
 201 getRequestURI = reqURI <$> getRequest
 202
 203 -- |Get the HTTP version of the request.
 204 getRequestVersion ∷ Resource HttpVersion
 205 getRequestVersion = reqVersion <$> getRequest
 206
 207 -- |This is an analogy of CGI PATH_INFO. 'getPathInfo' always returns
 208 -- @[]@ if the corresponding
 209 -- 'Network.HTTP.Lucu.Resource.Tree.ResourceDef' is not greedy. See
 210 -- 'getResourcePath'.
 211 --
 212 -- Note that the returned path components are URI-decoded.
 213 getPathInfo ∷ Resource [Strict.ByteString]
 214 getPathInfo = do rsrcPath ← getResourcePath
 215                  reqPath  ← splitPathInfo <$> getRequestURI
 216                  return $ drop (length rsrcPath) reqPath
 217
 218 -- |Assume the query part of request URI as
 219 -- application\/x-www-form-urlencoded, and parse it into pairs of
 220 -- @(name, formData)@. This function doesn't read the request
 221 -- body. Field names are decoded in UTF-8 for an hardly avoidable
 222 -- reason. 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 functions 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 $ mkAbortion' BadRequest
 261                                      $ "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 $ mkAbortion' InternalServerError
 284                                                 "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 $ mkAbortion' BadRequest
 293                                         $ "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 by the
 303 -- client.
 304 isEncodingAcceptable ∷ CIAscii → Resource Bool
 305 isEncodingAcceptable encoding = any doesMatch <$> getAcceptEncoding
 306     where
 307       doesMatch ∷ (CIAscii, Maybe Double) → Bool
 308       doesMatch (e, q) = (e ≡ "*" ∨ e ≡ encoding) ∧ q ≢ Just 0
 309
 310 -- |Return the value of request header \"Content-Type\" as 'MIMEType'.
 311 getContentType ∷ Resource (Maybe MIMEType)
 312 getContentType
 313     = do cTypeM ← getHeader "Content-Type"
 314          case cTypeM of
 315            Nothing
 316                → return Nothing
 317            Just cType
 318                → case P.parseOnly p (A.toByteString cType) of
 319                     Right t → return $ Just t
 320                     Left  _ → abort $ mkAbortion' BadRequest
 321                                     $ "Unparsable Content-Type: " ⊕ A.toText cType
 322     where
 323       p = do t ← mimeTypeP
 324              P.endOfInput
 325              return t
 326
 327 -- |Return the value of request header \"Authorization\" as
 328 -- 'AuthCredential'.
 329 getAuthorization ∷ Resource (Maybe AuthCredential)
 330 getAuthorization
 331     = do authM ← getHeader "Authorization"
 332          case authM of
 333            Nothing
 334                → return Nothing
 335            Just auth
 336                → case P.parseOnly p (A.toByteString auth) of
 337                     Right ac → return $ Just ac
 338                     Left  _  → return Nothing
 339     where
 340       p = do ac ← authCredentialP
 341              P.endOfInput
 342              return ac
 343
 344 -- |Tell the system that the 'Resource' found an entity for the
 345 -- request URI. If this is a GET or HEAD request, a found entity means
 346 -- a datum to be replied. If this is a PUT or DELETE request, it means
 347 -- a datum which was stored for the URI until now. For POST requests
 348 -- it raises an error.
 349 --
 350 -- 'foundEntity' performs \"If-Match\" test or \"If-None-Match\" test
 351 -- whenever possible, and if those tests fail, it immediately aborts
 352 -- with status \"412 Precondition Failed\" or \"304 Not Modified\"
 353 -- depending on the situation.
 354 --
 355 -- If the request method is either GET or HEAD, 'foundEntity'
 356 -- automatically puts \"ETag\" and \"Last-Modified\" headers into the
 357 -- response.
 358 foundEntity ∷ ETag → UTCTime → Resource ()
 359 foundEntity tag timeStamp
 360     = do driftTo ExaminingRequest
 361
 362          method ← getMethod
 363          when (method ≡ GET ∨ method ≡ HEAD)
 364              $ setHeader "Last-Modified" (HTTP.toAscii timeStamp)
 365          when (method ≡ POST)
 366              $ abort
 367              $ mkAbortion' InternalServerError
 368                "foundEntity: this is a POST request."
 369          foundETag tag
 370
 371          driftTo ReceivingBody
 372
 373 -- |Tell the system that the 'Resource' found an entity for the
 374 -- request URI. The only difference from 'foundEntity' is that
 375 -- 'foundETag' doesn't (nor can't) put \"Last-Modified\" header into
 376 -- the response.
 377 --
 378 -- Using this function is discouraged. You should use 'foundEntity'
 379 -- whenever possible.
 380 foundETag ∷ ETag → Resource ()
 381 foundETag tag
 382     = do driftTo ExaminingRequest
 383
 384          method ← getMethod
 385          when (method ≡ GET ∨ method ≡ HEAD)
 386              $ setHeader "ETag"
 387              $ A.fromAsciiBuilder
 388              $ printETag tag
 389          when (method ≡ POST)
 390              $ abort
 391              $ mkAbortion' InternalServerError
 392                "Illegal computation of foundETag for POST request."
 393
 394          -- If-Match があればそれを見る。
 395          ifMatch ← getHeader "If-Match"
 396          case ifMatch of
 397            Nothing    → return ()
 398            Just value → if value ≡ "*" then
 399                             return ()
 400                         else
 401                             case P.parseOnly p (A.toByteString value) of
 402                               Right tags
 403                                   -- tags の中に一致するものが無ければ
 404                                   -- PreconditionFailed で終了。
 405                                   → when ((¬) (any (≡ tag) tags))
 406                                         $ abort
 407                                         $ mkAbortion' PreconditionFailed
 408                                         $ "The entity tag doesn't match: " ⊕ A.toText value
 409                               Left _
 410                                   → abort $ mkAbortion' BadRequest
 411                                           $ "Unparsable If-Match: " ⊕ A.toText value
 412
 413          let statusForNoneMatch
 414                  = if method ≡ GET ∨ method ≡ HEAD then
 415                        NotModified
 416                    else
 417                        PreconditionFailed
 418
 419          -- If-None-Match があればそれを見る。
 420          ifNoneMatch ← getHeader "If-None-Match"
 421          case ifNoneMatch of
 422            Nothing    → return ()
 423            Just value → if value ≡ "*" then
 424                             abort $ mkAbortion' statusForNoneMatch
 425                                   $ "The entity tag matches: *"
 426                         else
 427                             case P.parseOnly p (A.toByteString value) of
 428                               Right tags
 429                                   → when (any (≡ tag) tags)
 430                                         $ abort
 431                                         $ mkAbortion' statusForNoneMatch
 432                                         $ "The entity tag matches: " ⊕ A.toText value
 433                               Left _
 434                                   → abort $ mkAbortion' BadRequest
 435                                           $ "Unparsable If-None-Match: " ⊕ A.toText value
 436
 437          driftTo ReceivingBody
 438     where
 439       p = do xs ← eTagListP
 440              P.endOfInput
 441              return xs
 442
 443 -- |Tell the system that the 'Resource' found an entity for the
 444 -- request URI. The only difference from 'foundEntity' is that
 445 -- 'foundTimeStamp' performs \"If-Modified-Since\" test or
 446 -- \"If-Unmodified-Since\" test instead of \"If-Match\" test or
 447 -- \"If-None-Match\" test. Be aware that any tests based on a last
 448 -- modification time are unsafe because it is possible to mess up such
 449 -- tests by modifying the entity twice in a second.
 450 --
 451 -- Using this function is discouraged. You should use 'foundEntity'
 452 -- whenever possible.
 453 foundTimeStamp ∷ UTCTime → Resource ()
 454 foundTimeStamp timeStamp
 455     = do driftTo ExaminingRequest
 456
 457          method ← getMethod
 458          when (method ≡ GET ∨ method ≡ HEAD)
 459              $ setHeader "Last-Modified" (HTTP.toAscii timeStamp)
 460          when (method ≡ POST)
 461              $ abort
 462              $ mkAbortion' InternalServerError
 463                "Illegal computation of foundTimeStamp for POST request."
 464
 465          let statusForIfModSince
 466                  = if method ≡ GET ∨ method ≡ HEAD then
 467                        NotModified
 468                    else
 469                        PreconditionFailed
 470
 471          -- If-Modified-Since があればそれを見る。
 472          ifModSince ← getHeader "If-Modified-Since"
 473          case ifModSince of
 474            Just str → case HTTP.fromAscii str of
 475                          Right lastTime
 476                              → when (timeStamp ≤ lastTime)
 477                                $ abort
 478                                $ mkAbortion' statusForIfModSince
 479                                $ "The entity has not been modified since " ⊕ A.toText str
 480                          Left _
 481                              → return () -- 不正な時刻は無視
 482            Nothing  → return ()
 483
 484          -- If-Unmodified-Since があればそれを見る。
 485          ifUnmodSince ← getHeader "If-Unmodified-Since"
 486          case ifUnmodSince of
 487            Just str → case HTTP.fromAscii str of
 488                          Right lastTime
 489                              → when (timeStamp > lastTime)
 490                                $ abort
 491                                $ mkAbortion' PreconditionFailed
 492                                $ "The entity has not been modified since " ⊕ A.toText str
 493                          Left _
 494                              → return () -- 不正な時刻は無視
 495            Nothing  → return ()
 496
 497          driftTo ReceivingBody
 498
 499 -- |@'foundNoEntity' mStr@ tells the system that the 'Resource' found
 500 -- no entity for the request URI. @mStr@ is an optional error message
 501 -- to be replied to the client.
 502 --
 503 -- If the request method is PUT, 'foundNoEntity' performs \"If-Match\"
 504 -- test and when that fails it aborts with status \"412 Precondition
 505 -- Failed\". If the request method is GET, HEAD, POST or DELETE,
 506 -- 'foundNoEntity' always aborts with status \"404 Not Found\".
 507 foundNoEntity ∷ Maybe Text → Resource ()
 508 foundNoEntity msgM
 509     = do driftTo ExaminingRequest
 510
 511          method ← getMethod
 512          when (method ≢ PUT)
 513              $ abort
 514              $ mkAbortion NotFound [] msgM
 515
 516          -- エンティティが存在しないと云ふ事は、"*" も含めたどのやうな
 517          -- If-Match: 條件も滿たさない。
 518          ifMatch ← getHeader "If-Match"
 519          when (ifMatch ≢ Nothing)
 520              $ abort
 521              $ mkAbortion PreconditionFailed [] msgM
 522
 523          driftTo ReceivingBody
 524
 525 -- |'foundNoEntity'' is the same as @'foundNoEntity' 'Nothing'@.
 526 foundNoEntity' ∷ Resource ()
 527 {-# INLINE foundNoEntity' #-}
 528 foundNoEntity' = foundNoEntity Nothing
 529
 530
 531 -- |@'getChunks' limit@ attemts to read the entire request body up to
 532 -- @limit@ bytes, and then make the 'Resource' transit to the
 533 -- /Deciding Header/ state. When the actual size of the body is larger
 534 -- than @limit@ bytes, 'getChunks' immediately aborts with status
 535 -- \"413 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 → Resource 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 → Resource Lazy.ByteString
 553 getChunks' limit = go limit (∅)
 554     where
 555       go ∷ Int → Seq Strict.ByteString → Resource 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                              ⊕ T.pack (show limit)
 563                              ⊕ " bytes."
 564       go n xs = do let n' = min n Lazy.defaultChunkSize
 565                    chunk ← getChunk n'
 566                    if Strict.null chunk then
 567                        -- Got EOF
 568                        return $ Lazy.fromChunks $ toList xs
 569                    else
 570                        do let n'' = n' - Strict.length chunk
 571                               xs' = xs ⊳ chunk
 572                           go n'' xs'
 573
 574 -- |@'getForm' limit@ attempts to read the request body with
 575 -- 'getChunks' and parse it as @application\/x-www-form-urlencoded@ or
 576 -- @multipart\/form-data@. If the request header \"Content-Type\" is
 577 -- neither of them, 'getForm' aborts with status \"415 Unsupported
 578 -- Media Type\". If the request has no \"Content-Type\", it aborts
 579 -- with \"400 Bad Request\".
 580 --
 581 -- Field names in @multipart\/form-data@ will be precisely decoded in
 582 -- accordance with RFC 2231. On the other hand,
 583 -- @application\/x-www-form-urlencoded@ says nothing about character
 584 -- encodings for field names, so they'll always be decoded in
 585 -- UTF-8. (This could be a bad design, but I can't think of any better
 586 -- idea.)
 587 getForm ∷ Maybe Int → Resource [(Text, FormData)]
 588 getForm limit
 589     = do cTypeM ← getContentType
 590          case cTypeM of
 591            Nothing
 592                → abort $ mkAbortion' BadRequest "Missing Content-Type"
 593            Just (MIMEType "application" "x-www-form-urlencoded" _)
 594                → readWWWFormURLEncoded
 595            Just (MIMEType "multipart" "form-data" params)
 596                → readMultipartFormData params
 597            Just cType
 598                → abort $ mkAbortion' UnsupportedMediaType
 599                        $ A.toText
 600                        $ A.fromAsciiBuilder
 601                        $ A.toAsciiBuilder "Unsupported media type: "
 602                        ⊕ printMIMEType cType
 603     where
 604       readWWWFormURLEncoded
 605           = (map toPairWithFormData ∘ parseWWWFormURLEncoded)
 606             <$>
 607             (bsToAscii =≪ getChunks limit)
 608
 609       bsToAscii bs
 610           = case A.fromByteString (Strict.concat (Lazy.toChunks bs)) of
 611               Just a  → return a
 612               Nothing → abort $ mkAbortion' BadRequest "Malformed x-www-form-urlencoded"
 613
 614       readMultipartFormData params
 615           = case M.lookup "boundary" params of
 616               Nothing
 617                   → abort $ mkAbortion' BadRequest "Missing boundary of multipart/form-data"
 618               Just boundary
 619                   → do src ← getChunks limit
 620                        b   ← case A.fromText boundary of
 621                                 Just b  → return b
 622                                 Nothing → abort $ mkAbortion' BadRequest
 623                                                 $ "Malformed boundary: " ⊕ boundary
 624                        case LP.parse (p b) src of
 625                          LP.Done _ formList
 626                              → return formList
 627                          _   → abort $ mkAbortion' BadRequest "Unparsable multipart/form-data"
 628           where
 629             p b = do xs ← multipartFormP b
 630                      P.endOfInput
 631                      return xs
 632
 633 -- |@'redirect' code uri@ declares the response status as @code@ and
 634 -- \"Location\" header field as @uri@. The @code@ must satisfy
 635 -- 'isRedirection' or it raises an error.
 636 redirect ∷ StatusCode → URI → Resource ()
 637 redirect code uri
 638     = do when (code ≡ NotModified ∨ not (isRedirection code))
 639              $ abort
 640              $ mkAbortion' InternalServerError
 641              $ A.toText
 642              $ A.fromAsciiBuilder
 643              $ A.toAsciiBuilder "Attempted to redirect with status "
 644              ⊕ printStatusCode code
 645          setStatus code
 646          setLocation uri
 647
 648 -- |@'setContentType' mType@ declares the response header
 649 -- \"Content-Type\" as @mType@. Declaring \"Content-Type\" is
 650 -- mandatory for sending a response body.
 651 setContentType ∷ MIMEType → Resource ()
 652 setContentType
 653     = setHeader "Content-Type" ∘ A.fromAsciiBuilder ∘ printMIMEType
 654
 655 -- |@'setLocation' uri@ declares the response header \"Location\" as
 656 -- @uri@. You usually don't need to call this function directly.
 657 setLocation ∷ URI → Resource ()
 658 setLocation uri
 659     = case A.fromChars uriStr of
 660         Just a  → setHeader "Location" a
 661         Nothing → abort $ mkAbortion' InternalServerError
 662                         $ "Malformed URI: " ⊕ T.pack uriStr
 663     where
 664       uriStr = uriToString id uri ""
 665
 666 -- |@'setContentEncoding' codings@ declares the response header
 667 -- \"Content-Encoding\" as @codings@.
 668 setContentEncoding ∷ [CIAscii] → Resource ()
 669 setContentEncoding codings
 670     = do ver ← getRequestVersion
 671          tr  ← case ver of
 672                   HttpVersion 1 0 → return (toAB ∘ unnormalizeCoding)
 673                   HttpVersion 1 1 → return toAB
 674                   _               → abort $ mkAbortion' InternalServerError
 675                                             "setContentEncoding: Unknown HTTP version"
 676          setHeader "Content-Encoding"
 677                    (A.fromAsciiBuilder $ joinWith ", " $ map tr codings)
 678     where
 679       toAB = A.toAsciiBuilder ∘ A.fromCIAscii
 680
 681 -- |@'setWWWAuthenticate' challenge@ declares the response header
 682 -- \"WWW-Authenticate\" as @challenge@.
 683 setWWWAuthenticate ∷ AuthChallenge → Resource ()
 684 setWWWAuthenticate = setHeader "WWW-Authenticate" ∘ printAuthChallenge
 685
 686 -- |Write a chunk in 'Strict.ByteString' to the response body. You
 687 -- must first declare the response header \"Content-Type\" before
 688 -- applying this function. See 'setContentType'.
 689 putChunk ∷ Strict.ByteString → Resource ()
 690 putChunk = putBuilder ∘ BB.fromByteString
 691
 692 -- |Write a chunk in lazy 'Lazy.ByteString' to the response body. It
 693 -- can be safely applied to an infinitely long 'Lazy.ByteString'.
 694 --
 695 -- Note that you must first declare the response header
 696 -- \"Content-Type\" before applying this function. See
 697 -- 'setContentType'.
 698 putChunks ∷ Lazy.ByteString → Resource ()
 699 putChunks = putBuilder ∘ BB.fromLazyByteString