From 1000bdc46cfe7b3ae550ff24ccea9f440f11b42a Mon Sep 17 00:00:00 2001 From: pho Date: Sat, 7 Apr 2007 19:31:28 +0900 Subject: [PATCH] ETag and Last Modified darcs-hash:20070407103128-62b54-d331c18f1076a3a244b3a63c37dc225195f282c6.gz --- Network/HTTP/Lucu/Abortion.hs | 12 +- Network/HTTP/Lucu/ETag.hs | 46 +++++ Network/HTTP/Lucu/Headers.hs | 7 +- Network/HTTP/Lucu/Httpd.hs | 2 +- Network/HTTP/Lucu/Interaction.hs | 7 +- Network/HTTP/Lucu/Parser.hs | 72 ++++++- Network/HTTP/Lucu/Parser/Http.hs | 10 +- Network/HTTP/Lucu/RequestReader.hs | 3 - Network/HTTP/Lucu/Resource.hs | 306 ++++++++++++++++++++++------ Network/HTTP/Lucu/ResponseWriter.hs | 28 ++- examples/HelloWorld.hs | 9 +- 11 files changed, 397 insertions(+), 105 deletions(-) create mode 100644 Network/HTTP/Lucu/ETag.hs diff --git a/Network/HTTP/Lucu/Abortion.hs b/Network/HTTP/Lucu/Abortion.hs index 75ce437..ff69157 100644 --- a/Network/HTTP/Lucu/Abortion.hs +++ b/Network/HTTP/Lucu/Abortion.hs @@ -1,7 +1,6 @@ module Network.HTTP.Lucu.Abortion ( Abortion(..) , abort -- MonadIO m => StatusCode -> [ (String, String) ] -> String -> m a - , abortIO -- StatusCode -> [ (String, String) ] -> String -> IO a , abortSTM -- StatusCode -> [ (String, String) ] -> String -> STM a , abortA -- ArrowIO a => StatusCode -> [ (String, String) ] -> String -> a b c , aboPage -- Config -> Abortion -> String @@ -35,25 +34,20 @@ data Abortion = Abortion { abort :: MonadIO m => StatusCode -> [ (String, String) ] -> String -> m a abort status headers msg - = liftIO $ abortIO status headers msg - - -abortIO :: StatusCode -> [ (String, String) ] -> String -> IO a -abortIO status headers msg = let abo = Abortion status headers msg exc = DynException (toDyn abo) in - throwIO exc + liftIO $ throwIO exc abortSTM :: StatusCode -> [ (String, String) ] -> String -> STM a abortSTM status headers msg - = unsafeIOToSTM $ abortIO status headers msg + = unsafeIOToSTM $ abort status headers msg abortA :: ArrowIO a => StatusCode -> [ (String, String) ] -> String -> a b c abortA status headers msg - = arrIO0 $ abortIO status headers msg + = arrIO0 $ abort status headers msg aboPage :: Config -> Abortion -> String diff --git a/Network/HTTP/Lucu/ETag.hs b/Network/HTTP/Lucu/ETag.hs new file mode 100644 index 0000000..0341f5a --- /dev/null +++ b/Network/HTTP/Lucu/ETag.hs @@ -0,0 +1,46 @@ +module Network.HTTP.Lucu.ETag + ( ETag + , mkETag -- Bool -> String -> ETag + , eTagP -- Parser ETag + , eTagListP -- Parser [ETag] + ) + where + +import Network.HTTP.Lucu.Parser +import Network.HTTP.Lucu.Parser.Http + + +data ETag = ETag { + etagIsWeak :: Bool + , etagToken :: String + } deriving (Eq) + + +instance Show ETag where + show (ETag isWeak token) = (if isWeak then + "W/" + else + "") + ++ + foldr (++) "" (["\""] ++ map quote token ++ ["\""]) + where + quote :: Char -> String + quote '"' = "\\\"" + quote c = [c] + + +mkETag :: Bool -> String -> ETag +mkETag = ETag + + +eTagP :: Parser ETag +eTagP = do isWeak <- option False (string "W/" >> return True) + str <- quotedStr + return $ mkETag isWeak str + + +eTagListP :: Parser [ETag] +eTagListP = allowEOF + $ sepBy1 eTagP (do many sp + char ',' + many sp) diff --git a/Network/HTTP/Lucu/Headers.hs b/Network/HTTP/Lucu/Headers.hs index 7936f04..ccd5140 100644 --- a/Network/HTTP/Lucu/Headers.hs +++ b/Network/HTTP/Lucu/Headers.hs @@ -77,7 +77,12 @@ headersP = do xs <- many header normalize :: String -> String normalize = trimBody . trim isWhiteSpace - trimBody = nubBy (\ a b -> a == ' ' && b == ' ') + trimBody = foldr (++) [] + . map (\ s -> if head s == ' ' then + " " + else + s) + . group . map (\ c -> if isWhiteSpace c then ' ' else c) diff --git a/Network/HTTP/Lucu/Httpd.hs b/Network/HTTP/Lucu/Httpd.hs index a49a81d..7b0a565 100644 --- a/Network/HTTP/Lucu/Httpd.hs +++ b/Network/HTTP/Lucu/Httpd.hs @@ -27,5 +27,5 @@ runHttpd cnf table = do (h, host, _) <- accept so tQueue <- newInteractionQueue readerTID <- forkIO $ requestReader cnf table h host tQueue - writerTID <- forkIO $ responseWriter h tQueue readerTID + writerTID <- forkIO $ responseWriter cnf h tQueue readerTID loop so diff --git a/Network/HTTP/Lucu/Interaction.hs b/Network/HTTP/Lucu/Interaction.hs index 491c029..5f28c55 100644 --- a/Network/HTTP/Lucu/Interaction.hs +++ b/Network/HTTP/Lucu/Interaction.hs @@ -55,9 +55,8 @@ data Interaction = Interaction { } -- Resource の視點で見た時の状態。常に上から下へ行き、逆行しない。初期 --- 状態は ExaminingHeader (リクエストボディが有る時) または --- DecidingHeader (無い時)。終了状態は常に Done -data InteractionState = ExaminingHeader +-- 状態は ExaminingRequest。 +data InteractionState = ExaminingRequest | GettingBody | DecidingHeader | DecidingBody @@ -94,7 +93,7 @@ newInteraction conf host req bodyToSend <- newTVarIO B.empty bodyIsNull <- newTVarIO True -- 一度でも bodyToSend が空でなくなったら False - state <- newTVarIO undefined + state <- newTVarIO ExaminingRequest wroteContinue <- newTVarIO False wroteHeader <- newTVarIO False diff --git a/Network/HTTP/Lucu/Parser.hs b/Network/HTTP/Lucu/Parser.hs index f99cdf5..ffbf6d1 100644 --- a/Network/HTTP/Lucu/Parser.hs +++ b/Network/HTTP/Lucu/Parser.hs @@ -2,9 +2,12 @@ module Network.HTTP.Lucu.Parser ( Parser(..) , ParserResult(..) - , parse -- Parser a -> ByteString -> ParserResult a + , parse -- Parser a -> ByteString -> (ParserResult a, ByteString) + , parseStr -- Parser a -> String -> (ParserResult a, ByteString) , anyChar -- Parser Char + , eof -- Parser () + , allowEOF -- Parser a -> Parser a , satisfy -- (Char -> Bool) -> Parser Char , char -- Char -> Parser Char , string -- String -> Parser String @@ -18,6 +21,9 @@ module Network.HTTP.Lucu.Parser , manyTill -- Parser a -> Parser end -> Parser [a] , many1Till -- Parser a -> Parser end -> Parser [a] , option -- a -> Parser a -> Parser a + , sepBy -- Parser a -> Parser sep -> Parser [a] + , sepBy1 -- Parser a -> Parser sep -> Parser [a] + , sp -- Parser Char , ht -- Parser Char , crlf -- Parser String @@ -30,9 +36,13 @@ import qualified Data.ByteString.Lazy.Char8 as B import Data.ByteString.Lazy.Char8 (ByteString) data Parser a = Parser { - runParser :: State ByteString (ParserResult a) + runParser :: State ParserState (ParserResult a) } +type ParserState = (ByteString, IsEOFFatal) + +type IsEOFFatal = Bool + data ParserResult a = Success a | IllegalInput -- 受理出來ない入力があった | ReachedEOF -- 限界を越えて讀まうとした @@ -41,31 +51,61 @@ data ParserResult a = Success a -- (>>=) :: Parser a -> (a -> Parser b) -> Parser b instance Monad Parser where - p >>= f = Parser $ do saved <- get -- 失敗した時の爲に状態を保存 + p >>= f = Parser $ do saved@(_, isEOFFatal) <- get -- 失敗した時の爲に状態を保存 result <- runParser p case result of Success a -> runParser (f a) IllegalInput -> do put saved -- 状態を復歸 return IllegalInput - ReachedEOF -> return ReachedEOF + ReachedEOF -> if isEOFFatal then + return ReachedEOF + else + do put saved + return IllegalInput return = Parser . return . Success fail _ = Parser $ return IllegalInput parse :: Parser a -> ByteString -> (ParserResult a, ByteString) -parse p input = runState (runParser p) input +parse p input = let (result, (input', _)) = runState (runParser p) (input, True) + in + (result, input') + + +parseStr :: Parser a -> String -> (ParserResult a, ByteString) +parseStr p input = parse p $ B.pack input anyChar :: Parser Char -anyChar = Parser $ do input <- get +anyChar = Parser $ do (input, isEOFFatal) <- get if B.null input then return ReachedEOF else do let c = B.head input - put (B.tail input) + put (B.tail input, isEOFFatal) return (Success c) +eof :: Parser () +eof = Parser $ do (input, _) <- get + if B.null input then + return $ Success () + else + return IllegalInput + + +allowEOF :: Parser a -> Parser a +allowEOF f = Parser $ do (input, isEOFFatal) <- get + put (input, False) + + result <- runParser f + + (input', _) <- get + put (input', isEOFFatal) + + return result + + satisfy :: (Char -> Bool) -> Parser Char satisfy f = do c <- anyChar unless (f c) (fail "") @@ -84,13 +124,17 @@ string str = do mapM_ char str infixr 0 <|> (<|>) :: Parser a -> Parser a -> Parser a -f <|> g = Parser $ do saved <- get -- 状態を保存 +f <|> g = Parser $ do saved@(_, isEOFFatal) <- get -- 状態を保存 result <- runParser f case result of Success a -> return $ Success a IllegalInput -> do put saved -- 状態を復歸 runParser g - ReachedEOF -> return ReachedEOF + ReachedEOF -> if isEOFFatal then + return ReachedEOF + else + do put saved + runParser g oneOf :: [Char] -> Parser Char @@ -150,6 +194,16 @@ option :: a -> Parser a -> Parser a option def p = p <|> return def +sepBy :: Parser a -> Parser sep -> Parser [a] +sepBy p sep = sepBy1 p sep <|> return [] + + +sepBy1 :: Parser a -> Parser sep -> Parser [a] +sepBy1 p sep = do x <- p + xs <- many $ sep >> p + return (x:xs) + + sp :: Parser Char sp = char ' ' diff --git a/Network/HTTP/Lucu/Parser/Http.hs b/Network/HTTP/Lucu/Parser/Http.hs index c1b30fc..534577c 100644 --- a/Network/HTTP/Lucu/Parser/Http.hs +++ b/Network/HTTP/Lucu/Parser/Http.hs @@ -18,7 +18,7 @@ import Network.HTTP.Lucu.Parser isCtl :: Char -> Bool isCtl c | c < '\x1f' = True - | c == '\x7f' = True + | c >= '\x7f' = True | otherwise = False @@ -54,13 +54,11 @@ quotedStr :: Parser String quotedStr = do char '"' xs <- many (qdtext <|> quotedPair) char '"' - return $ foldr (++) "" (["\""] ++ xs ++ ["\""]) + return $ foldr (++) "" xs where - qdtext = char '"' >> fail "" - <|> - do c <- text + qdtext = do c <- satisfy (/= '"') return [c] quotedPair = do q <- char '\\' c <- satisfy isChar - return [q, c] + return [c] diff --git a/Network/HTTP/Lucu/RequestReader.hs b/Network/HTTP/Lucu/RequestReader.hs index f2f3976..42eda0e 100644 --- a/Network/HTTP/Lucu/RequestReader.hs +++ b/Network/HTTP/Lucu/RequestReader.hs @@ -114,9 +114,6 @@ requestReader cnf tree h host tQueue acceptRequestForExistentResource :: Interaction -> ByteString -> ResourceDef -> STM (IO ()) acceptRequestForExistentResource itr input rsrcDef = do requestHasBody <- readItr itr itrRequestHasBody id - writeItr itr itrState (if requestHasBody - then ExaminingHeader - else DecidingHeader) enqueue itr return $ do runResource rsrcDef itr if requestHasBody then 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 diff --git a/Network/HTTP/Lucu/ResponseWriter.hs b/Network/HTTP/Lucu/ResponseWriter.hs index 373930a..7dca25b 100644 --- a/Network/HTTP/Lucu/ResponseWriter.hs +++ b/Network/HTTP/Lucu/ResponseWriter.hs @@ -1,5 +1,5 @@ module Network.HTTP.Lucu.ResponseWriter - ( responseWriter -- Handle -> InteractionQueue -> IO () + ( responseWriter -- Config -> Handle -> InteractionQueue -> IO () ) where @@ -11,7 +11,10 @@ import Control.Monad import Data.Maybe import qualified Data.Sequence as S import Data.Sequence (Seq, ViewR(..)) +import Network.HTTP.Lucu.Config +import Network.HTTP.Lucu.HttpVersion import Network.HTTP.Lucu.Interaction +import Network.HTTP.Lucu.Postprocess import Network.HTTP.Lucu.Response import Prelude hiding (catch) import System.IO @@ -21,8 +24,8 @@ import Control.Concurrent import Debug.Trace -responseWriter :: Handle -> InteractionQueue -> ThreadId -> IO () -responseWriter h tQueue readerTID +responseWriter :: Config -> Handle -> InteractionQueue -> ThreadId -> IO () +responseWriter cnf h tQueue readerTID = catch awaitSomethingToWrite $ \ exc -> case exc of IOException _ -> return () @@ -58,13 +61,16 @@ responseWriter h tQueue readerTID writeContinueIfNecessary itr = do expectedContinue <- readItr itr itrExpectedContinue id if expectedContinue then - do wroteContinue <- readItr itr itrWroteContinue id if wroteContinue then -- 既に Continue を書込み濟 retry else - return $ writeContinue itr + do reqBodyWanted <- readItr itr itrReqBodyWanted id + if reqBodyWanted /= Nothing then + return $ writeContinue itr + else + retry else retry @@ -92,7 +98,17 @@ responseWriter h tQueue readerTID return $ writeBodyChunk itr writeContinue :: Interaction -> IO () - writeContinue itr = fail "FIXME: not implemented" + writeContinue itr + = do let cont = Response { + resVersion = HttpVersion 1 1 + , resStatus = Continue + , resHeaders = [] + } + cont' <- completeUnconditionalHeaders cnf cont + hPutResponse h cont' + hFlush h + atomically $ writeItr itr itrWroteContinue True + awaitSomethingToWrite writeHeader :: Interaction -> IO () writeHeader itr diff --git a/examples/HelloWorld.hs b/examples/HelloWorld.hs index 42ccb90..2fb9ed9 100644 --- a/examples/HelloWorld.hs +++ b/examples/HelloWorld.hs @@ -1,11 +1,16 @@ +import Control.Monad.Trans import Data.Maybe import Network import Network.HTTP.Lucu.Config +import Network.HTTP.Lucu.ETag import Network.HTTP.Lucu.Httpd +import Network.HTTP.Lucu.Parser +import Network.HTTP.Lucu.Parser.Http import Network.HTTP.Lucu.Resource import Network.HTTP.Lucu.Response import Network.URI import System.Posix.Signals +import System.Time main :: IO () main = let config = defaultConfig { cnfServerPort = PortNumber 9999 } @@ -21,7 +26,9 @@ helloWorld resUsesNativeThread = False , resIsGreedy = False , resGet - = Just $ do setHeader "Content-Type" "text/plain" + = Just $ do time <- liftIO $ getClockTime + foundEntity False "abcde" time + setHeader "Content-Type" "text/plain" outputChunk "Hello, " outputChunk "World!\n" , resHead = Nothing -- 2.40.0