Re: Uploading Word documents, PDFs, PNG files etc

[Sebastian Tennant <sebyte@smolny.plus.com>]

[-- Attachment #1: Type: text/plain, Size: 1028 bytes --]

Quoth ludo@gnu.org (Ludovic Courtès):
> Hello,
>
> Sebastian Tennant <sebyte@smolny.plus.com> writes:
>
>> Content-Disposition is mandatory, but Content-Type is optional
>> (defaulting to text/plain) as is Content-Transfer-Encoding, so the
>> "header part" of any given MIME part may be a single line or it may be
>> three.
>
> Then I presume this could be read line-by-line as strings (using
> `read-line' from `(ice-9 rdelim)') until the end-of-header marker is
> reached.  The remaining data would be read using `uniform-vector-read!'
> or some such.

Problem solved.  With this patch applied to cgi.scm in ttn's (www cgi)
module, uploading of binary data now works with Guile 1.8.

In the end it was simply a case of splitting each part into a header
section and value section using string-contains and substring rather
than match:prefix and match:suffix.

Thanks for all your help.

Seb
-- 
Emacs' AlsaPlayer - Music Without Jolts
Lightweight, full-featured and mindful of your idyllic happiness.
http://home.gna.org/eap


[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: Unified diff --]
[-- Type: text/x-diff, Size: 4518 bytes --]

--- cgi.scm	2007-10-04 10:35:38.000000000 +0000
+++ cgi-patched.scm	2009-05-21 04:48:58.210914642 +0000
@@ -212,10 +212,9 @@
                               (#:raw-mime-headers . ,raw-headers)))
       (set! u (updated-alist u name value)))
 
-    (let ((name-exp     (make-regexp "name=\"([^\"]*)\""))
-          (filename-exp (make-regexp "filename=\"*([^\"\r]*)\"*"))
-          (type-exp     (make-regexp "Content-Type: ([^\r]*)\r\n" regexp/icase))
-          (value-exp    (make-regexp "\r\n\r\n")))
+    (let ((name-rx     (make-regexp "name=\"([^\"]*)\""))
+          (filename-rx (make-regexp "filename=\"*([^\"\r]*)\"*"))
+          (type-rx     (make-regexp "Content-Type: ([^\r]*)$" regexp/icase)))
 
       (let level ((str raw-data)
                   (boundary (determine-boundary (env-look 'content-type)))
@@ -233,41 +232,56 @@
                                      (lambda (seg-finish)
                                        (cons (subs str seg-start (- seg-finish 2))
                                              seg-finish))))))
+		   ;; segment-newstart is a cons of the form
+		   ;; ("<header(s)>\r\n\r\n<value-of-part>\r\n"
+		   ;;                 .
+		   ;;  <position-reached-in-raw-data>)
                    (lambda (segment-newstart)
                      (let* ((segment (car segment-newstart))
-                            (try (lambda (rx extract)
-                                   (and=> (regexp-exec rx segment)
-                                          extract)))
-                            (name (or parent-name
-                                      (try name-exp  m1)))
-                            (value    (try value-exp match:suffix))
-                            (type     (try type-exp  m1)))
-                       (and name
+			    ;; segment splitter
+			    (seg-split
+			     (lambda (pattern string portion)
+			       (and=> (string-contains string pattern) portion)))
+			    ;; split segment into header(s) and value
+			    (headers (seg-split "\r\n\r\n" segment
+						(lambda (index)
+						  (substring segment 2 index))))
+			    (value (seg-split "\r\n\r\n" segment
+					      (lambda (index)
+						(substring segment (+ index 4)))))
+			    ;; extract data from header(s)
+                            (hdr-extract (lambda (rx extract)
+					   (and=> (regexp-exec rx headers)
+						  extract)))
+                            (name (or parent-name (hdr-extract name-rx m1)))
+                            (type (hdr-extract type-rx m1))
+			    (filename (hdr-extract filename-rx m1)))
+
+		       (and name
                             value
-                            (cond ((and type
-                                        (not parent-name) ; only recurse once
-                                        (string-match "multipart/mixed" type))
-                                   (level value
-                                          (determine-boundary type)
-                                          name))
-                                  ((and type (try filename-exp m1))
-                                   => (lambda (filename)
-                                        (stash-file-upload!
-                                         name filename type value
-                                         (subs (try value-exp match:prefix)
-                                               2))))
-                                  (else
-                                   (stash-form-variable! name value)))))
+			    (cond ((and type
+					(not parent-name) ; only recurse once
+					(string-match "multipart/mixed" type))
+				   (level value
+					  (determine-boundary type)
+					  name))
+				  ((and type (hdr-extract filename-rx m1))
+				   => (lambda (filename)
+					(stash-file-upload!
+					 name filename type value headers)))
+				  (else
+				   (stash-form-variable! name value)))
+			    ))
                      (get-pair (cdr segment-newstart))))))))
 
     (cons (reverse! v) (reverse! u))))
 
 (define (get-cookies raw)
   ;; Parse RAW (a string) for cookie-like frags.  Return an alist.
-  (let ((pair-exp (make-regexp "([^=; \t\n]+)=([^=; \t\n]+)"))
+  (let ((pair-rx (make-regexp "([^=; \t\n]+)=([^=; \t\n]+)"))
         (c (list)))
     (define (get-pair str)
-      (let ((pair-match (regexp-exec pair-exp str)))
+      (let ((pair-match (regexp-exec pair-rx str)))
         (if (not pair-match) '()
             (let ((name (match:substring pair-match 1))
                   (value (match:substring pair-match 2)))