Network/HTTP/Lucu/Resource.hs

   1 -- #prune
   2
   3 -- |This is the Resource Monad; monadic actions to define the behavior
   4 -- of each resources. The 'Resource' Monad is a kind of IO Monad thus
   5 -- it implements MonadIO class. It is also a state machine.
   6 --
   7 -- Request Processing Flow:
   8 --
   9 --   1. A client issues an HTTP request.
  10 --
  11 --   2. If the URI of it matches to any resource, the corresponding
  12 --      'Resource' Monad starts running on a newly spawned thread.
  13 --
  14 --   3. The 'Resource' Monad looks at the request header, find (or not
  15 --      find) an entity, receive the request body (if any), decide the
  16 --      response header, and decide the response body. This process
  17 --      will be discussed later.
  18 --
  19 --   4. The 'Resource' Monad and its thread stops running. The client
  20 --      may or may not be sending us the next request at this point.
  21 --
  22 -- 'Resource' Monad takes the following states. The initial state is
  23 -- /Examining Request/ and the final state is /Done/.
  24 --
  25 --   [/Examining Request/] In this state, a 'Resource' looks at the
  26 --   request header and thinks about an entity for it. If there is a
  27 --   suitable entity, the 'Resource' tells the system an entity tag
  28 --   and its last modification time ('foundEntity'). If it found no
  29 --   entity, it tells the system so ('foundNoEntity'). In case it is
  30 --   impossible to decide the existence of entity, which is a typical
  31 --   case for POST requests, 'Resource' does nothing in this state.
  32 --
  33 --   [/Getting Body/] A 'Resource' asks the system to receive a
  34 --   request body from client. Before actually reading from the
  35 --   socket, the system sends \"100 Continue\" to the client if need
  36 --   be. When a 'Resource' transits to the next state without
  37 --   receiving all or part of request body, the system still reads it
  38 --   and just throws it away.
  39 --
  40 --   [/Deciding Header/] A 'Resource' makes a decision of status code
  41 --   and response header. When it transits to the next state, the
  42 --   system checks the validness of response header and then write
  43 --   them to the socket.
  44 --
  45 --   [/Deciding Body/] In this state, a 'Resource' asks the system to
  46 --   write some response body to the socket. When it transits to the
  47 --   next state without writing any response body, the system
  48 --   completes it depending on the status code.
  49 --
  50 --   [/Done/] Everything is over. A 'Resource' can do nothing for the
  51 --   HTTP interaction anymore.
  52 --
  53 -- Note that the state transition is one-way: for instance, it is an
  54 -- error to try to read a request body after writing some
  55 -- response. This limitation is for efficiency. We don't want to read
  56 -- the entire request before starting 'Resource', nor we don't want to
  57 -- postpone writing the entire response till the end of 'Resource'
  58 -- computation.
  59
  60 module Network.HTTP.Lucu.Resource
  61     (
  62     -- * Monad
  63     Resource
  64
  65     -- * Actions
  66
  67     -- ** Getting request header
  68
  69     -- |These actions can be computed regardless of the current state,
  70     -- and they don't change the state.
  71     , getConfig
  72     , getRequest
  73     , getMethod
  74     , getRequestURI
  75     , getResourcePath
  76     , getPathInfo
  77     , getQueryForm
  78     , getHeader
  79     , getAccept
  80     , getContentType
  81
  82     -- ** Finding an entity
  83
  84     -- |These actions can be computed only in the /Examining Request/
  85     -- state. After the computation, the 'Resource' transits to
  86     -- /Getting Body/ state.
  87     , foundEntity
  88     , foundETag
  89     , foundTimeStamp
  90     , foundNoEntity
  91
  92     -- ** Getting a request body
  93
  94     -- |Computation of these actions changes the state to /Getting
  95     -- Body/.
  96     , input
  97     , inputChunk
  98     , inputBS
  99     , inputChunkBS
 100     , inputForm
 101     , defaultLimit
 102
 103     -- ** Setting response headers
 104
 105     -- |Computation of these actions changes the state to /Deciding
 106     -- Header/.
 107     , setStatus
 108     , setHeader
 109     , redirect
 110     , setContentType
 111     , setLocation
 112
 113     -- ** Writing a response body
 114
 115     -- |Computation of these actions changes the state to /Deciding
 116     -- Body/.
 117     , output
 118     , outputChunk
 119     , outputBS
 120     , outputChunkBS
 121
 122     , driftTo
 123     )
 124     where
 125
 126 import           Control.Concurrent.STM
 127 import           Control.Monad.Reader
 128 import qualified Data.ByteString.Lazy.Char8 as B
 129 import           Data.ByteString.Lazy.Char8 (ByteString)
 130 import           Data.List
 131 import           Data.Maybe
 132 import           GHC.Conc (unsafeIOToSTM)
 133 import           Network.HTTP.Lucu.Abortion
 134 import           Network.HTTP.Lucu.Config
 135 import           Network.HTTP.Lucu.DefaultPage
 136 import           Network.HTTP.Lucu.ETag
 137 import qualified Network.HTTP.Lucu.Headers as H
 138 import           Network.HTTP.Lucu.HttpVersion
 139 import           Network.HTTP.Lucu.Interaction
 140 import           Network.HTTP.Lucu.Parser
 141 import           Network.HTTP.Lucu.Postprocess
 142 import           Network.HTTP.Lucu.RFC1123DateTime
 143 import           Network.HTTP.Lucu.Request
 144 import           Network.HTTP.Lucu.Response
 145 import           Network.HTTP.Lucu.MIMEType
 146 import           Network.HTTP.Lucu.Utils
 147 import           Network.URI
 148 import           System.Time
 149
 150 -- |The 'Resource' monad. /Interaction/ is an internal state thus it
 151 -- is not exposed to users. This monad implements 'MonadIO' so it can
 152 -- do any IO actions.
 153 type Resource a = ReaderT Interaction IO a
 154
 155 -- |Get the 'Network.HTTP.Lucu.Config.Config' value which is used for
 156 -- the httpd.
 157 getConfig :: Resource Config
 158 getConfig = do itr <- ask
 159                return $ itrConfig itr
 160
 161 -- |Get the 'Network.HTTP.Lucu.Request.Request' value which represents
 162 -- the request header. In general you don't have to use this action.
 163 getRequest :: Resource Request
 164 getRequest = do itr <- ask
 165                 req <- liftIO $ atomically $ readItr itr itrRequest fromJust
 166                 return req
 167
 168 -- |Get the 'Network.HTTP.Lucu.Request.Method' value of the request.
 169 getMethod :: Resource Method
 170 getMethod = do req <- getRequest
 171                return $ reqMethod req
 172
 173 -- |Get the URI of the request.
 174 getRequestURI :: Resource URI
 175 getRequestURI = do req <- getRequest
 176                    return $ reqURI req
 177
 178 -- |Get the path of this 'Resource' (to be exact,
 179 -- 'Network.HTTP.Lucu.Resource.Tree.ResourceDef') in the
 180 -- 'Network.HTTP.Lucu.Resource.Tree.ResTree'. The result of this
 181 -- action is the exact path in the tree even if the
 182 -- 'Network.HTTP.Lucu.Resource.Tree.ResourceDef' is greedy.
 183 --
 184 -- Example:
 185 --
 186 -- > main = let tree = mkResTree [ (["foo"], resFoo) ]
 187 -- >        in runHttpd defaultConfig tree
 188 -- >
 189 -- > resFoo = ResourceDef {
 190 -- >     resIsGreedy = True
 191 -- >   , resGet = Just $ do requestURI   <- getRequestURI
 192 -- >                        resourcePath <- getResourcePath
 193 -- >                        pathInfo     <- getPathInfo
 194 -- >                        -- uriPath requestURI == "/foo/bar/baz"
 195 -- >                        -- resourcePath       == ["foo"]
 196 -- >                        -- pathInfo           == ["bar", "baz"]
 197 -- >                        ...
 198 -- >   , ...
 199 -- >   }
 200 getResourcePath :: Resource [String]
 201 getResourcePath = do itr <- ask
 202                      return $ fromJust $ itrResourcePath itr
 203
 204
 205 -- |This is an analogy of CGI PATH_INFO. Its result is always @[]@ if
 206 -- the 'Network.HTTP.Lucu.Resource.Tree.ResourceDef' is not
 207 -- greedy. See 'getResourcePath'.
 208 getPathInfo :: Resource [String]
 209 getPathInfo = do rsrcPath <- getResourcePath
 210                  reqURI   <- getRequestURI
 211                  let reqPathStr = uriPath reqURI
 212                      reqPath    = [x | x <- splitBy (== '/') reqPathStr, x /= ""]
 213                  -- rsrcPath と reqPath の共通する先頭部分を reqPath か
 214                  -- ら全部取り除くと、それは PATH_INFO のやうなものにな
 215                  -- る。rsrcPath は全部一致してゐるに決まってゐる（でな
 216                  -- ければこの Resource が撰ばれた筈が無い）ので、
 217                  -- rsrcPath の長さの分だけ削除すれば良い。
 218                  return $ drop (length rsrcPath) reqPath
 219
 220 -- | Assume the query part of request URI as
 221 -- application\/x-www-form-urlencoded, and parse it. This action
 222 -- doesn't parse the request body. See 'inputForm'.
 223 getQueryForm :: Resource [(String, String)]
 224 getQueryForm = do reqURI <- getRequestURI
 225                   return $ parseWWWFormURLEncoded $ uriQuery reqURI
 226
 227 -- |Get a value of given request header. Comparison of header name is
 228 -- case-insensitive. Note that this action is not intended to be used
 229 -- so frequently: there should be actions like 'getContentType' for
 230 -- every common headers.
 231 getHeader :: String -> Resource (Maybe String)
 232 getHeader name = do req <- getRequest
 233                     return $ H.getHeader name req
 234
 235 -- |Get a list of 'Network.HTTP.Lucu.MIMEType.MIMEType' enumerated on
 236 -- header \"Accept\".
 237 getAccept :: Resource [MIMEType]
 238 getAccept = do accept <- getHeader "Accept"
 239                if accept == Nothing then
 240                    return []
 241                  else
 242                    case parseStr mimeTypeListP $ fromJust accept of
 243                      (Success xs, _) -> return xs
 244                      _               -> return []
 245
 246 -- |Get the header \"Content-Type\" as
 247 -- 'Network.HTTP.Lucu.MIMEType.MIMEType'.
 248 getContentType :: Resource (Maybe MIMEType)
 249 getContentType = do cType <- getHeader "Content-Type"
 250                     if cType == Nothing then
 251                         return Nothing
 252                       else
 253                         case parseStr mimeTypeP $ fromJust cType of
 254                           (Success t, _) -> return $ Just t
 255                           _              -> return Nothing
 256
 257
 258
 259 {- ExaminingRequest 時に使用するアクション群 -}
 260
 261 -- |Tell the system that the 'Resource' found an entity for the
 262 -- request URI. If this is a GET or HEAD request, a found entity means
 263 -- a datum to be replied. If this is a PUT or DELETE request, it means
 264 -- a datum which was stored for the URI up to now. It is an error to
 265 -- compute 'foundEntity' if this is a POST request.
 266 --
 267 -- Computation of 'foundEntity' performs \"If-Match\" test or
 268 -- \"If-None-Match\" test if possible. When those tests fail, the
 269 -- computation of 'Resource' immediately aborts with status \"412
 270 -- Precondition Failed\" or \"304 Not Modified\" depending on the
 271 -- situation.
 272 --
 273 -- If this is a GET or HEAD request, 'foundEntity' automatically puts
 274 -- \"ETag\" and \"Last-Modified\" headers into the response.
 275 foundEntity :: ETag -> ClockTime -> Resource ()
 276 foundEntity tag timeStamp
 277     = do driftTo ExaminingRequest
 278
 279          method <- getMethod
 280          when (method == GET || method == HEAD)
 281                   $ setHeader' "Last-Modified" $ formatHTTPDateTime timeStamp
 282          when (method == POST)
 283                   $ abort InternalServerError []
 284                         (Just "Illegal computation of foundEntity for POST request.")
 285          foundETag tag
 286
 287          driftTo GettingBody
 288
 289 -- |Tell the system that the 'Resource' found an entity for the
 290 -- request URI. The only difference from 'foundEntity' is that
 291 -- 'foundETag' doesn't (and can't) put \"Last-Modified\" header into
 292 -- the response.
 293 --
 294 -- This action is not preferred. You should use 'foundEntity' when
 295 -- possible.
 296 foundETag :: ETag -> Resource ()
 297 foundETag tag
 298     = do driftTo ExaminingRequest
 299
 300          method <- getMethod
 301          when (method == GET || method == HEAD)
 302                   $ setHeader' "ETag" $ show tag
 303          when (method == POST)
 304                   $ abort InternalServerError []
 305                         (Just "Illegal computation of foundETag for POST request.")
 306
 307          -- If-Match があればそれを見る。
 308          ifMatch <- getHeader "If-Match"
 309          case ifMatch of
 310            Nothing   -> return ()
 311            Just "*"  -> return ()
 312            Just list -> case parseStr eTagListP list of
 313                           (Success tags, _)
 314                               -- tags の中に一致するものが無ければ
 315                               -- PreconditionFailed で終了。
 316                               -> when (not $ any (== tag) tags)
 317                                  $ abort PreconditionFailed []
 318                                        $ Just ("The entity tag doesn't match: " ++ list)
 319                           _   -> abort BadRequest [] $ Just ("Unparsable If-Match: " ++ fromJust ifMatch)
 320
 321          let statusForNoneMatch = if method == GET || method == HEAD then
 322                                       NotModified
 323                                   else
 324                                       PreconditionFailed
 325
 326          -- If-None-Match があればそれを見る。
 327          ifNoneMatch <- getHeader "If-None-Match"
 328          case ifNoneMatch of
 329            Nothing   -> return ()
 330            Just "*"  -> abort statusForNoneMatch [] $ Just ("The entity tag matches: *")
 331            Just list -> case parseStr eTagListP list of
 332                           (Success tags, _)
 333                               -> when (any (== tag) tags)
 334                                  $ abort statusForNoneMatch [] $ Just ("The entity tag matches: " ++ list)
 335                           _   -> abort BadRequest [] $ Just ("Unparsable If-None-Match: " ++ list)
 336
 337          driftTo GettingBody
 338
 339 -- |Tell the system that the 'Resource' found an entity for the
 340 -- request URI. The only difference from 'foundEntity' is that
 341 -- 'foundTimeStamp' performs \"If-Modified-Since\" test or
 342 -- \"If-Unmodified-Since\" test instead of \"If-Match\" test or
 343 -- \"If-None-Match\" test. Be aware that any tests based on last
 344 -- modification time are unsafe because it is possible to mess up such
 345 -- tests by modifying the entity twice in a second.
 346 --
 347 -- This action is not preferred. You should use 'foundEntity' when
 348 -- possible.
 349 foundTimeStamp :: ClockTime -> Resource ()
 350 foundTimeStamp timeStamp
 351     = do driftTo ExaminingRequest
 352
 353          method <- getMethod
 354          when (method == GET || method == HEAD)
 355                   $ setHeader' "Last-Modified" $ formatHTTPDateTime timeStamp
 356          when (method == POST)
 357                   $ abort InternalServerError []
 358                         (Just "Illegal computation of foundTimeStamp for POST request.")
 359
 360          let statusForIfModSince = if method == GET || method == HEAD then
 361                                        NotModified
 362                                    else
 363                                        PreconditionFailed
 364
 365          -- If-Modified-Since があればそれを見る。
 366          ifModSince <- getHeader "If-Modified-Since"
 367          case ifModSince of
 368            Just str -> case parseHTTPDateTime str of
 369                          Just lastTime
 370                              -> when (timeStamp <= lastTime)
 371                                 $ abort statusForIfModSince []
 372                                       $ Just ("The entity has not been modified since " ++ str)
 373                          Nothing
 374                              -> return () -- 不正な時刻は無視
 375            Nothing  -> return ()
 376
 377          -- If-Unmodified-Since があればそれを見る。
 378          ifUnmodSince <- getHeader "If-Unmodified-Since"
 379          case ifUnmodSince of
 380            Just str -> case parseHTTPDateTime str of
 381                          Just lastTime
 382                              -> when (timeStamp > lastTime)
 383                                 $ abort PreconditionFailed []
 384                                       $ Just  ("The entity has not been modified since " ++ str)
 385                          Nothing
 386                              -> return () -- 不正な時刻は無視
 387            Nothing  -> return ()
 388
 389          driftTo GettingBody
 390
 391 -- | Computation of @'foundNoEntity' mStr@ tells the system that the
 392 -- 'Resource' found no entity for the request URI. @mStr@ is an
 393 -- optional error message to be replied to the client.
 394 --
 395 -- If this is a PUT request, 'foundNoEntity' performs \"If-Match\"
 396 -- test and aborts with status \"412 Precondition Failed\" when it
 397 -- failed. If this is a GET, HEAD, POST or DELETE request,
 398 -- 'foundNoEntity' always aborts with status \"404 Not Found\".
 399 foundNoEntity :: Maybe String -> Resource ()
 400 foundNoEntity msgM
 401     = do driftTo ExaminingRequest
 402
 403          method <- getMethod
 404          when (method /= PUT)
 405                   $ abort NotFound [] msgM
 406
 407          -- エンティティが存在しないと云ふ事は、"*" も含めたどのやうな
 408          -- If-Match: 條件も滿たさない。
 409          ifMatch <- getHeader "If-Match"
 410          when (ifMatch /= Nothing)
 411                   $ abort PreconditionFailed [] msgM
 412
 413          driftTo GettingBody
 414
 415
 416 {- GettingBody 時に使用するアクション群 -}
 417
 418 -- | Computation of @'input' limit@ attempts to read the request body
 419 -- up to @limit@ bytes, and then make the 'Resource' transit to
 420 -- /Deciding Header/ state. When the actual size of body is larger
 421 -- than @limit@ bytes, computation of 'Resource' immediately aborts
 422 -- with status \"413 Request Entity Too Large\". When the request has
 423 -- no body, 'input' returns an empty string.
 424 --
 425 -- @limit@ may be less than or equal to zero. In this case, the
 426 -- default limitation value
 427 -- ('Network.HTTP.Lucu.Config.cnfMaxEntityLength') is used. See
 428 -- 'defaultLimit'.
 429 --
 430 -- Note that 'inputBS' is more efficient than 'input' so you should
 431 -- use it whenever possible.
 432 input :: Int -> Resource String
 433 input limit = inputBS limit >>= return . B.unpack
 434
 435
 436 -- | This is mostly the same as 'input' but is more
 437 -- efficient. 'inputBS' returns a lazy ByteString but it's not really
 438 -- lazy: reading from the socket just happens at the computation of
 439 -- 'inputBS', not at the lazy evaluation of the ByteString. The same
 440 -- goes for 'inputChunkBS'.
 441 inputBS :: Int -> Resource ByteString
 442 inputBS limit
 443     = do driftTo GettingBody
 444          itr     <- ask
 445          hasBody <- liftIO $ atomically $ readItr itr itrRequestHasBody id
 446          chunk   <- if hasBody then
 447                         askForInput itr
 448                     else
 449                         do driftTo DecidingHeader
 450                            return B.empty
 451          return chunk
 452     where
 453       askForInput :: Interaction -> Resource ByteString
 454       askForInput itr
 455           = do let defaultLimit = cnfMaxEntityLength $ itrConfig itr
 456                    actualLimit  = if limit <= 0 then
 457                                       defaultLimit
 458                                   else
 459                                       limit
 460                when (actualLimit <= 0)
 461                         $ fail ("inputBS: limit must be positive: " ++ show actualLimit)
 462                -- Reader にリクエスト
 463                liftIO $ atomically
 464                           $ do chunkLen <- readItr itr itrReqChunkLength id
 465                                writeItr itr itrWillReceiveBody True
 466                                if fmap (> actualLimit) chunkLen == Just True then
 467                                    -- 受信前から多過ぎる事が分かってゐる
 468                                    tooLarge actualLimit
 469                                  else
 470                                    writeItr itr itrReqBodyWanted $ Just actualLimit
 471                -- 應答を待つ。トランザクションを分けなければ當然デッドロック。
 472                chunk <- liftIO $ atomically
 473                         $ do chunk       <- readItr itr itrReceivedBody id
 474                              chunkIsOver <- readItr itr itrReqChunkIsOver id
 475                              if B.length chunk < fromIntegral actualLimit then
 476                                  -- 要求された量に滿たなくて、まだ殘り
 477                                  -- があるなら再試行。
 478                                  unless chunkIsOver
 479                                             $ retry
 480                                else
 481                                  -- 制限値一杯まで讀むやうに指示したの
 482                                  -- にまだ殘ってゐるなら、それは多過ぎ
 483                                  -- る。
 484                                  unless chunkIsOver
 485                                             $ tooLarge actualLimit
 486                              -- 成功。itr 内にチャンクを置いたままにす
 487                              -- るとメモリの無駄になるので除去。
 488                              writeItr itr itrReceivedBody B.empty
 489                              return chunk
 490                driftTo DecidingHeader
 491                return chunk
 492
 493       tooLarge :: Int -> STM ()
 494       tooLarge lim = abortSTM RequestEntityTooLarge []
 495                      $ Just ("Request body must be smaller than "
 496                              ++ show lim ++ " bytes.")
 497
 498 -- | Computation of @'inputChunk' limit@ attempts to read a part of
 499 -- request body up to @limit@ bytes. You can read any large request by
 500 -- repeating computation of this action. When you've read all the
 501 -- request body, 'inputChunk' returns an empty string and then make
 502 -- the 'Resource' transit to /Deciding Header/ state.
 503 --
 504 -- @limit@ may be less than or equal to zero. In this case, the
 505 -- default limitation value
 506 -- ('Network.HTTP.Lucu.Config.cnfMaxEntityLength') is used. See
 507 -- 'defaultLimit'.
 508 --
 509 -- Note that 'inputChunkBS' is more efficient than 'inputChunk' so you
 510 -- should use it whenever possible.
 511 inputChunk :: Int -> Resource String
 512 inputChunk limit = inputChunkBS limit >>= return . B.unpack
 513
 514
 515 -- | This is mostly the same as 'inputChunk' but is more
 516 -- efficient. See 'inputBS'.
 517 inputChunkBS :: Int -> Resource ByteString
 518 inputChunkBS limit
 519     = do driftTo GettingBody
 520          itr <- ask
 521          hasBody <- liftIO $ atomically $ readItr itr itrRequestHasBody id
 522          chunk   <- if hasBody then
 523                         askForInput itr
 524                     else
 525                         do driftTo DecidingHeader
 526                            return B.empty
 527          return chunk
 528     where
 529       askForInput :: Interaction -> Resource ByteString
 530       askForInput itr
 531           = do let defaultLimit = cnfMaxEntityLength $ itrConfig itr
 532                    actualLimit  = if limit < 0 then
 533                                       defaultLimit
 534                                   else
 535                                       limit
 536                when (actualLimit <= 0)
 537                         $ fail ("inputChunkBS: limit must be positive: " ++ show actualLimit)
 538                -- Reader にリクエスト
 539                liftIO $ atomically
 540                           $ do writeItr itr itrReqBodyWanted $ Just actualLimit
 541                                writeItr itr itrWillReceiveBody True
 542                -- 應答を待つ。トランザクションを分けなければ當然デッドロック。
 543                chunk <- liftIO $ atomically
 544                         $ do chunk <- readItr itr itrReceivedBody id
 545                              -- 要求された量に滿たなくて、まだ殘りがあ
 546                              -- るなら再試行。
 547                              when (B.length chunk < fromIntegral actualLimit)
 548                                       $ do chunkIsOver <- readItr itr itrReqChunkIsOver id
 549                                            unless chunkIsOver
 550                                                       $ retry
 551                              -- 成功
 552                              writeItr itr itrReceivedBody B.empty
 553                              return chunk
 554                when (B.null chunk)
 555                         $ driftTo DecidingHeader
 556                return chunk
 557
 558 -- | Computation of @'inputForm' limit@ attempts to read the request
 559 -- body with 'input' and parse it as
 560 -- application\/x-www-form-urlencoded. If the request header
 561 -- \"Content-Type\" is not application\/x-www-form-urlencoded,
 562 -- 'inputForm' makes 'Resource' abort with status \"415 Unsupported
 563 -- Media Type\". If the request has no \"Content-Type\", it aborts
 564 -- with \"400 Bad Request\".
 565 --
 566 -- This action should also support multipart\/form-data somehow, but
 567 -- it is not (yet) done.
 568 inputForm :: Int -> Resource [(String, String)]
 569 inputForm limit
 570     = do cTypeM <- getContentType
 571          case cTypeM of
 572            Nothing
 573                -> abort BadRequest [] (Just "Missing Content-Type")
 574            Just (MIMEType "application" "x-www-form-urlencoded" _)
 575                -> readWWWFormURLEncoded
 576            Just (MIMEType "multipart" "form-data" _)
 577                -> readMultipartFormData
 578            Just cType
 579                -> abort UnsupportedMediaType [] (Just $ "Unsupported media type: "
 580                                                           ++ show cType)
 581     where
 582       readWWWFormURLEncoded
 583           = do src <- input limit
 584                return $ parseWWWFormURLEncoded src
 585
 586       readMultipartFormData -- FIXME: 未對應
 587           = abort UnsupportedMediaType []
 588             (Just $ "Sorry, inputForm does not currently support multipart/form-data.")
 589
 590 -- | This is just a constant -1. It's better to say @'input'
 591 -- 'defaultLimit'@ than to say @'input' (-1)@ but these are exactly
 592 -- the same.
 593 defaultLimit :: Int
 594 defaultLimit = (-1)
 595
 596
 597
 598 {- DecidingHeader 時に使用するアクション群 -}
 599
 600 -- | Set the response status code. If you omit to compute this action,
 601 -- the status code will be defaulted to \"200 OK\".
 602 setStatus :: StatusCode -> Resource ()
 603 setStatus code
 604     = do driftTo DecidingHeader
 605          itr <- ask
 606          liftIO $ atomically $ updateItr itr itrResponse
 607                     $ \ res -> res {
 608                                  resStatus = code
 609                                }
 610
 611 -- | Set a value of given resource header. Comparison of header name
 612 -- is case-insensitive. Note that this action is not intended to be
 613 -- used so frequently: there should be actions like 'setContentType'
 614 -- for every common headers.
 615 --
 616 -- Some important headers (especially \"Content-Length\" and
 617 -- \"Transfer-Encoding\") may be silently dropped or overwritten by
 618 -- the system not to corrupt the interaction with client at the
 619 -- viewpoint of HTTP protocol layer. For instance, if we are keeping
 620 -- the connection alive, without this process it causes a catastrophe
 621 -- to send a header \"Content-Length: 10\" and actually send a body of
 622 -- 20 bytes long. In this case the client shall only accept the first
 623 -- 10 bytes of response body and thinks that the residual 10 bytes is
 624 -- a part of header of the next response.
 625 setHeader :: String -> String -> Resource ()
 626 setHeader name value
 627     = driftTo DecidingHeader >> setHeader' name value
 628
 629
 630 setHeader' :: String -> String -> Resource()
 631 setHeader' name value
 632     = do itr <- ask
 633          liftIO $ atomically
 634                     $ updateItr itr itrResponse
 635                           $ H.setHeader name value
 636
 637 -- | Computation of @'redirect' code uri@ sets the response status to
 638 -- @code@ and \"Location\" header to @uri@. @code@ must satisfy
 639 -- 'Network.HTTP.Lucu.Response.isRedirection' or it causes an error.
 640 redirect :: StatusCode -> URI -> Resource ()
 641 redirect code uri
 642     = do when (code == NotModified || not (isRedirection code))
 643                   $ abort InternalServerError []
 644                         $ Just ("Attempted to redirect with status " ++ show code)
 645          setStatus code
 646          setLocation uri
 647
 648 -- | Computation of @'setContentType' mType@ sets the response header
 649 -- \"Content-Type\" to @mType@.
 650 setContentType :: MIMEType -> Resource ()
 651 setContentType mType
 652     = setHeader "Content-Type" $ show mType
 653
 654 -- | Computation of @'setLocation' uri@ sets the response header
 655 -- \"Location\" to @uri@.
 656 setLocation :: URI -> Resource ()
 657 setLocation uri
 658     = setHeader "Location" $ uriToString id uri $ ""
 659
 660
 661 {- DecidingBody 時に使用するアクション群 -}
 662
 663 -- | Computation of @'output' str@ writes @str@ as a response body,
 664 -- and then make the 'Resource' transit to /Done/ state. It is safe to
 665 -- apply 'output' to an infinite string, such as a lazy stream of
 666 -- \/dev\/random.
 667 --
 668 -- Note that 'outputBS' is more efficient than 'output' so you should
 669 -- use it whenever possible.
 670 output :: String -> Resource ()
 671 output = outputBS . B.pack
 672
 673 -- | This is mostly the same as 'output' but is more efficient.
 674 outputBS :: ByteString -> Resource ()
 675 outputBS str = do outputChunkBS str
 676                   driftTo Done
 677
 678 -- | Computation of @'outputChunk' str@ writes @str@ as a part of
 679 -- response body. You can compute this action multiple times to write
 680 -- a body little at a time. It is safe to apply 'outputChunk' to an
 681 -- infinite string.
 682 --
 683 -- Note that 'outputChunkBS' is more efficient than 'outputChunk' so
 684 -- you should use it whenever possible.
 685 outputChunk :: String -> Resource ()
 686 outputChunk = outputChunkBS . B.pack
 687
 688 -- | This is mostly the same as 'outputChunk' but is more efficient.
 689 outputChunkBS :: ByteString -> Resource ()
 690 outputChunkBS str
 691     = do driftTo DecidingBody
 692          itr <- ask
 693
 694          let limit = cnfMaxOutputChunkLength $ itrConfig itr
 695          when (limit <= 0)
 696                   $ fail ("cnfMaxOutputChunkLength must be positive: "
 697                           ++ show limit)
 698
 699          discardBody <- liftIO $ atomically $
 700                         readItr itr itrWillDiscardBody id
 701
 702          unless (discardBody)
 703                     $ sendChunks str limit
 704
 705          unless (B.null str)
 706                     $ liftIO $ atomically $
 707                       writeItr itr itrBodyIsNull False
 708     where
 709       {- チャンクの大きさは Config で制限されてゐる。もし例へば
 710          /dev/zero を B.readFile して作った ByteString をそのまま
 711          ResponseWriter に渡したりすると大變な事が起こる。何故なら
 712          ResponseWriter はTransfer-Encoding: chunked の時、ヘッダを書く
 713          爲にチャンクの大きさを測るから、その時に起こるであらう事は言ふ
 714          までも無い。 -}
 715       sendChunks :: ByteString -> Int -> Resource ()
 716       sendChunks str limit
 717           | B.null str = return ()
 718           | otherwise  = do let (chunk, remaining) = B.splitAt (fromIntegral limit) str
 719                             itr <- ask
 720                             liftIO $ atomically $
 721                                    do buf <- readItr itr itrBodyToSend id
 722                                       if B.null buf then
 723                                           -- バッファが消化された
 724                                           writeItr itr itrBodyToSend chunk
 725                                         else
 726                                           -- 消化されるのを待つ
 727                                           retry
 728                             -- 殘りのチャンクについて繰り返す
 729                             sendChunks remaining limit
 730
 731 {-
 732
 733   [GettingBody からそれ以降の状態に遷移する時]
 734
 735   body を讀み終へてゐなければ、殘りの body を讀み捨てる。
 736
 737
 738   [DecidingHeader からそれ以降の状態に遷移する時]
 739
 740   postprocess する。
 741
 742
 743   [Done に遷移する時]
 744
 745   bodyIsNull が False ならば何もしない。True だった場合は出力補完す
 746   る。
 747
 748 -}
 749
 750 driftTo :: InteractionState -> Resource ()
 751 driftTo newState
 752     = do itr <- ask
 753          liftIO $ atomically $ do oldState <- readItr itr itrState id
 754                                   if newState < oldState then
 755                                       throwStateError oldState newState
 756                                     else
 757                                       do let a = [oldState .. newState]
 758                                              b = tail a
 759                                              c = zip a b
 760                                          mapM_ (uncurry $ drift itr) c
 761                                          writeItr itr itrState newState
 762     where
 763       throwStateError :: Monad m => InteractionState -> InteractionState -> m a
 764
 765       throwStateError Done DecidingBody
 766           = fail "It makes no sense to output something after finishing to output."
 767
 768       throwStateError old new
 769           = fail ("state error: " ++ show old ++ " ==> " ++ show new)
 770
 771
 772       drift :: Interaction -> InteractionState -> InteractionState -> STM ()
 773
 774       drift itr GettingBody _
 775           = writeItr itr itrReqBodyWasteAll True
 776
 777       drift itr DecidingHeader _
 778           = postprocess itr
 779
 780       drift itr _ Done
 781           = do bodyIsNull <- readItr itr itrBodyIsNull id
 782                when bodyIsNull
 783                         $ writeDefaultPage itr
 784
 785       drift _ _ _
 786           = return ()