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