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

Last change on this file since 12457 was 12457, checked in by sjamaan, 11 years ago

First stab at implementing the CGI handler for Spiffy 4

File size: 5.8 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
36(module cgi-handler
37  (cgi-handler cgi-handler* cgi-default-environment)
38
39(import chicken scheme extras files posix regex data-structures)
40(require-extension spiffy srfi-13 intarweb uri-generic)
41
42(define (cgi-handler* interp)
43  (lambda (fn) (cgi-handler fn interp)))
44
45(define (alist->envlist alist)
46  (map (lambda (entry)
47         (conc (car entry) "=" (cdr entry)))
48       alist))
49
50(define (query->string q)
51  (if q
52      (string-join (map (lambda (entry)
53                          (string-append (car entry) "=" (cdr entry))) q) "&")
54      ""))
55
56(define (create-header-env headers)
57  (map (lambda (h)
58         (cons (conc "HTTP_" (string-translate (header-name->string (car h)) "-" "_"))
59               (unparse-header (car h) (cdr h))))
60       (headers->list headers)))
61
62(define (cgi-build-env req fn)
63  (let* ((server-env
64          `(("SERVER_PROTOCOL" . ,(sprintf "HTTP/~A.~A"
65                                           (request-major req)
66                                           (request-minor req)))
67            ("SERVER_PORT" . ,(server-port))
68            ("REQUEST_METHOD" . ,(request-method req))
69            ("CONTENT_TYPE" . ,(header-value 'content-type
70                                             (request-headers req)
71                                             'application/octet-stream))
72            ("CONTENT_LENGTH" . ,(header-value 'content-length
73                                               (request-headers req)
74                                               ""))
75            ("SCRIPT_NAME" . ,(current-file))
76            ("SCRIPT_FILENAME" . ,fn)
77            #;("REMOTE_ADDR" . ,(http:request-ip req))
78            ("QUERY_STRING" . ,(query->string (uri-query (request-uri req))))
79            ("SERVER_NAME" . ,(uri-host (request-uri (current-request))))
80            ("PATH_INFO" . ,(if (current-pathinfo)
81                                (string-join (current-pathinfo) "/")
82                                ""))
83            ("PATH_TRANSLATED" . "")))
84         (header-env (create-header-env (request-headers req))))
85    (alist->envlist (append (cgi-default-environment) header-env server-env))))
86
87(define (cgi-handler fn #!optional interp)
88  (let* ((path (make-pathname (root-path) fn))
89         (req (current-request))
90         (size (header-value 'content-length (request-headers req) 0))
91         (interp (or interp (make-pathname (root-path)
92                                           (uri-path (request-uri req)))))
93         (env (cgi-build-env req path)))
94    ;; TODO: stderr should be linked to spiffy error log (make log first)
95    ;; TODO: Actually use create-header-env to pass on client headers
96    (if (file-execute-access? interp)
97        (let-values (((i o pid) (process interp (list interp path) env)))
98          #;(log "(cgi) started program ~a(~a) ..." interp fn)
99          ;; XXX: Search for 'NPH' - No Parsed Headers
100          (close-output-port o)
101          (let* ((new-headers (read-headers i))
102                 (loc (header-value 'location new-headers))
103                 ;; TODO: also check for a 'status' header, which should
104                 ;; override this "guess" (which is on spec, though)
105                 (code (if loc 302 (response-code (current-response))))
106                 (reason (if loc "Found" (response-reason (current-response)))))
107            (parameterize ((current-response
108                            (update-response (current-response)
109                                             headers: new-headers
110                                             code: code
111                                             reason: reason)))
112              (write-response (current-response))
113              ;; TODO: Somehow link the real input port to the output
114              ;; port here, if possible.
115              (let loop ((out (read-string 1024 i)))
116                (unless (string-null? out)
117                        (display out (response-port (current-response)))
118                        (loop (read-string 1024 i))))
119              (close-input-port i))))
120          (error (sprintf "Invalid interpreter: ~A\n" interp)))))
121
122(define cgi-default-environment
123  (make-parameter `(("SERVER_SOFTWARE" . ,(server-software))
124                    ("GATEWAY_INTERFACE" . "CGI/1.1")
125                    ("REDIRECT_STATUS" . "200"))))
126)
Note: See TracBrowser for help on using the repository browser.