From: pho Date: Wed, 8 Jul 2009 13:16:02 +0000 (+0900) Subject: Fixed stack-overflow bugs X-Git-Tag: RELEASE-0_3_2 X-Git-Url: https://git.cielonegro.org/gitweb.cgi?a=commitdiff_plain;h=d4c76b57333f7dc59aad618ac5b40873577e9a58;p=Lucu.git Fixed stack-overflow bugs Ignore-this: 35225469f30594a7e86882dd56e7394a Fixed stack-overflow bugs. * Network.HTTP.Lucu.Parser: - Reimplemented 'many', 'many1' and 'count' in tail-recursive way. This resolves a stack overflow when a large file is POSTed as a multipart/form-data. darcs-hash:20090708131602-62b54-f46f949dea1aa96bcf30134a3cda1ccc0d4feeee.gz --- diff --git a/GNUmakefile b/GNUmakefile new file mode 100644 index 0000000..e85c5ed --- /dev/null +++ b/GNUmakefile @@ -0,0 +1,5 @@ +RUN_COMMAND = $(MAKE) -C examples run + +CONFIGURE_ARGS = -O + +include cabal-package.mk \ No newline at end of file diff --git a/Lucu.cabal b/Lucu.cabal index d9f6fc8..325195c 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.1 +Version: 0.3.2 License: PublicDomain License-File: COPYING Author: PHO @@ -92,7 +92,7 @@ Executable lucu-implant-file Buildable: False Main-Is: ImplantFile.hs Extensions: - UnboxedTuples + BangPatterns, UnboxedTuples ghc-options: -Wall -funbox-strict-fields diff --git a/Makefile b/Makefile deleted file mode 100644 index 4f04f26..0000000 --- a/Makefile +++ /dev/null @@ -1,32 +0,0 @@ -CABAL_FILE = Lucu.cabal -GHC = ghc - -build: dist/setup-config Setup - ./Setup build - -run: build - @echo ".:.:. Let's go .:.:." - $(MAKE) -C examples run - -dist/setup-config: $(CABAL_FILE) Setup -# ./Setup configure --disable-optimization - ./Setup configure -O - -Setup: Setup.hs - $(GHC) --make Setup - -clean: - rm -rf dist Setup Setup.o Setup.hi - find . -name '*~' -exec rm -f {} \; - $(MAKE) -C examples clean - -doc: dist/setup-config Setup - ./Setup haddock - -install: build - sudo ./Setup install - -sdist: Setup - ./Setup sdist - -.PHONY: build run clean install doc sdist diff --git a/NEWS b/NEWS index 2ee14bc..c5814dc 100644 --- a/NEWS +++ b/NEWS @@ -1,3 +1,10 @@ +Changes from 0.3.1 to 0.3.2 +--------------------------- +* Network.HTTP.Lucu.Parser: + - Reimplemented 'many', 'many1' and 'count' in tail-recursive + way. This resolves a stack overflow when a large file is POSTed + as a multipart/form-data. + Changes from 0.3 to 0.3.1 ------------------------- * Network.HTTP.Lucu.Resource: diff --git a/Network/HTTP/Lucu/Parser.hs b/Network/HTTP/Lucu/Parser.hs index 90c5269..8c591de 100644 --- a/Network/HTTP/Lucu/Parser.hs +++ b/Network/HTTP/Lucu/Parser.hs @@ -174,7 +174,8 @@ f <|> g IllegalInput -> do put saved -- 状態を復歸 runParser g ReachedEOF -> if pstIsEOFFatal saved then - return ReachedEOF + do put saved + return ReachedEOF else do put saved runParser g @@ -221,27 +222,48 @@ hexDigit = do c <- anyChar many :: Parser a -> Parser [a] -many p = p `seq` - do x <- p - xs <- many p - return (x:xs) - <|> - return [] +many !p = Parser $! many' p [] + +-- This implementation is rather ugly but we need to make it +-- tail-recursive to avoid stack overflow. +many' :: Parser a -> [a] -> State ParserState (ParserResult [a]) +many' !p !soFar + = do saved <- get + result <- runParser p + case result of + Success a -> many' p (a:soFar) + IllegalInput -> do put saved + return $! Success $ reverse soFar + ReachedEOF -> if pstIsEOFFatal saved then + do put saved + return ReachedEOF + else + do put saved + return $! Success $ reverse soFar many1 :: Parser a -> Parser [a] -many1 p = p `seq` - do x <- p - xs <- many p - return (x:xs) +many1 !p = do x <- p + xs <- many p + return (x:xs) count :: Int -> Parser a -> Parser [a] -count 0 _ = return [] -count n p = n `seq` p `seq` - do x <- p - xs <- count (n-1) p - return (x:xs) +count !n !p = Parser $! count' n p [] + +-- This implementation is rather ugly but we need to make it +-- tail-recursive to avoid stack overflow. +count' :: Int -> Parser a -> [a] -> State ParserState (ParserResult [a]) +count' 0 _ !soFar = return $! Success $ reverse soFar +count' !n !p !soFar = do saved <- get + result <- runParser p + case result of + Success a -> count' (n-1) p (a:soFar) + IllegalInput -> do put saved + return IllegalInput + ReachedEOF -> do put saved + return ReachedEOF + -- def may be a _|_ option :: a -> Parser a -> Parser a diff --git a/cabal-package.mk b/cabal-package.mk new file mode 100644 index 0000000..ca291ff --- /dev/null +++ b/cabal-package.mk @@ -0,0 +1,89 @@ +# -*- makefile-gmake -*- +# +# Variables: +# +# CONFIGURE_ARGS :: arguments to be passed to ./Setup configure +# default: --disable-optimization +# +# RUN_COMMAND :: command to be run for "make run" +# + +GHC ?= ghc +FIND ?= find +RM_RF ?= rm -rf +SUDO ?= sudo +AUTOCONF ?= autoconf + +CONFIGURE_ARGS ?= --disable-optimization + +SETUP_FILE := $(wildcard Setup.*hs) +CABAL_FILE := $(wildcard *.cabal) + +ifeq ($(shell ls configure.ac 2>/dev/null),configure.ac) + AUTOCONF_AC_FILE := configure.ac + AUTOCONF_FILE := configure +else + ifeq ($(shell ls configure.in 2>/dev/null),configure.in) + AUTOCONF_AC_FILE := configure.in + AUTOCONF_FILE := configure + else + AUTOCONF_AC_FILE := + AUTOCONF_FILE := + endif +endif + +BUILDINFO_IN_FILE := $(wildcard *.buildinfo.in) +BUILDINFO_FILE := $(BUILDINFO_IN_FILE:.in=) + +all: build + +build: setup-config build-hook + ./Setup build + +build-hook: + +ifeq ($(RUN_COMMAND),) +run: + @echo "cabal-package.mk: No command to run." + @echo "cabal-package.mk: If you want to run something, define RUN_COMMAND variable." +else +run: build + @echo ".:.:. Let's go .:.:." + $(RUN_COMMAND) +endif + +setup-config: dist/setup-config setup-config-hook $(BUILDINFO_FILE) + +setup-config-hook: + +dist/setup-config: $(CABAL_FILE) Setup $(AUTOCONF_FILE) + ./Setup configure $(CONFIGURE_ARGS) + +$(AUTOCONF_FILE): $(AUTOCONF_AC_FILE) + $(AUTOCONF) + +$(BUILDINFO_FILE): $(BUILDINFO_IN_FILE) configure + ./Setup configure $(CONFIGURE_ARGS) + +Setup: $(SETUP_FILE) + $(GHC) --make Setup + +clean: clean-hook + $(RM_RF) dist Setup *.o *.hi .setup-config *.buildinfo + $(FIND) . -name '*~' -exec rm -f {} \; + +clean-hook: + +doc: setup-config + ./Setup haddock + +install: build + $(SUDO) ./Setup install + +sdist: setup-config + ./Setup sdist + +test: build + ./Setup test + +.PHONY: build build-hook setup-config setup-config-hook run clean clean-hook install doc sdist test diff --git a/examples/Multipart.hs b/examples/Multipart.hs index e68bb39..6c15cd3 100644 --- a/examples/Multipart.hs +++ b/examples/Multipart.hs @@ -20,16 +20,19 @@ resMain = Just $ do setContentType $ read "text/html" output ("Multipart Form Test" ++ "
" ++ - " Enter some value:" ++ - " " ++ + " Upload some file:" ++ + " " ++ + " " ++ " " ++ "
") , resHead = Nothing , resPost = Just $ do form <- inputForm defaultLimit - let value = fromMaybe "" $ fmap snd $ find ((== "val") . fst) form + let text = fromMaybe "" $ fmap snd $ find ((== "text") . fst) form + file = fromMaybe "" $ fmap snd $ find ((== "file") . fst) form setContentType $ read "text/plain" - output ("You entered: " ++ value) + outputChunk ("You entered \"" ++ text ++ "\".\n") + output ("You uploaded a " ++ show (length file) ++ " bytes long file.\n") , resPut = Nothing , resDelete = Nothing } \ No newline at end of file