Network/HTTP/Lucu/Resource.hs

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