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