[elpa] 68/119: no multiple concurrent entry of ws-parse-request

[Eric Schulte]

eschulte pushed a commit to branch master
in repository elpa.

commit e65938b2138a79eff9427e3e3ec69f9e577e07ab
Author: Eric Schulte <address@hidden>
Date:   Sun Jan 5 22:39:52 2014 -0700

    no multiple concurrent entry of ws-parse-request
    
      This fixes large file uploads, in which the ws-parse-request function
      was entered multiple time simultaneously because of the process filter
      preempting a running ws-parse-request.
---
 doc/web-server.texi |   28 +++++++++++++++++---
 web-server-test.el  |   71 ++++++++++++++++++++++++++++-----------------------
 web-server.el       |   52 +++++++++++++++++++++----------------
 3 files changed, 92 insertions(+), 59 deletions(-)

diff --git a/doc/web-server.texi b/doc/web-server.texi
index 0f5bb9a..a994413 100644
--- a/doc/web-server.texi
+++ b/doc/web-server.texi
@@ -159,7 +159,8 @@ These examples demonstrate usage.
 * URL Parameter Echo::          Echo Parameters from a URL query string
 * POST Echo::                   Echo POST parameters back
 * Basic Authentication::        BASIC HTTP Authentication
-* Org-mode Export Server::      Export files to HTML and Tex
+* Org-mode Export::             Export files to HTML and Tex
+* File Upload::                 Upload files and return their sha1sum
 @end menu
 
 @node Hello World, Hello World UTF8, Usage Examples, Usage Examples
@@ -228,7 +229,7 @@ in a @code{POST} request.
 
 @verbatiminclude ../examples/5-post-echo.el
 
address@hidden Basic Authentication, Org-mode Export Server, POST Echo, Usage 
Examples
address@hidden Basic Authentication, Org-mode Export, POST Echo, Usage Examples
 @section Basic Authentication
 
 The following example demonstrates BASIC HTTP authentication.  The
@@ -254,8 +255,8 @@ proxy server (e.g., Apache or Nginx) with HTTPS support.
 
 @verbatiminclude ../examples/6-basic-authentication.el
 
address@hidden Org-mode Export Server, Function Index, Basic Authentication, 
Usage Examples
address@hidden Org-mode Export Server
address@hidden Org-mode Export, File Upload, Basic Authentication, Usage 
Examples
address@hidden Org-mode Export
 
 The following example exports a directory of Org-mode files as either
 text, HTML or LaTeX.  The Org-mode export engine is used to export
@@ -263,6 +264,25 @@ files on-demand as they are requested.
 
 @verbatiminclude ../examples/7-org-mode-file-server.el
 
address@hidden File Upload, Function Index, Org-mode Export, Usage Examples
address@hidden File Upload
+
+The following example demonstrates accessing an uploaded file.  This
+simple server accesses the file named ``file'' and returns it's
+sha1sum and file name.
+
address@hidden ../examples/8-file-upload.el
+
+A file may be uploaded from an HTML form, or using the @code{curl}
+program as in the following example.
+
address@hidden
+$ curl -s -F file=@/usr/share/emacs/24.3/etc/COPYING localhost:9008
+8624bcdae55baeef00cd11d5dfcfa60f68710a02  COPYING
+$ sha1sum /usr/share/emacs/24.3/etc/COPYING
+8624bcdae55baeef00cd11d5dfcfa60f68710a02  /usr/share/emacs/24.3/etc/COPYING
address@hidden example
+
 @node Function Index, Copying, Usage Examples, Top
 @chapter Function Index
 @cindex function index
diff --git a/web-server-test.el b/web-server-test.el
index ee80ae9..a3c618a 100644
--- a/web-server-test.el
+++ b/web-server-test.el
@@ -73,8 +73,11 @@
 (ert-deftest ws/parse-many-headers ()
   "Test that a number of headers parse successfully."
   (let ((server (ws-start nil ws-test-port))
-        (request (make-instance 'ws-request))
-        (header-string "GET / HTTP/1.1
+        (request (make-instance 'ws-request)))
+    (unwind-protect
+        (progn
+          (setf (pending request)
+                "GET / HTTP/1.1
 Host: localhost:7777
 User-Agent: Mozilla/5.0 (X11; Linux x86_64; rv:26.0) Gecko/20100101 
Firefox/26.0
 Accept: text/html,application/xhtml+xml,application/xml;q=0.9,*/*;q=0.8
@@ -84,10 +87,8 @@ DNT: 1
 Cookie: __utma=111872281.1462392269.1345929539.1345929539.1345929539.1
 Connection: keep-alive
 
-"))
-    (unwind-protect
-        (progn
-          (ws-parse-request request header-string)
+")
+          (ws-parse-request request)
           (let ((headers (cdr (headers request))))
             (should (string= (cdr (assoc :ACCEPT-ENCODING headers))
                              "gzip, deflate"))
@@ -97,8 +98,11 @@ Connection: keep-alive
 
 (ert-deftest ws/parse-post-data ()
   (let ((server (ws-start nil ws-test-port))
-        (request (make-instance 'ws-request))
-        (header-string "POST / HTTP/1.1
+        (request (make-instance 'ws-request)))
+    (unwind-protect
+        (progn
+          (setf (pending request)
+                "POST / HTTP/1.1
 User-Agent: curl/7.33.0
 Host: localhost:8080
 Accept: */*
@@ -116,10 +120,8 @@ Content-Disposition: form-data; name=\"name\"
 
 \"schulte\"
 ------------------f1270d0deb77af03--
-"))
-    (unwind-protect
-        (progn
-          (ws-parse-request request header-string)
+")
+          (ws-parse-request request)
           (let ((headers (cdr (headers request))))
             (should (string= (cdr (assoc 'content (cdr (assoc "name" 
headers))))
                              "\"schulte\""))
@@ -130,8 +132,11 @@ Content-Disposition: form-data; name=\"name\"
 (ert-deftest ws/parse-another-post-data ()
   "This one from an AJAX request."
   (let ((server (ws-start nil ws-test-port))
-        (request (make-instance 'ws-request))
-        (header-string "POST /complex.org HTTP/1.1
+        (request (make-instance 'ws-request)))
+    (unwind-protect
+        (progn
+          (setf (pending request)
+                "POST /complex.org HTTP/1.1
 Host: localhost:4444
 User-Agent: Mozilla/5.0 (X11; Linux x86_64; rv:26.0) Gecko/20100101 
Firefox/26.0
 Accept: */*
@@ -147,10 +152,8 @@ Connection: keep-alive
 Pragma: no-cache
 Cache-Control: no-cache
 
-org=-+one%0A-+two%0A-+three%0A-+four%0A%0A&beg=646&end=667&path=%2Fcomplex.org"))
-    (unwind-protect
-        (progn
-          (ws-parse-request request header-string)
+org=-+one%0A-+two%0A-+three%0A-+four%0A%0A&beg=646&end=667&path=%2Fcomplex.org")
+          (ws-parse-request request)
           (let ((headers (cdr (headers request))))
             (message "headers:%S" headers)
             (should (string= (cdr (assoc "path" headers)) "/complex.org"))
@@ -194,15 +197,16 @@ 
org=-+one%0A-+two%0A-+three%0A-+four%0A%0A&beg=646&end=667&path=%2Fcomplex.org")
   "Test that a number of headers parse successfully."
   (let* ((server (ws-start nil ws-test-port))
          (request (make-instance 'ws-request))
-         (username "foo") (password "bar")
-         (header-string (format "GET / HTTP/1.1
+         (username "foo") (password "bar"))
+    (unwind-protect
+        (progn
+          (setf (pending request)
+                (format "GET / HTTP/1.1
 Authorization: Basic %s
 Connection: keep-alive
 
-" (base64-encode-string (concat username ":" password)))))
-    (unwind-protect
-        (progn
-          (ws-parse-request request header-string)
+" (base64-encode-string (concat username ":" password))))
+          (ws-parse-request request)
           (with-slots (headers) request
             (cl-tree-equal (cdr (assoc :AUTHORIZATION headers))
                            (cons :BASIC (cons username password)))))
@@ -212,8 +216,12 @@ Connection: keep-alive
   "Test that `ws-parse-request' can handle at large file upload.
 At least when it comes in a single chunk."
   (let* ((long-string (mapconcat #'int-to-string (number-sequence 0 20000) " 
"))
-         (long-request
-          (format "POST / HTTP/1.1
+         (server (ws-start nil ws-test-port))
+         (request (make-instance 'ws-request)))
+    (unwind-protect
+        (progn
+          (setf (pending request)
+                (format "POST / HTTP/1.1
 User-Agent: curl/7.34.0
 Host: localhost:9008
 Accept: */*
@@ -229,12 +237,11 @@ Content-Type: application/octet-stream
 ------------------e458fb665704290b--
 
 " long-string))
-         (server (ws-start nil ws-test-port))
-         (request (make-instance 'ws-request)))
-    (unwind-protect
-        (progn (ws-parse-request request long-request)
-               (should (string= long-string
-                                (cdr (assoc 'content (cdr (assoc "file" 
(headers request))))))))
+          (ws-parse-request request)
+          (should
+           (string= long-string
+                    (cdr (assoc 'content
+                                (cdr (assoc "file" (headers request))))))))
       (ws-stop server))))
 
 (provide 'web-server-test)
diff --git a/web-server.el b/web-server.el
index 3d9b016..44b4432 100644
--- a/web-server.el
+++ b/web-server.el
@@ -45,6 +45,8 @@
    (pending  :initarg :pending  :accessor pending  :initform "")
    (context  :initarg :context  :accessor context  :initform nil)
    (boundary :initarg :boundary :accessor boundary :initform nil)
+   (index    :initarg :index    :accessor index    :initform 0)
+   (active   :initarg :active   :accessor active   :initform 0)
    (headers  :initarg :headers  :accessor headers  :initform (list nil))))
 
 (defvar ws-servers nil
@@ -201,28 +203,31 @@ function.
       (push (make-instance 'ws-request :process proc) requests))
     (let ((request (cl-find-if (lambda (c) (equal proc (process c))) 
requests)))
       (with-slots (pending) request (setq pending (concat pending string)))
-      (when (not (eq (catch 'close-connection
-                       (if (ws-parse-request request string)
-                           (ws-call-handler request handlers)
+      ;; if request is currently being parsed, just indicate new content
+      (if (> (active request) 0)
+          (incf (active request))
+        (when (not (eq (catch 'close-connection
+                         (if (progn (incf (active request))
+                                    (ws-parse-request request))
+                             (ws-call-handler request handlers)
                            :keep-open))
-                     :keep-open))
-        (setq requests (cl-remove-if (lambda (r) (eql proc (process r))) 
requests))
-        (delete-process proc)))))
+                       :keep-open))
+          (setq requests (cl-remove-if (lambda (r) (eql proc (process r))) 
requests))
+          (delete-process proc))))))
 
-(defun ws-parse-request (request string)
+(defun ws-parse-request (request)
   "Parse request STRING from REQUEST with process PROC.
 Return non-nil only when parsing is complete."
-  (with-slots (process pending context boundary headers) request
-    (setq pending (concat pending string))
-    (let ((delimiter (concat "\r\n" (if boundary (concat "--" boundary) "")))
-          ;; Track progress through string, always work with the
-          ;; section of string between LAST-INDEX and INDEX.
-          (last-index 0) index)
-      (catch 'finished-parsing-headers
+  (catch 'finished-parsing-headers
+    (with-slots (process pending context boundary headers index) request
+      (let ((delimiter (concat "\r\n" (if boundary (concat "--" boundary) "")))
+            ;; Track progress through string, always work with the
+            ;; section of string between INDEX and NEXT-INDEX.
+            next-index)
         ;; parse headers and append to request
-        (while (setq index (string-match delimiter pending last-index))
-          (let ((tmp (+ index (length delimiter))))
-            (if (= last-index index) ; double \r\n ends current run of headers
+        (while (setq next-index (string-match delimiter pending index))
+          (let ((tmp (+ next-index (length delimiter))))
+            (if (= index next-index) ; double \r\n ends current run of headers
                 (case context
                   ;; Parse URL data.
                   ;; http://www.w3.org/TR/html4/interact/forms.html#h-17.13.4
@@ -231,7 +236,7 @@ Return non-nil only when parsing is complete."
                          (ws-parse-query-string
                           (replace-regexp-in-string
                            "\\+" " "
-                           (ws-trim (substring pending last-index)))))
+                           (ws-trim (substring pending index)))))
                    (throw 'finished-parsing-headers t))
                   ;; Set custom delimiter for multipart form data.
                   (multipart/form-data
@@ -242,14 +247,14 @@ Return non-nil only when parsing is complete."
                   (progn
                     (setcdr (last headers)
                             (list (ws-parse-multipart/form process
-                                   (substring pending last-index index))))
+                                                           (substring pending 
index next-index))))
                     ;; Boundary suffixed by "--" indicates end of the headers.
                     (when (and (> (length pending) (+ tmp 2))
                                (string= (substring pending tmp (+ tmp 2)) 
"--"))
                       (throw 'finished-parsing-headers t)))
                 ;; Standard header parsing.
                 (let ((header (ws-parse process (substring pending
-                                                            last-index 
index))))
+                                                           index next-index))))
                   ;; Content-Type indicates that the next double \r\n
                   ;; will be followed by a special type of content which
                   ;; will require special parsing.  Thus we will note
@@ -262,9 +267,10 @@ Return non-nil only when parsing is complete."
                         (setq context (intern (downcase type))))
                     ;; All other headers are collected directly.
                     (setcdr (last headers) header)))))
-            (setq last-index tmp)))
-        (setq pending (ws-trim (substring pending last-index)))
-        nil))))
+            (setq index tmp)))))
+    (decf (active request))
+    (when (> (active request) 0) (ws-parse-request request))
+    nil))
 
  (defun ws-call-handler (request handlers)
   (catch 'matched-handler