Network/HTTP/Lucu/Resource.hs

   1 {-# LANGUAGE
   2     BangPatterns
   3   , GeneralizedNewtypeDeriving
   4   , DoAndIfThenElse
   5   , OverloadedStrings
   6   , RecordWildCards
   7   , UnicodeSyntax
   8   #-}
   9 -- |This is the Resource Monad; monadic actions to define a behavior
  10 -- of resource. The 'Resource' Monad is a kind of 'IO' Monad thus it
  11 -- implements 'MonadIO' class, and it is a state machine as well.
  12 --
  13 -- Request Processing Flow:
  14 --
  15 --   1. A client issues an HTTP request.
  16 --
  17 --   2. If the URI of it matches to any resource, the corresponding
  18 --      'Resource' Monad starts running on a newly spawned thread.
  19 --
  20 --   3. The 'Resource' Monad looks at request headers, find (or not
  21 --      find) an entity, receive the request body (if any), send
  22 --      response headers, and then send a response body. This process
  23 --      will be discussed later.
  24 --
  25 --   4. The 'Resource' Monad and its thread stops running. The client
  26 --      may or may not be sending us the next request at this point.
  27 --
  28 -- 'Resource' Monad takes the following states. The initial state is
  29 -- /Examining Request/ and the final state is /Done/.
  30 --
  31 --   [/Examining Request/] In this state, a 'Resource' looks at the
  32 --   request header fields and thinks about the corresponding entity
  33 --   for it. If there is a suitable entity, the 'Resource' tells the
  34 --   system an entity tag and its last modification time
  35 --   ('foundEntity'). If it found no entity, it tells the system so
  36 --   ('foundNoEntity'). In case it is impossible to decide the
  37 --   existence of entity, which is a typical case for POST requests,
  38 --   'Resource' does nothing in this state.
  39 --
  40 --   [/Receiving Body/] A 'Resource' asks the system to receive a
  41 --   request body from the client. Before actually reading from the
  42 --   socket, the system sends \"100 Continue\" to the client if need
  43 --   be. When a 'Resource' transits to the next state without
  44 --   receiving all or part of a request body, the system automatically
  45 --   discards it.
  46 --
  47 --   [/Deciding Header/] A 'Resource' makes a decision of response
  48 --   status code and header fields. When it transits to the next
  49 --   state, the system validates and completes the header fields and
  50 --   then sends them to the client.
  51 --
  52 --   [/Sending Body/] In this state, a 'Resource' asks the system to
  53 --   write some response body to the socket. When it transits to the
  54 --   next state without writing any response body, the system
  55 --   automatically completes it depending on the status code. (To be
  56 --   exact, such completion only occurs when the 'Resource' transits
  57 --   to this state without even declaring the \"Content-Type\" header
  58 --   field. See 'setContentType'.)
  59 --
  60 --   [/Done/] Everything is over. A 'Resource' can do nothing for the
  61 --   HTTP interaction anymore.
  62 --
  63 -- Note that the state transition is one-way: for instance, it is an
  64 -- error to try to read a request body after writing some
  65 -- response. This limitation is for efficiency. We don't want to read
  66 -- the entire request before starting 'Resource', nor we don't want to
  67 -- postpone writing the entire response till the end of 'Resource'
  68 -- computation.
  69 module Network.HTTP.Lucu.Resource
  70     (
  71     -- * Types
  72       Resource
  73     , ResourceDef(..)
  74     , emptyResource
  75     , FormData(..)
  76
  77     -- * Getting request header
  78     -- |These functions can be called regardless of the current state,
  79     -- and they don't change the state of 'Resource'.
  80     , getConfig
  81     , getRemoteAddr
  82     , getRemoteAddr'
  83     , getRemoteHost
  84     , getRemoteCertificate
  85     , getRequest
  86     , getMethod
  87     , getRequestURI
  88     , getRequestVersion
  89     , getResourcePath
  90     , getPathInfo
  91     , getQueryForm
  92     , getHeader
  93     , getAccept
  94     , getAcceptEncoding
  95     , isEncodingAcceptable
  96     , getContentType
  97     , getAuthorization
  98
  99     -- * Finding an entity
 100     -- |These functions can be called only in the /Examining Request/
 101     -- state. They make the 'Resource' transit to the /Receiving Body/
 102     -- state.
 103     , foundEntity
 104     , foundETag
 105     , foundTimeStamp
 106     , foundNoEntity
 107     , foundNoEntity'
 108
 109     -- * Receiving a request body
 110     -- |These functions make the 'Resource' transit to the /Receiving
 111     -- Body/ state.
 112     , getChunk
 113     , getChunks
 114     , getForm
 115
 116     -- * Declaring response status and header fields
 117     -- |These functions can be called at any time before transiting to
 118     -- the /Sending Body/ state, but they themselves never causes any
 119     -- state transitions.
 120     , setStatus
 121     , redirect
 122     , setContentType
 123     , setContentEncoding
 124     , setWWWAuthenticate
 125
 126     -- ** Less frequently used functions
 127     , setLocation
 128     , setHeader
 129     , deleteHeader
 130
 131     -- * Sending a response body
 132
 133     -- |These functions make the 'Resource' transit to the
 134     -- /Sending Body/ state.
 135     , putChunk
 136     , putChunks
 137     , putBuilder
 138     )
 139     where
 140 import Blaze.ByteString.Builder (Builder)
 141 import qualified Blaze.ByteString.Builder as BB
 142 import qualified Blaze.ByteString.Builder.Internal as BB
 143 import Control.Applicative
 144 import Control.Monad
 145 import Control.Monad.IO.Class
 146 import Control.Monad.Unicode
 147 import Data.Ascii (Ascii, CIAscii)
 148 import qualified Data.Ascii as A
 149 import qualified Data.Attoparsec.Char8 as P
 150 import qualified Data.Attoparsec.Lazy  as LP
 151 import Data.ByteString (ByteString)
 152 import qualified Data.ByteString as Strict
 153 import qualified Data.ByteString.Lazy as Lazy
 154 import Data.List
 155 import qualified Data.Map as M
 156 import Data.Maybe
 157 import Data.Monoid
 158 import Data.Monoid.Unicode
 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 → Builder → 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 !b = do c ← getChunk $ min n BB.defaultBufferSize
 565                     if Strict.null c then
 566                         -- Got EOF
 567                         return $ BB.toLazyByteString b
 568                     else
 569                         do let n'  = n - Strict.length c
 570                                xs' = b ⊕ BB.fromByteString c
 571                            go n' xs'
 572
 573 -- |@'getForm' limit@ attempts to read the request body with
 574 -- 'getChunks' and parse it as @application\/x-www-form-urlencoded@ or
 575 -- @multipart\/form-data@. If the request header \"Content-Type\" is
 576 -- neither of them, 'getForm' aborts with status \"415 Unsupported
 577 -- Media Type\". If the request has no \"Content-Type\", it aborts
 578 -- with \"400 Bad Request\".
 579 --
 580 -- Field names in @multipart\/form-data@ will be precisely decoded in
 581 -- accordance with RFC 2231. On the other hand,
 582 -- @application\/x-www-form-urlencoded@ says nothing about character
 583 -- encodings for field names, so they'll always be decoded in
 584 -- UTF-8. (This could be a bad design, but I can't think of any better
 585 -- idea.)
 586 getForm ∷ Maybe Int → Resource [(Text, FormData)]
 587 getForm limit
 588     = do cTypeM ← getContentType
 589          case cTypeM of
 590            Nothing
 591                → abort $ mkAbortion' BadRequest "Missing Content-Type"
 592            Just (MIMEType "application" "x-www-form-urlencoded" _)
 593                → readWWWFormURLEncoded
 594            Just (MIMEType "multipart" "form-data" params)
 595                → readMultipartFormData params
 596            Just cType
 597                → abort $ mkAbortion' UnsupportedMediaType
 598                        $ A.toText
 599                        $ A.fromAsciiBuilder
 600                        $ A.toAsciiBuilder "Unsupported media type: "
 601                        ⊕ printMIMEType cType
 602     where
 603       readWWWFormURLEncoded
 604           = (map toPairWithFormData ∘ parseWWWFormURLEncoded)
 605             <$>
 606             (bsToAscii =≪ getChunks limit)
 607
 608       bsToAscii bs
 609           = case A.fromByteString (Strict.concat (Lazy.toChunks bs)) of
 610               Just a  → return a
 611               Nothing → abort $ mkAbortion' BadRequest "Malformed x-www-form-urlencoded"
 612
 613       readMultipartFormData params
 614           = case M.lookup "boundary" params of
 615               Nothing
 616                   → abort $ mkAbortion' BadRequest "Missing boundary of multipart/form-data"
 617               Just boundary
 618                   → do src ← getChunks limit
 619                        b   ← case A.fromText boundary of
 620                                 Just b  → return b
 621                                 Nothing → abort $ mkAbortion' BadRequest
 622                                                 $ "Malformed boundary: " ⊕ boundary
 623                        case LP.parse (p b) src of
 624                          LP.Done _ formList
 625                              → return formList
 626                          LP.Fail _ eCtx e
 627                              → abort $ mkAbortion' BadRequest
 628                                      $ "Unparsable multipart/form-data: "
 629                                      ⊕ T.pack (intercalate ", " eCtx)
 630                                      ⊕ ": "
 631                                      ⊕ T.pack e
 632           where
 633             p b = do xs ← multipartFormP b
 634                      P.endOfInput
 635                      return xs
 636
 637 -- |@'redirect' code uri@ declares the response status as @code@ and
 638 -- \"Location\" header field as @uri@. The @code@ must satisfy
 639 -- 'isRedirection' or it raises an error.
 640 redirect ∷ StatusCode → URI → Resource ()
 641 redirect code uri
 642     = do when (code ≡ NotModified ∨ not (isRedirection code))
 643              $ abort
 644              $ mkAbortion' InternalServerError
 645              $ A.toText
 646              $ A.fromAsciiBuilder
 647              $ A.toAsciiBuilder "Attempted to redirect with status "
 648              ⊕ printStatusCode code
 649          setStatus code
 650          setLocation uri
 651
 652 -- |@'setContentType' mType@ declares the response header
 653 -- \"Content-Type\" as @mType@. Declaring \"Content-Type\" is
 654 -- mandatory for sending a response body.
 655 setContentType ∷ MIMEType → Resource ()
 656 setContentType
 657     = setHeader "Content-Type" ∘ A.fromAsciiBuilder ∘ printMIMEType
 658
 659 -- |@'setLocation' uri@ declares the response header \"Location\" as
 660 -- @uri@. You usually don't need to call this function directly.
 661 setLocation ∷ URI → Resource ()
 662 setLocation uri
 663     = case A.fromChars uriStr of
 664         Just a  → setHeader "Location" a
 665         Nothing → abort $ mkAbortion' InternalServerError
 666                         $ "Malformed URI: " ⊕ T.pack uriStr
 667     where
 668       uriStr = uriToString id uri ""
 669
 670 -- |@'setContentEncoding' codings@ declares the response header
 671 -- \"Content-Encoding\" as @codings@.
 672 setContentEncoding ∷ [CIAscii] → Resource ()
 673 setContentEncoding codings
 674     = do ver ← getRequestVersion
 675          tr  ← case ver of
 676                   HttpVersion 1 0 → return (toAB ∘ unnormalizeCoding)
 677                   HttpVersion 1 1 → return toAB
 678                   _               → abort $ mkAbortion' InternalServerError
 679                                             "setContentEncoding: Unknown HTTP version"
 680          setHeader "Content-Encoding"
 681              $ A.fromAsciiBuilder
 682              $ mconcat
 683              $ intersperse (A.toAsciiBuilder ", ")
 684              $ map tr codings
 685     where
 686       toAB = A.toAsciiBuilder ∘ A.fromCIAscii
 687
 688 -- |@'setWWWAuthenticate' challenge@ declares the response header
 689 -- \"WWW-Authenticate\" as @challenge@.
 690 setWWWAuthenticate ∷ AuthChallenge → Resource ()
 691 setWWWAuthenticate = setHeader "WWW-Authenticate" ∘ printAuthChallenge
 692
 693 -- |Write a chunk in 'Strict.ByteString' to the response body. You
 694 -- must first declare the response header \"Content-Type\" before
 695 -- applying this function. See 'setContentType'.
 696 putChunk ∷ Strict.ByteString → Resource ()
 697 putChunk = putBuilder ∘ BB.fromByteString
 698
 699 -- |Write a chunk in lazy 'Lazy.ByteString' to the response body. It
 700 -- can be safely applied to an infinitely long 'Lazy.ByteString'.
 701 --
 702 -- Note that you must first declare the response header
 703 -- \"Content-Type\" before applying this function. See
 704 -- 'setContentType'.
 705 putChunks ∷ Lazy.ByteString → Resource ()
 706 putChunks = putBuilder ∘ BB.fromLazyByteString