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