X-Git-Url: http://git.cielonegro.org/gitweb.cgi?p=Lucu.git;a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FResource.hs;h=883cc149188a404f2007425cf88d6bcfc8a2b1d8;hp=24ae4b254a8e548593f2927ae28eb9c4ec4a321e;hb=1000bdc46cfe7b3ae550ff24ccea9f440f11b42a;hpb=cd1b58b84ff354e3fc2a7d2c8fd548a7b59fe138

diff --git a/Network/HTTP/Lucu/Resource.hs b/Network/HTTP/Lucu/Resource.hs
index 24ae4b2..883cc14 100644
--- a/Network/HTTP/Lucu/Resource.hs
+++ b/Network/HTTP/Lucu/Resource.hs
@@ -6,6 +6,14 @@ module Network.HTTP.Lucu.Resource
     , findResource -- ResTree -> URI -> Maybe ResourceDef
     , runResource  -- ResourceDef -> Interaction -> IO ThreadId
 
+    , getMethod -- Resource Method
+    , getHeader -- String -> Resource (Maybe String)
+
+    , foundEntity    -- Bool -> String -> ClockTime -> Resource ()
+    , foundETag      -- Bool -> String -> Resource ()
+    , foundTimeStamp -- ClockTime -> Resource ()
+    , foundNoEntity  -- Maybe String -> Resource ()
+
     , input        -- Int -> Resource String
     , inputChunk   -- Int -> Resource String
     , inputBS      -- Int -> Resource ByteString
@@ -14,8 +22,9 @@ module Network.HTTP.Lucu.Resource
 
     , setStatus -- StatusCode -> Resource ()
     , setHeader -- String -> String -> Resource ()
-
     , redirect  -- StatusCode -> URI -> Resource ()
+    , setETag   -- Bool -> String -> Resource ()
+    , setLastModified -- ClockTime -> Resource ()
 
     , output        -- String -> Resource ()
     , outputChunk   -- String -> Resource ()
@@ -39,10 +48,13 @@ import           GHC.Conc (unsafeIOToSTM)
 import           Network.HTTP.Lucu.Abortion
 import           Network.HTTP.Lucu.Config
 import           Network.HTTP.Lucu.DefaultPage
+import           Network.HTTP.Lucu.ETag
 import qualified Network.HTTP.Lucu.Headers as H
 import           Network.HTTP.Lucu.HttpVersion
 import           Network.HTTP.Lucu.Interaction
+import           Network.HTTP.Lucu.Parser
 import           Network.HTTP.Lucu.Postprocess
+import           Network.HTTP.Lucu.RFC1123DateTime
 import           Network.HTTP.Lucu.Request
 import           Network.HTTP.Lucu.Response
 import           Network.HTTP.Lucu.Utils
@@ -50,6 +62,7 @@ import           Network.URI
 import           Prelude hiding (catch)
 import           System.IO
 import           System.IO.Error hiding (catch)
+import           System.Time
 
 
 type Resource a = ReaderT Interaction IO a
@@ -212,7 +225,130 @@ runResource def itr
                           show ioE
 
 
-{- Resource モナド -}
+getMethod :: Resource Method
+getMethod = do itr <- ask
+               return $ reqMethod $ fromJust $ itrRequest itr
+
+
+getHeader :: String -> Resource (Maybe String)
+getHeader name = do itr <- ask
+                    return $ H.getHeader name $ fromJust $ itrRequest itr
+
+
+{- ExaminingRequest 時に使用するアクション群 -}
+
+foundEntity :: Bool -> String -> ClockTime -> Resource ()
+foundEntity isWeak token timeStamp
+    = do driftTo ExaminingRequest
+
+         method <- getMethod
+         when (method == GET || method == HEAD)
+                  $ setHeader' "Last-Modified" $ formatHTTPDateTime timeStamp
+         foundETag isWeak token
+
+         driftTo GettingBody
+
+
+foundETag :: Bool -> String -> Resource ()
+foundETag isWeak token
+    = do driftTo ExaminingRequest
+
+         let tag = mkETag isWeak token
+      
+         method <- getMethod
+         when (method == GET || method == HEAD)
+                  $ setHeader' "ETag" $ show tag
+
+         -- If-Match があればそれを見る。
+         ifMatch <- getHeader "If-Match"
+         case ifMatch of
+           Nothing   -> return ()
+           Just "*"  -> return ()
+           Just list -> case parseStr eTagListP list of
+                          (Success tags, _)
+                              -- tags の中に一致するものが無ければ
+                              -- PreconditionFailed で終了。
+                              -> when (not $ any (== tag) tags)
+                                 $ abort PreconditionFailed [] ("The entity tag doesn't match: " ++ list)
+                          _   -> abort BadRequest [] ("Unparsable If-Match: " ++ fromJust ifMatch)
+
+         let statusForNoneMatch = if method == GET || method == HEAD then
+                                      NotModified
+                                  else
+                                      PreconditionFailed
+
+         -- If-None-Match があればそれを見る。
+         ifNoneMatch <- getHeader "If-None-Match"
+         case ifNoneMatch of
+           Nothing   -> return ()
+           Just "*"  -> abort statusForNoneMatch [] ("The entity tag matches: *")
+           Just list -> case parseStr eTagListP list of
+                          (Success tags, _)
+                              -> when (any (== tag) tags)
+                                 $ abort statusForNoneMatch [] ("The entity tag matches: " ++ list)
+                          _   -> abort BadRequest [] ("Unparsable If-None-Match: " ++ list)
+
+         driftTo GettingBody
+
+
+foundTimeStamp :: ClockTime -> Resource ()
+foundTimeStamp timeStamp
+    = do driftTo ExaminingRequest
+
+         method <- getMethod
+         when (method == GET || method == HEAD)
+                  $ setHeader' "Last-Modified" $ formatHTTPDateTime timeStamp
+
+         let statusForIfModSince = if method == GET || method == HEAD then
+                                       NotModified
+                                   else
+                                       PreconditionFailed
+
+         -- If-Modified-Since があればそれを見る。
+         ifModSince <- getHeader "If-Modified-Since"
+         case ifModSince of
+           Just str -> case parseHTTPDateTime str of
+                         Just lastTime
+                             -> when (timeStamp <= lastTime)
+                                $ abort statusForIfModSince [] ("The entity has not been modified since " ++ str)
+                         Nothing
+                             -> return () -- 不正な時刻は無視
+           Nothing  -> return ()
+
+         -- If-Unmodified-Since があればそれを見る。
+         ifUnmodSince <- getHeader "If-Unmodified-Since"
+         case ifUnmodSince of
+           Just str -> case parseHTTPDateTime str of
+                         Just lastTime
+                             -> when (timeStamp > lastTime)
+                                $ abort PreconditionFailed [] ("The entity has not been modified since " ++ str)
+                         Nothing
+                             -> return () -- 不正な時刻は無視
+           Nothing  -> return ()
+
+         driftTo GettingBody
+
+
+foundNoEntity :: Maybe String -> Resource ()
+foundNoEntity msgM
+    = do driftTo ExaminingRequest
+
+         let msg = fromMaybe "The requested entity was not found in this server." msgM
+
+         method <- getMethod
+         when (method /= PUT)
+              $ abort NotFound [] msg
+
+         -- エンティティが存在しないと云ふ事は、"*" も含めたどのやうな
+         -- If-Match: 條件も滿たさない。
+         ifMatch <- getHeader "If-Match"
+         when (ifMatch /= Nothing)
+                  $ abort PreconditionFailed [] msg
+
+         driftTo GettingBody
+
+
+{- GettingBody 時に使用するアクション群 -}
 
 input :: Int -> Resource String
 input limit = inputBS limit >>= return . B.unpack
@@ -223,44 +359,55 @@ input limit = inputBS limit >>= return . B.unpack
 inputBS :: Int -> Resource ByteString
 inputBS limit
     = do driftTo GettingBody
-         itr <- ask
-         let defaultLimit = cnfMaxEntityLength $ itrConfig itr
-             actualLimit  = if limit <= 0 then
-                                defaultLimit
-                            else
-                                limit
-         when (actualLimit <= 0)
-                  $ fail ("inputBS: limit must be positive: " ++ show actualLimit)
-         -- Reader にリクエスト
-         liftIO $ atomically
-                    $ do chunkLen <- readItr itr itrReqChunkLength id
-                         writeItr itr itrWillReceiveBody True
-                         if fmap (> actualLimit) chunkLen == Just True then
-                             -- 受信前から多過ぎる事が分かってゐる
-                             tooLarge actualLimit
-                           else
-                             writeItr itr itrReqBodyWanted $ Just actualLimit
-         -- 應答を待つ。トランザクションを分けなければ當然デッドロック。
-         chunk <- liftIO $ atomically
-                  $ do chunk       <- readItr itr itrReceivedBody id
-                       chunkIsOver <- readItr itr itrReqChunkIsOver id
-                       if B.length chunk < fromIntegral actualLimit then
-                           -- 要求された量に滿たなくて、まだ殘りがある
-                           -- なら再試行。
-                           unless chunkIsOver
-                                      $ retry
-                         else
-                           -- 制限値一杯まで讀むやうに指示したのにまだ殘っ
-                           -- てゐるなら、それは多過ぎる。
-                           unless chunkIsOver
-                                      $ tooLarge actualLimit
-                       -- 成功。itr 内にチャンクを置いたままにするとメ
-                       -- モリの無駄になるので除去。
-                       writeItr itr itrReceivedBody B.empty
-                       return chunk
-         driftTo DecidingHeader
+         itr     <- ask
+         hasBody <- liftIO $ atomically $ readItr itr itrRequestHasBody id
+         chunk   <- if hasBody then
+                        askForInput itr
+                    else
+                        do driftTo DecidingHeader
+                           return B.empty
          return chunk
     where
+      askForInput :: Interaction -> Resource ByteString
+      askForInput itr
+          = do let defaultLimit = cnfMaxEntityLength $ itrConfig itr
+                   actualLimit  = if limit <= 0 then
+                                      defaultLimit
+                                  else
+                                      limit
+               when (actualLimit <= 0)
+                        $ fail ("inputBS: limit must be positive: " ++ show actualLimit)
+               -- Reader にリクエスト
+               liftIO $ atomically
+                          $ do chunkLen <- readItr itr itrReqChunkLength id
+                               writeItr itr itrWillReceiveBody True
+                               if fmap (> actualLimit) chunkLen == Just True then
+                                   -- 受信前から多過ぎる事が分かってゐる
+                                   tooLarge actualLimit
+                                 else
+                                   writeItr itr itrReqBodyWanted $ Just actualLimit
+               -- 應答を待つ。トランザクションを分けなければ當然デッドロック。
+               chunk <- liftIO $ atomically
+                        $ do chunk       <- readItr itr itrReceivedBody id
+                             chunkIsOver <- readItr itr itrReqChunkIsOver id
+                             if B.length chunk < fromIntegral actualLimit then
+                                 -- 要求された量に滿たなくて、まだ殘り
+                                 -- があるなら再試行。
+                                 unless chunkIsOver
+                                            $ retry
+                               else
+                                 -- 制限値一杯まで讀むやうに指示したの
+                                 -- にまだ殘ってゐるなら、それは多過ぎ
+                                 -- る。
+                                 unless chunkIsOver
+                                            $ tooLarge actualLimit
+                             -- 成功。itr 内にチャンクを置いたままにす
+                             -- るとメモリの無駄になるので除去。
+                             writeItr itr itrReceivedBody B.empty
+                             return chunk
+               driftTo DecidingHeader
+               return chunk
+
       tooLarge :: Int -> STM ()
       tooLarge lim = abortSTM RequestEntityTooLarge []
                      ("Request body must be smaller than "
@@ -278,38 +425,51 @@ inputChunkBS :: Int -> Resource ByteString
 inputChunkBS limit
     = do driftTo GettingBody
          itr <- ask
-         let defaultLimit = cnfMaxEntityLength $ itrConfig itr
-             actualLimit  = if limit < 0 then
-                                defaultLimit
-                            else
-                                limit
-         when (actualLimit <= 0)
-                  $ fail ("inputChunkBS: limit must be positive: " ++ show actualLimit)
-         -- Reader にリクエスト
-         liftIO $ atomically
-                    $ do writeItr itr itrReqBodyWanted $ Just actualLimit
-                         writeItr itr itrWillReceiveBody True
-         -- 應答を待つ。トランザクションを分けなければ當然デッドロック。
-         chunk <- liftIO $ atomically
-                  $ do chunk <- readItr itr itrReceivedBody id
-                       -- 要求された量に滿たなくて、まだ殘りがあるなら
-                       -- 再試行。
-                       when (B.length chunk < fromIntegral actualLimit)
-                                $ do chunkIsOver <- readItr itr itrReqChunkIsOver id
-                                     unless chunkIsOver
-                                                $ retry
-                       -- 成功
-                       writeItr itr itrReceivedBody B.empty
-                       return chunk
-         when (B.null chunk)
-                  $ driftTo DecidingHeader
+         hasBody <- liftIO $ atomically $ readItr itr itrRequestHasBody id
+         chunk   <- if hasBody then
+                        askForInput itr
+                    else
+                        do driftTo DecidingHeader
+                           return B.empty
          return chunk
+    where
+      askForInput :: Interaction -> Resource ByteString
+      askForInput itr
+          = do let defaultLimit = cnfMaxEntityLength $ itrConfig itr
+                   actualLimit  = if limit < 0 then
+                                      defaultLimit
+                                  else
+                                      limit
+               when (actualLimit <= 0)
+                        $ fail ("inputChunkBS: limit must be positive: " ++ show actualLimit)
+               -- Reader にリクエスト
+               liftIO $ atomically
+                          $ do writeItr itr itrReqBodyWanted $ Just actualLimit
+                               writeItr itr itrWillReceiveBody True
+               -- 應答を待つ。トランザクションを分けなければ當然デッドロック。
+               chunk <- liftIO $ atomically
+                        $ do chunk <- readItr itr itrReceivedBody id
+                             -- 要求された量に滿たなくて、まだ殘りがあ
+                             -- るなら再試行。
+                             when (B.length chunk < fromIntegral actualLimit)
+                                      $ do chunkIsOver <- readItr itr itrReqChunkIsOver id
+                                           unless chunkIsOver
+                                                      $ retry
+                             -- 成功
+                             writeItr itr itrReceivedBody B.empty
+                             return chunk
+               when (B.null chunk)
+                        $ driftTo DecidingHeader
+               return chunk
 
 
 defaultLimit :: Int
 defaultLimit = (-1)
 
 
+
+{- DecidingHeader 時に使用するアクション群 -}
+
 setStatus :: StatusCode -> Resource ()
 setStatus code
     = do driftTo DecidingHeader
@@ -328,8 +488,12 @@ setStatus code
 
 setHeader :: String -> String -> Resource ()
 setHeader name value
-    = do driftTo DecidingHeader
-         itr <- ask
+    = driftTo DecidingHeader >> setHeader' name value
+         
+
+setHeader' :: String -> String -> Resource()
+setHeader' name value
+    = do itr <- ask
          liftIO $ atomically $ updateItr itr itrResponse
                     $ \ resM -> case resM of
                                   Nothing  -> Just $ Response {
@@ -349,6 +513,18 @@ redirect code uri
          setHeader "Location" (uriToString id uri $ "")
 
 
+setETag :: Bool -> String -> Resource ()
+setETag isWeak token
+    = setHeader "ETag" $ show $ mkETag isWeak token
+
+
+setLastModified :: ClockTime -> Resource ()
+setLastModified lastmod
+    = setHeader "Last-Modified" $ formatHTTPDateTime lastmod
+
+
+{- DecidingBody 時に使用するアクション群 -}
+
 output :: String -> Resource ()
 output = outputBS . B.pack