Network/HTTP/Lucu/Resource.hs

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