Network/HTTP/Lucu/Resource.hs

   1 {-# LANGUAGE
   2     GeneralizedNewtypeDeriving
   3   , DoAndIfThenElse
   4   , OverloadedStrings
   5   , RecordWildCards
   6   , UnicodeSyntax
   7   #-}
   8
   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" (printETag tag)
 460          when (method ≡ POST)
 461               $ abort InternalServerError []
 462                 (Just "Illegal computation of foundETag for POST request.")
 463
 464          -- If-Match があればそれを見る。
 465          ifMatch ← getHeader "If-Match"
 466          case ifMatch of
 467            Nothing    → return ()
 468            Just value → if value ≡ "*" then
 469                             return ()
 470                         else
 471                             case P.parseOnly p (A.toByteString value) of
 472                               Right tags
 473                                  -- tags の中に一致するものが無ければ
 474                                  -- PreconditionFailed で終了。
 475                                  → when ((¬) (any (≡ tag) tags))
 476                                        $ abort PreconditionFailed []
 477                                          (Just $ "The entity tag doesn't match: " ⊕ A.toText value)
 478                               Left _
 479                                    → abort BadRequest [] (Just $ "Unparsable If-Match: " ⊕ A.toText value)
 480
 481          let statusForNoneMatch
 482                  = if method ≡ GET ∨ method ≡ HEAD then
 483                        NotModified
 484                    else
 485                        PreconditionFailed
 486
 487          -- If-None-Match があればそれを見る。
 488          ifNoneMatch ← getHeader "If-None-Match"
 489          case ifNoneMatch of
 490            Nothing    → return ()
 491            Just value → if value ≡ "*" then
 492                              abort statusForNoneMatch [] (Just "The entity tag matches: *")
 493                          else
 494                              case P.parseOnly p (A.toByteString value) of
 495                                Right tags
 496                                    → when (any (≡ tag) tags)
 497                                          $ abort statusForNoneMatch []
 498                                            (Just $ "The entity tag matches: " ⊕ A.toText value)
 499                                Left _
 500                                    → abort BadRequest []
 501                                      (Just $ "Unparsable If-None-Match: " ⊕ A.toText value)
 502
 503          driftTo GettingBody
 504     where
 505       p = do xs ← eTagListP
 506              P.endOfInput
 507              return xs
 508
 509 -- |Tell the system that the 'Resource' found an entity for the
 510 -- request URI. The only difference from 'foundEntity' is that
 511 -- 'foundTimeStamp' performs \"If-Modified-Since\" test or
 512 -- \"If-Unmodified-Since\" test instead of \"If-Match\" test or
 513 -- \"If-None-Match\" test. Be aware that any tests based on last
 514 -- modification time are unsafe because it is possible to mess up such
 515 -- tests by modifying the entity twice in a second.
 516 --
 517 -- This action is not preferred. You should use 'foundEntity' whenever
 518 -- possible.
 519 foundTimeStamp ∷ UTCTime → Resource ()
 520 foundTimeStamp timeStamp
 521     = do driftTo ExaminingRequest
 522
 523          method ← getMethod
 524          when (method ≡ GET ∨ method ≡ HEAD)
 525              $ setHeader' "Last-Modified" (HTTP.toAscii timeStamp)
 526          when (method ≡ POST)
 527              $ abort InternalServerError []
 528                (Just "Illegal computation of foundTimeStamp for POST request.")
 529
 530          let statusForIfModSince
 531                  = if method ≡ GET ∨ method ≡ HEAD then
 532                        NotModified
 533                    else
 534                        PreconditionFailed
 535
 536          -- If-Modified-Since があればそれを見る。
 537          ifModSince ← getHeader "If-Modified-Since"
 538          case ifModSince of
 539            Just str → case HTTP.fromAscii str of
 540                          Right lastTime
 541                              → when (timeStamp ≤ lastTime)
 542                                $ abort statusForIfModSince []
 543                                  (Just $ "The entity has not been modified since " ⊕ A.toText str)
 544                          Left _
 545                              → return () -- 不正な時刻は無視
 546            Nothing  → return ()
 547
 548          -- If-Unmodified-Since があればそれを見る。
 549          ifUnmodSince ← getHeader "If-Unmodified-Since"
 550          case ifUnmodSince of
 551            Just str → case HTTP.fromAscii str of
 552                          Right lastTime
 553                              → when (timeStamp > lastTime)
 554                                $ abort PreconditionFailed []
 555                                  (Just $ "The entity has not been modified since " ⊕ A.toText str)
 556                          Left _
 557                              → return () -- 不正な時刻は無視
 558            Nothing  → return ()
 559
 560          driftTo GettingBody
 561
 562 -- | Computation of @'foundNoEntity' mStr@ tells the system that the
 563 -- 'Resource' found no entity for the request URI. @mStr@ is an
 564 -- optional error message to be replied to the client.
 565 --
 566 -- If this is a PUT request, 'foundNoEntity' performs \"If-Match\"
 567 -- test and aborts with status \"412 Precondition Failed\" when it
 568 -- failed. If this is a GET, HEAD, POST or DELETE request,
 569 -- 'foundNoEntity' always aborts with status \"404 Not Found\".
 570 foundNoEntity ∷ Maybe Text → Resource ()
 571 foundNoEntity msgM
 572     = do driftTo ExaminingRequest
 573
 574          method ← getMethod
 575          when (method ≢ PUT)
 576              $ abort NotFound [] msgM
 577
 578          -- エンティティが存在しないと云ふ事は、"*" も含めたどのやうな
 579          -- If-Match: 條件も滿たさない。
 580          ifMatch ← getHeader "If-Match"
 581          when (ifMatch ≢ Nothing)
 582              $ abort PreconditionFailed [] msgM
 583
 584          driftTo GettingBody
 585
 586
 587 {- GettingBody 時に使用するアクション群 -}
 588
 589 -- | Computation of @'input' limit@ attempts to read the request body
 590 -- up to @limit@ bytes, and then make the 'Resource' transit to
 591 -- /Deciding Header/ state. When the actual size of body is larger
 592 -- than @limit@ bytes, computation of 'Resource' immediately aborts
 593 -- with status \"413 Request Entity Too Large\". When the request has
 594 -- no body, 'input' returns an empty string.
 595 --
 596 -- @limit@ may be less than or equal to zero. In this case, the
 597 -- default limitation value ('cnfMaxEntityLength') is used. See
 598 -- 'defaultLimit'.
 599 --
 600 -- 'input' returns a 'Lazy.ByteString' but it's not really lazy:
 601 -- reading from the socket just happens at the computation of 'input',
 602 -- not at the evaluation of the 'Lazy.ByteString'. The same goes for
 603 -- 'inputChunk'.
 604 input ∷ Int → Resource Lazy.ByteString
 605 input limit
 606     = do driftTo GettingBody
 607          itr     ← getInteraction
 608          chunk   ← if reqHasBody $ fromJust $ itrRequest itr then
 609                        askForInput itr
 610                    else
 611                        do driftTo DecidingHeader
 612                           return (∅)
 613          return chunk
 614     where
 615       askForInput ∷ Interaction → Resource Lazy.ByteString
 616       askForInput (Interaction {..})
 617           = do let confLimit   = cnfMaxEntityLength itrConfig
 618                    actualLimit = if limit ≤ 0 then
 619                                      confLimit
 620                                  else
 621                                      limit
 622                when (actualLimit ≤ 0)
 623                         $ fail ("inputLBS: limit must be positive: " ⧺ show actualLimit)
 624                -- Reader にリクエスト
 625                liftIO $ atomically
 626                       $ writeTVar itrReqBodyWanted actualLimit
 627                -- 應答を待つ。トランザクションを分けなければ當然デッドロックする。
 628                chunk ← liftIO $ atomically
 629                        $ do chunkLen    ← readTVar itrReceivedBodyLen
 630                             chunkIsOver ← readTVar itrReqChunkIsOver
 631                             if chunkLen < actualLimit then
 632                                 -- 要求された量に滿たなくて、まだ殘りが
 633                                 -- あるなら再試行。
 634                                 unless chunkIsOver
 635                                     $ retry
 636                             else
 637                                 -- 制限値一杯まで讀むやうに指示したのに
 638                                 -- まだ殘ってゐるなら、それは多過ぎる。
 639                                 unless chunkIsOver
 640                                     $ tooLarge actualLimit
 641                             -- 成功。itr 内にチャンクを置いたままにする
 642                             -- とメモリの無駄になるので除去。
 643                             chunk ← seqToLBS <$> readTVar itrReceivedBody
 644                             writeTVar itrReceivedBody    (∅)
 645                             writeTVar itrReceivedBodyLen 0
 646                             return chunk
 647
 648                driftTo DecidingHeader
 649                return chunk
 650
 651       tooLarge ∷ Int → STM ()
 652       tooLarge lim = abortSTM RequestEntityTooLarge []
 653                      (Just $ "Request body must be smaller than "
 654                              ⊕ T.pack (show lim) ⊕ " bytes.")
 655
 656 seqToLBS ∷ Seq ByteString → Lazy.ByteString
 657 {-# INLINE seqToLBS #-}
 658 seqToLBS = Lazy.fromChunks ∘ toList
 659
 660 -- | Computation of @'inputChunk' limit@ attempts to read a part of
 661 -- request body up to @limit@ bytes. You can read any large request by
 662 -- repeating computation of this action. When you've read all the
 663 -- request body, 'inputChunk' returns an empty string and then make
 664 -- the 'Resource' transit to /Deciding Header/ state.
 665 --
 666 -- @limit@ may be less than or equal to zero. In this case, the
 667 -- default limitation value ('cnfMaxEntityLength') is used. See
 668 -- 'defaultLimit'.
 669 --
 670 -- Note that 'inputChunkLBS' is more efficient than 'inputChunk' so you
 671 -- should use it whenever possible.
 672 inputChunk ∷ Int → Resource Lazy.ByteString
 673 inputChunk limit
 674     = do driftTo GettingBody
 675          itr     ← getInteraction
 676          chunk   ← if reqHasBody $ fromJust $ itrRequest itr then
 677                        askForInput itr
 678                    else
 679                        do driftTo DecidingHeader
 680                           return (∅)
 681          return chunk
 682     where
 683       askForInput ∷ Interaction → Resource Lazy.ByteString
 684       askForInput (Interaction {..})
 685           = do let confLimit   = cnfMaxEntityLength itrConfig
 686                    actualLimit = if limit < 0 then
 687                                      confLimit
 688                                  else
 689                                      limit
 690                when (actualLimit ≤ 0)
 691                         $ fail ("inputChunkLBS: limit must be positive: " ++ show actualLimit)
 692                -- Reader にリクエスト
 693                liftIO $ atomically
 694                       $ writeTVar itrReqBodyWanted actualLimit
 695                -- 應答を待つ。トランザクションを分けなければ當然デッドロック。
 696                chunk ← liftIO $ atomically
 697                        $ do chunkLen ← readTVar itrReceivedBodyLen
 698                             -- 要求された量に滿たなくて、まだ殘りがある
 699                             -- なら再試行。
 700                             when (chunkLen < actualLimit)
 701                                 $ do chunkIsOver ← readTVar itrReqChunkIsOver
 702                                      unless chunkIsOver
 703                                          $ retry
 704                             -- 成功
 705                             chunk ← seqToLBS <$> readTVar itrReceivedBody
 706                             writeTVar itrReceivedBody    (∅)
 707                             writeTVar itrReceivedBodyLen 0
 708                             return chunk
 709                when (Lazy.null chunk)
 710                    $ driftTo DecidingHeader
 711                return chunk
 712
 713 -- | Computation of @'inputForm' limit@ attempts to read the request
 714 -- body with 'input' and parse it as
 715 -- @application\/x-www-form-urlencoded@ or @multipart\/form-data@. If
 716 -- the request header \"Content-Type\" is neither of them, 'inputForm'
 717 -- makes 'Resource' abort with status \"415 Unsupported Media
 718 -- Type\". If the request has no \"Content-Type\", it aborts with
 719 -- \"400 Bad Request\".
 720 --
 721 -- Field names in @multipart\/form-data@ will be precisely decoded in
 722 -- accordance with RFC 2231. On the other hand,
 723 -- @application\/x-www-form-urlencoded@ says nothing about the
 724 -- encoding of field names, so they'll always be decoded in UTF-8.
 725 inputForm ∷ Int → Resource [(Text, FormData)]
 726 inputForm limit
 727     = do cTypeM ← getContentType
 728          case cTypeM of
 729            Nothing
 730                → abort BadRequest [] (Just "Missing Content-Type")
 731            Just (MIMEType "application" "x-www-form-urlencoded" _)
 732                → readWWWFormURLEncoded
 733            Just (MIMEType "multipart" "form-data" params)
 734                → readMultipartFormData params
 735            Just cType
 736                → abort UnsupportedMediaType []
 737                  $ Just
 738                  $ A.toText
 739                  $ A.fromAsciiBuilder
 740                  $ A.toAsciiBuilder "Unsupported media type: "
 741                  ⊕ printMIMEType cType
 742     where
 743       readWWWFormURLEncoded
 744           = (map toPairWithFormData ∘ parseWWWFormURLEncoded)
 745             <$>
 746             (bsToAscii =≪ input limit)
 747
 748       bsToAscii bs
 749           = case A.fromByteString (Strict.concat (Lazy.toChunks bs)) of
 750               Just a  → return a
 751               Nothing → abort BadRequest [] (Just "Malformed x-www-form-urlencoded")
 752
 753       readMultipartFormData params
 754           = do case M.lookup "boundary" params of
 755                  Nothing
 756                      → abort BadRequest [] (Just "Missing boundary of multipart/form-data")
 757                  Just boundary
 758                      → do src ← input limit
 759                           b   ← case A.fromText boundary of
 760                                    Just b  → return b
 761                                    Nothing → abort BadRequest []
 762                                              (Just $ "Malformed boundary: " ⊕ boundary)
 763                           case LP.parse (p b) src of
 764                             LP.Done _ formList
 765                                 → return formList
 766                             _   → abort BadRequest [] (Just "Unparsable multipart/form-data")
 767           where
 768             p b = do xs ← multipartFormP b
 769                      P.endOfInput
 770                      return xs
 771
 772 -- | This is just a constant @-1@. It's better to say @'input'
 773 -- 'defaultLimit'@ than to say @'input' (-1)@ but these are exactly
 774 -- the same.
 775 defaultLimit ∷ Int
 776 defaultLimit = (-1)
 777
 778
 779 {- DecidingHeader 時に使用するアクション群 -}
 780
 781 -- | Set the response status code. If you omit to compute this action,
 782 -- the status code will be defaulted to \"200 OK\".
 783 setStatus ∷ StatusCode → Resource ()
 784 setStatus sc
 785     = do driftTo DecidingHeader
 786          itr ← getInteraction
 787          liftIO
 788              $ atomically
 789              $ setResponseStatus itr sc
 790
 791 -- | Set a value of given resource header. Comparison of header name
 792 -- is case-insensitive. Note that this action is not intended to be
 793 -- used so frequently: there should be actions like 'setContentType'
 794 -- for every common headers.
 795 --
 796 -- Some important headers (especially \"Content-Length\" and
 797 -- \"Transfer-Encoding\") may be silently dropped or overwritten by
 798 -- the system not to corrupt the interaction with client at the
 799 -- viewpoint of HTTP protocol layer. For instance, if we are keeping
 800 -- the connection alive, without this process it causes a catastrophe
 801 -- to send a header \"Content-Length: 10\" and actually send a body of
 802 -- 20 bytes long. In this case the client shall only accept the first
 803 -- 10 bytes of response body and thinks that the residual 10 bytes is
 804 -- a part of header of the next response.
 805 setHeader ∷ CIAscii → Ascii → Resource ()
 806 setHeader name value
 807     = driftTo DecidingHeader ≫ setHeader' name value
 808
 809 setHeader' ∷ CIAscii → Ascii → Resource ()
 810 setHeader' name value
 811     = do itr ← getInteraction
 812          liftIO $ atomically
 813                 $ do res ← readTVar $ itrResponse itr
 814                      let res' = H.setHeader name value res
 815                      writeTVar (itrResponse itr) res'
 816
 817 -- | Computation of @'redirect' code uri@ sets the response status to
 818 -- @code@ and \"Location\" header to @uri@. The @code@ must satisfy
 819 -- 'isRedirection' or it causes an error.
 820 redirect ∷ StatusCode → URI → Resource ()
 821 redirect code uri
 822     = do when (code ≡ NotModified ∨ not (isRedirection code))
 823              $ abort InternalServerError []
 824              $ Just
 825              $ A.toText
 826              $ A.fromAsciiBuilder
 827              $ A.toAsciiBuilder "Attempted to redirect with status "
 828              ⊕ printStatusCode code
 829          setStatus code
 830          setLocation uri
 831
 832 -- | Computation of @'setContentType' mType@ sets the response header
 833 -- \"Content-Type\" to @mType@.
 834 setContentType ∷ MIMEType → Resource ()
 835 setContentType
 836     = setHeader "Content-Type" ∘ A.fromAsciiBuilder ∘ printMIMEType
 837
 838 -- | Computation of @'setLocation' uri@ sets the response header
 839 -- \"Location\" to @uri@.
 840 setLocation ∷ URI → Resource ()
 841 setLocation uri
 842     = case A.fromChars uriStr of
 843         Just a  → setHeader "Location" a
 844         Nothing → abort InternalServerError []
 845                   (Just $ "Malformed URI: " ⊕ T.pack uriStr)
 846     where
 847       uriStr = uriToString id uri ""
 848
 849 -- |Computation of @'setContentEncoding' codings@ sets the response
 850 -- header \"Content-Encoding\" to @codings@.
 851 setContentEncoding ∷ [CIAscii] → Resource ()
 852 setContentEncoding codings
 853     = do ver ← getRequestVersion
 854          tr  ← case ver of
 855                   HttpVersion 1 0 → return (toAB ∘ unnormalizeCoding)
 856                   HttpVersion 1 1 → return toAB
 857                   _               → abort InternalServerError []
 858                                     (Just "setContentEncoding: Unknown HTTP version")
 859          setHeader "Content-Encoding"
 860                    (A.fromAsciiBuilder $ joinWith ", " $ map tr codings)
 861     where
 862       toAB = A.toAsciiBuilder ∘ A.fromCIAscii
 863
 864 -- |Computation of @'setWWWAuthenticate' challenge@ sets the response
 865 -- header \"WWW-Authenticate\" to @challenge@.
 866 setWWWAuthenticate ∷ AuthChallenge → Resource ()
 867 setWWWAuthenticate challenge
 868     = setHeader "WWW-Authenticate" (printAuthChallenge challenge)
 869
 870
 871 {- DecidingBody 時に使用するアクション群 -}
 872
 873 -- | Write a 'Lazy.ByteString' to the response body, and then transit
 874 -- to the /Done/ state. It is safe to apply 'output' to an infinite
 875 -- string, such as the lazy stream of \/dev\/random.
 876 output ∷ Lazy.ByteString → Resource ()
 877 {-# INLINE output #-}
 878 output str = outputChunk str *> driftTo Done
 879
 880 -- | Write a 'Lazy.ByteString' to the response body. This action can
 881 -- be repeated as many times as you want. It is safe to apply
 882 -- 'outputChunk' to an infinite string.
 883 outputChunk ∷ Lazy.ByteString → Resource ()
 884 outputChunk wholeChunk
 885     = do driftTo DecidingBody
 886          itr ← getInteraction
 887
 888          let limit = cnfMaxOutputChunkLength $ itrConfig itr
 889          when (limit ≤ 0)
 890              $ abort InternalServerError []
 891                (Just $ "cnfMaxOutputChunkLength must be positive: " ⊕ T.pack (show limit))
 892
 893          discardBody ← liftIO $ atomically $ readTVar $ itrWillDiscardBody itr
 894          unless (discardBody)
 895              $ sendChunks itr wholeChunk limit
 896
 897          unless (Lazy.null wholeChunk)
 898              $ liftIO $ atomically $
 899                writeTVar (itrSentNoBodySoFar itr) False
 900     where
 901       sendChunks ∷ Interaction → Lazy.ByteString → Int → Resource ()
 902       sendChunks itr@(Interaction {..}) str limit
 903           | Lazy.null str = return ()
 904           | otherwise     = do let (chunk, remaining) = Lazy.splitAt (fromIntegral limit) str
 905                                liftIO $ atomically
 906                                       $ putTMVar itrBodyToSend (chunkToBuilder chunk)
 907                                sendChunks itr remaining limit
 908
 909       chunkToBuilder ∷ Lazy.ByteString → Builder
 910       chunkToBuilder = mconcat ∘ map BB.fromByteString ∘ Lazy.toChunks
 911
 912 {-
 913
 914   [GettingBody からそれ以降の状態に遷移する時]
 915
 916   body を讀み終へてゐなければ、殘りの body を讀み捨てる。
 917
 918
 919   [DecidingHeader からそれ以降の状態に遷移する時]
 920
 921   postprocess する。
 922
 923
 924   [Done に遷移する時]
 925
 926   bodyIsNull が False ならば何もしない。True だった場合は出力補完す
 927   る。
 928
 929 -}
 930
 931 driftTo ∷ InteractionState → Resource ()
 932 driftTo newState
 933     = do itr ← getInteraction
 934          liftIO $ atomically
 935                 $ do oldState ← readTVar $ itrState itr
 936                      if newState < oldState then
 937                          throwStateError oldState newState
 938                      else
 939                          do let a = [oldState .. newState]
 940                                 b = tail a
 941                                 c = zip a b
 942                             mapM_ (uncurry $ drift itr) c
 943                             writeTVar (itrState itr) newState
 944     where
 945       throwStateError ∷ Monad m ⇒ InteractionState → InteractionState → m a
 946       throwStateError Done DecidingBody
 947           = fail "It makes no sense to output something after finishing to output."
 948       throwStateError old new
 949           = fail ("state error: " ⧺ show old ⧺ " ==> " ⧺ show new)
 950
 951       drift ∷ Interaction → InteractionState → InteractionState → STM ()
 952       drift (Interaction {..}) GettingBody _
 953           = writeTVar itrReqBodyWasteAll True
 954       drift itr DecidingHeader _
 955           = postprocess itr
 956       drift itr@(Interaction {..}) _ Done
 957           = do bodyIsNull ← readTVar itrSentNoBodySoFar
 958                when bodyIsNull
 959                    $ writeDefaultPage itr
 960       drift _ _ _
 961           = return ()