Network/HTTP/Lucu/Resource.hs

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