Network/HTTP/Lucu/Resource.hs

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