Changeset 12457 in project


Ignore:
Timestamp:
11/11/08 00:02:09 (13 years ago)
Author:
sjamaan
Message:

First stab at implementing the CGI handler for Spiffy 4

File:
1 copied

Legend:

Unmodified
Added
Removed
  • release/4/spiffy/trunk/cgi-handler.scm

    r12134 r12457  
    11;;;; cgi-handler.scm
    22;
    3 ; Copyright (c) 2007, Peter Bex
     3; Copyright (c) 2007-2008, Peter Bex
    44; Copyright (c) 2000-2005, Felix L. Winkelmann
    55; All rights reserved.
    66;
    7 ; Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following
    8 ; conditions are met:
     7; Redistribution and use in source and binary forms, with or without
     8; modification, are permitted provided that the following conditions
     9; are met:
    910;
    10 ;   Redistributions of source code must retain the above copyright notice, this list of conditions and the following
    11 ;     disclaimer.
    12 ;   Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following
    13 ;     disclaimer in the documentation and/or other materials provided with the distribution.
    14 ;   Neither the name of the author nor the names of its contributors may be used to endorse or promote
    15 ;     products derived from this software without specific prior written permission.
     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.
    1619;
    17 ; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS
    18 ; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
    19 ; AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
    20 ; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
    21 ; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
    22 ; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
    23 ; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
    24 ; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
    25 ; POSSIBILITY OF SUCH DAMAGE.
     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.
    2632;
    2733; CGI file handler
    2834; See the spec at http://hoohoo.ncsa.uiuc.edu/cgi/interface.html
    2935
    30 (declare
    31  (export cgi-handler cgi-handler* spiffy-cgi-default-environment) )
     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)
    3241
    3342(define (cgi-handler* interp)
     
    3645(define (alist->envlist alist)
    3746  (map (lambda (entry)
    38          (string-append (car entry) "=" (cdr entry)))
     47         (conc (car entry) "=" (cdr entry)))
    3948       alist))
    4049
     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
    4162(define (cgi-build-env req fn)
    42   (let* ((attrs (http:request-attributes req))
    43          (url (http:request-url req))
    44          (m (string-match "([^?]+)\\?(.*)" url))
    45          (server-env `(("SERVER_PROTOCOL" . ,(->string (http:request-protocol req)))
    46                        ("SERVER_PORT" . ,(->string (spiffy-tcp-port)))
    47                        ("REQUEST_METHOD" . ,(->string (http:request-method req)))
    48                        ("CONTENT_TYPE" . ,(alist-ref "content-type" attrs string=? "application/octet-stream"))
    49                        ("CONTENT_LENGTH" . ,(alist-ref "content-length" attrs string=?
    50                                                        (->string (string-length (http:request-unparsed-body req)))))
    51                        ("SCRIPT_NAME" . ,(if m (cadr m) url))
    52                        ("SCRIPT_FILENAME" . ,fn)
    53                        ("REMOTE_ADDR" . ,(http:request-ip req))
    54                        ("QUERY_STRING" . ,(if m (caddr m) ""))
    55                        ("SERVER_NAME" . ,(current-hostname))
    56                        ("PATH_INFO" . ,(or (current-pathinfo) ""))
    57                        ("PATH_TRANSLATED" . "")))
    58          (headers-env (map (lambda (attr)
    59                              (cons (string-append "HTTP_" (string-translate (string-upcase (car attr)) "-" "_"))
    60                                    (cdr attr)))
    61                            attrs)))
    62     (alist->envlist (append (spiffy-cgi-default-environment) headers-env server-env))))
     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))))
    6386
    64 (define (cgi-handler fn . args)
    65   (let* ((req (current-request))
    66          (interp (:optional args (string-match "([^?]+)\\?(.*)" (http:request-url req))))
    67          (body (http:request-unparsed-body req))
    68          (env (cgi-build-env req fn)))
     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
    6996    (if (file-execute-access? interp)
    70         (let-values (((i o pid) (process interp (list interp fn) env)))
    71                     (spiffy-debug "(cgi) started program ~a(~a) ..." interp fn)
    72                     (display body o)
    73                     (close-output-port o)
    74                     (let loop ()
    75                       (let ((ln (read-line i)))
    76                         (cond ((eof-object? ln)
    77                                (http:write-error-response 500 "Internal server error") )
    78                               ((string=? "" ln)
    79                                (let* ((body (read-string #f i))
    80                                       (len (string-length body)))
    81                                  (close-input-port i)
    82                                  (spiffy-debug "(cgi) program terminated normally, response has ~a bytes" len)
    83                                  (set-header! (sprintf "Content-Length: ~A") len)
    84                                  (write-response-header)
    85                                  (unless (eq? 'HEAD (http:request-method req))
    86                                          (display body) ) ) )
    87                               ((string-match "Location:[ \t]([^ \t].+)" ln) =>
    88                                (lambda (m)
    89                                  (redirect (cadr m))
    90                                  (loop) ) )
    91                               (else
    92                                (set-header! ln)
    93                                (loop) ) ) ) ) )
    94         (http:write-error-response 500 "Internal server error") ) ) )
     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)))))
    95121
    96 (define spiffy-cgi-default-environment
    97   (make-parameter `(("SERVER_SOFTWARE" . ,(spiffy-server-name))
     122(define cgi-default-environment
     123  (make-parameter `(("SERVER_SOFTWARE" . ,(server-software))
    98124                    ("GATEWAY_INTERFACE" . "CGI/1.1")
    99125                    ("REDIRECT_STATUS" . "200"))))
     126)
Note: See TracChangeset for help on using the changeset viewer.