From b0efa668bb881d1c9db4b852b1b9063a2db12b3d Mon Sep 17 00:00:00 2001 From: pho Date: Tue, 10 Nov 2009 01:23:50 +0900 Subject: [PATCH] Fix for insane memory usage Ignore-this: 844a3d7fd98d5d2b21795c7b5453723 * Network.HTTP.Lucu.Resource: (Thanks: Voker57) - Bugfix: inputForm was consuming too much memory. The memory usage is still somewhat high, but not insanely high. - Changed the type of FormData/fdContent from String to Lazy.ByteString. Sorry for frequent type changes. darcs-hash:20091109162350-62b54-6c0a9f1d9ae85a8a26354a9a1da0912f46c02a34.gz --- Lucu.cabal | 2 +- NEWS | 12 +++- Network/HTTP/Lucu/MultipartForm.hs | 8 +-- Network/HTTP/Lucu/Parser.hs | 96 ++++++++++++++++++++---------- Network/HTTP/Lucu/Resource.hs | 2 +- examples/Multipart.hs | 9 +-- 6 files changed, 88 insertions(+), 41 deletions(-) diff --git a/Lucu.cabal b/Lucu.cabal index 110eda1..8bb57b6 100644 --- a/Lucu.cabal +++ b/Lucu.cabal @@ -8,7 +8,7 @@ Description: messing around FastCGI. It is also intended to be run behind a reverse-proxy so it doesn't have some facilities like logging, client filtering or such like. -Version: 0.3.3 +Version: 0.4 License: PublicDomain License-File: COPYING Author: PHO diff --git a/NEWS b/NEWS index 52c5082..ff66a4e 100644 --- a/NEWS +++ b/NEWS @@ -1,6 +1,16 @@ +Changes from 0.3.3 to 0.4 +------------------------- +* Network.HTTP.Lucu.Resource: (Thanks: Voker57) + + - Bugfix: inputForm was consuming too much memory. The memory + usage is still somewhat high, but not insanely high. + + - Changed the type of FormData/fdContent from String to + Lazy.ByteString. Sorry for frequent type changes. + Changes from 0.3.2 to 0.3.3 --------------------------- -* Network.HTTP.Lucu.Resource: +* Network.HTTP.Lucu.Resource: (Thanks: Voker57) - getQueryForm and inputForm now returns [FormData] instead of [(String, String)] to possibly include a name of uploaded file. diff --git a/Network/HTTP/Lucu/MultipartForm.hs b/Network/HTTP/Lucu/MultipartForm.hs index 4a34ba5..e73b74d 100644 --- a/Network/HTTP/Lucu/MultipartForm.hs +++ b/Network/HTTP/Lucu/MultipartForm.hs @@ -16,7 +16,7 @@ import Network.HTTP.Lucu.Response import Network.HTTP.Lucu.Utils -data Part = Part Headers String +data Part = Part Headers L8.ByteString -- |This data type represents a form entry name, form value and -- possibly an uploaded file name. @@ -24,7 +24,7 @@ data FormData = FormData { fdName :: String , fdFileName :: Maybe String - , fdContent :: String + , fdContent :: L8.ByteString } instance HasHeaders Part where @@ -71,9 +71,9 @@ partP boundary return $ Part hs body -bodyP :: String -> Parser String +bodyP :: String -> Parser L8.ByteString bodyP boundary - = do body <- many $ + = do body <- manyChar $ do notFollowedBy $ do crlf string "--" string boundary diff --git a/Network/HTTP/Lucu/Parser.hs b/Network/HTTP/Lucu/Parser.hs index 6c66e7f..9a36ad5 100644 --- a/Network/HTTP/Lucu/Parser.hs +++ b/Network/HTTP/Lucu/Parser.hs @@ -39,6 +39,7 @@ module Network.HTTP.Lucu.Parser , hexDigit , notFollowedBy , many + , manyChar , many1 , count , option @@ -55,6 +56,7 @@ import Control.Monad.State.Strict import qualified Data.ByteString.Lazy as Lazy (ByteString) import qualified Data.ByteString.Lazy.Char8 as B hiding (ByteString) import qualified Data.Foldable as Fold +import Data.Int import qualified Data.Sequence as Seq import Data.Sequence (Seq, (|>)) @@ -88,8 +90,8 @@ instance Monad Parser where return IllegalInput ReachedEOF -> do put saved -- 状態を復歸 return ReachedEOF - return x = x `seq` Parser $! return $! Success x - fail _ = Parser $! return $! IllegalInput + return !x = Parser $! return $! Success x + fail _ = Parser $! return $! IllegalInput -- |@'failP'@ is just a synonym for @'Prelude.fail' -- 'Prelude.undefined'@. @@ -99,17 +101,15 @@ failP = fail undefined -- |@'parse' p bstr@ parses @bstr@ with @p@ and returns @(# result, -- remaining #)@. parse :: Parser a -> Lazy.ByteString -> (# ParserResult a, Lazy.ByteString #) -parse p input -- input は lazy である必要有り。 - = p `seq` - let (result, state') = runState (runParser p) (PST input True) +parse !p input -- input は lazy である必要有り。 + = let (!result, state') = runState (runParser p) (PST input True) in - result `seq` (# result, pstInput state' #) -- pstInput state' も lazy である必要有り。 + (# result, pstInput state' #) -- pstInput state' も lazy である必要有り。 -- |@'parseStr' p str@ packs @str@ and parses it. parseStr :: Parser a -> String -> (# ParserResult a, Lazy.ByteString #) -parseStr p input - = p `seq` -- input は lazy である必要有り。 - parse p (B.pack input) +parseStr !p input -- input は lazy である必要有り。 + = parse p (B.pack input) anyChar :: Parser Char @@ -132,16 +132,16 @@ eof = Parser $! -- |@'allowEOF' p@ makes @p@ treat reaching EOF a normal failure. allowEOF :: Parser a -> Parser a -allowEOF f = f `seq` - Parser $! do saved@(PST _ isEOFFatal) <- get - put $! saved { pstIsEOFFatal = False } +allowEOF !f + = Parser $! do saved@(PST _ isEOFFatal) <- get + put $! saved { pstIsEOFFatal = False } - result <- runParser f + result <- runParser f - state <- get - put $! state { pstIsEOFFatal = isEOFFatal } + state <- get + put $! state { pstIsEOFFatal = isEOFFatal } - return result + return result satisfy :: (Char -> Bool) -> Parser Char @@ -158,9 +158,22 @@ char !c = satisfy (== c) string :: String -> Parser String -string !str = str `seq` - do mapM_ char str - return str +string !str + = let bs = B.pack str + len = B.length bs + in + Parser $! + do st <- get + let (bs', rest) = B.splitAt len $ pstInput st + st' = st { pstInput = rest } + if B.length bs' < len then + return ReachedEOF + else + if bs == bs' then + do put st' + return $ Success str + else + return IllegalInput infixr 0 <|> @@ -168,9 +181,8 @@ infixr 0 <|> -- |This is the backtracking alternation. There is no non-backtracking -- equivalent. (<|>) :: Parser a -> Parser a -> Parser a -f <|> g - = f `seq` g `seq` - Parser $! do saved <- get -- 状態を保存 +(!f) <|> (!g) + = Parser $! do saved <- get -- 状態を保存 result <- runParser f case result of Success a -> return $! Success a @@ -240,6 +252,32 @@ many !p = Parser $! else (# Success (Fold.toList soFar), st #) +manyChar :: Parser Char -> Parser Lazy.ByteString +manyChar !p = Parser $! + do state <- get + case scan' state 0 of + Success len + -> do let (bs, rest) = B.splitAt len (pstInput state) + state' = state { pstInput = rest } + put state' + return $ Success bs + ReachedEOF + -> if pstIsEOFFatal state then + return ReachedEOF + else + error "internal error" + _ -> error "internal error" + where + scan' :: ParserState -> Int64 -> ParserResult Int64 + scan' !st !soFar + = case runState (runParser p) st of + (Success _ , st') -> scan' st' (soFar + 1) + (IllegalInput, _ ) -> Success soFar + (ReachedEOF , _ ) -> if pstIsEOFFatal st then + ReachedEOF + else + Success soFar + many1 :: Parser a -> Parser [a] many1 !p = do x <- p @@ -266,20 +304,18 @@ count' !n !p !soFar = do saved <- get -- def may be a _|_ option :: a -> Parser a -> Parser a -option def p = p `seq` - p <|> return def +option def !p = p <|> return def sepBy :: Parser a -> Parser sep -> Parser [a] -sepBy p sep = p `seq` sep `seq` - sepBy1 p sep <|> return [] +sepBy !p !sep = sepBy1 p sep <|> return [] sepBy1 :: Parser a -> Parser sep -> Parser [a] -sepBy1 p sep = p `seq` sep `seq` - do x <- p - xs <- many $! sep >> p - return (x:xs) +sepBy1 !p !sep + = do x <- p + xs <- many $! sep >> p + return (x:xs) sp :: Parser Char diff --git a/Network/HTTP/Lucu/Resource.hs b/Network/HTTP/Lucu/Resource.hs index a9d487c..e456fd2 100644 --- a/Network/HTTP/Lucu/Resource.hs +++ b/Network/HTTP/Lucu/Resource.hs @@ -312,7 +312,7 @@ pairToFormData (name, value) = FormData { fdName = name , fdFileName = Nothing - , fdContent = value + , fdContent = L8.pack value } -- |Get a value of given request header. Comparison of header name is diff --git a/examples/Multipart.hs b/examples/Multipart.hs index 1e2d50b..f8c1c7b 100644 --- a/examples/Multipart.hs +++ b/examples/Multipart.hs @@ -1,3 +1,4 @@ +import qualified Data.ByteString.Lazy.Char8 as L8 import Data.List import Data.Maybe import Network @@ -28,12 +29,12 @@ resMain , resHead = Nothing , resPost = Just $ do form <- inputForm defaultLimit - let text = fromMaybe "" $ fmap fdContent $ find ((== "text") . fdName) form - file = fromMaybe "" $ fmap fdContent $ find ((== "file") . fdName) form + let text = fromMaybe L8.empty $ fmap fdContent $ find ((== "text") . fdName) form + file = fromMaybe L8.empty $ fmap fdContent $ find ((== "file") . fdName) form fileName = fdFileName =<< find ((== "file") . fdName) form setContentType $ read "text/plain" - outputChunk ("You entered \"" ++ text ++ "\".\n") - outputChunk ("You uploaded a " ++ show (length file) ++ " bytes long file.\n") + outputChunk ("You entered \"" ++ L8.unpack text ++ "\".\n") + outputChunk ("You uploaded a " ++ show (L8.length file) ++ " bytes long file.\n") output ("The file name is " ++ show fileName ++ ".\n") , resPut = Nothing , resDelete = Nothing -- 2.40.0