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