Changeset 12478 in project


Ignore:
Timestamp:
11/12/08 00:31:50 (11 years ago)
Author:
sjamaan
Message:

Add local and remote IP-addresses to params. Implement more of CGI spec. Up until section 4, most is implemented now

Location:
release/4/spiffy/trunk
Files:
2 edited

Legend:

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

    r12457 r12478  
    3333; CGI file handler
    3434; 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
    3536
    3637(module cgi-handler
     
    3839
    3940(import chicken scheme extras files posix regex data-structures)
    40 (require-extension spiffy srfi-13 intarweb uri-generic)
     41(require-extension spiffy srfi-1 srfi-13 intarweb uri-generic)
    4142
    4243(define (cgi-handler* interp)
     
    4546(define (alist->envlist alist)
    4647  (map (lambda (entry)
    47          (conc (car entry) "=" (cdr entry)))
     48         (conc (car entry) "=" (or (cdr entry) "")))
    4849       alist))
    4950
    5051(define (query->string q)
    51   (if q
     52  (and q
    5253      (string-join (map (lambda (entry)
    53                           (string-append (car entry) "=" (cdr entry))) q) "&")
    54       ""))
     54                          (string-append (car entry) "=" (cdr entry))) q) "&")))
     55
     56(define (environmentize str)
     57  (conc "HTTP_" (string-upcase (string-translate str "-" "_"))))
    5558
    5659(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)))
     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)))
    6170
    6271(define (cgi-build-env req fn)
    6372  (let* ((server-env
    64           `(("SERVER_PROTOCOL" . ,(sprintf "HTTP/~A.~A"
     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
    6594                                           (request-major req)
    6695                                           (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" . "")))
     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)))
    84112         (header-env (create-header-env (request-headers req))))
    85113    (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))))))
    86122
    87123(define (cgi-handler fn #!optional interp)
    88124  (let* ((path (make-pathname (root-path) fn))
    89125         (req (current-request))
    90          (size (header-value 'content-length (request-headers req) 0))
     126         (len (header-value 'content-length (request-headers req) 0))
    91127         (interp (or interp (make-pathname (root-path)
    92128                                           (uri-path (request-uri req)))))
     
    95131    ;; TODO: Actually use create-header-env to pass on client headers
    96132    (if (file-execute-access? interp)
    97         (let-values (((i o pid) (process interp (list interp path) env)))
     133        ;; XXX The script should be called with the query args on the
     134        ;; commandline but only if those do not contain any unencoded '='
     135        ;; characters. Otherwise, it should pass no commandline arguments.
     136        ;; XXX Current working directory should be the dir with the script.
     137        (let-values (((i o pid) (process interp '() env)))
    98138          #;(log "(cgi) started program ~a(~a) ..." interp fn)
    99           ;; XXX: Search for 'NPH' - No Parsed Headers
     139          (copy-port (request-port (current-request)) o len)
    100140          (close-output-port o)
     141          ;; TODO: Implement read timeout
    101142          (let* ((new-headers (read-headers i))
    102143                 (loc (header-value 'location new-headers))
     
    111152                                             reason: reason)))
    112153              (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))))
     154              (copy-port i (response-port (current-response)))
    119155              (close-input-port i))))
    120156          (error (sprintf "Invalid interpreter: ~A\n" interp)))))
     
    122158(define cgi-default-environment
    123159  (make-parameter `(("SERVER_SOFTWARE" . ,(server-software))
    124                     ("GATEWAY_INTERFACE" . "CGI/1.1")
    125                     ("REDIRECT_STATUS" . "200"))))
     160                    ("GATEWAY_INTERFACE" . "CGI/1.1"))))
    126161)
  • release/4/spiffy/trunk/spiffy.scm

    r12428 r12478  
    3838(module spiffy
    3939  (start-server with-headers send-status send-static-file
    40    current-request current-response current-file current-pathinfo
     40   current-request remote-address local-address
     41   current-response current-file current-pathinfo
    4142   server-software root-path server-port index-files mime-type-map
    4243   default-mime-type file-extension-handlers default-host vhost-map
     
    5657(define current-file     (make-parameter #f))
    5758(define current-pathinfo (make-parameter #f))
     59(define local-address    (make-parameter #f))
     60(define remote-address   (make-parameter #f))
    5861
    5962;;; Configuration
     
    257260
    258261(define (handle-incoming-request in out)
    259   (parameterize ((current-request (read-request in))
    260                  (current-response
    261                   (make-response port: out
    262                                  headers: (headers
    263                                            `((content-type text/html))))))
    264     (let ((path (uri-path (request-uri (current-request)))))
    265       (receive (req cont)
    266         (call/cc (lambda (c) (values (normalize-current-request-uri) c)))
    267         (parameterize ((current-request req)
    268                        (request-restarter cont))
    269           (handle-exceptions exn ((handle-exception) exn
    270                                   (with-output-to-string print-call-chain))
    271             (if (and (uri-host (request-uri (current-request))) (pair? path))
    272                 (let* ((host (uri-host (request-uri (current-request))))
    273                        (handler (alist-ref host
    274                                            (vhost-map)
    275                                            (lambda (h _)
    276                                              (if (not (regexp? h))
    277                                                  (string-match (regexp h #t) host)
    278                                                  (string-match h host))))))
    279                   (if handler
    280                       (handler (lambda () (process-entry "" path)))
    281                       ;; Is this ok?
    282                       (send-status 404 "Not found" "<p>Host not found</p>")))
    283                 ;; No host in the request? That's an error.
    284                 (send-status 400 "Bad request"
    285                              "<p>Your client sent a request that the server did not understand</p>")))))
    286       ;; For now, just close the ports and allow the thread to exit
    287       (close-output-port out)
    288       (close-input-port in))))
     262  (receive (local remote)
     263    (tcp-addresses in)
     264    (parameterize ((remote-address remote)
     265                   (local-address local)
     266                   (current-request (read-request in))
     267                   (current-response
     268                    (make-response port: out
     269                                   headers: (headers
     270                                             `((content-type text/html))))))
     271      (let ((path (uri-path (request-uri (current-request)))))
     272        (receive (req cont)
     273          (call/cc (lambda (c) (values (normalize-current-request-uri) c)))
     274          (parameterize ((current-request req)
     275                         (request-restarter cont))
     276            (handle-exceptions exn ((handle-exception) exn
     277                                    (with-output-to-string print-call-chain))
     278                               (if (and (uri-host (request-uri (current-request))) (pair? path))
     279                                   (let* ((host (uri-host (request-uri (current-request))))
     280                                          (handler (alist-ref host
     281                                                              (vhost-map)
     282                                                              (lambda (h _)
     283                                                                (if (not (regexp? h))
     284                                                                    (string-match (regexp h #t) host)
     285                                                                    (string-match h host))))))
     286                                     (if handler
     287                                         (handler (lambda () (process-entry "" path)))
     288                                         ;; Is this ok?
     289                                         (send-status 404 "Not found" "<p>Host not found</p>")))
     290                                   ;; No host in the request? That's an error.
     291                                   (send-status 400 "Bad request"
     292                                                "<p>Your client sent a request that the server did not understand</p>")))))
     293        ;; For now, just close the ports and allow the thread to exit
     294        (close-output-port out)
     295        (close-input-port in)))))
    289296
    290297(define (htmlize str)
Note: See TracChangeset for help on using the changeset viewer.