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