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