]> gitweb @ CieloNegro.org - Lucu.git/commitdiff
Fixed stack-overflow bugs RELEASE-0_3_2
authorpho <pho@cielonegro.org>
Wed, 8 Jul 2009 13:16:02 +0000 (22:16 +0900)
committerpho <pho@cielonegro.org>
Wed, 8 Jul 2009 13:16:02 +0000 (22:16 +0900)
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

GNUmakefile [new file with mode: 0644]
Lucu.cabal
Makefile [deleted file]
NEWS
Network/HTTP/Lucu/Parser.hs
cabal-package.mk [new file with mode: 0644]
examples/Multipart.hs

diff --git a/GNUmakefile b/GNUmakefile
new file mode 100644 (file)
index 0000000..e85c5ed
--- /dev/null
@@ -0,0 +1,5 @@
+RUN_COMMAND = $(MAKE) -C examples run
+
+CONFIGURE_ARGS = -O
+
+include cabal-package.mk
\ No newline at end of file
index d9f6fc8d5b8940b0f3369c0cfd071ff15aa2cf96..325195c87cc47e221491fed7a26d8510d3d793f8 100644 (file)
@@ -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 <pho at cielonegro dot org>
@@ -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 (file)
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 2ee14bc1776834a301186aef48e554294a77d74c..c5814dcc2d0d5d6803688bbaccf5f3c62e19a1e5 100644 (file)
--- 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:
index 90c52696fbb4293e95849e5335758d7a255913bd..8c591defd4be602e13db5534567637039b0679bb 100644 (file)
@@ -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 (file)
index 0000000..ca291ff
--- /dev/null
@@ -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
index e68bb396e5b292814845f7849af70995f0f35546..6c15cd3a8a4ab1130737c1c770983892edb2d596 100644 (file)
@@ -20,16 +20,19 @@ resMain
           = Just $ do setContentType $ read "text/html"
                       output ("<title>Multipart Form Test</title>" ++
                               "<form action=\"/\" method=\"post\" enctype=\"multipart/form-data\">" ++
-                              "  Enter some value:" ++
-                              "  <input type=\"text\" name=\"val\">" ++
+                              "  Upload some file:" ++
+                              "  <input type=\"text\" name=\"text\">" ++
+                              "  <input type=\"file\" name=\"file\">" ++
                               "  <input type=\"submit\" value=\"Submit\">" ++
                               "</form>")
       , 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