source: project/release/4/spiffy/trunk/cgi-handler.scm @ 12527

Last change on this file since 12527 was 12527, checked in by sjamaan, 12 years ago

Add logging support

File size: 8.3 KB
Line 
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
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-to (debug-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-logged-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)
Note: See TracBrowser for help on using the repository browser.