Network/HTTP/Lucu/Resource.hs

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