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