Changeset 4149 in project


Ignore:
Timestamp:
05/12/07 14:39:25 (13 years ago)
Author:
sjamaan
Message:

Get the CGI handler to serve PHP scripts correctly

Location:
spiffy
Files:
2 edited

Legend:

Unmodified
Added
Removed
  • spiffy/cgi-handler.scm

    r4127 r4149  
    2626;
    2727; CGI file handler
     28; See the spec at http://hoohoo.ncsa.uiuc.edu/cgi/interface.html
    2829
    2930(declare
     
    3334  (lambda (fn) (cgi-handler fn interp)))
    3435
     36(define (alist->envlist alist)
     37  (map (lambda (entry)
     38         (string-append (car entry) "=" (cdr entry)))
     39       alist))
     40
     41(define (cgi-build-env req fn)
     42  ;; XXX TODO: Extract path_info and query string in a useful way from the http request.
     43  (let* ((attrs (http:request-attributes req))
     44         (url (http:request-url req))
     45         (m (string-match "([^?]+)\\?(.*)" url))
     46         (server-env `(("SERVER_PROTOCOL" . ,(->string (http:request-protocol req)))
     47                       ("SERVER_PORT" . ,(->string spiffy-tcp-port))
     48                       ("REQUEST_METHOD" . ,(->string (http:request-method req)))
     49                       ("CONTENT_TYPE" . ,(alist-ref "content-type" attrs string=? "application/octet-stream"))
     50                       ("CONTENT_LENGTH" . ,(alist-ref "content-length" attrs string=?
     51                                                       (->string (string-length (http:request-unparsed-body req)))))
     52                       ("SCRIPT_NAME" . ,(if m (cadr m) url))
     53                       ("SCRIPT_FILENAME" . ,fn)
     54                       ("REMOTE_ADDR" . ,(http:request-ip req))
     55                       ("QUERY_STRING" . ,(if m (caddr m) ""))
     56                       ("SERVER_NAME" . ,(get-host-name))
     57                       ; Spiffy has no support for path info currently
     58                       ; (it's the part that comes after the filename, between the slash and the question mark)
     59                       ("PATH_INFO" . "")
     60                       ("PATH_TRANSLATED" . "")))
     61         (headers-env (map (lambda (attr)
     62                             (cons (string-append "HTTP_" (string-translate (string-upcase (car attr)) "-" "_"))
     63                                   (cdr attr)))
     64                           attrs)))
     65    (alist->envlist (append spiffy-cgi-default-environment headers-env server-env))))
     66
    3567(define (cgi-handler fn . args)
    36   (let* ((r (current-request))
    37          (p (http:request-url r))
    38          (m (string-match "([^?]+)\\?(.*)" p))
    39          (interp (:optional args m))
    40          (as (http:request-attributes r))
    41          (body (http:request-unparsed-body r))
    42          (env (append
    43                `(,(conc "SERVER_PROTOCOL=" (http:request-protocol r))
    44                  ,(conc "SERVER_PORT=" spiffy-tcp-port)
    45                  ,(conc "REQUEST_METHOD=" (http:request-method r))
    46                  ,(conc "PATH_INFO=" p)
    47                  ,(conc "CONTENT_TYPE=" (alist-ref "content-type" as string=? "application/octet-stream"))
    48                  ,(conc "CONTENT_LENGTH=" (alist-ref "content-length" as string=? (string-length body)))
    49                  ,(conc "SCRIPT_NAME=" (if m (cadr m) fn))
    50                  ,(conc "SCRIPT_FILENAME=" fn)
    51                  ,(conc "REMOTE_ADDR=" (http:request-ip r))
    52                  ,@(if m (list (conc "QUERY_STRING=" (caddr m))) '()) )
    53                (map (lambda (attr)
    54                       (string-append
    55                        "HTTP_"
    56                        (string-translate
    57                         (string-upcase (car attr))
    58                         "-" "_")
    59                        "=" (cdr attr) ) )
    60                     as)
    61                spiffy-cgi-default-environment)) )
     68  (let* ((req (current-request))
     69         (interp (:optional args (string-match "([^?]+)\\?(.*)" (http:request-url req))))
     70         (body (http:request-unparsed-body req))
     71         (env (cgi-build-env req fn)))
    6272    (if (file-execute-access? interp)
    6373        (let-values (((i o pid) (process interp (list interp fn) env)))
     
    6575                    (display body o)
    6676                    (close-output-port o)
    67                     (write-response-header r)
    6877                    (let loop ()
    6978                      (let ((ln (read-line i)))
     
    7584                                 (close-input-port i)
    7685                                 (spiffy-debug "(cgi) program terminated normally, response has ~a bytes" len)
     86                                 (write-response-header req (car (current-response-code)) (cdr (current-response-code)) (current-response-headers))
    7787                                 (printf "Content-Length: ~A\r\n\r\n" len)
    7888                                 (unless (eq? 'HEAD (http:request-method (current-request)))
    7989                                         (display body) ) ) )
    80                               ((string-match "Status:(.+)" ln) =>
     90                              ((string-match "Location:[ \t]([^ \t].+)" ln) =>
    8191                               (lambda (m)
    82                                  (printf "~a ~a\r\n" (http:request-protocol r) (cadr m))
     92                                 (redirect (cadr m))
    8393                                 (loop) ) )
    8494                              (else
    85                                (printf "~a\r\n" ln)
     95                               (set-header! ln)
    8696                               (loop) ) ) ) ) )
    8797        (http:write-error-response 500 "Internal server error") ) ) )
    8898
    89 (define spiffy-cgi-default-environment
    90   `(,(conc "SERVER_SOFTWARE=" (chicken-version #t))
    91     ,(conc "SERVER_NAME=" spiffy-server-name)
    92     "GATEWAY_INTERFACE=CGI/1.1") )
     99(define spiffy-cgi-default-environment
     100  `(("SERVER_SOFTWARE" . ,spiffy-server-name)
     101    ("GATEWAY_INTERFACE" . "CGI/1.1")))
  • spiffy/spiffy-base.scm

    r4127 r4149  
    504504       "([-_A-Z0-9a-z]+)\\:[ \t]*([^ \t].*)") ) )
    505505
    506 (define (set-header! header #!optional (allow-multiple #f))
     506(define (single-header? name)
     507  (member name '("Set-Cookie")))
     508
     509(define (set-header! header)
    507510  (match (string-match *header-regexp* header)
    508511    [(_ name val)
    509512     (spiffy-debug "set-header: ~S -> ~S" name val)
    510      (if allow-multiple
    511          (current-response-headers (alist-cons name val (current-response-headers)))
     513     (if (single-header? name)
    512514         (let* ([rh (current-response-headers)]
    513515                [a (alist-ref name rh string-ci=?)] )
    514516           (if a
    515517               (set-cdr! a val)
    516                (current-response-headers (alist-cons name val rh)) ) ) ) ]
     518               (current-response-headers (alist-cons name val rh)) ) )
     519         (current-response-headers (alist-cons name val (current-response-headers))))]
    517520    [_ (error "invalid header syntax" header)] ) )
    518521
Note: See TracChangeset for help on using the changeset viewer.