Network/HTTP/Lucu/Resource.hs

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