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