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     , setETag
 108     , setLastModified
 109     , setContentType
 110
 111     -- ** Writing a response body
 112
 113     -- |Computation of these actions changes the state to /Deciding
 114     -- Body/.
 115     , output
 116     , outputChunk
 117     , outputBS
 118     , outputChunkBS
 119
 120     , driftTo
 121     )
 122     where
 123
 124 import           Control.Concurrent.STM
 125 import           Control.Monad.Reader
 126 import qualified Data.ByteString.Lazy.Char8 as B
 127 import           Data.ByteString.Lazy.Char8 (ByteString)
 128 import           Data.List
 129 import           Data.Maybe
 130 import           GHC.Conc (unsafeIOToSTM)
 131 import           Network.HTTP.Lucu.Abortion
 132 import           Network.HTTP.Lucu.Config
 133 import           Network.HTTP.Lucu.DefaultPage
 134 import           Network.HTTP.Lucu.ETag
 135 import qualified Network.HTTP.Lucu.Headers as H
 136 import           Network.HTTP.Lucu.HttpVersion
 137 import           Network.HTTP.Lucu.Interaction
 138 import           Network.HTTP.Lucu.Parser
 139 import           Network.HTTP.Lucu.Postprocess
 140 import           Network.HTTP.Lucu.RFC1123DateTime
 141 import           Network.HTTP.Lucu.Request
 142 import           Network.HTTP.Lucu.Response
 143 import           Network.HTTP.Lucu.MIMEType
 144 import           Network.HTTP.Lucu.Utils
 145 import           Network.URI
 146 import           System.Time
 147
 148 -- |The 'Resource' monad. /Interaction/ is an internal state thus it
 149 -- is not exposed to users. This monad implements 'MonadIO' so it can
 150 -- do any IO actions.
 151 type Resource a = ReaderT Interaction IO a
 152
 153 -- |Get the 'Network.HTTP.Lucu.Config.Config' value which is used for
 154 -- the httpd.
 155 getConfig :: Resource Config
 156 getConfig = do itr <- ask
 157                return $ itrConfig itr
 158
 159 -- |Get the 'Network.HTTP.Lucu.Request.Request' value which represents
 160 -- the request header. In general you don't have to use this action.
 161 getRequest :: Resource Request
 162 getRequest = do itr <- ask
 163                 return $ fromJust $ itrRequest itr
 164
 165 -- |Get the 'Network.HTTP.Lucu.Request.Method' value of the request.
 166 getMethod :: Resource Method
 167 getMethod = do req <- getRequest
 168                return $ reqMethod req
 169
 170 -- |Get the URI of the request.
 171 getRequestURI :: Resource URI
 172 getRequestURI = do req <- getRequest
 173                    return $ reqURI req
 174
 175 -- |Get the path of this 'Resource' (to be exact,
 176 -- 'Network.HTTP.Lucu.Resource.Tree.ResourceDef') in the
 177 -- 'Network.HTTP.Lucu.Resource.Tree.ResTree'. The result of this
 178 -- action is the exact path in the tree even if the
 179 -- 'Network.HTTP.Lucu.Resource.Tree.ResourceDef' is greedy.
 180 --
 181 -- Example:
 182 --
 183 -- > main = let tree = mkResTree [ (["foo"], resFoo) ]
 184 -- >        in runHttpd defaultConfig tree
 185 -- >
 186 -- > resFoo = ResourceDef {
 187 -- >     resIsGreedy = True
 188 -- >   , resGet = Just $ do requestURI   <- getRequestURI
 189 -- >                        resourcePath <- getResourcePath
 190 -- >                        pathInfo     <- getPathInfo
 191 -- >                        -- uriPath requestURI == "/foo/bar/baz"
 192 -- >                        -- resourcePath       == ["foo"]
 193 -- >                        -- pathInfo           == ["bar", "baz"]
 194 -- >                        ...
 195 -- >   , ...
 196 -- >   }
 197 getResourcePath :: Resource [String]
 198 getResourcePath = do itr <- ask
 199                      return $ fromJust $ itrResourcePath itr
 200
 201
 202 -- |This is an analogy of CGI PATH_INFO. Its result is always @[]@ if
 203 -- the 'Network.HTTP.Lucu.Resource.Tree.ResourceDef' is not
 204 -- greedy. See 'getResourcePath'.
 205 getPathInfo :: Resource [String]
 206 getPathInfo = do rsrcPath <- getResourcePath
 207                  reqURI   <- getRequestURI
 208                  let reqPathStr = uriPath reqURI
 209                      reqPath    = [x | x <- splitBy (== '/') reqPathStr, x /= ""]
 210                  -- rsrcPath と reqPath の共通する先頭部分を reqPath か
 211                  -- ら全部取り除くと、それは PATH_INFO のやうなものにな
 212                  -- る。rsrcPath は全部一致してゐるに決まってゐる（でな
 213                  -- ければこの Resource が撰ばれた筈が無い）ので、
 214                  -- rsrcPath の長さの分だけ削除すれば良い。
 215                  return $ drop (length rsrcPath) reqPath
 216
 217 -- |Get a value of given request header. Comparison of header name is
 218 -- case-insensitive. Note that this action is not intended to be used
 219 -- so frequently: there should be an action like 'getContentType' for
 220 -- every common headers.
 221 getHeader :: String -> Resource (Maybe String)
 222 getHeader name = do itr <- ask
 223                     return $ H.getHeader name $ fromJust $ itrRequest itr
 224
 225 -- |Get a list of 'Network.HTTP.Lucu.MIMEType.MIMEType' enumerated on
 226 -- header \"Accept\".
 227 getAccept :: Resource [MIMEType]
 228 getAccept = do accept <- getHeader "Accept"
 229                if accept == Nothing then
 230                    return []
 231                  else
 232                    case parseStr mimeTypeListP $ fromJust accept of
 233                      (Success xs, _) -> return xs
 234                      _               -> return []
 235
 236 -- |Get the header \"Content-Type\" as
 237 -- 'Network.HTTP.Lucu.MIMEType.MIMEType'.
 238 getContentType :: Resource (Maybe MIMEType)
 239 getContentType = do cType <- getHeader "Content-Type"
 240                     if cType == Nothing then
 241                         return Nothing
 242                       else
 243                         case parseStr mimeTypeP $ fromJust cType of
 244                           (Success t, _) -> return $ Just t
 245                           _              -> return Nothing
 246
 247
 248
 249 {- ExaminingRequest 時に使用するアクション群 -}
 250
 251 foundEntity :: ETag -> ClockTime -> Resource ()
 252 foundEntity tag timeStamp
 253     = do driftTo ExaminingRequest
 254
 255          method <- getMethod
 256          when (method == GET || method == HEAD)
 257                   $ setHeader' "Last-Modified" $ formatHTTPDateTime timeStamp
 258          foundETag tag
 259
 260          driftTo GettingBody
 261
 262
 263 foundETag :: ETag -> Resource ()
 264 foundETag tag
 265     = do driftTo ExaminingRequest
 266
 267          method <- getMethod
 268          when (method == GET || method == HEAD)
 269                   $ setHeader' "ETag" $ show tag
 270
 271          -- If-Match があればそれを見る。
 272          ifMatch <- getHeader "If-Match"
 273          case ifMatch of
 274            Nothing   -> return ()
 275            Just "*"  -> return ()
 276            Just list -> case parseStr eTagListP list of
 277                           (Success tags, _)
 278                               -- tags の中に一致するものが無ければ
 279                               -- PreconditionFailed で終了。
 280                               -> when (not $ any (== tag) tags)
 281                                  $ abort PreconditionFailed []
 282                                        $ Just ("The entity tag doesn't match: " ++ list)
 283                           _   -> abort BadRequest [] $ Just ("Unparsable If-Match: " ++ fromJust ifMatch)
 284
 285          let statusForNoneMatch = if method == GET || method == HEAD then
 286                                       NotModified
 287                                   else
 288                                       PreconditionFailed
 289
 290          -- If-None-Match があればそれを見る。
 291          ifNoneMatch <- getHeader "If-None-Match"
 292          case ifNoneMatch of
 293            Nothing   -> return ()
 294            Just "*"  -> abort statusForNoneMatch [] $ Just ("The entity tag matches: *")
 295            Just list -> case parseStr eTagListP list of
 296                           (Success tags, _)
 297                               -> when (any (== tag) tags)
 298                                  $ abort statusForNoneMatch [] $ Just ("The entity tag matches: " ++ list)
 299                           _   -> abort BadRequest [] $ Just ("Unparsable If-None-Match: " ++ list)
 300
 301          driftTo GettingBody
 302
 303
 304 foundTimeStamp :: ClockTime -> Resource ()
 305 foundTimeStamp timeStamp
 306     = do driftTo ExaminingRequest
 307
 308          method <- getMethod
 309          when (method == GET || method == HEAD)
 310                   $ setHeader' "Last-Modified" $ formatHTTPDateTime timeStamp
 311
 312          let statusForIfModSince = if method == GET || method == HEAD then
 313                                        NotModified
 314                                    else
 315                                        PreconditionFailed
 316
 317          -- If-Modified-Since があればそれを見る。
 318          ifModSince <- getHeader "If-Modified-Since"
 319          case ifModSince of
 320            Just str -> case parseHTTPDateTime str of
 321                          Just lastTime
 322                              -> when (timeStamp <= lastTime)
 323                                 $ abort statusForIfModSince []
 324                                       $ Just ("The entity has not been modified since " ++ str)
 325                          Nothing
 326                              -> return () -- 不正な時刻は無視
 327            Nothing  -> return ()
 328
 329          -- If-Unmodified-Since があればそれを見る。
 330          ifUnmodSince <- getHeader "If-Unmodified-Since"
 331          case ifUnmodSince of
 332            Just str -> case parseHTTPDateTime str of
 333                          Just lastTime
 334                              -> when (timeStamp > lastTime)
 335                                 $ abort PreconditionFailed []
 336                                       $ Just  ("The entity has not been modified since " ++ str)
 337                          Nothing
 338                              -> return () -- 不正な時刻は無視
 339            Nothing  -> return ()
 340
 341          driftTo GettingBody
 342
 343
 344 foundNoEntity :: Maybe String -> Resource ()
 345 foundNoEntity msgM
 346     = do driftTo ExaminingRequest
 347
 348          method <- getMethod
 349          when (method /= PUT)
 350               $ abort NotFound [] msgM
 351
 352          -- エンティティが存在しないと云ふ事は、"*" も含めたどのやうな
 353          -- If-Match: 條件も滿たさない。
 354          ifMatch <- getHeader "If-Match"
 355          when (ifMatch /= Nothing)
 356                   $ abort PreconditionFailed [] msgM
 357
 358          driftTo GettingBody
 359
 360
 361 {- GettingBody 時に使用するアクション群 -}
 362
 363 input :: Int -> Resource String
 364 input limit = inputBS limit >>= return . B.unpack
 365
 366
 367 -- 多くとも limit バイトまでのリクエストボディ全體を受信する。limit が
 368 -- 零以下なら Config で設定されたデフォルトのボディ長により制限される。
 369 inputBS :: Int -> Resource ByteString
 370 inputBS limit
 371     = do driftTo GettingBody
 372          itr     <- ask
 373          hasBody <- liftIO $ atomically $ readItr itr itrRequestHasBody id
 374          chunk   <- if hasBody then
 375                         askForInput itr
 376                     else
 377                         do driftTo DecidingHeader
 378                            return B.empty
 379          return chunk
 380     where
 381       askForInput :: Interaction -> Resource ByteString
 382       askForInput itr
 383           = do let defaultLimit = cnfMaxEntityLength $ itrConfig itr
 384                    actualLimit  = if limit <= 0 then
 385                                       defaultLimit
 386                                   else
 387                                       limit
 388                when (actualLimit <= 0)
 389                         $ fail ("inputBS: limit must be positive: " ++ show actualLimit)
 390                -- Reader にリクエスト
 391                liftIO $ atomically
 392                           $ do chunkLen <- readItr itr itrReqChunkLength id
 393                                writeItr itr itrWillReceiveBody True
 394                                if fmap (> actualLimit) chunkLen == Just True then
 395                                    -- 受信前から多過ぎる事が分かってゐる
 396                                    tooLarge actualLimit
 397                                  else
 398                                    writeItr itr itrReqBodyWanted $ Just actualLimit
 399                -- 應答を待つ。トランザクションを分けなければ當然デッドロック。
 400                chunk <- liftIO $ atomically
 401                         $ do chunk       <- readItr itr itrReceivedBody id
 402                              chunkIsOver <- readItr itr itrReqChunkIsOver id
 403                              if B.length chunk < fromIntegral actualLimit then
 404                                  -- 要求された量に滿たなくて、まだ殘り
 405                                  -- があるなら再試行。
 406                                  unless chunkIsOver
 407                                             $ retry
 408                                else
 409                                  -- 制限値一杯まで讀むやうに指示したの
 410                                  -- にまだ殘ってゐるなら、それは多過ぎ
 411                                  -- る。
 412                                  unless chunkIsOver
 413                                             $ tooLarge actualLimit
 414                              -- 成功。itr 内にチャンクを置いたままにす
 415                              -- るとメモリの無駄になるので除去。
 416                              writeItr itr itrReceivedBody B.empty
 417                              return chunk
 418                driftTo DecidingHeader
 419                return chunk
 420
 421       tooLarge :: Int -> STM ()
 422       tooLarge lim = abortSTM RequestEntityTooLarge []
 423                      $ Just ("Request body must be smaller than "
 424                              ++ show lim ++ " bytes.")
 425
 426
 427 inputChunk :: Int -> Resource String
 428 inputChunk limit = inputChunkBS limit >>= return . B.unpack
 429
 430
 431 -- 多くとも limit バイトまでのリクエストボディの一部を受信する。limit
 432 -- が 0 以下なら Config で設定されたデフォルトのボディ長により制限され
 433 -- る。これ以上ボディが殘ってゐなければ空文字列を返す。
 434 inputChunkBS :: Int -> Resource ByteString
 435 inputChunkBS limit
 436     = do driftTo GettingBody
 437          itr <- ask
 438          hasBody <- liftIO $ atomically $ readItr itr itrRequestHasBody id
 439          chunk   <- if hasBody then
 440                         askForInput itr
 441                     else
 442                         do driftTo DecidingHeader
 443                            return B.empty
 444          return chunk
 445     where
 446       askForInput :: Interaction -> Resource ByteString
 447       askForInput itr
 448           = do let defaultLimit = cnfMaxEntityLength $ itrConfig itr
 449                    actualLimit  = if limit < 0 then
 450                                       defaultLimit
 451                                   else
 452                                       limit
 453                when (actualLimit <= 0)
 454                         $ fail ("inputChunkBS: limit must be positive: " ++ show actualLimit)
 455                -- Reader にリクエスト
 456                liftIO $ atomically
 457                           $ do writeItr itr itrReqBodyWanted $ Just actualLimit
 458                                writeItr itr itrWillReceiveBody True
 459                -- 應答を待つ。トランザクションを分けなければ當然デッドロック。
 460                chunk <- liftIO $ atomically
 461                         $ do chunk <- readItr itr itrReceivedBody id
 462                              -- 要求された量に滿たなくて、まだ殘りがあ
 463                              -- るなら再試行。
 464                              when (B.length chunk < fromIntegral actualLimit)
 465                                       $ do chunkIsOver <- readItr itr itrReqChunkIsOver id
 466                                            unless chunkIsOver
 467                                                       $ retry
 468                              -- 成功
 469                              writeItr itr itrReceivedBody B.empty
 470                              return chunk
 471                when (B.null chunk)
 472                         $ driftTo DecidingHeader
 473                return chunk
 474
 475
 476 -- application/x-www-form-urlencoded または multipart/form-data をパー
 477 -- スする。もし Content-Type が無かったら BadRequest で終了し、未對應の
 478 -- タイプであったら UnsupportedMediaType で終了する。
 479 inputForm :: Int -> Resource [(String, String)]
 480 inputForm limit
 481     = do cTypeM <- getContentType
 482          case cTypeM of
 483            Nothing
 484                -> abort BadRequest [] (Just "Missing Content-Type")
 485            Just (MIMEType "application" "x-www-form-urlencoded" _)
 486                -> readWWWFormURLEncoded
 487            Just (MIMEType "multipart" "form-data" _)
 488                -> readMultipartFormData
 489            Just cType
 490                -> abort UnsupportedMediaType [] (Just $ "Unsupported media type: "
 491                                                           ++ show cType)
 492     where
 493       readWWWFormURLEncoded
 494           = do src <- input limit
 495                return $ do pairStr <- splitBy (\ c -> c == ';' || c == '&') src
 496                            let pair = break (== '=') pairStr
 497                            return ( unEscapeString $ fst pair
 498                                   , unEscapeString $ snd pair
 499                                   )
 500       readMultipartFormData -- FIXME: 未對應
 501           = abort UnsupportedMediaType []
 502             (Just $ "Sorry, inputForm does not currently support multipart/form-data.")
 503
 504
 505 defaultLimit :: Int
 506 defaultLimit = (-1)
 507
 508
 509
 510 {- DecidingHeader 時に使用するアクション群 -}
 511
 512 setStatus :: StatusCode -> Resource ()
 513 setStatus code
 514     = do driftTo DecidingHeader
 515          itr <- ask
 516          liftIO $ atomically $ updateItr itr itrResponse
 517                     $ \ res -> res {
 518                                  resStatus = code
 519                                }
 520
 521
 522 setHeader :: String -> String -> Resource ()
 523 setHeader name value
 524     = driftTo DecidingHeader >> setHeader' name value
 525
 526
 527 setHeader' :: String -> String -> Resource()
 528 setHeader' name value
 529     = do itr <- ask
 530          liftIO $ atomically
 531                     $ updateItr itr itrResponse
 532                           $ H.setHeader name value
 533
 534
 535 redirect :: StatusCode -> URI -> Resource ()
 536 redirect code uri
 537     = do when (code == NotModified || not (isRedirection code))
 538                   $ abort InternalServerError []
 539                         $ Just ("Attempted to redirect with status " ++ show code)
 540          setStatus code
 541          setHeader "Location" (uriToString id uri $ "")
 542
 543
 544 setETag :: ETag -> Resource ()
 545 setETag tag
 546     = setHeader "ETag" $ show tag
 547
 548
 549 setLastModified :: ClockTime -> Resource ()
 550 setLastModified lastmod
 551     = setHeader "Last-Modified" $ formatHTTPDateTime lastmod
 552
 553
 554 setContentType :: MIMEType -> Resource ()
 555 setContentType mType
 556     = setHeader "Content-Type" $ show mType
 557
 558
 559 {- DecidingBody 時に使用するアクション群 -}
 560
 561 output :: String -> Resource ()
 562 output = outputBS . B.pack
 563
 564
 565 outputBS :: ByteString -> Resource ()
 566 outputBS str = do outputChunkBS str
 567                   driftTo Done
 568
 569
 570 outputChunk :: String -> Resource ()
 571 outputChunk = outputChunkBS . B.pack
 572
 573
 574 {- チャンクの大きさは Config で制限されてゐる。もし例へば /dev/zero を
 575    B.readFile して作った ByteString をそのまま ResponseWriter に渡した
 576    りすると大變な事が起こる。何故なら ResponseWriter は
 577    Transfer-Encoding: chunked の時、ヘッダを書く爲にチャンクの大きさを
 578    測るから、その時に起こるであらう事は言ふまでも無い。 -}
 579
 580 outputChunkBS :: ByteString -> Resource ()
 581 outputChunkBS str
 582     = do driftTo DecidingBody
 583          itr <- ask
 584
 585          let limit = cnfMaxOutputChunkLength $ itrConfig itr
 586          when (limit <= 0)
 587                   $ fail ("cnfMaxOutputChunkLength must be positive: "
 588                           ++ show limit)
 589
 590          discardBody <- liftIO $ atomically $
 591                         readItr itr itrWillDiscardBody id
 592
 593          unless (discardBody)
 594                     $ sendChunks str limit
 595
 596          unless (B.null str)
 597                     $ liftIO $ atomically $
 598                       writeItr itr itrBodyIsNull False
 599     where
 600       sendChunks :: ByteString -> Int -> Resource ()
 601       sendChunks str limit
 602           | B.null str = return ()
 603           | otherwise  = do let (chunk, remaining) = B.splitAt (fromIntegral limit) str
 604                             itr <- ask
 605                             liftIO $ atomically $
 606                                    do buf <- readItr itr itrBodyToSend id
 607                                       if B.null buf then
 608                                           -- バッファが消化された
 609                                           writeItr itr itrBodyToSend chunk
 610                                         else
 611                                           -- 消化されるのを待つ
 612                                           retry
 613                             -- 殘りのチャンクについて繰り返す
 614                             sendChunks remaining limit
 615
 616 {-
 617
 618   [GettingBody からそれ以降の状態に遷移する時]
 619
 620   body を讀み終へてゐなければ、殘りの body を讀み捨てる。
 621
 622
 623   [DecidingHeader からそれ以降の状態に遷移する時]
 624
 625   postprocess する。
 626
 627
 628   [Done に遷移する時]
 629
 630   bodyIsNull が False ならば何もしない。True だった場合は出力補完す
 631   る。
 632
 633 -}
 634
 635 driftTo :: InteractionState -> Resource ()
 636 driftTo newState
 637     = do itr <- ask
 638          liftIO $ atomically $ do oldState <- readItr itr itrState id
 639                                   if newState < oldState then
 640                                       throwStateError oldState newState
 641                                     else
 642                                       do let a = [oldState .. newState]
 643                                              b = tail a
 644                                              c = zip a b
 645                                          mapM_ (uncurry $ drift itr) c
 646                                          writeItr itr itrState newState
 647     where
 648       throwStateError :: Monad m => InteractionState -> InteractionState -> m a
 649
 650       throwStateError Done DecidingBody
 651           = fail "It makes no sense to output something after finishing to output."
 652
 653       throwStateError old new
 654           = fail ("state error: " ++ show old ++ " ==> " ++ show new)
 655
 656
 657       drift :: Interaction -> InteractionState -> InteractionState -> STM ()
 658
 659       drift itr GettingBody _
 660           = writeItr itr itrReqBodyWasteAll True
 661
 662       drift itr DecidingHeader _
 663           = postprocess itr
 664
 665       drift itr _ Done
 666           = do bodyIsNull <- readItr itr itrBodyIsNull id
 667                when bodyIsNull
 668                         $ writeDefaultPage itr
 669
 670       drift _ _ _
 671           = return ()