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.Char8 as C8
 155 import qualified Data.ByteString.Lazy  as Lazy
 156 import Data.Foldable (toList)
 157 import Data.List
 158 import qualified Data.Map as M
 159 import Data.Maybe
 160 import Data.Monoid
 161 import Data.Monoid.Unicode
 162 import Data.Sequence (Seq)
 163 import Data.Text (Text)
 164 import qualified Data.Text as T
 165 import qualified Data.Text.Encoding as T
 166 import Data.Time
 167 import qualified Data.Time.HTTP as HTTP
 168 import Network.HTTP.Lucu.Abortion
 169 import Network.HTTP.Lucu.Authorization
 170 import Network.HTTP.Lucu.Config
 171 import Network.HTTP.Lucu.ContentCoding
 172 import Network.HTTP.Lucu.DefaultPage
 173 import Network.HTTP.Lucu.ETag
 174 import qualified Network.HTTP.Lucu.Headers as H
 175 import Network.HTTP.Lucu.HttpVersion
 176 import Network.HTTP.Lucu.Interaction
 177 import Network.HTTP.Lucu.MultipartForm
 178 import Network.HTTP.Lucu.Postprocess
 179 import Network.HTTP.Lucu.Request
 180 import Network.HTTP.Lucu.Response
 181 import Network.HTTP.Lucu.MIMEType
 182 import Network.HTTP.Lucu.Utils
 183 import Network.Socket hiding (accept)
 184 import Network.URI hiding (path)
 185 import OpenSSL.X509
 186 import Prelude.Unicode
 187
 188 -- |The 'Resource' monad. This monad implements 'MonadIO' so it can do
 189 -- any 'IO' actions.
 190 newtype Resource a
 191     = Resource {
 192         unRes ∷ ReaderT Interaction IO a
 193       }
 194     deriving (Applicative, Functor, Monad, MonadIO)
 195
 196 runRes ∷ Resource a → Interaction → IO a
 197 runRes r itr
 198     = runReaderT (unRes r) itr
 199
 200 getInteraction ∷ Resource Interaction
 201 getInteraction = Resource ask
 202
 203 -- |Get the 'Config' value which is used for the httpd.
 204 getConfig ∷ Resource Config
 205 getConfig = itrConfig <$> getInteraction
 206
 207 -- |Get the 'SockAddr' of the remote host. If you want a string
 208 -- representation instead of 'SockAddr', use 'getRemoteAddr''.
 209 getRemoteAddr ∷ Resource SockAddr
 210 getRemoteAddr = itrRemoteAddr <$> getInteraction
 211
 212 -- |Get the string representation of the address of remote host. If
 213 -- you want a 'SockAddr' instead of 'String', use 'getRemoteAddr'.
 214 getRemoteAddr' ∷ Resource HostName
 215 getRemoteAddr'
 216     = do sa          ← getRemoteAddr
 217          (Just a, _) ← liftIO $ getNameInfo [NI_NUMERICHOST] False False sa
 218          return a
 219
 220 -- |Resolve an address to the remote host.
 221 getRemoteHost ∷ Resource (Maybe HostName)
 222 getRemoteHost
 223     = do sa ← getRemoteAddr
 224          fst <$> (liftIO $ getNameInfo [] True False sa)
 225
 226 -- | Return the X.509 certificate of the client, or 'Nothing' if:
 227 --
 228 --   * This request didn't came through an SSL stream.
 229 --
 230 --   * The client didn't send us its certificate.
 231 --
 232 --   * The 'OpenSSL.Session.VerificationMode' of
 233 --   'OpenSSL.Session.SSLContext' in 'SSLConfig' has not been set to
 234 --   'OpenSSL.Session.VerifyPeer'.
 235 getRemoteCertificate ∷ Resource (Maybe X509)
 236 getRemoteCertificate = itrRemoteCert <$> getInteraction
 237
 238 -- |Get the 'Request' value which represents the request header. In
 239 -- general you don't have to use this action.
 240 getRequest ∷ Resource Request
 241 getRequest
 242     = do itr ← getInteraction
 243          liftIO $ atomically $ readItr itrRequest fromJust itr
 244
 245 -- |Get the 'Method' value of the request.
 246 getMethod ∷ Resource Method
 247 getMethod = reqMethod <$> getRequest
 248
 249 -- |Get the URI of the request.
 250 getRequestURI ∷ Resource URI
 251 getRequestURI = reqURI <$> getRequest
 252
 253 -- |Get the HTTP version of the request.
 254 getRequestVersion ∷ Resource HttpVersion
 255 getRequestVersion = reqVersion <$> getRequest
 256
 257 -- |Get the path of this 'Resource' (to be exact,
 258 -- 'Network.HTTP.Lucu.Resource.Tree.ResourceDef') in the
 259 -- 'Network.HTTP.Lucu.Resource.Tree.ResTree'. The result of this
 260 -- action is the exact path in the tree even if the
 261 -- 'Network.HTTP.Lucu.Resource.Tree.ResourceDef' is greedy.
 262 --
 263 -- Example:
 264 --
 265 -- > main = let tree = mkResTree [ (["foo"], resFoo) ]
 266 -- >        in runHttpd defaultConfig tree
 267 -- >
 268 -- > resFoo = ResourceDef {
 269 -- >     resIsGreedy = True
 270 -- >   , resGet = Just $ do requestURI   ← getRequestURI
 271 -- >                        resourcePath ← getResourcePath
 272 -- >                        pathInfo     ← getPathInfo
 273 -- >                        -- uriPath requestURI == "/foo/bar/baz"
 274 -- >                        -- resourcePath       == ["foo"]
 275 -- >                        -- pathInfo           == ["bar", "baz"]
 276 -- >                        ...
 277 -- >   , ...
 278 -- >   }
 279 getResourcePath ∷ Resource [Ascii]
 280 getResourcePath = (fromJust ∘ itrResourcePath) <$> getInteraction
 281
 282 -- |This is an analogy of CGI PATH_INFO. The result is
 283 -- URI-unescaped. It is always @[]@ if the
 284 -- 'Network.HTTP.Lucu.Resource.Tree.ResourceDef' is not greedy. See
 285 -- 'getResourcePath'.
 286 getPathInfo ∷ Resource [ByteString]
 287 getPathInfo = do rsrcPath ← getResourcePath
 288                  uri      ← getRequestURI
 289                  let reqPathStr = uriPath uri
 290                      reqPath    = [unEscapeString x | x ← splitBy (≡ '/') reqPathStr, (¬) (null x)]
 291                  -- rsrcPath と reqPath の共通する先頭部分を reqPath か
 292                  -- ら全部取り除くと、それは PATH_INFO のやうなものにな
 293                  -- る。rsrcPath は全部一致してゐるに決まってゐる（でな
 294                  -- ければこの Resource が撰ばれた筈が無い）ので、
 295                  -- rsrcPath の長さの分だけ削除すれば良い。
 296                  return $ map C8.pack $ drop (length rsrcPath) reqPath
 297
 298 -- |Assume the query part of request URI as
 299 -- application\/x-www-form-urlencoded, and parse it to pairs of
 300 -- @(name, formData)@. This action doesn't parse the request body. See
 301 -- 'inputForm'. Field names are decoded in UTF-8.
 302 getQueryForm ∷ Resource [(Text, FormData)]
 303 getQueryForm = parse' <$> getRequestURI
 304     where
 305       parse' = map toPairWithFormData ∘
 306                parseWWWFormURLEncoded ∘
 307                fromJust ∘
 308                A.fromChars ∘
 309                drop 1 ∘
 310                uriQuery
 311
 312 toPairWithFormData ∷ (ByteString, ByteString) → (Text, FormData)
 313 toPairWithFormData (name, value)
 314     = let fd = FormData {
 315                  fdFileName = Nothing
 316                , fdContent  = Lazy.fromChunks [value]
 317                }
 318       in (T.decodeUtf8 name, fd)
 319
 320 -- |Get a value of given request header. Comparison of header name is
 321 -- case-insensitive. Note that this action is not intended to be used
 322 -- so frequently: there should be actions like 'getContentType' for
 323 -- every common headers.
 324 getHeader ∷ CIAscii → Resource (Maybe Ascii)
 325 getHeader name
 326     = H.getHeader name <$> getRequest
 327
 328 -- |Get a list of 'MIMEType' enumerated on header \"Accept\".
 329 getAccept ∷ Resource [MIMEType]
 330 getAccept
 331     = do acceptM ← getHeader "Accept"
 332          case acceptM of
 333            Nothing
 334                → return []
 335            Just accept
 336                → case P.parseOnly p (A.toByteString accept) of
 337                     Right xs → return xs
 338                     Left  _  → abort BadRequest []
 339                                (Just $ "Unparsable Accept: " ⊕ A.toText accept)
 340     where
 341       p = do xs ← mimeTypeListP
 342              P.endOfInput
 343              return xs
 344
 345 -- |Get a list of @(contentCoding, qvalue)@ enumerated on header
 346 -- \"Accept-Encoding\". The list is sorted in descending order by
 347 -- qvalue.
 348 getAcceptEncoding ∷ Resource [(CIAscii, Maybe Double)]
 349 getAcceptEncoding
 350     = do accEncM ← getHeader "Accept-Encoding"
 351          case accEncM of
 352            Nothing
 353                -- HTTP/1.0 には Accept-Encoding が無い場合の規定が無い
 354                -- ので安全の爲 identity が指定された事にする。HTTP/1.1
 355                -- の場合は何でも受け入れて良い事になってゐるので "*" が
 356                -- 指定された事にする。
 357                → do ver ← getRequestVersion
 358                     case ver of
 359                       HttpVersion 1 0 → return [("identity", Nothing)]
 360                       HttpVersion 1 1 → return [("*"       , Nothing)]
 361                       _               → abort InternalServerError []
 362                                         (Just "getAcceptEncoding: unknown HTTP version")
 363            Just ae
 364                → if ae ≡ "" then
 365                       -- identity のみが許される。
 366                       return [("identity", Nothing)]
 367                   else
 368                       case P.parseOnly p (A.toByteString ae) of
 369                         Right xs → return $ map toTuple $ reverse $ sort xs
 370                         Left  _  → abort BadRequest []
 371                                    (Just $ "Unparsable Accept-Encoding: " ⊕ A.toText ae)
 372     where
 373       p = do xs ← acceptEncodingListP
 374              P.endOfInput
 375              return xs
 376
 377       toTuple (AcceptEncoding {..})
 378           = (aeEncoding, aeQValue)
 379
 380 -- |Check whether a given content-coding is acceptable.
 381 isEncodingAcceptable ∷ CIAscii → Resource Bool
 382 isEncodingAcceptable encoding = any f <$> getAcceptEncoding
 383     where
 384       f (e, q)
 385           = (e ≡ "*" ∨ e ≡ encoding) ∧ q ≢ Just 0
 386
 387 -- |Get the header \"Content-Type\" as 'MIMEType'.
 388 getContentType ∷ Resource (Maybe MIMEType)
 389 getContentType
 390     = do cTypeM ← getHeader "Content-Type"
 391          case cTypeM of
 392            Nothing
 393                → return Nothing
 394            Just cType
 395                → case P.parseOnly p (A.toByteString cType) of
 396                     Right t → return $ Just t
 397                     Left  _ → abort BadRequest []
 398                               (Just $ "Unparsable Content-Type: " ⊕ A.toText cType)
 399     where
 400       p = do t ← mimeTypeP
 401              P.endOfInput
 402              return t
 403
 404 -- |Get the header \"Authorization\" as 'AuthCredential'.
 405 getAuthorization ∷ Resource (Maybe AuthCredential)
 406 getAuthorization
 407     = do authM ← getHeader "Authorization"
 408          case authM of
 409            Nothing
 410                → return Nothing
 411            Just auth
 412                → case P.parseOnly p (A.toByteString auth) of
 413                     Right ac → return $ Just ac
 414                     Left  _  → return Nothing
 415     where
 416       p = do ac ← authCredentialP
 417              P.endOfInput
 418              return ac
 419
 420
 421 {- ExaminingRequest 時に使用するアクション群 -}
 422
 423 -- |Tell the system that the 'Resource' found an entity for the
 424 -- request URI. If this is a GET or HEAD request, a found entity means
 425 -- a datum to be replied. If this is a PUT or DELETE request, it means
 426 -- a datum which was stored for the URI until now. It is an error to
 427 -- compute 'foundEntity' if this is a POST request.
 428 --
 429 -- Computation of 'foundEntity' performs \"If-Match\" test or
 430 -- \"If-None-Match\" test if possible. When those tests fail, the
 431 -- computation of 'Resource' immediately aborts with status \"412
 432 -- Precondition Failed\" or \"304 Not Modified\" depending on the
 433 -- situation.
 434 --
 435 -- If this is a GET or HEAD request, 'foundEntity' automatically puts
 436 -- \"ETag\" and \"Last-Modified\" headers into the response.
 437 foundEntity ∷ ETag → UTCTime → Resource ()
 438 foundEntity !tag !timeStamp
 439     = do driftTo ExaminingRequest
 440
 441          method ← getMethod
 442          when (method ≡ GET ∨ method ≡ HEAD)
 443              $ setHeader' "Last-Modified" (HTTP.toAscii timeStamp)
 444          when (method ≡ POST)
 445              $ abort InternalServerError []
 446                (Just "Illegal computation of foundEntity for a POST request.")
 447          foundETag tag
 448
 449          driftTo GettingBody
 450
 451 -- |Tell the system that the 'Resource' found an entity for the
 452 -- request URI. The only difference from 'foundEntity' is that
 453 -- 'foundETag' doesn't (and can't) put \"Last-Modified\" header into
 454 -- the response.
 455 --
 456 -- This action is not preferred. You should use 'foundEntity' whenever
 457 -- possible.
 458 foundETag ∷ ETag → Resource ()
 459 foundETag !tag
 460     = do driftTo ExaminingRequest
 461
 462          method ← getMethod
 463          when (method ≡ GET ∨ method ≡ HEAD)
 464               $ setHeader' "ETag" (printETag tag)
 465          when (method ≡ POST)
 466               $ abort InternalServerError []
 467                 (Just "Illegal computation of foundETag for POST request.")
 468
 469          -- If-Match があればそれを見る。
 470          ifMatch ← getHeader "If-Match"
 471          case ifMatch of
 472            Nothing    → return ()
 473            Just value → if value ≡ "*" then
 474                             return ()
 475                         else
 476                             case P.parseOnly p (A.toByteString value) of
 477                               Right tags
 478                                  -- tags の中に一致するものが無ければ
 479                                  -- PreconditionFailed で終了。
 480                                  → when ((¬) (any (≡ tag) tags))
 481                                        $ abort PreconditionFailed []
 482                                          (Just $ "The entity tag doesn't match: " ⊕ A.toText value)
 483                               Left _
 484                                    → abort BadRequest [] (Just $ "Unparsable If-Match: " ⊕ A.toText value)
 485
 486          let statusForNoneMatch
 487                  = if method ≡ GET ∨ method ≡ HEAD then
 488                        NotModified
 489                    else
 490                        PreconditionFailed
 491
 492          -- If-None-Match があればそれを見る。
 493          ifNoneMatch ← getHeader "If-None-Match"
 494          case ifNoneMatch of
 495            Nothing    → return ()
 496            Just value → if value ≡ "*" then
 497                              abort statusForNoneMatch [] (Just "The entity tag matches: *")
 498                          else
 499                              case P.parseOnly p (A.toByteString value) of
 500                                Right tags
 501                                    → when (any (≡ tag) tags)
 502                                          $ abort statusForNoneMatch []
 503                                            (Just $ "The entity tag matches: " ⊕ A.toText value)
 504                                Left _
 505                                    → abort BadRequest []
 506                                      (Just $ "Unparsable If-None-Match: " ⊕ A.toText value)
 507
 508          driftTo GettingBody
 509     where
 510       p = do xs ← eTagListP
 511              P.endOfInput
 512              return xs
 513
 514 -- |Tell the system that the 'Resource' found an entity for the
 515 -- request URI. The only difference from 'foundEntity' is that
 516 -- 'foundTimeStamp' performs \"If-Modified-Since\" test or
 517 -- \"If-Unmodified-Since\" test instead of \"If-Match\" test or
 518 -- \"If-None-Match\" test. Be aware that any tests based on last
 519 -- modification time are unsafe because it is possible to mess up such
 520 -- tests by modifying the entity twice in a second.
 521 --
 522 -- This action is not preferred. You should use 'foundEntity' whenever
 523 -- possible.
 524 foundTimeStamp ∷ UTCTime → Resource ()
 525 foundTimeStamp timeStamp
 526     = do driftTo ExaminingRequest
 527
 528          method ← getMethod
 529          when (method ≡ GET ∨ method ≡ HEAD)
 530              $ setHeader' "Last-Modified" (HTTP.toAscii timeStamp)
 531          when (method ≡ POST)
 532              $ abort InternalServerError []
 533                (Just "Illegal computation of foundTimeStamp for POST request.")
 534
 535          let statusForIfModSince
 536                  = if method ≡ GET ∨ method ≡ HEAD then
 537                        NotModified
 538                    else
 539                        PreconditionFailed
 540
 541          -- If-Modified-Since があればそれを見る。
 542          ifModSince ← getHeader "If-Modified-Since"
 543          case ifModSince of
 544            Just str → case HTTP.fromAscii str of
 545                          Right lastTime
 546                              → when (timeStamp ≤ lastTime)
 547                                $ abort statusForIfModSince []
 548                                  (Just $ "The entity has not been modified since " ⊕ A.toText str)
 549                          Left _
 550                              → return () -- 不正な時刻は無視
 551            Nothing  → return ()
 552
 553          -- If-Unmodified-Since があればそれを見る。
 554          ifUnmodSince ← getHeader "If-Unmodified-Since"
 555          case ifUnmodSince of
 556            Just str → case HTTP.fromAscii str of
 557                          Right lastTime
 558                              → when (timeStamp > lastTime)
 559                                $ abort PreconditionFailed []
 560                                  (Just $ "The entity has not been modified since " ⊕ A.toText str)
 561                          Left _
 562                              → return () -- 不正な時刻は無視
 563            Nothing  → return ()
 564
 565          driftTo GettingBody
 566
 567 -- | Computation of @'foundNoEntity' mStr@ tells the system that the
 568 -- 'Resource' found no entity for the request URI. @mStr@ is an
 569 -- optional error message to be replied to the client.
 570 --
 571 -- If this is a PUT request, 'foundNoEntity' performs \"If-Match\"
 572 -- test and aborts with status \"412 Precondition Failed\" when it
 573 -- failed. If this is a GET, HEAD, POST or DELETE request,
 574 -- 'foundNoEntity' always aborts with status \"404 Not Found\".
 575 foundNoEntity ∷ Maybe Text → Resource ()
 576 foundNoEntity msgM
 577     = do driftTo ExaminingRequest
 578
 579          method ← getMethod
 580          when (method ≢ PUT)
 581              $ abort NotFound [] msgM
 582
 583          -- エンティティが存在しないと云ふ事は、"*" も含めたどのやうな
 584          -- If-Match: 條件も滿たさない。
 585          ifMatch ← getHeader "If-Match"
 586          when (ifMatch ≢ Nothing)
 587              $ abort PreconditionFailed [] msgM
 588
 589          driftTo GettingBody
 590
 591
 592 {- GettingBody 時に使用するアクション群 -}
 593
 594 -- | Computation of @'input' limit@ attempts to read the request body
 595 -- up to @limit@ bytes, and then make the 'Resource' transit to
 596 -- /Deciding Header/ state. When the actual size of body is larger
 597 -- than @limit@ bytes, computation of 'Resource' immediately aborts
 598 -- with status \"413 Request Entity Too Large\". When the request has
 599 -- no body, 'input' returns an empty string.
 600 --
 601 -- @limit@ may be less than or equal to zero. In this case, the
 602 -- default limitation value ('cnfMaxEntityLength') is used. See
 603 -- 'defaultLimit'.
 604 --
 605 -- 'input' returns a 'Lazy.ByteString' but it's not really lazy:
 606 -- reading from the socket just happens at the computation of 'input',
 607 -- not at the evaluation of the 'Lazy.ByteString'. The same goes for
 608 -- 'inputChunk'.
 609 input ∷ Int → Resource Lazy.ByteString
 610 input limit
 611     = do driftTo GettingBody
 612          itr     ← getInteraction
 613          hasBody ← liftIO $ atomically $ readItr itrRequestHasBody id itr
 614          chunk   ← if hasBody then
 615                        askForInput itr
 616                    else
 617                        do driftTo DecidingHeader
 618                           return (∅)
 619          return chunk
 620     where
 621       askForInput ∷ Interaction → Resource Lazy.ByteString
 622       askForInput itr
 623           = do let confLimit   = cnfMaxEntityLength $ itrConfig itr
 624                    actualLimit = if limit ≤ 0 then
 625                                      confLimit
 626                                  else
 627                                      limit
 628                when (actualLimit ≤ 0)
 629                         $ fail ("inputLBS: limit must be positive: " ⧺ show actualLimit)
 630                -- Reader にリクエスト
 631                liftIO $ atomically
 632                       $ do chunkLen ← readItr itrReqChunkLength id itr
 633                            writeItr itrWillReceiveBody True itr
 634                            if ((> actualLimit) <$> chunkLen) ≡ Just True then
 635                                -- 受信前から多過ぎる事が分かってゐる
 636                                tooLarge actualLimit
 637                            else
 638                                writeItr itrReqBodyWanted (Just actualLimit) itr
 639                -- 應答を待つ。トランザクションを分けなければ當然デッドロックする。
 640                chunk ← liftIO $ atomically
 641                        $ do chunkLen    ← readItr itrReceivedBodyLen id itr
 642                             chunkIsOver ← readItr itrReqChunkIsOver  id itr
 643                             if chunkLen < actualLimit then
 644                                 -- 要求された量に滿たなくて、まだ殘りが
 645                                 -- あるなら再試行。
 646                                 unless chunkIsOver
 647                                     $ retry
 648                             else
 649                                 -- 制限値一杯まで讀むやうに指示したのに
 650                                 -- まだ殘ってゐるなら、それは多過ぎる。
 651                                 unless chunkIsOver
 652                                     $ tooLarge actualLimit
 653                             -- 成功。itr 内にチャンクを置いたままにする
 654                             -- とメモリの無駄になるので除去。
 655                             chunk ← readItr itrReceivedBody seqToLBS itr
 656                             writeItr itrReceivedBody (∅) 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                             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 $ updateItr itrResponse f itr
 800     where
 801       f res = res {
 802                 resStatus = code
 803               }
 804
 805 -- | Set a value of given resource header. Comparison of header name
 806 -- is case-insensitive. Note that this action is not intended to be
 807 -- used so frequently: there should be actions like 'setContentType'
 808 -- for every common headers.
 809 --
 810 -- Some important headers (especially \"Content-Length\" and
 811 -- \"Transfer-Encoding\") may be silently dropped or overwritten by
 812 -- the system not to corrupt the interaction with client at the
 813 -- viewpoint of HTTP protocol layer. For instance, if we are keeping
 814 -- the connection alive, without this process it causes a catastrophe
 815 -- to send a header \"Content-Length: 10\" and actually send a body of
 816 -- 20 bytes long. In this case the client shall only accept the first
 817 -- 10 bytes of response body and thinks that the residual 10 bytes is
 818 -- a part of header of the next response.
 819 setHeader ∷ CIAscii → Ascii → Resource ()
 820 setHeader name value
 821     = driftTo DecidingHeader ≫ setHeader' name value
 822
 823 setHeader' ∷ CIAscii → Ascii → Resource ()
 824 setHeader' name value
 825     = do itr ← getInteraction
 826          liftIO $ atomically
 827                 $ updateItr itrResponse (H.setHeader name value) itr
 828
 829 -- | Computation of @'redirect' code uri@ sets the response status to
 830 -- @code@ and \"Location\" header to @uri@. The @code@ must satisfy
 831 -- 'isRedirection' or it causes an error.
 832 redirect ∷ StatusCode → URI → Resource ()
 833 redirect code uri
 834     = do when (code ≡ NotModified ∨ not (isRedirection code))
 835              $ abort InternalServerError []
 836              $ Just
 837              $ A.toText
 838              $ A.fromAsciiBuilder
 839              $ A.toAsciiBuilder "Attempted to redirect with status "
 840              ⊕ printStatusCode code
 841          setStatus code
 842          setLocation uri
 843
 844 -- | Computation of @'setContentType' mType@ sets the response header
 845 -- \"Content-Type\" to @mType@.
 846 setContentType ∷ MIMEType → Resource ()
 847 setContentType
 848     = setHeader "Content-Type" ∘ A.fromAsciiBuilder ∘ printMIMEType
 849
 850 -- | Computation of @'setLocation' uri@ sets the response header
 851 -- \"Location\" to @uri@.
 852 setLocation ∷ URI → Resource ()
 853 setLocation uri
 854     = case A.fromChars uriStr of
 855         Just a  → setHeader "Location" a
 856         Nothing → abort InternalServerError []
 857                   (Just $ "Malformed URI: " ⊕ T.pack uriStr)
 858     where
 859       uriStr = uriToString id uri ""
 860
 861 -- |Computation of @'setContentEncoding' codings@ sets the response
 862 -- header \"Content-Encoding\" to @codings@.
 863 setContentEncoding ∷ [CIAscii] → Resource ()
 864 setContentEncoding codings
 865     = do ver ← getRequestVersion
 866          tr  ← case ver of
 867                   HttpVersion 1 0 → return (toAB ∘ unnormalizeCoding)
 868                   HttpVersion 1 1 → return toAB
 869                   _               → abort InternalServerError []
 870                                     (Just "setContentEncoding: Unknown HTTP version")
 871          setHeader "Content-Encoding"
 872                    (A.fromAsciiBuilder $ joinWith ", " $ map tr codings)
 873     where
 874       toAB = A.toAsciiBuilder ∘ A.fromCIAscii
 875
 876 -- |Computation of @'setWWWAuthenticate' challenge@ sets the response
 877 -- header \"WWW-Authenticate\" to @challenge@.
 878 setWWWAuthenticate ∷ AuthChallenge → Resource ()
 879 setWWWAuthenticate challenge
 880     = setHeader "WWW-Authenticate" (printAuthChallenge challenge)
 881
 882
 883 {- DecidingBody 時に使用するアクション群 -}
 884
 885 -- | Computation of @'output' str@ writes @str@ as a response body,
 886 -- and then make the 'Resource' transit to /Done/ state. It is safe to
 887 -- apply 'output' to an infinite string, such as a lazy stream of
 888 -- \/dev\/random.
 889 output ∷ Lazy.ByteString → Resource ()
 890 {-# INLINE output #-}
 891 output str = outputChunk str *> driftTo Done
 892
 893 -- | Computation of @'outputChunk' str@ writes @str@ as a part of
 894 -- response body. You can compute this action multiple times to write
 895 -- a body little at a time. It is safe to apply 'outputChunk' to an
 896 -- infinite string.
 897 outputChunk ∷ Lazy.ByteString → Resource ()
 898 outputChunk wholeChunk
 899     = do driftTo DecidingBody
 900          itr ← getInteraction
 901
 902          let limit = cnfMaxOutputChunkLength $ itrConfig itr
 903          when (limit ≤ 0)
 904              $ abort InternalServerError []
 905                (Just $ "cnfMaxOutputChunkLength must be positive: " ⊕ T.pack (show limit))
 906
 907          discardBody ← liftIO $ atomically $
 908                        readItr itrWillDiscardBody id itr
 909
 910          unless (discardBody)
 911              $ sendChunks wholeChunk limit
 912
 913          unless (Lazy.null wholeChunk)
 914              $ liftIO $ atomically $
 915                writeItr itrBodyIsNull False itr
 916     where
 917       sendChunks ∷ Lazy.ByteString → Int → Resource ()
 918       sendChunks str limit
 919           | Lazy.null str = return ()
 920           | otherwise     = do let (chunk, remaining) = Lazy.splitAt (fromIntegral limit) str
 921                                itr ← getInteraction
 922                                liftIO $ atomically
 923                                       $ putTMVar (itrBodyToSend itr) (chunkToBuilder chunk)
 924                                sendChunks remaining limit
 925
 926       chunkToBuilder ∷ Lazy.ByteString → Builder
 927       chunkToBuilder = mconcat ∘ map BB.fromByteString ∘ Lazy.toChunks
 928
 929 {-
 930
 931   [GettingBody からそれ以降の状態に遷移する時]
 932
 933   body を讀み終へてゐなければ、殘りの body を讀み捨てる。
 934
 935
 936   [DecidingHeader からそれ以降の状態に遷移する時]
 937
 938   postprocess する。
 939
 940
 941   [Done に遷移する時]
 942
 943   bodyIsNull が False ならば何もしない。True だった場合は出力補完す
 944   る。
 945
 946 -}
 947
 948 driftTo ∷ InteractionState → Resource ()
 949 driftTo newState
 950     = do itr ← getInteraction
 951          liftIO $ atomically $ do oldState ← readItr itrState id itr
 952                                   if newState < oldState then
 953                                       throwStateError oldState newState
 954                                     else
 955                                       do let a = [oldState .. newState]
 956                                              b = tail a
 957                                              c = zip a b
 958                                          mapM_ (uncurry $ drift itr) c
 959                                          writeItr itrState newState itr
 960     where
 961       throwStateError ∷ Monad m => InteractionState → InteractionState → m a
 962
 963       throwStateError Done DecidingBody
 964           = fail "It makes no sense to output something after finishing to output."
 965
 966       throwStateError old new
 967           = fail ("state error: " ⧺ show old ⧺ " ==> " ⧺ show new)
 968
 969
 970       drift ∷ Interaction → InteractionState → InteractionState → STM ()
 971
 972       drift itr GettingBody _
 973           = writeItr itrReqBodyWasteAll True itr
 974
 975       drift itr DecidingHeader _
 976           = postprocess itr
 977
 978       drift itr _ Done
 979           = do bodyIsNull ← readItr itrBodyIsNull id itr
 980                when bodyIsNull
 981                         $ writeDefaultPage itr
 982
 983       drift _ _ _
 984           = return ()