Network/HTTP/Lucu/Resource.hs

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