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