From 078fc2851ceae061fe368f2bc09fcd16d67ae00f Mon Sep 17 00:00:00 2001 From: pho Date: Wed, 3 Oct 2007 23:57:40 +0900 Subject: [PATCH] The parser now returns unboxed tuple. darcs-hash:20071003145740-62b54-b0dc200b632ee22a6090b7948ac39fa8b319c939.gz --- Network/HTTP/Lucu/MIMEType.hs | 9 ++++----- Network/HTTP/Lucu/MIMEType/Guess.hs | 11 +++++++---- Network/HTTP/Lucu/Parser.hs | 8 ++++---- Network/HTTP/Lucu/RFC1123DateTime.hs | 4 ++-- Network/HTTP/Lucu/RequestReader.hs | 25 ++++++++++++++----------- Network/HTTP/Lucu/Resource.hs | 28 +++++++++++++++------------- 6 files changed, 46 insertions(+), 39 deletions(-) diff --git a/Network/HTTP/Lucu/MIMEType.hs b/Network/HTTP/Lucu/MIMEType.hs index 947cb00..da4f503 100644 --- a/Network/HTTP/Lucu/MIMEType.hs +++ b/Network/HTTP/Lucu/MIMEType.hs @@ -46,11 +46,10 @@ instance Read MIMEType where -- exception for parse error. parseMIMEType :: String -> MIMEType parseMIMEType str = case parseStr mimeTypeP str of - (Success t, r) -> if B.null r then - t - else - error ("unparsable MIME Type: " ++ str) - _ -> error ("unparsable MIME Type: " ++ str) + (# Success t, r #) -> if B.null r + then t + else error ("unparsable MIME Type: " ++ str) + (# _ , _ #) -> error ("unparsable MIME Type: " ++ str) mimeTypeP :: Parser MIMEType diff --git a/Network/HTTP/Lucu/MIMEType/Guess.hs b/Network/HTTP/Lucu/MIMEType/Guess.hs index dfcceb9..d6c4958 100644 --- a/Network/HTTP/Lucu/MIMEType/Guess.hs +++ b/Network/HTTP/Lucu/MIMEType/Guess.hs @@ -40,10 +40,13 @@ parseExtMapFile fpath = fpath `seq` do file <- B.readFile fpath case parse (allowEOF extMapP) file of - (Success xs, _) -> return $ compile xs - (_, input') -> let near = B.unpack $ B.take 100 input' - in - fail ("Failed to parse: " ++ fpath ++ " (near: " ++ near ++ ")") + (# Success xs, _ #) + -> return $ compile xs + + (# _, input' #) + -> let near = B.unpack $ B.take 100 input' + in + fail ("Failed to parse: " ++ fpath ++ " (near: " ++ near ++ ")") extMapP :: Parser [ (MIMEType, [String]) ] diff --git a/Network/HTTP/Lucu/Parser.hs b/Network/HTTP/Lucu/Parser.hs index f2e4be3..5671ec0 100644 --- a/Network/HTTP/Lucu/Parser.hs +++ b/Network/HTTP/Lucu/Parser.hs @@ -95,18 +95,18 @@ failP = fail undefined -- |@'parse' p bstr@ parses @bstr@ with @p@ and returns @(result, -- remaining)@. -parse :: Parser a -> LazyByteString -> (ParserResult a, LazyByteString) +parse :: Parser a -> LazyByteString -> (# ParserResult a, LazyByteString #) parse p input -- input は lazy である必要有り。 = p `seq` let (result, state') = runState (runParser p) (PST input True) in - result `seq` (result, pstInput state') -- pstInput state' も lazy である必要有り。 + result `seq` (# result, pstInput state' #) -- pstInput state' も lazy である必要有り。 -- |@'parseStr' p str@ packs @str@ and parses it. -parseStr :: Parser a -> String -> (ParserResult a, LazyByteString) +parseStr :: Parser a -> String -> (# ParserResult a, LazyByteString #) parseStr p input = p `seq` -- input は lazy である必要有り。 - parse p $! B.pack input + parse p (B.pack input) anyChar :: Parser Char diff --git a/Network/HTTP/Lucu/RFC1123DateTime.hs b/Network/HTTP/Lucu/RFC1123DateTime.hs index 4d7aa15..2cd06cc 100644 --- a/Network/HTTP/Lucu/RFC1123DateTime.hs +++ b/Network/HTTP/Lucu/RFC1123DateTime.hs @@ -65,8 +65,8 @@ formatHTTPDateTime time parseHTTPDateTime :: String -> Maybe ClockTime parseHTTPDateTime src = case parseStr httpDateTime src of - (Success ct, _) -> Just ct - _ -> Nothing + (# Success ct, _ #) -> Just ct + (# _ , _ #) -> Nothing httpDateTime :: Parser ClockTime diff --git a/Network/HTTP/Lucu/RequestReader.hs b/Network/HTTP/Lucu/RequestReader.hs index 091a3a2..8760cb8 100644 --- a/Network/HTTP/Lucu/RequestReader.hs +++ b/Network/HTTP/Lucu/RequestReader.hs @@ -50,9 +50,9 @@ requestReader cnf tree h addr tQueue -- Request 應答を設定し、それを出力してから切斷するやう -- に ResponseWriter に通知する。 case parse requestP input of - (Success req , input') -> acceptParsableRequest req input' - (IllegalInput, _ ) -> acceptNonparsableRequest BadRequest - (ReachedEOF , _ ) -> acceptNonparsableRequest BadRequest + (# Success req , input' #) -> acceptParsableRequest req input' + (# IllegalInput, _ #) -> acceptNonparsableRequest BadRequest + (# ReachedEOF , _ #) -> acceptNonparsableRequest BadRequest acceptNonparsableRequest :: StatusCode -> IO () acceptNonparsableRequest status @@ -150,7 +150,7 @@ requestReader cnf tree h addr tQueue -- 讀み終へてゐない do let (_, input') = B.splitAt (fromIntegral $ fromJust remainingM) input - (footerR, input'') = parse chunkFooterP input' + (# footerR, input'' #) = parse chunkFooterP input' if footerR == Success () then -- チャンクフッタを正常に讀めた @@ -188,10 +188,11 @@ requestReader cnf tree h addr tQueue if newRemaining == Just 0 then -- チャンクフッタを讀む case parse chunkFooterP input' of - (Success _, input'') + (# Success _, input'' #) -> do updateStates return $ observeChunkedRequest itr input'' - _ -> return $ chunkWasMalformed itr + (# _, _ #) + -> return $ chunkWasMalformed itr else -- まだチャンクの終はりに達してゐない do updateStates @@ -206,23 +207,25 @@ requestReader cnf tree h addr tQueue = {-# SCC "seekNextChunk" #-} case parse chunkHeaderP input of -- 最終チャンク (中身が空) - (Success 0, input') + (# Success 0, input' #) -> case parse chunkTrailerP input' of - (Success _, input'') + (# Success _, input'' #) -> do writeItr itr itrReqChunkLength $ Nothing writeItr itr itrReqChunkRemaining $ Nothing writeItr itr itrReqChunkIsOver True return $ acceptRequest input'' - _ -> return $ chunkWasMalformed itr + (# _, _ #) + -> return $ chunkWasMalformed itr -- 最終でないチャンク - (Success len, input') + (# Success len, input' #) -> do writeItr itr itrReqChunkLength $ Just len writeItr itr itrReqChunkRemaining $ Just len return $ observeChunkedRequest itr input' -- チャンクヘッダがをかしい - _ -> return $ chunkWasMalformed itr + (# _, _ #) + -> return $ chunkWasMalformed itr chunkWasMalformed :: Interaction -> IO () chunkWasMalformed itr diff --git a/Network/HTTP/Lucu/Resource.hs b/Network/HTTP/Lucu/Resource.hs index 7b64629..8942c76 100644 --- a/Network/HTTP/Lucu/Resource.hs +++ b/Network/HTTP/Lucu/Resource.hs @@ -280,9 +280,9 @@ getAccept = do acceptM <- getHeader "Accept" -> return [] Just accept -> case parseStr mimeTypeListP accept of - (Success xs, _) -> return xs - _ -> abort BadRequest [] - (Just $ "Unparsable Accept: " ++ accept) + (# Success xs, _ #) -> return xs + (# _ , _ #) -> abort BadRequest [] + (Just $ "Unparsable Accept: " ++ accept) -- |Get a list of @(contentCoding, qvalue)@ enumerated on header -- \"Accept-Encoding\". The list is sorted in descending order by @@ -305,9 +305,9 @@ getAcceptEncoding -> return [("identity", Nothing)] Just accEnc -> case parseStr acceptEncodingListP accEnc of - (Success x, _) -> return $ reverse $ sortBy orderAcceptEncodings x - _ -> abort BadRequest [] - (Just $ "Unparsable Accept-Encoding: " ++ accEnc) + (# Success x, _ #) -> return $ reverse $ sortBy orderAcceptEncodings x + (# _ , _ #) -> abort BadRequest [] + (Just $ "Unparsable Accept-Encoding: " ++ accEnc) -- |Check whether a given content-coding is acceptable. isEncodingAcceptable :: String -> Resource Bool @@ -327,9 +327,9 @@ getContentType -> return Nothing Just cType -> case parseStr mimeTypeP cType of - (Success t, _) -> return $ Just t - _ -> abort BadRequest [] - (Just $ "Unparsable Content-Type: " ++ cType) + (# Success t, _ #) -> return $ Just t + (# _ , _ #) -> abort BadRequest [] + (Just $ "Unparsable Content-Type: " ++ cType) {- ExaminingRequest 時に使用するアクション群 -} @@ -388,13 +388,14 @@ foundETag tag Nothing -> return () Just "*" -> return () Just list -> case parseStr eTagListP list of - (Success tags, _) + (# Success tags, _ #) -- tags の中に一致するものが無ければ -- PreconditionFailed で終了。 -> when (not $ any (== tag) tags) $ abort PreconditionFailed [] $! Just ("The entity tag doesn't match: " ++ list) - _ -> abort BadRequest [] $! Just ("Unparsable If-Match: " ++ fromJust ifMatch) + (# _, _ #) + -> abort BadRequest [] $! Just ("Unparsable If-Match: " ++ fromJust ifMatch) let statusForNoneMatch = if method == GET || method == HEAD then NotModified @@ -407,10 +408,11 @@ foundETag tag Nothing -> return () Just "*" -> abort statusForNoneMatch [] $! Just ("The entity tag matches: *") Just list -> case parseStr eTagListP list of - (Success tags, _) + (# Success tags, _ #) -> when (any (== tag) tags) $ abort statusForNoneMatch [] $! Just ("The entity tag matches: " ++ list) - _ -> abort BadRequest [] $! Just ("Unparsable If-None-Match: " ++ list) + (# _, _ #) + -> abort BadRequest [] $! Just ("Unparsable If-None-Match: " ++ list) driftTo GettingBody -- 2.40.0