Index: packages.lisp
===================================================================
--- packages.lisp	(revision 497)
+++ packages.lisp	(working copy)
@@ -53,6 +53,7 @@
            #:*reply*
            #:*request*
            #:*rewrite-for-session-urls*
+           #:*request-id-query-string-name*
            #:*session*
            #:*session-cookie-name*
            #:*session-max-time*
@@ -170,6 +171,7 @@
            #:remote-port
            #:request-method
            #:request-uri
+           #:request-tracking-info
            #:require-authorization
            #:reset-sessions
            #:return-code
Index: request.lisp
===================================================================
--- request.lisp	(revision 497)
+++ request.lisp	(working copy)
@@ -63,21 +63,80 @@
 about an incoming request. They are created automatically by TBNL and
 can be accessed by the corresponding handler."))
 
-(defun parse-rfc2388-form-data (stream content-type-header)
+(defclass request-tracking ()
+  ((request-id :initform nil :initarg :request-id
+               :accessor request-id
+               :documentation "A string used to identify the
+request. It can be used by a popup page or an ajax mechanism to
+monitor the upload progress.")
+   (start-time :initform (get-universal-time)
+               :documentation "Time when we start to process the request.")
+   (content-length :initarg :content-length :initform 0)
+   (content-length-consumed :initarg :content-length-consumed
+                            :initform 0
+                            :accessor content-length-consumed
+                            :documentation "Number of bytes read for
+the current request. This is mainly used for reporting the current
+progress for huge file uploads."))
+  (:documentation "This is object is mainly used to track large file
+upload request. This way we can provide a constant feedback to the
+user."))
+
+(defun request-tracking-info (request-id)
+  "Given a request-id (string), return the following tuples:
+
+content-length content-length-consumed 
+finished percentage elapsed time-remaining kbps"
+  (let ((tracking-obj (session-value (intern request-id :keyword))))
+    (when tracking-obj
+      (with-slots ((content-length content-length)
+                   (content-length-consumed content-length-consumed)
+                   (start-time start-time))
+          tracking-obj
+        (let* ((percentage (if (= content-length 0)
+                               100
+                               (floor (/ (* content-length-consumed 100)
+                                         content-length))))
+               (finished (= content-length content-length-consumed))
+               (elapsed (- (get-universal-time) start-time))
+               (byte-per-sec (if (= elapsed 0) 0 (/ content-length-consumed elapsed)))
+               (kbps (if (= byte-per-sec 0) 0 (/ (* 8 byte-per-sec) 1000)))
+               (content-length-remaining (- content-length content-length-consumed))
+               (time-remaining (if (= byte-per-sec 0) 0 (/ content-length-remaining byte-per-sec))))
+          (values content-length content-length-consumed finished
+                  percentage elapsed time-remaining kbps))))))
+
+(defun parse-rfc2388-form-data (request content-type-header)
   "Create an alist of POST parameters from the stream STREAM which is
 supposed to be of content type 'multipart/form-data'."
-  (let* ((parsed-content-type-header (rfc2388:parse-header content-type-header :value))
-	 (boundary (or (cdr (rfc2388:find-parameter "BOUNDARY"
+  (let* (request-tracking
+         (stream (string-assoc "content-stream" (headers-in request)))
+         (tbnl-request-id (get-parameter *request-id-query-string-name* request))
+         (parsed-content-type-header (rfc2388:parse-header content-type-header :value))
+         (boundary (or (cdr (rfc2388:find-parameter "BOUNDARY"
                                                     (rfc2388:header-parameters parsed-content-type-header)))
-		       (return-from parse-rfc2388-form-data))))
-    (loop for part in (rfc2388:parse-mime stream boundary)
+                       (return-from parse-rfc2388-form-data))))
+    (when tbnl-request-id
+      (setf request-tracking
+            (make-instance 'request-tracking
+                           :request-id tbnl-request-id
+                           :content-length (or (parse-integer
+                                                (string-assoc "content-length" (headers-in request))
+                                                :junk-allowed t)
+                                               0))
+            (session-value (intern tbnl-request-id :keyword)) ;is it a good namespace to store the symbol?
+            request-tracking))
+    (loop for part in (rfc2388:parse-mime stream boundary :progress-tracking
+                                          (when request-tracking
+                                            #'(lambda (byte-read)
+                                                (incf (content-length-consumed request-tracking) byte-read))))
           for headers = (rfc2388:mime-part-headers part)
           for content-disposition-header = (rfc2388:find-content-disposition-header headers)
           for name = (cdr (rfc2388:find-parameter "NAME" (rfc2388:header-parameters content-disposition-header)))
           when name
-            collect (cons name
-                          (let ((contents (rfc2388:mime-part-contents part)))
-                            (if (pathnamep contents)
+          collect (cons name
+                        (let ((contents (rfc2388:mime-part-contents part)))
+                          (if (pathnamep contents)
                               (list contents
                                     (rfc2388:get-file-name headers)
                                     (rfc2388:content-type part :as-string t))
@@ -120,6 +179,17 @@
          ;; some clients send requests like
          ;; "GET http://server/foo.html HTTP/1.0"...
          (setq script-name (cl-ppcre:regex-replace "^https?://[^/]+" script-name ""))
+         ;; compute GET parameters from query string and cookies from
+         ;; the incoming 'Cookie' header
+         (setq get-parameters
+                 (form-url-encoded-list-to-alist
+                  (cl-ppcre:split "&" query-string))
+               cookies-in
+                 (form-url-encoded-list-to-alist
+                  (cl-ppcre:split ";"
+                                  (string-assoc "Cookie" headers-in)))
+               session (session-verify request)
+               *session* session)
          ;; if the content-type is 'application/x-www-form-urlencoded'
          ;; or 'multipart/form-data', compute the post parameters from
          ;; the content body
@@ -134,25 +204,13 @@
                                          :test #'char-equal)
                           (setf (slot-value request 'raw-post-data) t)
                           (handler-case
-                            (parse-rfc2388-form-data (string-assoc "content-stream"
-                                                                   headers-in)
-                                                     content-type)
+                            (parse-rfc2388-form-data request content-type)
                             (error (msg)
                               (log-message :error
                                            "While parsing multipart/form-data parameters: ~A"
                                            msg)
                               nil))))))
-         ;; compute GET parameters from query string and cookies from
-         ;; the incoming 'Cookie' header
-         (setq get-parameters
-                 (form-url-encoded-list-to-alist
-                  (cl-ppcre:split "&" query-string))
-               cookies-in
-                 (form-url-encoded-list-to-alist
-                  (cl-ppcre:split ";"
-                                  (string-assoc "Cookie" headers-in)))
-               session (session-verify request)
-               *session* session))
+         )
        (error (cond)
          (log-message* "Error when creating REQUEST object: ~A" cond)
          ;; we assume it's not our fault...
Index: specials.lisp
===================================================================
--- specials.lisp	(revision 498)
+++ specials.lisp	(working copy)
@@ -94,6 +94,14 @@
   "The three-character names of the twelve months - needed for cookie
 date format.")
 
+(defvar *request-id-query-string-name* "tbnl-request-id"
+  "The name of the GET parameter which is used to identify / track the
+request on the client side. If it is found in the query string, tbnl
+will create a request-tracking object, keyed by this
+*request-id-query-string-name* and periodically update the
+content-length-consumed field. This object can be retrieved by looking
+up (session-value (intern request-id :keyword))")
+
 (defvar *session-cookie-name* "tbnl-session"
   "The name of the cookie \(or the GET parameter) which is used to
 store the session on the client side.")
Index: test/test.lisp
===================================================================
--- test/test.lisp	(revision 497)
+++ test/test.lisp	(working copy)
@@ -346,6 +346,136 @@
                 (:p (:input :type :submit :name "clean" :value "Delete uploaded files")))))
       (menu-link)))))
 
+(defun decode-hhmmss (seconds)
+  (list (floor (/ seconds 3600))
+        (floor (mod (/ seconds 60) 60))
+        (floor (mod seconds 60))))
+
+(defun bytes->normalized-string (bytes &key (display-unit t))
+  (let ((kb 1024)
+        (mb (* 1024 1024)))
+    (cond ((< bytes kb)
+           (format nil "~A~A" bytes (if display-unit " bytes" "")))
+          ((< bytes mb)
+           (format nil "~,2f~A" (/ bytes kb) (if display-unit " Kb" "")))
+          (t
+           (format nil "~,2f~A" (/ bytes mb) (if display-unit " Mb" ""))))))
+
+(defun upload-progress ()
+  (no-cache)
+  (let ((tbnl-request-id (get-parameter tbnl::*request-id-query-string-name*)))
+    (multiple-value-bind
+          (content-length content-length-consumed finished percentage elapsed time-remaining kbps)
+        (request-tracking-info tbnl-request-id)
+      (unless content-length
+        (return-from upload-progress
+          (with-html
+            (:html (:head (:title "File Upload Status")
+                          (:meta :http-equiv "Refresh" :content
+                                 (format nil "1; URL=~A" (request-uri))))
+                   (:body (:p "Starting to upload..."))))))
+      (with-html
+        (:html
+         (:head (:title "File Upload Status")
+                (unless finished
+                  (htm (:meta :http-equiv "Refresh" :content
+                              (format nil "1; URL=~A" (request-uri))))))
+         (:body
+          (:table
+           :border 0 :width "100%"
+           (:tr (:td :align "center" :bgcolor "#ecf8ff"
+                     "File Upload In Progress"))
+           (:tr (:td
+                 (:table :border 0 :width "100%"
+                         (:tr (:td
+                               (:table :border 0 :width (format nil "~A%" percentage) :bgcolor "red"
+                                       (:tr (:td :width "100%" :style "height: 20px"))))))))
+           (:tr (:td (fmt "~A out of ~A uploaded (~,1f Kbps)"
+                          (bytes->normalized-string content-length-consumed)
+                          (bytes->normalized-string content-length)
+                          kbps)))
+           (if finished
+               (htm (:tr (:td :align "center" (:b "Upload finished.")))
+                    (:tr (:td :align :center
+                              (:form (:input :type :button :value "Close"
+                                             :onClick "window.close()")))))
+               (htm (:tr (:td (fmt "Estimated time left: ~{~2,'0d~^:~}"
+                                   (decode-hhmmss time-remaining) )))
+                    (:tr (:td (fmt "Elapsed time: ~{~2,'0d~^:~}"
+                                   (decode-hhmmss elapsed)))))))))))))
+
+(defun upload-test-with-popup ()
+;;  (start-session)                       ;progress tracking is stored in session
+  (let (post-parameter-p)
+    (when (post-parameter "file1")
+      (handle-file (post-parameter "file1"))
+      (setq post-parameter-p t))
+    (when (post-parameter "file2")
+      (handle-file (post-parameter "file2"))
+      (setq post-parameter-p t))
+    (when (post-parameter "clean")
+      (clean-tmp-dir)
+      (setq post-parameter-p t))
+    (when post-parameter-p
+      ;; redirect so user can safely use 'Back' button
+      (redirect (script-name))))
+  (no-cache)
+  (let ((tbnl-request-id (symbol-name (gensym "uploadtracking"))))
+    (with-html
+      (:html
+       (:head (:title "TBNL File Upload Test with popup progress bar.")
+              (:script
+               (fmt
+                "
+function popUP(mypage, myname, w, h, scroll, titlebar) {
+	var winl = (screen.width - w) / 2;
+	var wint = (screen.height - h) / 2;
+	winprops = 'height='+h+',width='+w+',top='+wint+
+               ',left='+winl+',scrollbars='+scroll+',resizable';
+	win = window.open(mypage, myname, winprops)
+	if (parseInt(navigator.appVersion) >= 4) {
+		win.window.focus();
+	}
+}
+function postIt() {
+	popUP('upload-progress.html?~A=~A','Uploader',460,262,false,false);
+	document.forms[0].submit();
+}
+" tbnl::*request-id-query-string-name* tbnl-request-id)))
+       (:body
+        (:h2 (tbnl-link)
+             " File Upload Test with popup progress bar")
+        (:form :method :post :enctype "multipart/form-data" :action
+               (conc "?tbnl-request-id=" tbnl-request-id)
+               (:p "First file: "
+                   (:input :type :file
+                           :name "file1"))
+               (:p "Second file: "
+                   (:input :type :file
+                           :name "file2"))
+               (:p (:input :type :button :value :submit :onClick "postIt();")))
+        (when *tmp-test-files*
+          (htm
+           (:p
+            (:table :border 1 :cellpadding 2 :cellspacing 0
+                    (:tr (:td :colspan 3 (:b "Uploaded files")))
+                    (loop for (path file-name nil) in *tmp-test-files*
+                          for counter from 1
+                          do (htm
+                              (:tr (:td :align "right" (str counter))
+                                   (:td (:a :href (format nil "files/~A?path=~A"
+                                                          (url-encode file-name)
+                                                          (url-encode (namestring path)))
+                                            (esc file-name)))
+                                   (:td :align "right"
+                                        (str (ignore-errors
+                                               (with-open-file (in path)
+                                                 (file-length in))))
+                                        "&nbsp;Bytes"))))))
+           (:form :method :post
+                  (:p (:input :type :submit :name "clean" :value "Delete uploaded files")))))
+        (menu-link))))))
+
 (defun send-file ()
   (let* ((path (get-parameter "path"))
          (file-info (and path
@@ -446,6 +576,8 @@
                     " \(writing directly to the stream)"))
               (:tr (:td (:a :href "/tbnl/test/upload.html"
                             "File Uploads")))
+              (:tr (:td (:a :href "/tbnl/test/upload-with-popup.html"
+                            "File Uploads with pop up progress bar")))
               (:tr (:td (:a :href "/tbnl/test/forbidden.html"
                             "Forbidden \(403) page")))
               (:tr (:td (:a :href "/tbnl/test/oops.html"
@@ -490,6 +622,8 @@
                  ("/tbnl/test/parameter_utf8_get.html" parameter-test-utf8-get)
                  ("/tbnl/test/parameter_utf8_post.html" parameter-test-utf8-post)
                  ("/tbnl/test/upload.html" upload-test)
+                 ("/tbnl/test/upload-with-popup.html" upload-test-with-popup)
+                 ("/tbnl/test/upload-progress.html" upload-progress)
                  ("/tbnl/test/redir.html" redir)
                  ("/tbnl/test/oops.html" oops)
                  #+:lispworks


