/[guile]/guile/guile-www/cgi.scm
ViewVC logotype

Diff of /guile/guile-www/cgi.scm

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.5 by ttn, Sat Nov 17 01:54:05 2001 UTC revision 1.6 by ttn, Sat Apr 27 01:49:47 2002 UTC
# Line 1  Line 1 
1  ;;;; www/cgi.scm: Common Gateway Interface support for WWW scripts.  ;;; www/cgi.scm --- Common Gateway Interface support for WWW scripts
2    
3  ;;;;    Copyright (C) 1997,2001 Free Software Foundation, Inc.  ;;      Copyright (C) 1997,2001,2002 Free Software Foundation, Inc.
4  ;;;;  ;;
5  ;;;; This program is free software; you can redistribute it and/or modify  ;; This program is free software; you can redistribute it and/or modify
6  ;;;; it under the terms of the GNU General Public License as published by  ;; it under the terms of the GNU General Public License as published by
7  ;;;; the Free Software Foundation; either version 2, or (at your option)  ;; the Free Software Foundation; either version 2, or (at your option)
8  ;;;; any later version.  ;; any later version.
9  ;;;;  ;;
10  ;;;; This program is distributed in the hope that it will be useful,  ;; This program is distributed in the hope that it will be useful,
11  ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of  ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
12  ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the  ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
13  ;;;; GNU General Public License for more details.  ;; GNU General Public License for more details.
14  ;;;;  ;;
15  ;;;; You should have received a copy of the GNU General Public License  ;; You should have received a copy of the GNU General Public License
16  ;;;; along with this software; see the file COPYING.  If not, write to  ;; along with this software; see the file COPYING.  If not, write to
17  ;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330,  ;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
18  ;;;; Boston, MA 02111-1307 USA  ;; Boston, MA 02111-1307 USA
19  ;;;;  ;;
20    
21  ;;; Commentary:  ;;; Commentary:
22    
# Line 42  Line 42 
42  ;;    cgi-content-length  ;;    cgi-content-length
43  ;;    cgi-http-accept-types  ;;    cgi-http-accept-types
44  ;;    cgi-http-user-agent  ;;    cgi-http-user-agent
45    ;;    cgi-http-cookie
46  ;;   (cgi:init)  ;;   (cgi:init)
47  ;;   (cgi:values name)  ;;   (cgi:values name)
48  ;;   (cgi:value name)  ;;   (cgi:value name)
49  ;;   (cgi:names)  ;;   (cgi:names)
50  ;;   (cgi:form-data?)  ;;   (cgi:form-data?)
51    ;;   (cgi:uploads name)
52    ;;   (cgi:upload name)
53    ;;   (cgi:cookies name)
54    ;;   (cgi:cookie name)
55    ;;   (cgi:make-cookie value #&key path domain expires secure)
56    
57  ;;; Code:  ;;; Code:
58    
59  (define-module (www cgi)  (define-module (www cgi)
60    :use-module (www url))    :use-module (www url)
61      :use-module (ice-9 regex)
62      :use-module (ice-9 optargs))
63    
64  (define form-variables '())  (define form-variables '())
65    
66    (define file-uploads '())
67    
68    (define cookies '())
69    
70  ;;; CGI environment variables.  ;;; CGI environment variables.
71  ;;; Should these all be public?  ;;; Should these all be public?
72    
# Line 79  Line 91 
91  (define-public cgi-content-length #f)  (define-public cgi-content-length #f)
92  (define-public cgi-http-accept-types #f)  (define-public cgi-http-accept-types #f)
93  (define-public cgi-http-user-agent #f)  (define-public cgi-http-user-agent #f)
94    (define-public cgi-http-cookie #f)
95    
96    
97  ;;; CGI high-level interface  ;;; CGI high-level interface
98  ;;;  
99  ;;; A typical CGI program will first call (cgi:init) to initialize  ;; A typical CGI program will first call (cgi:init) to initialize
100  ;;; the environment and read in any data returned from a form.  Form  ;; the environment and read in any data returned from a form.  Form
101  ;;; data can be extracted conveniently with these functions:  ;; data can be extracted conveniently with these functions:
102  ;;;  ;;
103  ;;; (cgi:values NAME)  ;; (cgi:values NAME)
104  ;;;     Fetch any values associated with NAME found in the form data.  ;;      Fetch any values associated with NAME found in the form data.
105  ;;;     Returned value is a list, even if it contains only one element.  ;;      Returned value is a list, even if it contains only one element.
106  ;;; (cgi:value NAME)  ;; (cgi:value NAME)
107  ;;;     Fetch only the CAR from (cgi:values NAME).  Convenient for when  ;;      Fetch only the CAR from (cgi:values NAME).  Convenient for when
108  ;;;     you are certain that NAME is associated with only one value.  ;;      you are certain that NAME is associated with only one value.
109    ;; (cgi:uploads NAME)
110    ;;     Fetch any files associated with name. Returns list. Can only be
111    ;;     called once per particular name. Subsequent calls will return
112    ;;     #f. The caller had better hang onto the descriptor, lest the
113    ;;     garbage man wisk it away for good. This is done do minimize the
114    ;;     amount of time the file is resident in memory.
115    ;; (cgi:upload NAME)
116    ;;     Fetch the first file associated with form var NAME. Can only be
117    ;;     called once per NAME, so the called had better be sure that
118    ;;     there is only one file associated with NAME. Use (cgi:uploads
119    ;;     NAME) if you are unsure.
120    ;; (cgi:cookies NAME)
121    ;;     Fetch any cookie values associated with NAME. Return a list
122    ;;     of values in the order they were found in the HTTP header,
123    ;;     which should be the order of most specific to least specific
124    ;;     path associated with the cookie.
125    ;; (cgi:cookies NAME)
126    ;;     Fetch the first cookie value associated with NAME.
127    ;; (cgi:make-cookie NAME VALUE #&key path domain expires secure)
128    ;;     Create a cookie suitable for inclusion into an HTTP response
129    ;;     header. Recognize optional parameters path, doman, expires,
130    ;;     (which should be strings) and secure (which is boolean).
131    
132  (define-public (cgi:init)  (define-public (cgi:init)
133    (init-environment)    (init-environment)
134    (and cgi-content-length    (and cgi-content-length
135           (string-ci=? cgi-content-type
136                        "application/x-www-form-urlencoded")
137         (parse-form (read-raw-form-data)))         (parse-form (read-raw-form-data)))
138      (and cgi-content-length
139           (string-ci=? (make-shared-substring cgi-content-type 0 19)
140                        "multipart/form-data")
141           (parse-form-multipart (read-raw-form-data)))
142    (and cgi-query-string    (and cgi-query-string
143         (parse-form cgi-query-string)))         (parse-form cgi-query-string))
144      (and cgi-http-cookie
145           (get-cookies)))
146    
147  (define-public (cgi:values name)  (define-public (cgi:values name)
148    (assoc-ref form-variables name))    (assoc-ref form-variables name))
# Line 113  Line 156 
156    
157  (define-public (cgi:form-data?) (not (null? form-variables)))  (define-public (cgi:form-data?) (not (null? form-variables)))
158    
159    (define-public (cgi:uploads name)
160      (let ((uploads (assoc-ref file-uploads name)))
161        (if uploads (assoc-remove! file-uploads name))
162        uploads))
163    
164    (define-public (cgi:upload name)
165      (let ((uploads (cgi:uploads name)))
166        (and uploads (car uploads))))
167    
168    (define-public (cgi:cookies name)
169      (assoc-ref cookies name))
170    
171    (define-public (cgi:cookie name)
172      (let ((cookie-values (cgi:cookies name)))
173        (and cookie-values (car cookie-values))))
174    
175    (define-public cgi:make-cookie
176      (lambda* (name value #&key path domain expires secure)
177               (format #f "Set-Cookie: ~A=~A~A~A~A~A"
178                       name value
179                       (if (bound? path)
180                           (format #f "; path=~A" path) "")
181                       (if (bound? domain)
182                           (format #f "; domain=~A" domain) "")
183                       (if (bound? expires)
184                           (format #f "; expires=~A" expires) "")
185                       (if (and (bound? secure) secure)
186                           "; secure" ""))))
187    
188    
189    
190  ;;;; Internal functions.  ;;; Internal functions.
191  ;;;;  
192  ;;;; (parse-form DATA): parse DATA as raw form response data, adding  ;; (parse-form DATA): parse DATA as raw form response data of enctype
193  ;;;;   values as necessary to `form-variables'.  ;;  x-www-form-urlencoded, adding values as necessary to `form-variables'.
194  ;;;; (read-raw-form-data): read in `content-length' bytes from stdin  ;; (parse-form-multipart DATA): parse DATA as raw form response data
195  ;;;; (init-environment): initialize CGI environment from Unix env vars.  ;;  of enctype multipart/form-data, adding values as necessary to
196    ;;  'form-variables' and file data to 'file-uploads'.
197    ;; (read-raw-form-data): read in `content-length' bytes from stdin
198    ;; (init-environment): initialize CGI environment from Unix env vars.
199    ;; (get-cookies): initialize the cookie list from cgi-http-cookie.
200    
201  (define (parse-form raw-data)  (define (parse-form raw-data)
202    ;; get-name and get-value are used to parse individual `name=value' pairs.    ;; get-name and get-value are used to parse individual `name=value' pairs.
# Line 140  Line 217 
217                                    (cons value (or old-value '()))))))                                    (cons value (or old-value '()))))))
218              (separate-fields-discarding-char #\& raw-data)))              (separate-fields-discarding-char #\& raw-data)))
219    
220    
221    (define (parse-form-multipart raw-data)
222      (let* ((boundary (format #f "--~A"
223                               (match:substring
224                                (string-match "boundary=(.*)$" cgi-content-type)
225                                1)))
226             (boundary-len (string-length boundary))
227             (name-exp (make-regexp "name=\"([^\"]*)\""))
228             (filename-exp (make-regexp "filename=\"([^\"]*)\""))
229             (type-exp (make-regexp "Content-Type: (.*)\r\n"))
230             (value-exp (make-regexp "\r\n\r\n")))
231        (define (get-pair raw-data)
232          (define (get-segment str)
233            (define (find-bound str)
234              (define (find-bound-h str n)
235                (let ((n-str (string-length str)))
236                  (if (< n-str boundary-len)
237                      #f
238                      (if (string=? boundary (make-shared-substring
239                                              str 0 boundary-len))
240                          n
241                          (find-bound-h (make-shared-substring str 1 n-str)
242                                        (+ n 1))))))
243              (find-bound-h str 0))
244            (let* ((seg-start (find-bound str))
245                   (seg-length (find-bound (make-shared-substring
246                                            str (+ seg-start boundary-len)
247                                            (string-length str)))))
248              (if (and seg-start seg-length)
249                  (cons (make-shared-substring
250                         str (+ seg-start boundary-len)
251                         (+ seg-start seg-length boundary-len -2))
252                        (make-shared-substring
253                         str (+ seg-start seg-length boundary-len)
254                         (string-length str)))
255                  #f)))
256          (let ((segment-pair (get-segment raw-data)))
257            (if segment-pair
258                (let* ((segment (car segment-pair))
259                       (name-match (regexp-exec name-exp segment))
260                       (filename-match (regexp-exec filename-exp segment))
261                       (type-match (regexp-exec type-exp segment))
262                       (value-match (regexp-exec value-exp segment)))
263                  (if (and name-match value-match)
264                      (if (and filename-match type-match)
265                          (let* ((name (match:substring name-match 1))
266                                 (value (match:substring filename-match 1))
267                                 (old-value (cgi:values name))
268                                 (file-data (match:suffix value-match))
269                                 (old-file-data (assoc-ref file-uploads name)))
270                            (set! form-variables
271                                  (assoc-set! form-variables name
272                                              (cons value (or old-value '()))))
273                            (set! file-uploads
274                                  (assoc-set! file-uploads name
275                                              (cons file-data (or old-file-data
276                                                                  '())))))
277                          (let* ((name (match:substring name-match 1))
278                                 (value (match:suffix value-match))
279                                 (old-value (cgi:values name)))
280                            (set! form-variables
281                                  (assoc-set! form-variables name
282                                              (cons value (or old-value '())))))))
283                  (get-pair (cdr segment-pair))))))
284        (get-pair raw-data)))
285    
286  (define (read-raw-form-data)  (define (read-raw-form-data)
287    (and cgi-content-length (read-n-chars cgi-content-length)))    (and cgi-content-length (read-n-chars cgi-content-length)))
288    
# Line 149  Line 292 
292    (let ((server-software (getenv "SERVER_SOFTWARE")))    (let ((server-software (getenv "SERVER_SOFTWARE")))
293      (if server-software      (if server-software
294          (let ((slash (string-index server-software #\/)))          (let ((slash (string-index server-software #\/)))
295            (set! cgi-server-software-type    (substring server-software 0 slash))            (set! cgi-server-software-type    (substring server-software
296            (set! cgi-server-software-version (substring server-software (1+ slash))))))                                                         0 slash))
297              (set! cgi-server-software-version (substring server-software
298                                                           (1+ slash))))))
299    
300    (set! cgi-server-hostname        (getenv "SERVER_NAME"))    (set! cgi-server-hostname        (getenv "SERVER_NAME"))
301    (set! cgi-gateway-interface      (getenv "GATEWAY_INTERFACE"));"CGI/revision"    (set! cgi-gateway-interface      (getenv "GATEWAY_INTERFACE")) ;"CGI/revision"
302    
303    (let* ((server-protocol (getenv "SERVER_PROTOCOL")))    (let* ((server-protocol (getenv "SERVER_PROTOCOL")))
304      (if server-protocol      (if server-protocol
305          (let ((slash (string-index server-protocol #\/)))          (let ((slash (string-index server-protocol #\/)))
306            (set! cgi-server-protocol-name     (substring server-protocol 0 slash))            (set! cgi-server-protocol-name     (substring server-protocol
307            (set! cgi-server-protocol-version  (substring server-protocol (1+ slash))))))                                                          0 slash))
308              (set! cgi-server-protocol-version  (substring server-protocol
309                                                            (1+ slash))))))
310    
311    (let ((port (getenv "SERVER_PORT")))    (let ((port (getenv "SERVER_PORT")))
312      (set! cgi-server-port (and port (string->number port))))      (set! cgi-server-port (and port (string->number port))))
# Line 189  Line 336 
336            (and types (separate-fields-discarding-char #\, types))))            (and types (separate-fields-discarding-char #\, types))))
337    
338    ;; HTTP_USER_AGENT format: software/version library/version.    ;; HTTP_USER_AGENT format: software/version library/version.
339    (set! cgi-http-user-agent                (getenv "HTTP_USER_AGENT")))    (set! cgi-http-user-agent                (getenv "HTTP_USER_AGENT"))
340      (set! cgi-http-cookie                    (getenv "HTTP_COOKIE")))
341    
342    ;;; Seting up the cookies
343    (define (get-cookies)
344      (let ((pair-exp (make-regexp "([^=; \t\n]+)=([^=; \t\n]+)")))
345        (define (get-pair str)
346          (let ((pair-match (regexp-exec pair-exp str)))
347            (if (not pair-match) '()
348                (let ((name (match:substring pair-match 1))
349                      (value (match:substring pair-match 2)))
350                  (if (and name value)
351                      (set! cookies
352                            (assoc-set! cookies name
353                                        (append (or (cgi:cookies name) '())
354                                                (list value)))))
355                  (get-pair (match:suffix pair-match))))))
356        (get-pair cgi-http-cookie)))
357    
358    
359  ;;; System I/O and low-level stuff.  ;;; System I/O and low-level stuff.

Legend:
Removed from v.1.5  
changed lines
  Added in v.1.6

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26