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