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 the behavior
   9 -- of each resources. The 'Resource' Monad is a kind of 'Prelude.IO'
  10 -- Monad thus it implements 'Control.Monad.Trans.MonadIO' class. It is
  11 -- also a state machine.
  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 the request header, find (or not
  21 --      find) an entity, receive the request body (if any), decide the
  22 --      response header, and decide the 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 and thinks about an entity for it. If there is a
  33 --   suitable entity, the 'Resource' tells the system an entity tag
  34 --   and its last modification time ('foundEntity'). If it found no
  35 --   entity, it tells the system so ('foundNoEntity'). In case it is
  36 --   impossible to decide the existence of entity, which is a typical
  37 --   case for POST requests, 'Resource' does nothing in this state.
  38 --
  39 --   [/Getting Body/] A 'Resource' asks the system to receive a
  40 --   request body from 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 request body, the system still reads it
  44 --   and just throws it away.
  45 --
  46 --   [/Deciding Header/] A 'Resource' makes a decision of status code
  47 --   and response header. When it transits to the next state, the
  48 --   system checks the validness of response header and then write
  49 --   them to the socket.
  50 --
  51 --   [/Deciding 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 --   completes it depending on the status code.
  55 --
  56 --   [/Done/] Everything is over. A 'Resource' can do nothing for the
  57 --   HTTP interaction anymore.
  58 --
  59 -- Note that the state transition is one-way: for instance, it is an
  60 -- error to try to read a request body after writing some
  61 -- response. This limitation is for efficiency. We don't want to read
  62 -- the entire request before starting 'Resource', nor we don't want to
  63 -- postpone writing the entire response till the end of 'Resource'
  64 -- computation.
  65 module Network.HTTP.Lucu.Resource
  66     (
  67     -- * Types
  68       Resource
  69     , FormData(..)
  70
  71     -- * Getting request header
  72     -- |These actions can be computed regardless of the current state,
  73     -- and they don't change the state.
  74     , getConfig
  75     , getRemoteAddr
  76     , getRemoteAddr'
  77     , getRemoteHost
  78     , getRemoteCertificate
  79     , getRequest
  80     , getMethod
  81     , getRequestURI
  82     , getRequestVersion
  83     , getResourcePath
  84     , getPathInfo
  85     , getQueryForm
  86     , getHeader
  87     , getAccept
  88     , getAcceptEncoding
  89     , isEncodingAcceptable
  90     , getContentType
  91     , getAuthorization
  92
  93     -- * Finding an entity
  94     -- |These actions can be computed only in the /Examining Request/
  95     -- state. After the computation, the 'Resource' transits to
  96     -- /Getting Body/ state.
  97     , foundEntity
  98     , foundETag
  99     , foundTimeStamp
 100     , foundNoEntity
 101
 102     -- * Getting a request body
 103     -- |Computation of these actions changes the state to /Getting
 104     -- Body/.
 105     , getChunk
 106     , getChunks
 107     , getForm
 108     , defaultLimit
 109
 110     -- * Setting response headers
 111     -- |Computation of these actions changes the state to /Deciding
 112     -- Header/.
 113     , setStatus
 114     , redirect
 115     , setContentType
 116     , setContentEncoding
 117     , setWWWAuthenticate
 118
 119     -- ** Less frequently used functions
 120     , setLocation
 121     , setHeader
 122     , deleteHeader
 123
 124     -- * Writing a response body
 125     -- |Computation of these actions changes the state to /Deciding
 126     -- Body/.
 127     , putChunk
 128     , putChunks
 129     , putBuilder
 130     )
 131     where
 132 import Blaze.ByteString.Builder (Builder)
 133 import qualified Blaze.ByteString.Builder.ByteString as BB
 134 import Control.Applicative
 135 import Control.Concurrent.STM
 136 import Control.Monad
 137 import Control.Monad.IO.Class
 138 import Control.Monad.Unicode
 139 import Data.Ascii (Ascii, CIAscii)
 140 import qualified Data.Ascii as A
 141 import qualified Data.Attoparsec.Char8 as P
 142 import qualified Data.Attoparsec.Lazy  as LP
 143 import Data.ByteString (ByteString)
 144 import qualified Data.ByteString as Strict
 145 import qualified Data.ByteString.Lazy as Lazy
 146 import Data.Foldable (toList)
 147 import Data.List
 148 import qualified Data.Map as M
 149 import Data.Maybe
 150 import Data.Monoid.Unicode
 151 import Data.Sequence (Seq)
 152 import Data.Text (Text)
 153 import qualified Data.Text as T
 154 import qualified Data.Text.Encoding as T
 155 import Data.Time
 156 import qualified Data.Time.HTTP as HTTP
 157 import Network.HTTP.Lucu.Abortion
 158 import Network.HTTP.Lucu.Authorization
 159 import Network.HTTP.Lucu.Config
 160 import Network.HTTP.Lucu.ContentCoding
 161 import Network.HTTP.Lucu.ETag
 162 import qualified Network.HTTP.Lucu.Headers as H
 163 import Network.HTTP.Lucu.HttpVersion
 164 import Network.HTTP.Lucu.Interaction
 165 import Network.HTTP.Lucu.MultipartForm
 166 import Network.HTTP.Lucu.Postprocess
 167 import Network.HTTP.Lucu.Request
 168 import Network.HTTP.Lucu.Resource.Internal
 169 import Network.HTTP.Lucu.Response
 170 import Network.HTTP.Lucu.MIMEType
 171 import Network.HTTP.Lucu.Utils
 172 import Network.Socket hiding (accept)
 173 import Network.URI hiding (path)
 174 import OpenSSL.X509
 175 import Prelude.Unicode
 176
 177 -- |Get the 'Config' value which is used for the httpd.
 178 getConfig ∷ Resource Config
 179 getConfig = itrConfig <$> getInteraction
 180
 181 -- |Get the 'SockAddr' of the remote host. If you want a string
 182 -- representation instead of 'SockAddr', use 'getRemoteAddr''.
 183 getRemoteAddr ∷ Resource SockAddr
 184 getRemoteAddr = itrRemoteAddr <$> getInteraction
 185
 186 -- |Get the string representation of the address of remote host. If
 187 -- you want a 'SockAddr' instead of 'String', use 'getRemoteAddr'.
 188 getRemoteAddr' ∷ Resource HostName
 189 getRemoteAddr'
 190     = do sa          ← getRemoteAddr
 191          (Just a, _) ← liftIO $ getNameInfo [NI_NUMERICHOST] True False sa
 192          return a
 193
 194 -- |Resolve an address to the remote host.
 195 getRemoteHost ∷ Resource (Maybe HostName)
 196 getRemoteHost
 197     = do sa ← getRemoteAddr
 198          fst <$> (liftIO $ getNameInfo [] True False sa)
 199
 200 -- | Return the X.509 certificate of the client, or 'Nothing' if:
 201 --
 202 --   * This request didn't came through an SSL stream.
 203 --
 204 --   * The client didn't send us its certificate.
 205 --
 206 --   * The 'OpenSSL.Session.VerificationMode' of
 207 --   'OpenSSL.Session.SSLContext' in 'SSLConfig' has not been set to
 208 --   'OpenSSL.Session.VerifyPeer'.
 209 getRemoteCertificate ∷ Resource (Maybe X509)
 210 getRemoteCertificate = itrRemoteCert <$> getInteraction
 211
 212 -- |Get the 'Method' value of the request.
 213 getMethod ∷ Resource Method
 214 getMethod = reqMethod <$> getRequest
 215
 216 -- |Get the URI of the request.
 217 getRequestURI ∷ Resource URI
 218 getRequestURI = reqURI <$> getRequest
 219
 220 -- |Get the HTTP version of the request.
 221 getRequestVersion ∷ Resource HttpVersion
 222 getRequestVersion = reqVersion <$> getRequest
 223
 224 -- |Get the path of this 'Resource' (to be exact,
 225 -- 'Network.HTTP.Lucu.Resource.Tree.ResourceDef') in the
 226 -- 'Network.HTTP.Lucu.Resource.Tree.ResTree'. The result of this
 227 -- action is the exact path in the tree even when the
 228 -- 'Network.HTTP.Lucu.Resource.Tree.ResourceDef' is greedy.
 229 --
 230 -- Example:
 231 --
 232 -- > main = let tree = mkResTree [ (["foo"], resFoo) ]
 233 -- >        in runHttpd defaultConfig tree
 234 -- >
 235 -- > resFoo = ResourceDef {
 236 -- >     resIsGreedy = True
 237 -- >   , resGet = Just $ do requestURI   <- getRequestURI
 238 -- >                        resourcePath <- getResourcePath
 239 -- >                        pathInfo     <- getPathInfo
 240 -- >                        -- uriPath requestURI == "/foo/bar/baz"
 241 -- >                        -- resourcePath       == ["foo"]
 242 -- >                        -- pathInfo           == ["bar", "baz"]
 243 -- >                        ...
 244 -- >   , ...
 245 -- >   }
 246 getResourcePath ∷ Resource [Text]
 247 getResourcePath = (fromJust ∘ itrResourcePath) <$> getInteraction
 248
 249 -- |This is an analogy of CGI PATH_INFO. The result is
 250 -- URI-unescaped. It is always @[]@ if the
 251 -- 'Network.HTTP.Lucu.Resource.Tree.ResourceDef' is not greedy. See
 252 -- 'getResourcePath'.
 253 --
 254 -- Note that the returned path is URI-decoded and then UTF-8 decoded.
 255 getPathInfo ∷ Resource [Text]
 256 getPathInfo = do rsrcPath ← getResourcePath
 257                  reqPath  ← splitPathInfo <$> getRequestURI
 258                  -- rsrcPath と reqPath の共通する先頭部分を reqPath か
 259                  -- ら全部取り除くと、それは PATH_INFO のやうなものにな
 260                  -- る。rsrcPath は全部一致してゐるに決まってゐる（でな
 261                  -- ければこの Resource が撰ばれた筈が無い）ので、
 262                  -- rsrcPath の長さの分だけ削除すれば良い。
 263                  return $ drop (length rsrcPath) reqPath
 264
 265 -- |Assume the query part of request URI as
 266 -- application\/x-www-form-urlencoded, and parse it to pairs of
 267 -- @(name, formData)@. This action doesn't parse the request body. See
 268 -- 'inputForm'. Field names are decoded in UTF-8.
 269 getQueryForm ∷ Resource [(Text, FormData)]
 270 getQueryForm = parse' <$> getRequestURI
 271     where
 272       parse' = map toPairWithFormData ∘
 273                parseWWWFormURLEncoded ∘
 274                fromJust ∘
 275                A.fromChars ∘
 276                drop 1 ∘
 277                uriQuery
 278
 279 toPairWithFormData ∷ (ByteString, ByteString) → (Text, FormData)
 280 toPairWithFormData (name, value)
 281     = let fd = FormData {
 282                  fdFileName = Nothing
 283                , fdContent  = Lazy.fromChunks [value]
 284                }
 285       in (T.decodeUtf8 name, fd)
 286
 287 -- |Get a value of given request header. Comparison of header name is
 288 -- case-insensitive. Note that this action is not intended to be used
 289 -- so frequently: there should be actions like 'getContentType' for
 290 -- every common headers.
 291 getHeader ∷ CIAscii → Resource (Maybe Ascii)
 292 getHeader name
 293     = H.getHeader name <$> getRequest
 294
 295 -- |Get a list of 'MIMEType' enumerated on header \"Accept\".
 296 getAccept ∷ Resource [MIMEType]
 297 getAccept
 298     = do acceptM ← getHeader "Accept"
 299          case acceptM of
 300            Nothing
 301                → return []
 302            Just accept
 303                → case P.parseOnly p (A.toByteString accept) of
 304                     Right xs → return xs
 305                     Left  _  → abort BadRequest []
 306                                (Just $ "Unparsable Accept: " ⊕ A.toText accept)
 307     where
 308       p = do xs ← mimeTypeListP
 309              P.endOfInput
 310              return xs
 311
 312 -- |Get a list of @(contentCoding, qvalue)@ enumerated on header
 313 -- \"Accept-Encoding\". The list is sorted in descending order by
 314 -- qvalue.
 315 getAcceptEncoding ∷ Resource [(CIAscii, Maybe Double)]
 316 getAcceptEncoding
 317     = do accEncM ← getHeader "Accept-Encoding"
 318          case accEncM of
 319            Nothing
 320                -- HTTP/1.0 には Accept-Encoding が無い場合の規定が無い
 321                -- ので安全の爲 identity が指定された事にする。HTTP/1.1
 322                -- の場合は何でも受け入れて良い事になってゐるので "*" が
 323                -- 指定された事にする。
 324                → do ver ← getRequestVersion
 325                     case ver of
 326                       HttpVersion 1 0 → return [("identity", Nothing)]
 327                       HttpVersion 1 1 → return [("*"       , Nothing)]
 328                       _               → abort InternalServerError []
 329                                         (Just "getAcceptEncoding: unknown HTTP version")
 330            Just ae
 331                → if ae ≡ "" then
 332                       -- identity のみが許される。
 333                       return [("identity", Nothing)]
 334                   else
 335                       case P.parseOnly p (A.toByteString ae) of
 336                         Right xs → return $ map toTuple $ reverse $ sort xs
 337                         Left  _  → abort BadRequest []
 338                                    (Just $ "Unparsable Accept-Encoding: " ⊕ A.toText ae)
 339     where
 340       p = do xs ← acceptEncodingListP
 341              P.endOfInput
 342              return xs
 343
 344       toTuple (AcceptEncoding {..})
 345           = (aeEncoding, aeQValue)
 346
 347 -- |Check whether a given content-coding is acceptable.
 348 isEncodingAcceptable ∷ CIAscii → Resource Bool
 349 isEncodingAcceptable encoding = any f <$> getAcceptEncoding
 350     where
 351       f (e, q)
 352           = (e ≡ "*" ∨ e ≡ encoding) ∧ q ≢ Just 0
 353
 354 -- |Get the header \"Content-Type\" as 'MIMEType'.
 355 getContentType ∷ Resource (Maybe MIMEType)
 356 getContentType
 357     = do cTypeM ← getHeader "Content-Type"
 358          case cTypeM of
 359            Nothing
 360                → return Nothing
 361            Just cType
 362                → case P.parseOnly p (A.toByteString cType) of
 363                     Right t → return $ Just t
 364                     Left  _ → abort BadRequest []
 365                               (Just $ "Unparsable Content-Type: " ⊕ A.toText cType)
 366     where
 367       p = do t ← mimeTypeP
 368              P.endOfInput
 369              return t
 370
 371 -- |Get the header \"Authorization\" as 'AuthCredential'.
 372 getAuthorization ∷ Resource (Maybe AuthCredential)
 373 getAuthorization
 374     = do authM ← getHeader "Authorization"
 375          case authM of
 376            Nothing
 377                → return Nothing
 378            Just auth
 379                → case P.parseOnly p (A.toByteString auth) of
 380                     Right ac → return $ Just ac
 381                     Left  _  → return Nothing
 382     where
 383       p = do ac ← authCredentialP
 384              P.endOfInput
 385              return ac
 386
 387
 388 -- Finding an entity
 389
 390 -- |Tell the system that the 'Resource' found an entity for the
 391 -- request URI. If this is a GET or HEAD request, a found entity means
 392 -- a datum to be replied. If this is a PUT or DELETE request, it means
 393 -- a datum which was stored for the URI until now. It is an error to
 394 -- compute 'foundEntity' if this is a POST request.
 395 --
 396 -- Computation of 'foundEntity' performs \"If-Match\" test or
 397 -- \"If-None-Match\" test if possible. When those tests fail, the
 398 -- computation of 'Resource' immediately aborts with status \"412
 399 -- Precondition Failed\" or \"304 Not Modified\" depending on the
 400 -- situation.
 401 --
 402 -- If this is a GET or HEAD request, 'foundEntity' automatically puts
 403 -- \"ETag\" and \"Last-Modified\" headers into the response.
 404 foundEntity ∷ ETag → UTCTime → Resource ()
 405 foundEntity tag timeStamp
 406     = do driftTo ExaminingRequest
 407
 408          method ← getMethod
 409          when (method ≡ GET ∨ method ≡ HEAD)
 410              $ setHeader' "Last-Modified" (HTTP.toAscii timeStamp)
 411          when (method ≡ POST)
 412              $ abort InternalServerError []
 413                (Just "Illegal computation of foundEntity for a POST request.")
 414          foundETag tag
 415
 416          driftTo GettingBody
 417
 418 -- |Tell the system that the 'Resource' found an entity for the
 419 -- request URI. The only difference from 'foundEntity' is that
 420 -- 'foundETag' doesn't (and can't) put \"Last-Modified\" header into
 421 -- the response.
 422 --
 423 -- This action is not preferred. You should use 'foundEntity' whenever
 424 -- possible.
 425 foundETag ∷ ETag → Resource ()
 426 foundETag tag
 427     = do driftTo ExaminingRequest
 428
 429          method ← getMethod
 430          when (method ≡ GET ∨ method ≡ HEAD)
 431               $ setHeader' "ETag"
 432               $ A.fromAsciiBuilder
 433               $ printETag tag
 434          when (method ≡ POST)
 435               $ abort InternalServerError []
 436                 (Just "Illegal computation of foundETag for POST request.")
 437
 438          -- If-Match があればそれを見る。
 439          ifMatch ← getHeader "If-Match"
 440          case ifMatch of
 441            Nothing    → return ()
 442            Just value → if value ≡ "*" then
 443                             return ()
 444                         else
 445                             case P.parseOnly p (A.toByteString value) of
 446                               Right tags
 447                                  -- tags の中に一致するものが無ければ
 448                                  -- PreconditionFailed で終了。
 449                                  → when ((¬) (any (≡ tag) tags))
 450                                        $ abort PreconditionFailed []
 451                                          (Just $ "The entity tag doesn't match: " ⊕ A.toText value)
 452                               Left _
 453                                    → abort BadRequest [] (Just $ "Unparsable If-Match: " ⊕ A.toText value)
 454
 455          let statusForNoneMatch
 456                  = if method ≡ GET ∨ method ≡ HEAD then
 457                        NotModified
 458                    else
 459                        PreconditionFailed
 460
 461          -- If-None-Match があればそれを見る。
 462          ifNoneMatch ← getHeader "If-None-Match"
 463          case ifNoneMatch of
 464            Nothing    → return ()
 465            Just value → if value ≡ "*" then
 466                              abort statusForNoneMatch [] (Just "The entity tag matches: *")
 467                          else
 468                              case P.parseOnly p (A.toByteString value) of
 469                                Right tags
 470                                    → when (any (≡ tag) tags)
 471                                          $ abort statusForNoneMatch []
 472                                            (Just $ "The entity tag matches: " ⊕ A.toText value)
 473                                Left _
 474                                    → abort BadRequest []
 475                                      (Just $ "Unparsable If-None-Match: " ⊕ A.toText value)
 476
 477          driftTo GettingBody
 478     where
 479       p = do xs ← eTagListP
 480              P.endOfInput
 481              return xs
 482
 483 -- |Tell the system that the 'Resource' found an entity for the
 484 -- request URI. The only difference from 'foundEntity' is that
 485 -- 'foundTimeStamp' performs \"If-Modified-Since\" test or
 486 -- \"If-Unmodified-Since\" test instead of \"If-Match\" test or
 487 -- \"If-None-Match\" test. Be aware that any tests based on last
 488 -- modification time are unsafe because it is possible to mess up such
 489 -- tests by modifying the entity twice in a second.
 490 --
 491 -- This action is not preferred. You should use 'foundEntity' whenever
 492 -- possible.
 493 foundTimeStamp ∷ UTCTime → Resource ()
 494 foundTimeStamp timeStamp
 495     = do driftTo ExaminingRequest
 496
 497          method ← getMethod
 498          when (method ≡ GET ∨ method ≡ HEAD)
 499              $ setHeader' "Last-Modified" (HTTP.toAscii timeStamp)
 500          when (method ≡ POST)
 501              $ abort InternalServerError []
 502                (Just "Illegal computation of foundTimeStamp for POST request.")
 503
 504          let statusForIfModSince
 505                  = if method ≡ GET ∨ method ≡ HEAD then
 506                        NotModified
 507                    else
 508                        PreconditionFailed
 509
 510          -- If-Modified-Since があればそれを見る。
 511          ifModSince ← getHeader "If-Modified-Since"
 512          case ifModSince of
 513            Just str → case HTTP.fromAscii str of
 514                          Right lastTime
 515                              → when (timeStamp ≤ lastTime)
 516                                $ abort statusForIfModSince []
 517                                  (Just $ "The entity has not been modified since " ⊕ A.toText str)
 518                          Left _
 519                              → return () -- 不正な時刻は無視
 520            Nothing  → return ()
 521
 522          -- If-Unmodified-Since があればそれを見る。
 523          ifUnmodSince ← getHeader "If-Unmodified-Since"
 524          case ifUnmodSince of
 525            Just str → case HTTP.fromAscii str of
 526                          Right lastTime
 527                              → when (timeStamp > lastTime)
 528                                $ abort PreconditionFailed []
 529                                  (Just $ "The entity has not been modified since " ⊕ A.toText str)
 530                          Left _
 531                              → return () -- 不正な時刻は無視
 532            Nothing  → return ()
 533
 534          driftTo GettingBody
 535
 536 -- | Computation of @'foundNoEntity' mStr@ tells the system that the
 537 -- 'Resource' found no entity for the request URI. @mStr@ is an
 538 -- optional error message to be replied to the client.
 539 --
 540 -- If this is a PUT request, 'foundNoEntity' performs \"If-Match\"
 541 -- test and aborts with status \"412 Precondition Failed\" when it
 542 -- failed. If this is a GET, HEAD, POST or DELETE request,
 543 -- 'foundNoEntity' always aborts with status \"404 Not Found\".
 544 foundNoEntity ∷ Maybe Text → Resource ()
 545 foundNoEntity msgM
 546     = do driftTo ExaminingRequest
 547
 548          method ← getMethod
 549          when (method ≢ PUT)
 550              $ abort NotFound [] msgM
 551
 552          -- エンティティが存在しないと云ふ事は、"*" も含めたどのやうな
 553          -- If-Match: 條件も滿たさない。
 554          ifMatch ← getHeader "If-Match"
 555          when (ifMatch ≢ Nothing)
 556              $ abort PreconditionFailed [] msgM
 557
 558          driftTo GettingBody
 559
 560
 561 -- Getting a request body
 562
 563 -- | Computation of @'input' limit@ attempts to read the request body
 564 -- up to @limit@ bytes, and then make the 'Resource' transit to
 565 -- /Deciding Header/ state. When the actual size of body is larger
 566 -- than @limit@ bytes, computation of 'Resource' immediately aborts
 567 -- with status \"413 Request Entity Too Large\". When the request has
 568 -- no body, 'input' returns an empty string.
 569 --
 570 -- @limit@ may be less than or equal to zero. In this case, the
 571 -- default limitation value ('cnfMaxEntityLength') is used. See
 572 -- 'defaultLimit'.
 573 --
 574 -- 'input' returns a 'Lazy.ByteString' but it's not really lazy:
 575 -- reading from the socket just happens at the computation of 'input',
 576 -- not at the evaluation of the 'Lazy.ByteString'. The same goes for
 577 -- 'inputChunk'.
 578 input ∷ Int → Resource Lazy.ByteString
 579 input limit
 580     = do driftTo GettingBody
 581          itr     ← getInteraction
 582          chunk   ← if reqMustHaveBody $ fromJust $ itrRequest itr then
 583                        askForInput itr
 584                    else
 585                        do driftTo DecidingHeader
 586                           return (∅)
 587          return chunk
 588     where
 589       askForInput ∷ Interaction → Resource Lazy.ByteString
 590       askForInput (Interaction {..})
 591           = do let confLimit   = cnfMaxEntityLength itrConfig
 592                    actualLimit = if limit ≤ 0 then
 593                                      confLimit
 594                                  else
 595                                      limit
 596                when (actualLimit ≤ 0)
 597                         $ fail ("inputLBS: limit must be positive: " ⧺ show actualLimit)
 598                -- Reader にリクエスト
 599                liftIO $ atomically
 600                       $ writeTVar itrReqBodyWanted actualLimit
 601                -- 應答を待つ。トランザクションを分けなければ當然デッドロックする。
 602                chunk ← liftIO $ atomically
 603                        $ do chunkLen    ← readTVar itrReceivedBodyLen
 604                             chunkIsOver ← readTVar itrReqChunkIsOver
 605                             if chunkLen < actualLimit then
 606                                 -- 要求された量に滿たなくて、まだ殘りが
 607                                 -- あるなら再試行。
 608                                 unless chunkIsOver
 609                                     $ retry
 610                             else
 611                                 -- 制限値一杯まで讀むやうに指示したのに
 612                                 -- まだ殘ってゐるなら、それは多過ぎる。
 613                                 unless chunkIsOver
 614                                     $ tooLarge actualLimit
 615                             -- 成功。itr 内にチャンクを置いたままにする
 616                             -- とメモリの無駄になるので除去。
 617                             chunk ← seqToLBS <$> readTVar itrReceivedBody
 618                             writeTVar itrReceivedBody    (∅)
 619                             writeTVar itrReceivedBodyLen 0
 620                             return chunk
 621
 622                driftTo DecidingHeader
 623                return chunk
 624
 625       tooLarge ∷ Int → STM ()
 626       tooLarge lim = abortSTM RequestEntityTooLarge []
 627                      (Just $ "Request body must be smaller than "
 628                              ⊕ T.pack (show lim) ⊕ " bytes.")
 629
 630 seqToLBS ∷ Seq ByteString → Lazy.ByteString
 631 {-# INLINE seqToLBS #-}
 632 seqToLBS = Lazy.fromChunks ∘ toList
 633
 634 -- | Computation of @'inputChunk' limit@ attempts to read a part of
 635 -- request body up to @limit@ bytes. You can read any large request by
 636 -- repeating computation of this action. When you've read all the
 637 -- request body, 'inputChunk' returns an empty string and then make
 638 -- the 'Resource' transit to /Deciding Header/ state.
 639 --
 640 -- @limit@ may be less than or equal to zero. In this case, the
 641 -- default limitation value ('cnfMaxEntityLength') is used. See
 642 -- 'defaultLimit'.
 643 --
 644 -- Note that 'inputChunkLBS' is more efficient than 'inputChunk' so you
 645 -- should use it whenever possible.
 646 inputChunk ∷ Int → Resource Lazy.ByteString
 647 inputChunk limit
 648     = do driftTo GettingBody
 649          itr     ← getInteraction
 650          chunk   ← if reqMustHaveBody $ fromJust $ itrRequest itr then
 651                        askForInput itr
 652                    else
 653                        do driftTo DecidingHeader
 654                           return (∅)
 655          return chunk
 656     where
 657       askForInput ∷ Interaction → Resource Lazy.ByteString
 658       askForInput (Interaction {..})
 659           = do let confLimit   = cnfMaxEntityLength itrConfig
 660                    actualLimit = if limit < 0 then
 661                                      confLimit
 662                                  else
 663                                      limit
 664                when (actualLimit ≤ 0)
 665                         $ fail ("inputChunkLBS: limit must be positive: " ++ show actualLimit)
 666                -- Reader にリクエスト
 667                liftIO $ atomically
 668                       $ writeTVar itrReqBodyWanted actualLimit
 669                -- 應答を待つ。トランザクションを分けなければ當然デッドロック。
 670                chunk ← liftIO $ atomically
 671                        $ do chunkLen ← readTVar itrReceivedBodyLen
 672                             -- 要求された量に滿たなくて、まだ殘りがある
 673                             -- なら再試行。
 674                             when (chunkLen < actualLimit)
 675                                 $ do chunkIsOver ← readTVar itrReqChunkIsOver
 676                                      unless chunkIsOver
 677                                          $ retry
 678                             -- 成功
 679                             chunk ← seqToLBS <$> readTVar itrReceivedBody
 680                             writeTVar itrReceivedBody    (∅)
 681                             writeTVar itrReceivedBodyLen 0
 682                             return chunk
 683                when (Lazy.null chunk)
 684                    $ driftTo DecidingHeader
 685                return chunk
 686
 687 -- | Computation of @'inputForm' limit@ attempts to read the request
 688 -- body with 'input' and parse it as
 689 -- @application\/x-www-form-urlencoded@ or @multipart\/form-data@. If
 690 -- the request header \"Content-Type\" is neither of them, 'inputForm'
 691 -- makes 'Resource' abort with status \"415 Unsupported Media
 692 -- Type\". If the request has no \"Content-Type\", it aborts with
 693 -- \"400 Bad Request\".
 694 --
 695 -- Field names in @multipart\/form-data@ will be precisely decoded in
 696 -- accordance with RFC 2231. On the other hand,
 697 -- @application\/x-www-form-urlencoded@ says nothing about the
 698 -- encoding of field names, so they'll always be decoded in UTF-8.
 699 inputForm ∷ Int → Resource [(Text, FormData)]
 700 inputForm limit
 701     = do cTypeM ← getContentType
 702          case cTypeM of
 703            Nothing
 704                → abort BadRequest [] (Just "Missing Content-Type")
 705            Just (MIMEType "application" "x-www-form-urlencoded" _)
 706                → readWWWFormURLEncoded
 707            Just (MIMEType "multipart" "form-data" params)
 708                → readMultipartFormData params
 709            Just cType
 710                → abort UnsupportedMediaType []
 711                  $ Just
 712                  $ A.toText
 713                  $ A.fromAsciiBuilder
 714                  $ A.toAsciiBuilder "Unsupported media type: "
 715                  ⊕ printMIMEType cType
 716     where
 717       readWWWFormURLEncoded
 718           = (map toPairWithFormData ∘ parseWWWFormURLEncoded)
 719             <$>
 720             (bsToAscii =≪ input limit)
 721
 722       bsToAscii bs
 723           = case A.fromByteString (Strict.concat (Lazy.toChunks bs)) of
 724               Just a  → return a
 725               Nothing → abort BadRequest [] (Just "Malformed x-www-form-urlencoded")
 726
 727       readMultipartFormData params
 728           = do case M.lookup "boundary" params of
 729                  Nothing
 730                      → abort BadRequest [] (Just "Missing boundary of multipart/form-data")
 731                  Just boundary
 732                      → do src ← input limit
 733                           b   ← case A.fromText boundary of
 734                                    Just b  → return b
 735                                    Nothing → abort BadRequest []
 736                                              (Just $ "Malformed boundary: " ⊕ boundary)
 737                           case LP.parse (p b) src of
 738                             LP.Done _ formList
 739                                 → return formList
 740                             _   → abort BadRequest [] (Just "Unparsable multipart/form-data")
 741           where
 742             p b = do xs ← multipartFormP b
 743                      P.endOfInput
 744                      return xs
 745
 746 -- | This is just a constant @-1@. It's better to say @'input'
 747 -- 'defaultLimit'@ than to say @'input' (-1)@ but these are exactly
 748 -- the same.
 749 defaultLimit ∷ Int
 750 defaultLimit = (-1)
 751
 752
 753 -- Setting response headers
 754
 755 -- | Computation of @'redirect' code uri@ sets the response status to
 756 -- @code@ and \"Location\" header to @uri@. The @code@ must satisfy
 757 -- 'isRedirection' or it causes an error.
 758 redirect ∷ StatusCode → URI → Resource ()
 759 redirect code uri
 760     = do when (code ≡ NotModified ∨ not (isRedirection code))
 761              $ abort InternalServerError []
 762              $ Just
 763              $ A.toText
 764              $ A.fromAsciiBuilder
 765              $ A.toAsciiBuilder "Attempted to redirect with status "
 766              ⊕ printStatusCode code
 767          setStatus code
 768          setLocation uri
 769
 770 -- | Computation of @'setContentType' mType@ sets the response header
 771 -- \"Content-Type\" to @mType@.
 772 setContentType ∷ MIMEType → Resource ()
 773 setContentType
 774     = setHeader "Content-Type" ∘ A.fromAsciiBuilder ∘ printMIMEType
 775
 776 -- | Computation of @'setLocation' uri@ sets the response header
 777 -- \"Location\" to @uri@. You usually don't need to call this function
 778 -- directly.
 779 setLocation ∷ URI → Resource ()
 780 setLocation uri
 781     = case A.fromChars uriStr of
 782         Just a  → setHeader "Location" a
 783         Nothing → abort InternalServerError []
 784                   (Just $ "Malformed URI: " ⊕ T.pack uriStr)
 785     where
 786       uriStr = uriToString id uri ""
 787
 788 -- |Computation of @'setContentEncoding' codings@ sets the response
 789 -- header \"Content-Encoding\" to @codings@.
 790 setContentEncoding ∷ [CIAscii] → Resource ()
 791 setContentEncoding codings
 792     = do ver ← getRequestVersion
 793          tr  ← case ver of
 794                   HttpVersion 1 0 → return (toAB ∘ unnormalizeCoding)
 795                   HttpVersion 1 1 → return toAB
 796                   _               → abort InternalServerError []
 797                                     (Just "setContentEncoding: Unknown HTTP version")
 798          setHeader "Content-Encoding"
 799                    (A.fromAsciiBuilder $ joinWith ", " $ map tr codings)
 800     where
 801       toAB = A.toAsciiBuilder ∘ A.fromCIAscii
 802
 803 -- |Computation of @'setWWWAuthenticate' challenge@ sets the response
 804 -- header \"WWW-Authenticate\" to @challenge@.
 805 setWWWAuthenticate ∷ AuthChallenge → Resource ()
 806 setWWWAuthenticate challenge
 807     = setHeader "WWW-Authenticate" (printAuthChallenge challenge)
 808
 809
 810 -- Writing a response body
 811
 812 -- | Write a chunk in 'Lazy.ByteString' to the response body. It is
 813 -- safe to apply this function to an infinitely long
 814 -- 'Lazy.ByteString'.
 815 --
 816 -- Note that you must first set the response header \"Content-Type\"
 817 -- before applying this function. See: 'setContentType'
 818 putChunk ∷ Lazy.ByteString → Resource ()
 819 putChunk = putBuilder ∘ BB.fromLazyByteString