Network/HTTP/Lucu/Resource.hs

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