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