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