Network/HTTP/Lucu/Resource.hs

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