Network/HTTP/Lucu/Resource.hs

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