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