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