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 |
|
|
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 |
|
|
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)) |
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. |
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 |
|
|
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)))) |
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. |