1 | ;;;; cgi-handler.scm |
---|
2 | ; |
---|
3 | ; Copyright (c) 2007-2008, Peter Bex |
---|
4 | ; Copyright (c) 2000-2005, Felix L. Winkelmann |
---|
5 | ; All rights reserved. |
---|
6 | ; |
---|
7 | ; Redistribution and use in source and binary forms, with or without |
---|
8 | ; modification, are permitted provided that the following conditions |
---|
9 | ; are met: |
---|
10 | ; |
---|
11 | ; 1. Redistributions of source code must retain the above copyright |
---|
12 | ; notice, this list of conditions and the following disclaimer. |
---|
13 | ; 2. Redistributions in binary form must reproduce the above copyright |
---|
14 | ; notice, this list of conditions and the following disclaimer in the |
---|
15 | ; documentation and/or other materials provided with the distribution. |
---|
16 | ; 3. Neither the name of the author nor the names of its |
---|
17 | ; contributors may be used to endorse or promote products derived |
---|
18 | ; from this software without specific prior written permission. |
---|
19 | ; |
---|
20 | ; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS |
---|
21 | ; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT |
---|
22 | ; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS |
---|
23 | ; FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE |
---|
24 | ; COPYRIGHT HOLDERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, |
---|
25 | ; INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES |
---|
26 | ; (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR |
---|
27 | ; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) |
---|
28 | ; HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, |
---|
29 | ; STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) |
---|
30 | ; ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED |
---|
31 | ; OF THE POSSIBILITY OF SUCH DAMAGE. |
---|
32 | ; |
---|
33 | ; CGI file handler |
---|
34 | ; See the spec at http://hoohoo.ncsa.uiuc.edu/cgi/interface.html |
---|
35 | ; Newer CGI spec: RFC 3875 at http://www.ietf.org/rfc/rfc3875 |
---|
36 | |
---|
37 | (module cgi-handler |
---|
38 | (cgi-handler cgi-handler* cgi-default-environment) |
---|
39 | |
---|
40 | (import chicken scheme extras files posix regex data-structures) |
---|
41 | (require-extension spiffy srfi-1 srfi-13 intarweb uri-generic) |
---|
42 | |
---|
43 | (define (cgi-handler* #!optional interp) |
---|
44 | (lambda (fn) (cgi-handler fn interp))) |
---|
45 | |
---|
46 | (define (alist->envlist alist) |
---|
47 | (map (lambda (entry) |
---|
48 | (conc (car entry) "=" (or (cdr entry) ""))) |
---|
49 | alist)) |
---|
50 | |
---|
51 | (define (query->string q) |
---|
52 | (and q |
---|
53 | (string-join (map (lambda (entry) |
---|
54 | (string-append (car entry) "=" (cdr entry))) q) "&"))) |
---|
55 | |
---|
56 | (define (environmentize str) |
---|
57 | (conc "HTTP_" (string-upcase (string-translate str "-" "_")))) |
---|
58 | |
---|
59 | (define (create-header-env headers) |
---|
60 | (fold |
---|
61 | (lambda (h result) |
---|
62 | ;; As per RFC 3875, section 4.1.18, remove all redundant information |
---|
63 | ;; all information related to authentication. |
---|
64 | (if (member (car h) '(content-type content-length authorization)) |
---|
65 | result |
---|
66 | (cons (cons (environmentize (header-name->string (car h))) |
---|
67 | (unparse-header (car h) (cdr h))) |
---|
68 | result))) |
---|
69 | '() (headers->list headers))) |
---|
70 | |
---|
71 | (define (cgi-build-env req fn) |
---|
72 | (let* ((server-env |
---|
73 | `(;; XXX When intarweb is modified to parse authorization, fix this |
---|
74 | #;("AUTH_TYPE" . ,(header-value 'authorization |
---|
75 | (request-headers req))) |
---|
76 | ;; Username MUST be available when AUTH_TYPE is set |
---|
77 | #;("REMOTE_USER" . ,(header-value ... )) |
---|
78 | ("CONTENT_LENGTH" . ,(header-value 'content-length |
---|
79 | (request-headers req))) |
---|
80 | ("CONTENT_TYPE" . ,(and-let* ((contents (header-contents |
---|
81 | 'content-type |
---|
82 | (request-headers req)))) |
---|
83 | (unparse-header 'content-type contents))) |
---|
84 | ("PATH_INFO" . ,(string-join (current-pathinfo) "/")) |
---|
85 | ("QUERY_STRING" . ,(query->string (uri-query (request-uri req)))) |
---|
86 | ("REMOTE_ADDR" . ,(remote-address)) |
---|
87 | ;; This should really be the FQDN of the remote address |
---|
88 | ("REMOTE_HOST" . ,(remote-address)) |
---|
89 | ("REQUEST_METHOD" . ,(request-method req)) |
---|
90 | ("SCRIPT_NAME" . ,(current-file)) |
---|
91 | ("SERVER_NAME" . ,(uri-host (request-uri (current-request)))) |
---|
92 | ("SERVER_PORT" . ,(server-port)) ; OK? |
---|
93 | ("SERVER_PROTOCOL" . ,(sprintf "HTTP/~A.~A" ; protocol, NOT scheme |
---|
94 | (request-major req) |
---|
95 | (request-minor req))) |
---|
96 | ;; RFC 3875, section 4.1.6: |
---|
97 | ;; "The value is derived in this way irrespective of whether |
---|
98 | ;; it maps to a valid repository location." |
---|
99 | ;; ie, this value does not always make sense |
---|
100 | ("PATH_TRANSLATED" . ,(and (not (null? (current-pathinfo))) |
---|
101 | (make-pathname |
---|
102 | (root-path) |
---|
103 | (string-join (current-pathinfo) "/")))) |
---|
104 | ;; PHP _always_ wants the REDIRECT_STATUS "for security", |
---|
105 | ;; so just initialize it unconditionally. |
---|
106 | ;; See http://php.net/security.cgi-bin |
---|
107 | ("REDIRECT_STATUS" . ,(response-code (current-response))) |
---|
108 | ;; More stuff needed because PHP's CGI is broken |
---|
109 | ;; See http://bugs.php.net/28227 |
---|
110 | ;; (yes, that's right; it's been broken since 2004) |
---|
111 | ("SCRIPT_FILENAME" . ,fn))) |
---|
112 | (header-env (create-header-env (request-headers req)))) |
---|
113 | (alist->envlist (append (cgi-default-environment) header-env server-env)))) |
---|
114 | |
---|
115 | (define (copy-port in out #!optional limit) |
---|
116 | (let ((bufsize 1024)) |
---|
117 | (let loop ((data (read-string (min (or limit bufsize) bufsize) in))) |
---|
118 | (unless (string-null? data) |
---|
119 | (display data out) |
---|
120 | (when limit (set! limit (- limit (string-length data)))) |
---|
121 | (loop (read-string (min (or limit bufsize) bufsize) in)))))) |
---|
122 | |
---|
123 | (define (status-parser str) |
---|
124 | (let ((parts (string-match "([0-9]+) (.+)" str))) |
---|
125 | (cons (string->number (second parts)) (third parts)))) |
---|
126 | |
---|
127 | (define (cgi-handler fn #!optional interp) |
---|
128 | (let* ((path (make-pathname (root-path) fn)) |
---|
129 | (req (current-request)) |
---|
130 | (len (header-value 'content-length (request-headers req) 0)) |
---|
131 | (interp (or interp (make-pathname (root-path) |
---|
132 | (string-join (uri-path (request-uri req)) "/")))) |
---|
133 | (env (cgi-build-env req path))) |
---|
134 | ;; TODO: stderr should be linked to spiffy error log (make log first) |
---|
135 | (if (file-execute-access? interp) |
---|
136 | ;; XXX The script should be called with the query args on the |
---|
137 | ;; commandline but only if those do not contain any unencoded '=' |
---|
138 | ;; characters. Otherwise, it should pass no commandline arguments. |
---|
139 | ;; XXX Current working directory should be the dir with the script. |
---|
140 | (let-values (((i o pid) (process interp '() env))) |
---|
141 | #;(log "(cgi) started program ~a(~a) ..." interp fn) |
---|
142 | (copy-port (request-port (current-request)) o len) |
---|
143 | (close-output-port o) |
---|
144 | ;; TODO: Implement read timeout |
---|
145 | (let* ((new-headers (parameterize ((header-parsers |
---|
146 | (cons `(status |
---|
147 | . ,(single status-parser)) |
---|
148 | (header-parsers)))) |
---|
149 | (read-headers i))) |
---|
150 | (loc (header-value 'location new-headers)) |
---|
151 | (status (header-value 'status new-headers)) |
---|
152 | (code (cond |
---|
153 | (status (car status)) |
---|
154 | (loc 302) |
---|
155 | (else (response-code (current-response))))) |
---|
156 | (reason (cond |
---|
157 | (status (cdr status)) |
---|
158 | (loc "Found") |
---|
159 | (else (response-reason (current-response)))))) |
---|
160 | (parameterize ((current-response |
---|
161 | (update-response (current-response) |
---|
162 | headers: new-headers |
---|
163 | code: code |
---|
164 | reason: reason))) |
---|
165 | (write-response (current-response)) |
---|
166 | (copy-port i (response-port (current-response))) |
---|
167 | (close-input-port i)))) |
---|
168 | (error (sprintf "Invalid interpreter: ~A\n" interp))))) |
---|
169 | |
---|
170 | (define cgi-default-environment |
---|
171 | (make-parameter `(("SERVER_SOFTWARE" . ,(server-software)) |
---|
172 | ("GATEWAY_INTERFACE" . "CGI/1.1")))) |
---|
173 | ) |
---|