Network/HTTP/Lucu/Resource.hs

   1 -- |This is the Resource Monad; monadic actions to define the behavior
   2 -- of each resources. The 'Resource' Monad is a kind of IO Monad thus
   3 -- it implements MonadIO class. It is also a state machine.
   4 --
   5 -- Request Processing Flow:
   6 --
   7 --   1. A client issues an HTTP request.
   8 --
   9 --   2. If the URI of it matches to any resource, the corresponding
  10 --      'Resource' Monad starts running on a newly spawned thread.
  11 --
  12 --   3. The 'Resource' Monad looks at the request header, find (or not
  13 --      find) an entity, receive the request body (if any), decide the
  14 --      response header, and decide the response body. This process
  15 --      will be discussed later.
  16 --
  17 --   4. The 'Resource' Monad and its thread stops running. The client
  18 --      may or may not be sending us the next request at this point.
  19 --
  20 -- 'Resource' Monad is composed of the following states. The initial
  21 -- state is /Examining Request/ and the final state is /Done/.
  22 --
  23 --   [/Examining Request/] In this state, a 'Resource' looks at the
  24 --   request header and thinks about an entity for it. If there is a
  25 --   suitable entity, the 'Resource' tells the system an entity tag
  26 --   and its last modification time ('foundEntity'). If it found no
  27 --   entity, it tells the system so ('foundNoEntity'). In case it is
  28 --   impossible to decide the existence of entity, which is a typical
  29 --   case for POST requests, 'Resource' does nothing in this state.
  30 --
  31 --   [/Getting Body/] A 'Resource' asks the system to receive a
  32 --   request body from client. Before actually reading from the
  33 --   socket, the system sends \"100 Continue\" to the client if need
  34 --   be. When a 'Resource' transits to the next state without
  35 --   receiving all or part of request body, the system still reads it
  36 --   and just throws it away.
  37 --
  38 --   [/Deciding Header/] A 'Resource' makes a decision of status code
  39 --   and response headers. When it transits to the next state, ...
  40 --
  41 --   [/Deciding Body/]
  42 --
  43 --   [/Done/]
  44
  45
  46 -- 一方通行であること、その理由
  47
  48 -- FIXME: 續きを書く
  49
  50 module Network.HTTP.Lucu.Resource
  51     ( Resource
  52
  53     , getConfig
  54     , getRequest
  55     , getMethod
  56     , getRequestURI
  57     , getResourcePath
  58     , getPathInfo
  59     , getHeader
  60     , getAccept
  61     , getContentType
  62
  63     , foundEntity
  64     , foundETag
  65     , foundTimeStamp
  66     , foundNoEntity
  67
  68     , input
  69     , inputChunk
  70     , inputBS
  71     , inputChunkBS
  72     , inputForm
  73     , defaultLimit
  74
  75     , setStatus
  76     , setHeader
  77     , redirect
  78     , setETag
  79     , setLastModified
  80     , setContentType
  81
  82     , output
  83     , outputChunk
  84     , outputBS
  85     , outputChunkBS
  86
  87     , driftTo
  88     )
  89     where
  90
  91 import           Control.Concurrent.STM
  92 import           Control.Monad.Reader
  93 import qualified Data.ByteString.Lazy.Char8 as B
  94 import           Data.ByteString.Lazy.Char8 (ByteString)
  95 import           Data.List
  96 import           Data.Maybe
  97 import           GHC.Conc (unsafeIOToSTM)
  98 import           Network.HTTP.Lucu.Abortion
  99 import           Network.HTTP.Lucu.Config
 100 import           Network.HTTP.Lucu.DefaultPage
 101 import           Network.HTTP.Lucu.ETag
 102 import qualified Network.HTTP.Lucu.Headers as H
 103 import           Network.HTTP.Lucu.HttpVersion
 104 import           Network.HTTP.Lucu.Interaction
 105 import           Network.HTTP.Lucu.Parser
 106 import           Network.HTTP.Lucu.Postprocess
 107 import           Network.HTTP.Lucu.RFC1123DateTime
 108 import           Network.HTTP.Lucu.Request
 109 import           Network.HTTP.Lucu.Response
 110 import           Network.HTTP.Lucu.MIMEType
 111 import           Network.HTTP.Lucu.Utils
 112 import           Network.URI
 113 import           System.Time
 114
 115
 116 type Resource a = ReaderT Interaction IO a
 117
 118
 119 getConfig :: Resource Config
 120 getConfig = do itr <- ask
 121                return $ itrConfig itr
 122
 123
 124 getRequest :: Resource Request
 125 getRequest = do itr <- ask
 126                 return $ fromJust $ itrRequest itr
 127
 128
 129 getMethod :: Resource Method
 130 getMethod = do req <- getRequest
 131                return $ reqMethod req
 132
 133
 134 getRequestURI :: Resource URI
 135 getRequestURI = do req <- getRequest
 136                    return $ reqURI req
 137
 138
 139 getResourcePath :: Resource [String]
 140 getResourcePath = do itr <- ask
 141                      return $ fromJust $ itrResourcePath itr
 142
 143
 144 getPathInfo :: Resource [String]
 145 getPathInfo = do rsrcPath <- getResourcePath
 146                  reqURI   <- getRequestURI
 147                  let reqPathStr = uriPath reqURI
 148                      reqPath    = [x | x <- splitBy (== '/') reqPathStr, x /= ""]
 149                  -- rsrcPath と reqPath の共通する先頭部分を reqPath か
 150                  -- ら全部取り除くと、それは PATH_INFO のやうなものにな
 151                  -- る。rsrcPath は全部一致してゐるに決まってゐる（でな
 152                  -- ければこの Resource が撰ばれた筈が無い）ので、
 153                  -- rsrcPath の長さの分だけ削除すれば良い。
 154                  return $ drop (length rsrcPath) reqPath
 155
 156
 157 getHeader :: String -> Resource (Maybe String)
 158 getHeader name = do itr <- ask
 159                     return $ H.getHeader name $ fromJust $ itrRequest itr
 160
 161
 162 getAccept :: Resource [MIMEType]
 163 getAccept = do accept <- getHeader "Accept"
 164                if accept == Nothing then
 165                    return []
 166                  else
 167                    case parseStr mimeTypeListP $ fromJust accept of
 168                      (Success xs, _) -> return xs
 169                      _               -> return []
 170
 171
 172 getContentType :: Resource (Maybe MIMEType)
 173 getContentType = do cType <- getHeader "Content-Type"
 174                     if cType == Nothing then
 175                         return Nothing
 176                       else
 177                         case parseStr mimeTypeP $ fromJust cType of
 178                           (Success t, _) -> return $ Just t
 179                           _              -> return Nothing
 180
 181
 182
 183 {- ExaminingRequest 時に使用するアクション群 -}
 184
 185 foundEntity :: ETag -> ClockTime -> Resource ()
 186 foundEntity tag timeStamp
 187     = do driftTo ExaminingRequest
 188
 189          method <- getMethod
 190          when (method == GET || method == HEAD)
 191                   $ setHeader' "Last-Modified" $ formatHTTPDateTime timeStamp
 192          foundETag tag
 193
 194          driftTo GettingBody
 195
 196
 197 foundETag :: ETag -> Resource ()
 198 foundETag tag
 199     = do driftTo ExaminingRequest
 200
 201          method <- getMethod
 202          when (method == GET || method == HEAD)
 203                   $ setHeader' "ETag" $ show tag
 204
 205          -- If-Match があればそれを見る。
 206          ifMatch <- getHeader "If-Match"
 207          case ifMatch of
 208            Nothing   -> return ()
 209            Just "*"  -> return ()
 210            Just list -> case parseStr eTagListP list of
 211                           (Success tags, _)
 212                               -- tags の中に一致するものが無ければ
 213                               -- PreconditionFailed で終了。
 214                               -> when (not $ any (== tag) tags)
 215                                  $ abort PreconditionFailed []
 216                                        $ Just ("The entity tag doesn't match: " ++ list)
 217                           _   -> abort BadRequest [] $ Just ("Unparsable If-Match: " ++ fromJust ifMatch)
 218
 219          let statusForNoneMatch = if method == GET || method == HEAD then
 220                                       NotModified
 221                                   else
 222                                       PreconditionFailed
 223
 224          -- If-None-Match があればそれを見る。
 225          ifNoneMatch <- getHeader "If-None-Match"
 226          case ifNoneMatch of
 227            Nothing   -> return ()
 228            Just "*"  -> abort statusForNoneMatch [] $ Just ("The entity tag matches: *")
 229            Just list -> case parseStr eTagListP list of
 230                           (Success tags, _)
 231                               -> when (any (== tag) tags)
 232                                  $ abort statusForNoneMatch [] $ Just ("The entity tag matches: " ++ list)
 233                           _   -> abort BadRequest [] $ Just ("Unparsable If-None-Match: " ++ list)
 234
 235          driftTo GettingBody
 236
 237
 238 foundTimeStamp :: ClockTime -> Resource ()
 239 foundTimeStamp timeStamp
 240     = do driftTo ExaminingRequest
 241
 242          method <- getMethod
 243          when (method == GET || method == HEAD)
 244                   $ setHeader' "Last-Modified" $ formatHTTPDateTime timeStamp
 245
 246          let statusForIfModSince = if method == GET || method == HEAD then
 247                                        NotModified
 248                                    else
 249                                        PreconditionFailed
 250
 251          -- If-Modified-Since があればそれを見る。
 252          ifModSince <- getHeader "If-Modified-Since"
 253          case ifModSince of
 254            Just str -> case parseHTTPDateTime str of
 255                          Just lastTime
 256                              -> when (timeStamp <= lastTime)
 257                                 $ abort statusForIfModSince []
 258                                       $ Just ("The entity has not been modified since " ++ str)
 259                          Nothing
 260                              -> return () -- 不正な時刻は無視
 261            Nothing  -> return ()
 262
 263          -- If-Unmodified-Since があればそれを見る。
 264          ifUnmodSince <- getHeader "If-Unmodified-Since"
 265          case ifUnmodSince of
 266            Just str -> case parseHTTPDateTime str of
 267                          Just lastTime
 268                              -> when (timeStamp > lastTime)
 269                                 $ abort PreconditionFailed []
 270                                       $ Just  ("The entity has not been modified since " ++ str)
 271                          Nothing
 272                              -> return () -- 不正な時刻は無視
 273            Nothing  -> return ()
 274
 275          driftTo GettingBody
 276
 277
 278 foundNoEntity :: Maybe String -> Resource ()
 279 foundNoEntity msgM
 280     = do driftTo ExaminingRequest
 281
 282          method <- getMethod
 283          when (method /= PUT)
 284               $ abort NotFound [] msgM
 285
 286          -- エンティティが存在しないと云ふ事は、"*" も含めたどのやうな
 287          -- If-Match: 條件も滿たさない。
 288          ifMatch <- getHeader "If-Match"
 289          when (ifMatch /= Nothing)
 290                   $ abort PreconditionFailed [] msgM
 291
 292          driftTo GettingBody
 293
 294
 295 {- GettingBody 時に使用するアクション群 -}
 296
 297 input :: Int -> Resource String
 298 input limit = inputBS limit >>= return . B.unpack
 299
 300
 301 -- 多くとも limit バイトまでのリクエストボディ全體を受信する。limit が
 302 -- 零以下なら Config で設定されたデフォルトのボディ長により制限される。
 303 inputBS :: Int -> Resource ByteString
 304 inputBS limit
 305     = do driftTo GettingBody
 306          itr     <- ask
 307          hasBody <- liftIO $ atomically $ readItr itr itrRequestHasBody id
 308          chunk   <- if hasBody then
 309                         askForInput itr
 310                     else
 311                         do driftTo DecidingHeader
 312                            return B.empty
 313          return chunk
 314     where
 315       askForInput :: Interaction -> Resource ByteString
 316       askForInput itr
 317           = do let defaultLimit = cnfMaxEntityLength $ itrConfig itr
 318                    actualLimit  = if limit <= 0 then
 319                                       defaultLimit
 320                                   else
 321                                       limit
 322                when (actualLimit <= 0)
 323                         $ fail ("inputBS: limit must be positive: " ++ show actualLimit)
 324                -- Reader にリクエスト
 325                liftIO $ atomically
 326                           $ do chunkLen <- readItr itr itrReqChunkLength id
 327                                writeItr itr itrWillReceiveBody True
 328                                if fmap (> actualLimit) chunkLen == Just True then
 329                                    -- 受信前から多過ぎる事が分かってゐる
 330                                    tooLarge actualLimit
 331                                  else
 332                                    writeItr itr itrReqBodyWanted $ Just actualLimit
 333                -- 應答を待つ。トランザクションを分けなければ當然デッドロック。
 334                chunk <- liftIO $ atomically
 335                         $ do chunk       <- readItr itr itrReceivedBody id
 336                              chunkIsOver <- readItr itr itrReqChunkIsOver id
 337                              if B.length chunk < fromIntegral actualLimit then
 338                                  -- 要求された量に滿たなくて、まだ殘り
 339                                  -- があるなら再試行。
 340                                  unless chunkIsOver
 341                                             $ retry
 342                                else
 343                                  -- 制限値一杯まで讀むやうに指示したの
 344                                  -- にまだ殘ってゐるなら、それは多過ぎ
 345                                  -- る。
 346                                  unless chunkIsOver
 347                                             $ tooLarge actualLimit
 348                              -- 成功。itr 内にチャンクを置いたままにす
 349                              -- るとメモリの無駄になるので除去。
 350                              writeItr itr itrReceivedBody B.empty
 351                              return chunk
 352                driftTo DecidingHeader
 353                return chunk
 354
 355       tooLarge :: Int -> STM ()
 356       tooLarge lim = abortSTM RequestEntityTooLarge []
 357                      $ Just ("Request body must be smaller than "
 358                              ++ show lim ++ " bytes.")
 359
 360
 361 inputChunk :: Int -> Resource String
 362 inputChunk limit = inputChunkBS limit >>= return . B.unpack
 363
 364
 365 -- 多くとも limit バイトまでのリクエストボディの一部を受信する。limit
 366 -- が 0 以下なら Config で設定されたデフォルトのボディ長により制限され
 367 -- る。これ以上ボディが殘ってゐなければ空文字列を返す。
 368 inputChunkBS :: Int -> Resource ByteString
 369 inputChunkBS limit
 370     = do driftTo GettingBody
 371          itr <- ask
 372          hasBody <- liftIO $ atomically $ readItr itr itrRequestHasBody id
 373          chunk   <- if hasBody then
 374                         askForInput itr
 375                     else
 376                         do driftTo DecidingHeader
 377                            return B.empty
 378          return chunk
 379     where
 380       askForInput :: Interaction -> Resource ByteString
 381       askForInput itr
 382           = do let defaultLimit = cnfMaxEntityLength $ itrConfig itr
 383                    actualLimit  = if limit < 0 then
 384                                       defaultLimit
 385                                   else
 386                                       limit
 387                when (actualLimit <= 0)
 388                         $ fail ("inputChunkBS: limit must be positive: " ++ show actualLimit)
 389                -- Reader にリクエスト
 390                liftIO $ atomically
 391                           $ do writeItr itr itrReqBodyWanted $ Just actualLimit
 392                                writeItr itr itrWillReceiveBody True
 393                -- 應答を待つ。トランザクションを分けなければ當然デッドロック。
 394                chunk <- liftIO $ atomically
 395                         $ do chunk <- readItr itr itrReceivedBody id
 396                              -- 要求された量に滿たなくて、まだ殘りがあ
 397                              -- るなら再試行。
 398                              when (B.length chunk < fromIntegral actualLimit)
 399                                       $ do chunkIsOver <- readItr itr itrReqChunkIsOver id
 400                                            unless chunkIsOver
 401                                                       $ retry
 402                              -- 成功
 403                              writeItr itr itrReceivedBody B.empty
 404                              return chunk
 405                when (B.null chunk)
 406                         $ driftTo DecidingHeader
 407                return chunk
 408
 409
 410 -- application/x-www-form-urlencoded または multipart/form-data をパー
 411 -- スする。もし Content-Type が無かったら BadRequest で終了し、未對應の
 412 -- タイプであったら UnsupportedMediaType で終了する。
 413 inputForm :: Int -> Resource [(String, String)]
 414 inputForm limit
 415     = do cTypeM <- getContentType
 416          case cTypeM of
 417            Nothing
 418                -> abort BadRequest [] (Just "Missing Content-Type")
 419            Just (MIMEType "application" "x-www-form-urlencoded" _)
 420                -> readWWWFormURLEncoded
 421            Just (MIMEType "multipart" "form-data" _)
 422                -> readMultipartFormData
 423            Just cType
 424                -> abort UnsupportedMediaType [] (Just $ "Unsupported media type: "
 425                                                           ++ show cType)
 426     where
 427       readWWWFormURLEncoded
 428           = do src <- input limit
 429                return $ do pairStr <- splitBy (\ c -> c == ';' || c == '&') src
 430                            let pair = break (== '=') pairStr
 431                            return ( unEscapeString $ fst pair
 432                                   , unEscapeString $ snd pair
 433                                   )
 434       readMultipartFormData -- FIXME: 未對應
 435           = abort UnsupportedMediaType []
 436             (Just $ "Sorry, inputForm does not currently support multipart/form-data.")
 437
 438
 439 defaultLimit :: Int
 440 defaultLimit = (-1)
 441
 442
 443
 444 {- DecidingHeader 時に使用するアクション群 -}
 445
 446 setStatus :: StatusCode -> Resource ()
 447 setStatus code
 448     = do driftTo DecidingHeader
 449          itr <- ask
 450          liftIO $ atomically $ updateItr itr itrResponse
 451                     $ \ res -> res {
 452                                  resStatus = code
 453                                }
 454
 455
 456 setHeader :: String -> String -> Resource ()
 457 setHeader name value
 458     = driftTo DecidingHeader >> setHeader' name value
 459
 460
 461 setHeader' :: String -> String -> Resource()
 462 setHeader' name value
 463     = do itr <- ask
 464          liftIO $ atomically
 465                     $ updateItr itr itrResponse
 466                           $ H.setHeader name value
 467
 468
 469 redirect :: StatusCode -> URI -> Resource ()
 470 redirect code uri
 471     = do when (code == NotModified || not (isRedirection code))
 472                   $ abort InternalServerError []
 473                         $ Just ("Attempted to redirect with status " ++ show code)
 474          setStatus code
 475          setHeader "Location" (uriToString id uri $ "")
 476
 477
 478 setETag :: ETag -> Resource ()
 479 setETag tag
 480     = setHeader "ETag" $ show tag
 481
 482
 483 setLastModified :: ClockTime -> Resource ()
 484 setLastModified lastmod
 485     = setHeader "Last-Modified" $ formatHTTPDateTime lastmod
 486
 487
 488 setContentType :: MIMEType -> Resource ()
 489 setContentType mType
 490     = setHeader "Content-Type" $ show mType
 491
 492
 493 {- DecidingBody 時に使用するアクション群 -}
 494
 495 output :: String -> Resource ()
 496 output = outputBS . B.pack
 497
 498
 499 outputBS :: ByteString -> Resource ()
 500 outputBS str = do outputChunkBS str
 501                   driftTo Done
 502
 503
 504 outputChunk :: String -> Resource ()
 505 outputChunk = outputChunkBS . B.pack
 506
 507
 508 {- チャンクの大きさは Config で制限されてゐる。もし例へば /dev/zero を
 509    B.readFile して作った ByteString をそのまま ResponseWriter に渡した
 510    りすると大變な事が起こる。何故なら ResponseWriter は
 511    Transfer-Encoding: chunked の時、ヘッダを書く爲にチャンクの大きさを
 512    測るから、その時に起こるであらう事は言ふまでも無い。 -}
 513
 514 outputChunkBS :: ByteString -> Resource ()
 515 outputChunkBS str
 516     = do driftTo DecidingBody
 517          itr <- ask
 518
 519          let limit = cnfMaxOutputChunkLength $ itrConfig itr
 520          when (limit <= 0)
 521                   $ fail ("cnfMaxOutputChunkLength must be positive: "
 522                           ++ show limit)
 523
 524          discardBody <- liftIO $ atomically $
 525                         readItr itr itrWillDiscardBody id
 526
 527          unless (discardBody)
 528                     $ sendChunks str limit
 529
 530          unless (B.null str)
 531                     $ liftIO $ atomically $
 532                       writeItr itr itrBodyIsNull False
 533     where
 534       sendChunks :: ByteString -> Int -> Resource ()
 535       sendChunks str limit
 536           | B.null str = return ()
 537           | otherwise  = do let (chunk, remaining) = B.splitAt (fromIntegral limit) str
 538                             itr <- ask
 539                             liftIO $ atomically $
 540                                    do buf <- readItr itr itrBodyToSend id
 541                                       if B.null buf then
 542                                           -- バッファが消化された
 543                                           writeItr itr itrBodyToSend chunk
 544                                         else
 545                                           -- 消化されるのを待つ
 546                                           retry
 547                             -- 殘りのチャンクについて繰り返す
 548                             sendChunks remaining limit
 549
 550 {-
 551
 552   [GettingBody からそれ以降の状態に遷移する時]
 553
 554   body を讀み終へてゐなければ、殘りの body を讀み捨てる。
 555
 556
 557   [DecidingHeader からそれ以降の状態に遷移する時]
 558
 559   postprocess する。
 560
 561
 562   [Done に遷移する時]
 563
 564   bodyIsNull が False ならば何もしない。True だった場合は出力補完す
 565   る。
 566
 567 -}
 568
 569 driftTo :: InteractionState -> Resource ()
 570 driftTo newState
 571     = do itr <- ask
 572          liftIO $ atomically $ do oldState <- readItr itr itrState id
 573                                   if newState < oldState then
 574                                       throwStateError oldState newState
 575                                     else
 576                                       do let a = [oldState .. newState]
 577                                              b = tail a
 578                                              c = zip a b
 579                                          mapM_ (uncurry $ drift itr) c
 580                                          writeItr itr itrState newState
 581     where
 582       throwStateError :: Monad m => InteractionState -> InteractionState -> m a
 583
 584       throwStateError Done DecidingBody
 585           = fail "It makes no sense to output something after finishing to output."
 586
 587       throwStateError old new
 588           = fail ("state error: " ++ show old ++ " ==> " ++ show new)
 589
 590
 591       drift :: Interaction -> InteractionState -> InteractionState -> STM ()
 592
 593       drift itr GettingBody _
 594           = writeItr itr itrReqBodyWasteAll True
 595
 596       drift itr DecidingHeader _
 597           = postprocess itr
 598
 599       drift itr _ Done
 600           = do bodyIsNull <- readItr itr itrBodyIsNull id
 601                when bodyIsNull
 602                         $ writeDefaultPage itr
 603
 604       drift _ _ _
 605           = return ()