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