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. This action
 306 -- doesn't parse the request body. See 'inputForm'.
 307 getQueryForm :: Resource [FormData]
 308 getQueryForm = do uri <- getRequestURI
 309                   return $! map pairToFormData $ parseWWWFormURLEncoded $ snd $ splitAt 1 $ uriQuery uri
 310
 311 pairToFormData :: (String, String) -> FormData
 312 pairToFormData (name, value)
 313     = FormData {
 314         fdName     = name
 315       , fdFileName = Nothing
 316       , fdContent  = L8.pack value
 317       }
 318
 319 -- |Get a value of given request header. Comparison of header name is
 320 -- case-insensitive. Note that this action is not intended to be used
 321 -- so frequently: there should be actions like 'getContentType' for
 322 -- every common headers.
 323 getHeader :: Strict.ByteString -> Resource (Maybe Strict.ByteString)
 324 getHeader name = name `seq`
 325                  do req <- getRequest
 326                     return $! H.getHeader name req
 327
 328 -- |Get a list of 'Network.HTTP.Lucu.MIMEType.MIMEType' enumerated on
 329 -- header \"Accept\".
 330 getAccept :: Resource [MIMEType]
 331 getAccept = do acceptM <- getHeader (C8.pack "Accept")
 332                case acceptM of
 333                  Nothing
 334                      -> return []
 335                  Just accept
 336                      -> case parse mimeTypeListP (L8.fromChunks [accept]) of
 337                           (# Success xs, _ #) -> return xs
 338                           (# _         , _ #) -> abort BadRequest []
 339                                                  (Just $ "Unparsable Accept: " ++ C8.unpack accept)
 340
 341 -- |Get a list of @(contentCoding, qvalue)@ enumerated on header
 342 -- \"Accept-Encoding\". The list is sorted in descending order by
 343 -- qvalue.
 344 getAcceptEncoding :: Resource [(String, Maybe Double)]
 345 getAcceptEncoding
 346     = do accEncM <- getHeader (C8.pack "Accept-Encoding")
 347          case accEncM of
 348            Nothing
 349                -- HTTP/1.0 には Accept-Encoding が無い場合の規定が無い
 350                -- ので安全の爲 identity が指定された事にする。HTTP/1.1
 351                -- の場合は何でも受け入れて良い事になってゐるので "*" が
 352                -- 指定された事にする。
 353                -> do ver <- getRequestVersion
 354                      case ver of
 355                        HttpVersion 1 0 -> return [("identity", Nothing)]
 356                        HttpVersion 1 1 -> return [("*"       , Nothing)]
 357                        _               -> undefined
 358            Just value
 359                -> if C8.null value then
 360                       -- identity のみが許される。
 361                       return [("identity", Nothing)]
 362                   else
 363                       case parse acceptEncodingListP (L8.fromChunks [value]) of
 364                         (# Success x, _ #) -> return $ reverse $ sortBy orderAcceptEncodings x
 365                         (# _        , _ #) -> abort BadRequest []
 366                                               (Just $ "Unparsable Accept-Encoding: " ++ C8.unpack value)
 367
 368 -- |Check whether a given content-coding is acceptable.
 369 isEncodingAcceptable :: String -> Resource Bool
 370 isEncodingAcceptable coding
 371     = do accList <- getAcceptEncoding
 372          return (flip any accList $ \ (c, q) ->
 373                      (c == "*" || C8.pack c `H.noCaseEq` C8.pack coding) && q /= Just 0)
 374
 375
 376 -- |Get the header \"Content-Type\" as
 377 -- 'Network.HTTP.Lucu.MIMEType.MIMEType'.
 378 getContentType :: Resource (Maybe MIMEType)
 379 getContentType
 380     = do cTypeM <- getHeader (C8.pack "Content-Type")
 381          case cTypeM of
 382            Nothing
 383                -> return Nothing
 384            Just cType
 385                -> case parse mimeTypeP (L8.fromChunks [cType]) of
 386                     (# Success t, _ #) -> return $ Just t
 387                     (# _        , _ #) -> abort BadRequest []
 388                                           (Just $ "Unparsable Content-Type: " ++ C8.unpack cType)
 389
 390
 391 -- |Get the header \"Authorization\" as
 392 -- 'Network.HTTP.Lucu.Authorization.AuthCredential'.
 393 getAuthorization :: Resource (Maybe AuthCredential)
 394 getAuthorization
 395     = do authM <- getHeader (C8.pack "Authorization")
 396          case authM of
 397            Nothing
 398                -> return Nothing
 399            Just auth
 400                -> case parse authCredentialP (L8.fromChunks [auth]) of
 401                     (# Success a, _ #) -> return $ Just a
 402                     (# _        , _ #) -> return Nothing
 403
 404
 405 {- ExaminingRequest 時に使用するアクション群 -}
 406
 407 -- |Tell the system that the 'Resource' found an entity for the
 408 -- request URI. If this is a GET or HEAD request, a found entity means
 409 -- a datum to be replied. If this is a PUT or DELETE request, it means
 410 -- a datum which was stored for the URI up to now. It is an error to
 411 -- compute 'foundEntity' if this is a POST request.
 412 --
 413 -- Computation of 'foundEntity' performs \"If-Match\" test or
 414 -- \"If-None-Match\" test if possible. When those tests fail, the
 415 -- computation of 'Resource' immediately aborts with status \"412
 416 -- Precondition Failed\" or \"304 Not Modified\" depending on the
 417 -- situation.
 418 --
 419 -- If this is a GET or HEAD request, 'foundEntity' automatically puts
 420 -- \"ETag\" and \"Last-Modified\" headers into the response.
 421 foundEntity :: ETag -> UTCTime -> Resource ()
 422 foundEntity tag timeStamp
 423     = tag `seq` timeStamp `seq`
 424       do driftTo ExaminingRequest
 425
 426          method <- getMethod
 427          when (method == GET || method == HEAD)
 428                   $ setHeader' (C8.pack "Last-Modified") (C8.pack $ HTTP.format timeStamp)
 429          when (method == POST)
 430                   $ abort InternalServerError []
 431                         (Just "Illegal computation of foundEntity for POST request.")
 432          foundETag tag
 433
 434          driftTo GettingBody
 435
 436 -- |Tell the system that the 'Resource' found an entity for the
 437 -- request URI. The only difference from 'foundEntity' is that
 438 -- 'foundETag' doesn't (and can't) put \"Last-Modified\" header into
 439 -- the response.
 440 --
 441 -- This action is not preferred. You should use 'foundEntity' whenever
 442 -- possible.
 443 foundETag :: ETag -> Resource ()
 444 foundETag tag
 445     = tag `seq`
 446       do driftTo ExaminingRequest
 447
 448          method <- getMethod
 449          when (method == GET || method == HEAD)
 450                   $ setHeader' (C8.pack "ETag") (C8.pack $ show tag)
 451          when (method == POST)
 452                   $ abort InternalServerError []
 453                         (Just "Illegal computation of foundETag for POST request.")
 454
 455          -- If-Match があればそれを見る。
 456          ifMatch <- getHeader (C8.pack "If-Match")
 457          case ifMatch of
 458            Nothing    -> return ()
 459            Just value -> if value == C8.pack "*" then
 460                              return ()
 461                          else
 462                              case parse eTagListP (L8.fromChunks [value]) of
 463                                (# Success tags, _ #)
 464                                  -- tags の中に一致するものが無ければ
 465                                  -- PreconditionFailed で終了。
 466                                  -> when (not $ any (== tag) tags)
 467                                     $ abort PreconditionFailed []
 468                                           $! Just ("The entity tag doesn't match: " ++ C8.unpack value)
 469                                (# _, _ #)
 470                                    -> abort BadRequest [] $! Just ("Unparsable If-Match: " ++ C8.unpack value)
 471
 472          let statusForNoneMatch = if method == GET || method == HEAD then
 473                                       NotModified
 474                                   else
 475                                       PreconditionFailed
 476
 477          -- If-None-Match があればそれを見る。
 478          ifNoneMatch <- getHeader (C8.pack "If-None-Match")
 479          case ifNoneMatch of
 480            Nothing    -> return ()
 481            Just value -> if value == C8.pack "*" then
 482                              abort statusForNoneMatch [] $! Just ("The entity tag matches: *")
 483                          else
 484                              case parse eTagListP (L8.fromChunks [value]) of
 485                                (# Success tags, _ #)
 486                                    -> when (any (== tag) tags)
 487                                       $ abort statusForNoneMatch [] $! Just ("The entity tag matches: " ++ C8.unpack value)
 488                                (# _, _ #)
 489                                    -> abort BadRequest [] $! Just ("Unparsable If-None-Match: " ++ C8.unpack value)
 490
 491          driftTo GettingBody
 492
 493 -- |Tell the system that the 'Resource' found an entity for the
 494 -- request URI. The only difference from 'foundEntity' is that
 495 -- 'foundTimeStamp' performs \"If-Modified-Since\" test or
 496 -- \"If-Unmodified-Since\" test instead of \"If-Match\" test or
 497 -- \"If-None-Match\" test. Be aware that any tests based on last
 498 -- modification time are unsafe because it is possible to mess up such
 499 -- tests by modifying the entity twice in a second.
 500 --
 501 -- This action is not preferred. You should use 'foundEntity' whenever
 502 -- possible.
 503 foundTimeStamp :: UTCTime -> Resource ()
 504 foundTimeStamp timeStamp
 505     = timeStamp `seq`
 506       do driftTo ExaminingRequest
 507
 508          method <- getMethod
 509          when (method == GET || method == HEAD)
 510                   $ setHeader' (C8.pack "Last-Modified") (C8.pack $ HTTP.format timeStamp)
 511          when (method == POST)
 512                   $ abort InternalServerError []
 513                         (Just "Illegal computation of foundTimeStamp for POST request.")
 514
 515          let statusForIfModSince = if method == GET || method == HEAD then
 516                                        NotModified
 517                                    else
 518                                        PreconditionFailed
 519
 520          -- If-Modified-Since があればそれを見る。
 521          ifModSince <- getHeader (C8.pack "If-Modified-Since")
 522          case ifModSince of
 523            Just str -> case HTTP.parse (C8.unpack str) of
 524                          Just lastTime
 525                              -> when (timeStamp <= lastTime)
 526                                 $ abort statusForIfModSince []
 527                                       $! Just ("The entity has not been modified since " ++ C8.unpack str)
 528                          Nothing
 529                              -> return () -- 不正な時刻は無視
 530            Nothing  -> return ()
 531
 532          -- If-Unmodified-Since があればそれを見る。
 533          ifUnmodSince <- getHeader (C8.pack "If-Unmodified-Since")
 534          case ifUnmodSince of
 535            Just str -> case HTTP.parse (C8.unpack str) of
 536                          Just lastTime
 537                              -> when (timeStamp > lastTime)
 538                                 $ abort PreconditionFailed []
 539                                       $! Just  ("The entity has not been modified since " ++ C8.unpack str)
 540                          Nothing
 541                              -> return () -- 不正な時刻は無視
 542            Nothing  -> return ()
 543
 544          driftTo GettingBody
 545
 546 -- | Computation of @'foundNoEntity' mStr@ tells the system that the
 547 -- 'Resource' found no entity for the request URI. @mStr@ is an
 548 -- optional error message to be replied to the client.
 549 --
 550 -- If this is a PUT request, 'foundNoEntity' performs \"If-Match\"
 551 -- test and aborts with status \"412 Precondition Failed\" when it
 552 -- failed. If this is a GET, HEAD, POST or DELETE request,
 553 -- 'foundNoEntity' always aborts with status \"404 Not Found\".
 554 foundNoEntity :: Maybe String -> Resource ()
 555 foundNoEntity msgM
 556     = msgM `seq`
 557       do driftTo ExaminingRequest
 558
 559          method <- getMethod
 560          when (method /= PUT)
 561                   $ abort NotFound [] msgM
 562
 563          -- エンティティが存在しないと云ふ事は、"*" も含めたどのやうな
 564          -- If-Match: 條件も滿たさない。
 565          ifMatch <- getHeader (C8.pack "If-Match")
 566          when (ifMatch /= Nothing)
 567                   $ abort PreconditionFailed [] msgM
 568
 569          driftTo GettingBody
 570
 571
 572 {- GettingBody 時に使用するアクション群 -}
 573
 574 -- | Computation of @'input' limit@ attempts to read the request body
 575 -- up to @limit@ bytes, and then make the 'Resource' transit to
 576 -- /Deciding Header/ state. When the actual size of body is larger
 577 -- than @limit@ bytes, computation of 'Resource' immediately aborts
 578 -- with status \"413 Request Entity Too Large\". When the request has
 579 -- no body, 'input' returns an empty string.
 580 --
 581 -- @limit@ may be less than or equal to zero. In this case, the
 582 -- default limitation value
 583 -- ('Network.HTTP.Lucu.Config.cnfMaxEntityLength') is used. See
 584 -- 'defaultLimit'.
 585 --
 586 -- Note that 'inputLBS' is more efficient than 'input' so you should
 587 -- use it whenever possible.
 588 input :: Int -> Resource String
 589 input limit = limit `seq`
 590               inputLBS limit >>= return . L8.unpack
 591
 592
 593 -- | This is mostly the same as 'input' but is more
 594 -- efficient. 'inputLBS' returns a 'Data.ByteString.Lazy.ByteString'
 595 -- but it's not really lazy: reading from the socket just happens at
 596 -- the computation of 'inputLBS', not at the evaluation of the
 597 -- 'Data.ByteString.Lazy.ByteString'. The same goes for
 598 -- 'inputChunkLBS'.
 599 inputLBS :: Int -> Resource Lazy.ByteString
 600 inputLBS limit
 601     = limit `seq`
 602       do driftTo GettingBody
 603          itr     <- getInteraction
 604          hasBody <- liftIO $! atomically $! readItr itr itrRequestHasBody id
 605          chunk   <- if hasBody then
 606                         askForInput itr
 607                     else
 608                         do driftTo DecidingHeader
 609                            return L8.empty
 610          return chunk
 611     where
 612       askForInput :: Interaction -> Resource Lazy.ByteString
 613       askForInput itr
 614           = itr `seq`
 615             do let confLimit   = cnfMaxEntityLength $ itrConfig itr
 616                    actualLimit = if limit <= 0 then
 617                                      confLimit
 618                                  else
 619                                      limit
 620                when (actualLimit <= 0)
 621                         $ fail ("inputLBS: limit must be positive: " ++ show actualLimit)
 622                -- Reader にリクエスト
 623                liftIO $! atomically
 624                           $! do chunkLen <- readItr itr itrReqChunkLength id
 625                                 writeItr itr itrWillReceiveBody True
 626                                 if fmap (> actualLimit) chunkLen == Just True then
 627                                     -- 受信前から多過ぎる事が分かってゐる
 628                                     tooLarge actualLimit
 629                                   else
 630                                     writeItr itr itrReqBodyWanted $ Just actualLimit
 631                -- 應答を待つ。トランザクションを分けなければ當然デッドロック。
 632                chunk <- liftIO $! atomically
 633                         $! do chunk       <- readItr itr itrReceivedBody id
 634                               chunkIsOver <- readItr itr itrReqChunkIsOver id
 635                               if L8.length chunk < fromIntegral actualLimit then
 636                                   -- 要求された量に滿たなくて、まだ殘り
 637                                   -- があるなら再試行。
 638                                   unless chunkIsOver
 639                                              $ retry
 640                                 else
 641                                   -- 制限値一杯まで讀むやうに指示したの
 642                                   -- にまだ殘ってゐるなら、それは多過ぎ
 643                                   -- る。
 644                                   unless chunkIsOver
 645                                              $ tooLarge actualLimit
 646                               -- 成功。itr 内にチャンクを置いたままにす
 647                               -- るとメモリの無駄になるので除去。
 648                               writeItr itr itrReceivedBody L8.empty
 649                               return chunk
 650                driftTo DecidingHeader
 651                return chunk
 652
 653       tooLarge :: Int -> STM ()
 654       tooLarge lim = lim `seq`
 655                      abortSTM RequestEntityTooLarge []
 656                      $! Just ("Request body must be smaller than "
 657                               ++ show lim ++ " bytes.")
 658
 659 -- | Computation of @'inputChunk' limit@ attempts to read a part of
 660 -- request body up to @limit@ bytes. You can read any large request by
 661 -- repeating computation of this action. When you've read all the
 662 -- request body, 'inputChunk' returns an empty string and then make
 663 -- the 'Resource' transit to /Deciding Header/ state.
 664 --
 665 -- @limit@ may be less than or equal to zero. In this case, the
 666 -- default limitation value
 667 -- ('Network.HTTP.Lucu.Config.cnfMaxEntityLength') is used. See
 668 -- 'defaultLimit'.
 669 --
 670 -- Note that 'inputChunkLBS' is more efficient than 'inputChunk' so you
 671 -- should use it whenever possible.
 672 inputChunk :: Int -> Resource String
 673 inputChunk limit = limit `seq`
 674                    inputChunkLBS limit >>= return . L8.unpack
 675
 676
 677 -- | This is mostly the same as 'inputChunk' but is more
 678 -- efficient. See 'inputLBS'.
 679 inputChunkLBS :: Int -> Resource Lazy.ByteString
 680 inputChunkLBS limit
 681     = limit `seq`
 682       do driftTo GettingBody
 683          itr     <- getInteraction
 684          hasBody <- liftIO $ atomically $ readItr itr itrRequestHasBody id
 685          chunk   <- if hasBody then
 686                         askForInput itr
 687                     else
 688                         do driftTo DecidingHeader
 689                            return L8.empty
 690          return chunk
 691     where
 692       askForInput :: Interaction -> Resource Lazy.ByteString
 693       askForInput itr
 694           = itr `seq`
 695             do let confLimit   = cnfMaxEntityLength $! itrConfig itr
 696                    actualLimit = if limit < 0 then
 697                                       confLimit
 698                                   else
 699                                       limit
 700                when (actualLimit <= 0)
 701                         $ fail ("inputChunkLBS: limit must be positive: " ++ show actualLimit)
 702                -- Reader にリクエスト
 703                liftIO $! atomically
 704                           $! do writeItr itr itrReqBodyWanted $! Just actualLimit
 705                                 writeItr itr itrWillReceiveBody True
 706                -- 應答を待つ。トランザクションを分けなければ當然デッドロック。
 707                chunk <- liftIO $! atomically
 708                         $ do chunk <- readItr itr itrReceivedBody id
 709                              -- 要求された量に滿たなくて、まだ殘りがあ
 710                              -- るなら再試行。
 711                              when (L8.length chunk < fromIntegral actualLimit)
 712                                       $ do chunkIsOver <- readItr itr itrReqChunkIsOver id
 713                                            unless chunkIsOver
 714                                                       $ retry
 715                              -- 成功
 716                              writeItr itr itrReceivedBody L8.empty
 717                              return chunk
 718                when (L8.null chunk)
 719                         $ driftTo DecidingHeader
 720                return chunk
 721
 722 -- | Computation of @'inputForm' limit@ attempts to read the request
 723 -- body with 'input' and parse it as
 724 -- application\/x-www-form-urlencoded or multipart\/form-data. If the
 725 -- request header \"Content-Type\" is neither of them, 'inputForm'
 726 -- makes 'Resource' abort with status \"415 Unsupported Media
 727 -- Type\". If the request has no \"Content-Type\", it aborts with
 728 -- \"400 Bad Request\".
 729 inputForm :: Int -> Resource [FormData]
 730 inputForm limit
 731     = limit `seq`
 732       do cTypeM <- getContentType
 733          case cTypeM of
 734            Nothing
 735                -> abort BadRequest [] (Just "Missing Content-Type")
 736            Just (MIMEType "application" "x-www-form-urlencoded" _)
 737                -> readWWWFormURLEncoded
 738            Just (MIMEType "multipart" "form-data" params)
 739                -> readMultipartFormData params
 740            Just cType
 741                -> abort UnsupportedMediaType [] (Just $! "Unsupported media type: "
 742                                                           ++ show cType)
 743     where
 744       readWWWFormURLEncoded
 745           = do src <- input limit
 746                return $ map pairToFormData $ parseWWWFormURLEncoded src
 747
 748       readMultipartFormData params
 749           = do case find ((== "boundary") . map toLower . fst) params of
 750                  Nothing
 751                      -> abort BadRequest [] (Just "Missing boundary of multipart/form-data")
 752                  Just (_, boundary)
 753                      -> do src <- inputLBS limit
 754                            case parse (multipartFormP boundary) src of
 755                              (# Success fdList, _ #) -> return fdList
 756                              (# _, _ #)
 757                                  -> abort BadRequest [] (Just "Unparsable multipart/form-data")
 758
 759 -- | This is just a constant @-1@. It's better to say @'input'
 760 -- 'defaultLimit'@ than to say @'input' (-1)@ but these are exactly
 761 -- the same.
 762 defaultLimit :: Int
 763 defaultLimit = (-1)
 764
 765
 766
 767 {- DecidingHeader 時に使用するアクション群 -}
 768
 769 -- | Set the response status code. If you omit to compute this action,
 770 -- the status code will be defaulted to \"200 OK\".
 771 setStatus :: StatusCode -> Resource ()
 772 setStatus code
 773     = code `seq`
 774       do driftTo DecidingHeader
 775          itr <- getInteraction
 776          liftIO $! atomically $! updateItr itr itrResponse
 777                     $! \ res -> res {
 778                                   resStatus = code
 779                                 }
 780
 781 -- | Set a value of given resource header. Comparison of header name
 782 -- is case-insensitive. Note that this action is not intended to be
 783 -- used so frequently: there should be actions like 'setContentType'
 784 -- for every common headers.
 785 --
 786 -- Some important headers (especially \"Content-Length\" and
 787 -- \"Transfer-Encoding\") may be silently dropped or overwritten by
 788 -- the system not to corrupt the interaction with client at the
 789 -- viewpoint of HTTP protocol layer. For instance, if we are keeping
 790 -- the connection alive, without this process it causes a catastrophe
 791 -- to send a header \"Content-Length: 10\" and actually send a body of
 792 -- 20 bytes long. In this case the client shall only accept the first
 793 -- 10 bytes of response body and thinks that the residual 10 bytes is
 794 -- a part of header of the next response.
 795 setHeader :: Strict.ByteString -> Strict.ByteString -> Resource ()
 796 setHeader name value
 797     = name `seq` value `seq`
 798       driftTo DecidingHeader >> setHeader' name value
 799
 800
 801 setHeader' :: Strict.ByteString -> Strict.ByteString -> Resource ()
 802 setHeader' name value
 803     = name `seq` value `seq`
 804       do itr <- getInteraction
 805          liftIO $ atomically
 806                     $ updateItr itr itrResponse
 807                           $ H.setHeader name value
 808
 809 -- | Computation of @'redirect' code uri@ sets the response status to
 810 -- @code@ and \"Location\" header to @uri@. The @code@ must satisfy
 811 -- 'Network.HTTP.Lucu.Response.isRedirection' or it causes an error.
 812 redirect :: StatusCode -> URI -> Resource ()
 813 redirect code uri
 814     = code `seq` uri `seq`
 815       do when (code == NotModified || not (isRedirection code))
 816                   $ abort InternalServerError []
 817                         $! Just ("Attempted to redirect with status " ++ show code)
 818          setStatus code
 819          setLocation uri
 820 {-# INLINE redirect #-}
 821
 822
 823 -- | Computation of @'setContentType' mType@ sets the response header
 824 -- \"Content-Type\" to @mType@.
 825 setContentType :: MIMEType -> Resource ()
 826 setContentType mType
 827     = setHeader (C8.pack "Content-Type") (C8.pack $ show mType)
 828
 829 -- | Computation of @'setLocation' uri@ sets the response header
 830 -- \"Location\" to @uri@.
 831 setLocation :: URI -> Resource ()
 832 setLocation uri
 833     = setHeader (C8.pack "Location") (C8.pack $ uriToString id uri $ "")
 834
 835 -- |Computation of @'setContentEncoding' codings@ sets the response
 836 -- header \"Content-Encoding\" to @codings@.
 837 setContentEncoding :: [String] -> Resource ()
 838 setContentEncoding codings
 839     = do ver <- getRequestVersion
 840          let tr = case ver of
 841                     HttpVersion 1 0 -> unnormalizeCoding
 842                     HttpVersion 1 1 -> id
 843                     _               -> undefined
 844          setHeader (C8.pack "Content-Encoding") (C8.pack $ joinWith ", " $ map tr codings)
 845
 846 -- |Computation of @'setWWWAuthenticate' challenge@ sets the response
 847 -- header \"WWW-Authenticate\" to @challenge@.
 848 setWWWAuthenticate :: AuthChallenge -> Resource ()
 849 setWWWAuthenticate challenge
 850     = setHeader (C8.pack "WWW-Authenticate") (C8.pack $ show challenge)
 851
 852
 853 {- DecidingBody 時に使用するアクション群 -}
 854
 855 -- | Computation of @'output' str@ writes @str@ as a response body,
 856 -- and then make the 'Resource' transit to /Done/ state. It is safe to
 857 -- apply 'output' to an infinite string, such as a lazy stream of
 858 -- \/dev\/random.
 859 --
 860 -- Note that 'outputLBS' is more efficient than 'output' so you should
 861 -- use it whenever possible.
 862 output :: String -> Resource ()
 863 output str = outputLBS $! L8.pack str
 864 {-# INLINE output #-}
 865
 866 -- | This is mostly the same as 'output' but is more efficient.
 867 outputLBS :: Lazy.ByteString -> Resource ()
 868 outputLBS str = do outputChunkLBS str
 869                    driftTo Done
 870 {-# INLINE outputLBS #-}
 871
 872 -- | Computation of @'outputChunk' str@ writes @str@ as a part of
 873 -- response body. You can compute this action multiple times to write
 874 -- a body little at a time. It is safe to apply 'outputChunk' to an
 875 -- infinite string.
 876 --
 877 -- Note that 'outputChunkLBS' is more efficient than 'outputChunk' so
 878 -- you should use it whenever possible.
 879 outputChunk :: String -> Resource ()
 880 outputChunk str = outputChunkLBS $! L8.pack str
 881 {-# INLINE outputChunk #-}
 882
 883 -- | This is mostly the same as 'outputChunk' but is more efficient.
 884 outputChunkLBS :: Lazy.ByteString -> Resource ()
 885 outputChunkLBS wholeChunk
 886     = wholeChunk `seq`
 887       do driftTo DecidingBody
 888          itr <- getInteraction
 889
 890          let limit = cnfMaxOutputChunkLength $ itrConfig itr
 891          when (limit <= 0)
 892                   $ fail ("cnfMaxOutputChunkLength must be positive: "
 893                           ++ show limit)
 894
 895          discardBody <- liftIO $ atomically $
 896                         readItr itr itrWillDiscardBody id
 897
 898          unless (discardBody)
 899                     $ sendChunks wholeChunk limit
 900
 901          unless (L8.null wholeChunk)
 902                     $ liftIO $ atomically $
 903                       writeItr itr itrBodyIsNull False
 904     where
 905       -- チャンクの大きさは Config で制限されてゐる。もし例へば
 906       -- "/dev/zero" を L8.readFile して作った Lazy.ByteString をそのまま
 907       -- ResponseWriter に渡したりすると大變な事が起こる。何故なら
 908       -- ResponseWriter は Transfer-Encoding: chunked の時、ヘッダを書
 909       -- く爲にチャンクの大きさを測る。
 910       sendChunks :: Lazy.ByteString -> Int -> Resource ()
 911       sendChunks str limit
 912           | L8.null str = return ()
 913           | otherwise   = do let (chunk, remaining) = L8.splitAt (fromIntegral limit) str
 914                              itr <- getInteraction
 915                              liftIO $ atomically $
 916                                     do buf <- readItr itr itrBodyToSend id
 917                                        if L8.null buf then
 918                                            -- バッファが消化された
 919                                            writeItr itr itrBodyToSend chunk
 920                                          else
 921                                            -- 消化されるのを待つ
 922                                            retry
 923                              -- 殘りのチャンクについて繰り返す
 924                              sendChunks remaining limit
 925
 926 {-
 927
 928   [GettingBody からそれ以降の状態に遷移する時]
 929
 930   body を讀み終へてゐなければ、殘りの body を讀み捨てる。
 931
 932
 933   [DecidingHeader からそれ以降の状態に遷移する時]
 934
 935   postprocess する。
 936
 937
 938   [Done に遷移する時]
 939
 940   bodyIsNull が False ならば何もしない。True だった場合は出力補完す
 941   る。
 942
 943 -}
 944
 945 driftTo :: InteractionState -> Resource ()
 946 driftTo newState
 947     = newState `seq`
 948       do itr <- getInteraction
 949          liftIO $ atomically $ do oldState <- readItr itr itrState id
 950                                   if newState < oldState then
 951                                       throwStateError oldState newState
 952                                     else
 953                                       do let a = [oldState .. newState]
 954                                              b = tail a
 955                                              c = zip a b
 956                                          mapM_ (uncurry $ drift itr) c
 957                                          writeItr itr itrState newState
 958     where
 959       throwStateError :: Monad m => InteractionState -> InteractionState -> m a
 960
 961       throwStateError Done DecidingBody
 962           = fail "It makes no sense to output something after finishing to output."
 963
 964       throwStateError old new
 965           = fail ("state error: " ++ show old ++ " ==> " ++ show new)
 966
 967
 968       drift :: Interaction -> InteractionState -> InteractionState -> STM ()
 969
 970       drift itr GettingBody _
 971           = writeItr itr itrReqBodyWasteAll True
 972
 973       drift itr DecidingHeader _
 974           = postprocess itr
 975
 976       drift itr _ Done
 977           = do bodyIsNull <- readItr itr itrBodyIsNull id
 978                when bodyIsNull
 979                         $ writeDefaultPage itr
 980
 981       drift _ _ _
 982           = return ()