improved guile-www/cgi.scm

[Aaron VanDevender]

I've fleshed out guile-www/cgi.scm so that it now:

o  supports multipart/formdata in addition to 
   x-www-form-urlencoded POSTs.
o  supports the uploading of files to the server.
o  supports setting and reading cookies.

cya
.sig

Patch Follows:

--- guile.old/guile/guile-www/cgi.scm   Fri Nov 16 19:54:05 2001
+++ guile.new/guile/guile-www/cgi.scm   Sat Mar  2 23:09:37 2002
@@ -42,6 +42,7 @@
 ;;    cgi-content-length
 ;;    cgi-http-accept-types
 ;;    cgi-http-user-agent
+;;    cgi-http-cookie
 ;;   (cgi:init)
 ;;   (cgi:values name)
 ;;   (cgi:value name)
@@ -51,10 +52,16 @@
 ;;; Code:
 
 (define-module (www cgi)
-  :use-module (www url))
+  :use-module (www url)
+  :use-module (ice-9 regex)
+  :use-module (ice-9 optargs))
 
 (define form-variables '())
 
+(define file-uploads '())
+
+(define cookies '())
+
 ;;; CGI environment variables.
 ;;; Should these all be public?
 
@@ -79,6 +86,7 @@
 (define-public cgi-content-length #f)
 (define-public cgi-http-accept-types #f)
 (define-public cgi-http-user-agent #f)
+(define-public cgi-http-cookie #f)
 
 
 ;;; CGI high-level interface
@@ -93,13 +101,43 @@
 ;;; (cgi:value NAME)
 ;;;    Fetch only the CAR from (cgi:values NAME).  Convenient for when
 ;;;    you are certain that NAME is associated with only one value.
+;;; (cgi:uploads NAME)
+;;;     Fetch any files associated with name. Returns list. Can only be
+;;;     called once per particular name. Subsequent calls will return
+;;;     #f. The caller had better hang onto the descriptor, lest the
+;;;     garbage man wisk it away for good. This is done do minimize the
+;;;     amount of time the file is resident in memory.
+;;; (cgi:upload NAME)
+;;;     Fetch the first file associated with form var NAME. Can only be
+;;;     called once per NAME, so the called had better be sure that
+;;;     there is only one file associated with NAME. Use (cgi:uploads
+;;;     NAME) if you are unsure.
+;;; (cgi:cookies NAME)
+;;;     Fetch any cookie values associated with NAME. Returns a list
+;;;     of values in the order they were found in the HTTP header,
+;;;     which should be the order of most specific to least specific
+;;;     path associated with the cookie.
+;;; (cgi:cookies NAME)
+;;;     Fetch the first cookie value associated with NAME.
+;;; (cgi:make-cookie NAME VALUE #&key path domain expires secure)
+;;;     Create a cookie suitable for inclusion into an HTTP response
+;;;     header. Recognizes optional parameters path, doman, expires,
+;;;     (which should be strings) and secure (which is boolean).
 
 (define-public (cgi:init)
   (init-environment)
   (and cgi-content-length
+       (string-ci=? cgi-content-type
+                   "application/x-www-form-urlencoded")
        (parse-form (read-raw-form-data)))
+  (and cgi-content-length
+       (string-ci=? (make-shared-substring cgi-content-type 0 19) 
+                   "multipart/form-data")
+       (parse-form-multipart (read-raw-form-data)))
   (and cgi-query-string
-       (parse-form cgi-query-string)))
+       (parse-form cgi-query-string))
+  (and cgi-http-cookie
+       (get-cookies)))
 
 (define-public (cgi:values name)
   (assoc-ref form-variables name))
@@ -113,13 +151,46 @@
 
 (define-public (cgi:form-data?) (not (null? form-variables)))
 
+(define-public (cgi:uploads name)
+  (let ((uploads (assoc-ref file-uploads name)))
+    (if uploads (assoc-remove! file-uploads name))
+    uploads))
+
+(define-public (cgi:upload name)
+  (let ((uploads (cgi:uploads name)))
+    (and uploads (car uploads))))
+
+(define-public (cgi:cookies name)
+  (assoc-ref cookies name))
+
+(define-public (cgi:cookie name)
+  (let ((cookie-values (cgi:cookies name)))
+    (and cookie-values (car cookie-values))))
+
+(define-public cgi:make-cookie
+  (lambda* (name value #&key path domain expires secure)
+          (string-append "Set-Cookie: " name "=" value
+                         (if (bound? path)
+                             (string-append "; path=" path) "")
+                         (if (bound? domain)
+                             (string-append "; domain=" domain) "")
+                         (if (bound? expires)
+                             (string-append "; expires=" expires) "")
+                         (if (bound? secure)
+                             (if secure "; secure" "") ""))))
+
+
 
 ;;;; Internal functions.
 ;;;;
-;;;; (parse-form DATA): parse DATA as raw form response data, adding
-;;;;   values as necessary to `form-variables'.
+;;;; (parse-form DATA): parse DATA as raw form response data of enctype
+;;;;  x-www-form-urlencoded, adding values as necessary to `form-variables'.
+;;;; (parse-form-multipart DATA): parse DATA as raw form response data
+;;;;  of enctype multipart/form-data, adding values as necessary to
+;;;;  'form-variables' and file data to 'file-uploads'.
 ;;;; (read-raw-form-data): read in `content-length' bytes from stdin
 ;;;; (init-environment): initialize CGI environment from Unix env vars.
+;;;; (get-cookies): initialize the cookie list from cgi-http-cookie.
 
 (define (parse-form raw-data)
   ;; get-name and get-value are used to parse individual `name=value' pairs.
@@ -140,6 +211,64 @@
                                  (cons value (or old-value '()))))))
            (separate-fields-discarding-char #\& raw-data)))
 
+
+(define (parse-form-multipart raw-data) 
+  (let* ((boundary (string-append "--" (match:substring 
+                                       (string-match "boundary=(.*)$" 
cgi-content-type) 1)))
+        (boundary-len (string-length boundary))
+        (name-exp (make-regexp "name=\"([^\"]*)\""))
+        (filename-exp (make-regexp "filename=\"([^\"]*)\""))
+        (type-exp (make-regexp "Content-Type: (.*)\r\n"))
+        (value-exp (make-regexp "\r\n\r\n")))
+    (define (get-pair raw-data)
+      (define (get-segment str)
+       (define (find-bound str)
+         (define (find-bound-h str n)
+           (let ((n-str (string-length str)))
+             (if (< n-str boundary-len)
+                 #f
+                 (if (string=? boundary (make-shared-substring str 0 
boundary-len))
+                     n
+                     (find-bound-h (make-shared-substring str 1 n-str) (+ n 
1))))))
+         (find-bound-h str 0))
+       (let* ((seg-start (find-bound str))
+              (seg-length (find-bound (make-shared-substring str (+ seg-start 
boundary-len)
+                                                             (string-length 
str)))))
+         (if (and seg-start seg-length)
+             (cons (make-shared-substring str (+ seg-start boundary-len)
+                                          (+ seg-start seg-length boundary-len 
-2))
+                   (make-shared-substring str (+ seg-start seg-length 
boundary-len) 
+                                          (string-length str)))
+             #f)))
+      (let ((segment-pair (get-segment raw-data)))
+       (if segment-pair
+           (let* ((segment (car segment-pair))
+                  (name-match (regexp-exec name-exp segment))
+                  (filename-match (regexp-exec filename-exp segment))
+                  (type-match (regexp-exec type-exp segment))
+                  (value-match (regexp-exec value-exp segment)))
+             (if (and name-match value-match)
+                 (if (and filename-match type-match)
+                     (let* ((name (match:substring name-match 1))
+                            (value (match:substring filename-match 1))
+                            (old-value (cgi:values name))
+                            (file-data (match:suffix value-match))
+                            (old-file-data (assoc-ref file-uploads name)))
+                       (set! form-variables
+                             (assoc-set! form-variables name
+                                         (cons value (or old-value '()))))
+                       (set! file-uploads 
+                             (assoc-set! file-uploads name
+                                         (cons file-data (or old-file-data 
'())))))
+                     (let* ((name (match:substring name-match 1))
+                            (value (match:suffix value-match))
+                            (old-value (cgi:values name)))
+                       (set! form-variables
+                             (assoc-set! form-variables name
+                                         (cons value (or old-value '())))))))
+             (get-pair (cdr segment-pair))))))
+    (get-pair raw-data)))
+
 (define (read-raw-form-data)
   (and cgi-content-length (read-n-chars cgi-content-length)))
 
@@ -189,7 +318,23 @@
          (and types (separate-fields-discarding-char #\, types))))
 
   ;; HTTP_USER_AGENT format: software/version library/version.
-  (set! cgi-http-user-agent               (getenv "HTTP_USER_AGENT")))
+  (set! cgi-http-user-agent               (getenv "HTTP_USER_AGENT"))
+  (set! cgi-http-cookie                    (getenv "HTTP_COOKIE")))
+
+;;; Seting up the cookies
+(define (get-cookies)
+  (let ((pair-exp (make-regexp "([^=; \t\n]+)=([^=; \t\n]+)")))
+    (define (get-pair str)
+      (let ((pair-match (regexp-exec pair-exp str)))
+       (if (not pair-match) '()
+           (let ((name (match:substring pair-match 1))
+                 (value (match:substring pair-match 2)))
+             (if (and name value)
+                 (set! cookies 
+                       (assoc-set! cookies name
+                                   (append (or (cgi:cookies name) '()) (list 
value)))))
+             (get-pair (match:suffix pair-match))))))
+    (get-pair cgi-http-cookie)))
 
 
 ;;; System I/O and low-level stuff.