;;;; fcgi-handler.scm ; ; Copyright (c) 2012, Andy Bennett ; Based on cgi-handler.scm: ; Copyright (c) 2007-2009, Peter Bex ; Copyright (c) 2000-2005, Felix L. Winkelmann ; All rights reserved. ; ; Redistribution and use in source and binary forms, with or without ; modification, are permitted provided that the following conditions ; are met: ; ; 1. Redistributions of source code must retain the above copyright ; notice, this list of conditions and the following disclaimer. ; 2. Redistributions in binary form must reproduce the above copyright ; notice, this list of conditions and the following disclaimer in the ; documentation and/or other materials provided with the distribution. ; 3. Neither the name of the author nor the names of its ; contributors may be used to endorse or promote products derived ; from this software without specific prior written permission. ; ; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT ; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS ; FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE ; COPYRIGHT HOLDERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, ; INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES ; (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR ; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) ; HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, ; STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ; ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED ; OF THE POSSIBILITY OF SUCH DAMAGE. ; ; FCGI file handler ; See the spec at http://www.fastcgi.com/drupal/node/6?q=node/22 ; Also requires the CGI spec: RFC 3875 at http://www.ietf.org/rfc/rfc3875 (module fcgi-handler (fcgi-handler fcgi-register-application fcgi-responder fcgi-authorizer fcgi-filter) (import chicken scheme extras files posix regex data-structures foreign ports) (use spiffy srfi-1 srfi-4 srfi-13 srfi-18 intarweb uri-common (prefix uri-generic generic:) records socket) ; for now we support only a single connection carrying one request at a time to each instance. ; this means we don't have to have extra threads to marshall data in and out of the request threads. ; we also don't have to keep track of any request ids or other per-request state. ; http://www.toggo.de/fcgi-bin/fcgi_application ; csc -s -O2 -d1 -inline -local fcgi-handler.scm fork-exec.c -J && csc -s -d0 fcgi-handler.import.scm (define fcgi-version 1) (define fcgi-header-len 8) ; packet types (define fcgi-begin-request 1) (define fcgi-abort-request 2) (define fcgi-end-request 3) (define fcgi-params 4) (define fcgi-stdin 5) (define fcgi-stdout 6) (define fcgi-stderr 7) (define fcgi-data 8) (define fcgi-get-values 9) (define fcgi-get-values-result 10) (define fcgi-unknown-type 11) (define fcgi-maxtype fcgi-unknown-type) ; roles (define fcgi-responder 1) (define fcgi-authorizer 2) (define fcgi-filter 3) ; header fields (define header-version 0) (define header-type 1) (define header-request-id-b1 2) (define header-request-id-b0 3) (define header-content-length-b1 4) (define header-content-length-b0 5) (define header-padding-length 6) (define header-reserved 7) ; flags for various records ; FCGI_BEGIN_REQUEST (define fcgi-keep-conn 1) ; FCGI_END_REQUEST (define fcgi-request-complete 0) (define fcgi-cant-mpx-conn 1) (define fcgi-overloaded 2) (define fcgi-unknown-role 3) (define request-state (make-parameter #f)) ; assumes no more than one simultaneous request per thread (define fcgi-apps '()) ; an alist mapping application names to a vector of application processes (instances). (define instance (make-record-type 'instance '(in-use started pid socket fcgi-max-conns ; The maximum number of concurrent transport connections this application will accept, e.g. "1" or "10". fcgi-max-reqs ; The maximum number of concurrent requests this application will accept, e.g. "1" or "50". fcgi-mpxs-conns ; "0" if this application does not multiplex connections (i.e. handle concurrent requests over each connection), "1" otherwise. curr-conns ; The current number of concurrent transport connections curr-reqs ; The current number of requests in flight. max-conns ; The maximum number of concurrent transport connections we have used. max-reqs ; The maximum number of concurrent requests we have had in flight. total-conns; The number of times we have opened the socket. total-reqs ; The number of requests this instance has processed. ))) (define make-instance (record-constructor instance)) (define instance-in-use (record-accessor instance 'in-use)) (define instance-socket (record-accessor instance 'socket)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; CGI & FCGI Environment Utilities ;;; (define (alist->envlist alist) (map (lambda (entry) (conc (car entry) "=" (or (cdr entry) ""))) alist)) (define (alist->name/value-pairs alist) (filter-map (lambda (entry) (and-let* ((name (car entry)) (value (cdr entry)) (value (->string value)) (name-len (string-length name)) (value-len (string-length value)) (name-len-size (if (> name-len #x7f) 4 1)) (value-len-size (if (> value-len #x7f) 4 1)) (name-len-start 0) (value-len-start name-len-size) (name-start (+ value-len-start value-len-size)) (value-start (+ name-start name-len)) (blob-len (+ value-start value-len)) (blob (make-empty-record blob-len))) (if (> name-len-size 1) (u32encode blob name-len (+ 3 name-len-start) (+ 2 name-len-start) (+ 1 name-len-start) name-len-start) (u8vector-set! blob name-len-start name-len)) (if (> value-len-size 1) (u32encode blob value-len (+ 3 value-len-start) (+ 2 value-len-start) (+ 1 value-len-start) value-len-start) (u8vector-set! blob value-len-start value-len)) (with-input-from-string name (lambda () (read-u8vector! name-len blob (current-input-port) name-start))) (with-input-from-string value (lambda () (read-u8vector! value-len blob (current-input-port) value-start))) (u8vector->blob/shared blob))) alist)) (define (environmentize str) (conc "HTTP_" (string-upcase (string-translate str "-" "_")))) (define (create-header-env headers) (fold (lambda (h result) ;; As per RFC 3875, section 4.1.18, remove all redundant information ;; all information related to authentication. (if (member (car h) '(content-type content-length authorization)) result (append! (map (lambda (x) (cons (environmentize (symbol->http-name (car h))) x)) (unparse-header (car h) (cdr h))) result))) '() (headers->list headers))) (define (fcgi-build-request-env req) (let* ((server-env `(;; TODO: Enable and find a script that requires auth, then test it! #;("AUTH_TYPE" . ,(header-value 'authorization (request-headers req))) ;; Username MUST be available when AUTH_TYPE is set #;("REMOTE_USER" . ,(header-value ... )) ;; We're not supposed to send CONTENT_LENGTH to an Authorizer. ("CONTENT_LENGTH" . ,(header-value 'content-length (request-headers req))) ("CONTENT_TYPE" . ,(and-let* ((contents (header-contents 'content-type (request-headers req)))) (car (unparse-header 'content-type contents)))) ;; We're not supposed to send PATH_INFO to an Authorizer. ;; This doesn't seem to work anyway. ("PATH_INFO" . ,(and (current-pathinfo) (string-join (current-pathinfo) "/"))) ; This isn't in the CGI spec, but lots of scripts expect to see it. ("REQUEST_URI" . ,(string-append "/" (string-join (cdr (uri-path (request-uri req))) "/") (or (and-let* ((query-string (generic:uri-query (uri->uri-generic (request-uri req))))) (string-append "?" query-string)) ""))) ("QUERY_STRING" . ,(generic:uri-query (uri->uri-generic (request-uri req)))) ("REMOTE_ADDR" . ,(remote-address)) ;; This should really be the FQDN of the remote address ("REMOTE_HOST" . ,(remote-address)) ("REQUEST_METHOD" . ,(request-method req)) ("SERVER_NAME" . ,(uri-host (request-uri (current-request)))) ("SERVER_PORT" . ,(server-port)) ; OK? ("SERVER_PROTOCOL" . ,(sprintf "HTTP/~A.~A" ; protocol, NOT scheme (request-major req) (request-minor req))) ("SERVER_SOFTWARE" . ,(and-let* ((contents (header-contents 'server (response-headers (current-response))))) (car (unparse-header 'server contents)))) ;; RFC 3875, section 4.1.6: ;; "The value is derived in this way irrespective of whether ;; it maps to a valid repository location." ;; ie, this value does not always make sense ;; We're not supposed to send PATH_TRANSLATED to an Authorizer. ;; This doesn't seem to work anyway. ("PATH_TRANSLATED" . ,(and (current-pathinfo) (not (null? (current-pathinfo))) (make-pathname (root-path) (string-join (current-pathinfo) "/")))) ;; PHP _always_ wants the REDIRECT_STATUS "for security", ;; so just initialize it unconditionally. ;; See http://php.net/security.cgi-bin ("REDIRECT_STATUS" . ,(response-code (current-response))) ;; Nonstandard but reasonably widely used Apache extension ("HTTPS" . ,(and (secure-connection?) "on")))) (header-env (create-header-env (request-headers req)))) (append header-env server-env))) (define (fcgi-build-initial-env fn) (let* ((server-env ;; We're not supposed to send SCRIPT_NAME to an Authorizer. `(("SCRIPT_NAME" . ,(if (list? fn) (car fn) fn)) ("PHP_FCGI_CHILDREN" . "1") ;; More stuff needed because PHP's CGI is broken ;; See http://bugs.php.net/28227 ;; (yes, that's right; it's been broken since 2004) ("SCRIPT_FILENAME" . ,(if (list? fn) (car fn) fn))))) (append (fcgi-default-environment) server-env))) (define fcgi-default-environment (make-parameter `(("GATEWAY_INTERFACE" . "CGI/1.1")))) ;; "the server retains its responsibility to the client to conform to the ;; relevant network protocol even if the CGI script fails to conform to ;; this specification." -- RFC 3875, Section 3.1 ;; The simplest way to ensure that the client conforms to the protocol ;; is to discard any content-length headers and simply close the connection. (define (sanitize-headers script-headers) (headers '((connection close)) (remove-header 'content-length script-headers))) (define (status-parser str) (let ((parts (string-match "([0-9]+) (.+)" str))) (cons (string->number (second parts)) (third parts)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (define (copy-port-to-stream in out #!optional limit) (assert (port? in)) (assert (procedure? out)) (let ((bufsize 65535)) (let loop ((data (read-string (min (or limit bufsize) bufsize) in))) (unless (string-null? data) (out data) (when limit (set! limit (- limit (string-length data)))) (loop (read-string (min (or limit bufsize) bufsize) in)))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; FCGI Request Handlers ;;; (define (fcgi-handler app-name #!key (continue #f)) ; get the content-length header. if there isn't one then tell them to f-off - cgi mandates it: whatever; we don't care (let* ((app (alist-ref app-name fcgi-apps)) (handler (car app)) (instances (cdr app)) (instance (select-instance instances)) ; FIXME: deal with this returning #f: i.e. no instances are available (s (socket af/unix sock/stream)) (continue-param #f)) (handle-exceptions exn (begin (release-instance instance) (socket-close* s) (abort exn)) (socket-connect s (unix-address (instance-socket instance))) (let* ((req (current-request)) (len (header-value 'content-length (request-headers req) 0))) (set! continue-param (handler app-name s req len)) (socket-close s))) (release-instance instance) (if (and continue continue-param) (continue continue-param)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; FCGI Responder Role ;;; (define (fcgi-handler-responder app-name socket req content-length) (let ((headers "")) (define (send-body m) (if (eq? 'HEAD (request-method (current-request))) #f (display m (response-port (current-response))))) (define (handle-stdout m) (if headers (begin ; We're still collecting the headers before sending them to the client so that we can sanitize them. ; HTTP headers must be ISO-8859-1 so we can use byte-oriented string procedures to find the end of header marker. ; We assume that headers are "short" and therefore O(N) procedures such as string-append and substring-index are cheap. (set! headers (string-append headers (blob->string m))) (let ((end-of-headers (substring-index "\r\n\r\n" headers))) (if end-of-headers ; We have all of the headers and perhaps some of the body. (let* ((end-of-headers (+ 4 end-of-headers)) (script-headers (with-input-from-string (substring headers 0 end-of-headers) (lambda () (parameterize ((header-parsers `((status . ,(single status-parser)) ,@(header-parsers)))) (read-headers (current-input-port)))))) (loc (header-value 'location script-headers)) (status (header-value 'status script-headers)) (code (cond (status (car status)) (loc 302) (else (response-code (current-response))))) (reason (cond (status (cdr status)) (loc "Found") (else (response-reason (current-response))))) ;; Get rid of our temporary Status "header" again (script-headers (remove-header 'status script-headers))) ; TODO: We should get rid of the Content-Length header as well and allow spiffy to recalculate it but that would ; involve reworking things such that we store the response somewhere and then flushing it with send-response ; rather than just streaming it directly to the client. Reworking in this way will also allow us to call ; finish-response-body like we're supposed to. OTOH, if we used send-response then it would do it for us. (current-response (update-response (current-response) headers: (sanitize-headers script-headers) code: code reason: reason)) (write-logged-response) ; Send the start of the body (send-body (substring headers end-of-headers)) (set! headers #f))))) (send-body (blob->string m)))) (let ((in-out-dance (make-in-out-dance app-name socket stdout-handler: handle-stdout))) (read/write-socket socket 1 fcgi-begin-request fcgi-responder) (read/write-socket socket 1 fcgi-params (fcgi-build-request-env req)) (read/write-socket socket 1 fcgi-params 'close-stream) ; stream request data over fcgi-stdin. (copy-port-to-stream (request-port req) in-out-dance content-length) (let loop ((done? (in-out-dance 'close-stream))) ; wait for all the replies to come back (if (not done?) (loop (in-out-dance)))) #f))) ; Responders never continue: we've sent a response. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; FCGI Authorizer Role ;;; (define (fcgi-handler-authorizer app-name socket req content-length) (let ((headers "") (variables '()) (success #f)) (define (send-body m) (if (or success (eq? 'HEAD (request-method (current-request)))) #f (display m (response-port (current-response))))) (define (handle-stdout m) (if headers (begin ; We're still collecting the headers before sending them to the client so that we can sanitize them and extract the ; FCGI Status & Variable-* headers. ; HTTP headers must be ISO-8859-1 so we can use byte-oriented string procedures to find the end of header marker. ; We assume that headers are "short" and therefore O(N) procedures such as string-append and substring-index are cheap. (set! headers (string-append headers (blob->string m))) (let ((end-of-headers (substring-index "\r\n\r\n" headers))) (if end-of-headers ; We have all of the headers and perhaps some of the body. (let* ((end-of-headers (+ 4 end-of-headers)) (header-lines (string-split (substring headers 0 end-of-headers) "\n" #t)) (header-lines (reverse (fold (lambda (v s) (let ((header (string-match "^Variable-([^ ]+): ([^\r]+)\r?" v))) (if header ; Is it a Variable- header (begin (set! variables (cons (cons (second header) (third header)) variables)) s) (cons v s)))) '() header-lines))) (script-headers (with-input-from-string (string-intersperse header-lines "\n") (lambda () (parameterize ((header-parsers `((status . ,(single status-parser)) ,@(header-parsers)))) (read-headers (current-input-port)))))) (loc (header-value 'location script-headers)) (status (header-value 'status script-headers)) (code (cond (status (car status)) (loc 302) (else (response-code (current-response))))) (reason (cond (status (cdr status)) (loc "Found") (else (response-reason (current-response))))) ;; Get rid of our temporary Status "header" again (script-headers (remove-header 'status script-headers))) (if (eqv? code 200) (set! success #t) (begin ; For Authorizer response status values other than "200" (OK), the Web server denies access and sends the response status, headers, and content back to the HTTP client. (current-response (update-response (current-response) headers: (sanitize-headers script-headers) code: code reason: reason)) (write-logged-response))) (send-body (substring headers end-of-headers)) (set! headers #f))))) (send-body (blob->string m)))) (let ((in-out-dance (make-in-out-dance app-name socket stdout-handler: handle-stdout))) (read/write-socket socket 1 fcgi-begin-request fcgi-authorizer) (read/write-socket socket 1 fcgi-params (fcgi-build-request-env req)) (read/write-socket socket 1 fcgi-params 'close-stream) ; stream request data over fcgi-stdin. (copy-port-to-stream (request-port req) in-out-dance content-length) (let loop ((done? (in-out-dance 'close-stream))) ; wait for all the replies to come back (if (not done?) (loop (in-out-dance)))) (if success variables #f)))) ; Authorizers continue if they succeed otherwise they send their own response. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; FCGI Filter Role ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; High Level FCGI Socket Protocol ;;; (define (read/write-socket socket request-id type . args) (if type (let ((messages (read-socket socket request-id))) (write-socket socket request-id type args) messages) (begin (thread-wait-for-i/o! (socket-fileno socket) #:input) (read-socket socket request-id)))) ; This returns a procedure which does the fcgi dance involving multiplexing the ; stdin, stdout and stderr streams over the socket. We have to make that the ; socket doesn't deadlock. ; Deadlock might occur if we let the FCGI script fill up all the buffers and we ; neglect to read anything before sending data. ; We handle each kind of record that we're interested in and route the replies ; to their destinations. A stdout handler is supplied by the FCGI role handler. (define (make-in-out-dance app-name socket #!key (stdout-handler #f)) (define (in-out-dance #!optional (data #f)) (let ((messages (if data (read/write-socket socket 1 fcgi-stdin data) (read/write-socket socket 1 #f))) (over #f)) (map (lambda (m) (select (car m) ((fcgi-end-request) (set! over #t)) ((fcgi-stdout) (if stdout-handler (map stdout-handler (cdr m)))) ((fcgi-stderr) (map (lambda (m) (log-to (error-log) "fcgi: ~a: ~a" app-name (blob->string m))) (cdr m))) (else (log-to (error-log) "fcgi: ~a: Unhandled packet type: ~a: ~a" app-name (car m) (cdr m))))) messages) over)) (assert stdout-handler) in-out-dance) (define (write-socket socket request-id type args) (define (write-record header content) (assert (blob? content)) (let ((size (blob-size content))) (let loop ((start 0)) (let ((end (+ start (min (- size start) 65535)))) (send-packet socket header content start end) ;(printf "Wrote ~a record of ~a bytes\n" type (- end start)) (if (< end size) (loop end)))))) (let* ((header (make-header type request-id)) (encoder (get-ws->app type)) (content (if (eqv? (car args) 'close-stream) (make-blob 0) (apply encoder args)))) (cond ((list? content) (map (cut write-record header <>) content)) (else (write-record header content))))) (define (read-socket socket request-id) (if (socket-receive-ready? socket) (receive (type req-id content) (recv-packet socket) (assert (= request-id req-id)) (let* ((decoder (get-app->ws type)) (content (decoder content))) (alist-update! type (list content) '()))) '())) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Record Definitions ;;; ;;; WS->App : Records of this type can only be sent by the Web server to ;;; the application. Records of other types can only be sent by ;;; the application to the Web server. ;;; ;;; Management : Records of this type contain information that is not specific ;;; to a Web server request, and use the null request ID. Records ;;; of other types contain request-specific information, and ;;; cannot use the null request ID. ;;; ;;; Stream : Records of this type form a stream, terminated by a record ;;; with empty contentData. Records of other types are discrete; ;;; each carries a meaningful unit of data. ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (define (u32encode header value b0 b1 b2 b3) (let ((b1b0 (bitwise-and value #xffff)) (b3b2 (bitwise-ior (arithmetic-shift (bitwise-and value #xffff0000) -16) #x8000))) (u16encode header b1b0 b0 b1) (u16encode header b3b2 b2 b3))) (define (u32decode header b0 b1 b2 b3) (let ((b1b0 (u16decode header b0 b1)) (b3b2 (u16decode header b2 (bitwise-and b3 #x7f)))) (bitwise-ior (arithmetic-shift b3b2 16) b1b0))) (define (u16encode header value b0 b1) (let ((b0v (bitwise-and value #xff)) (b1v (arithmetic-shift (bitwise-and value #xff00) -8))) (u8vector-set! header b0 b0v) (u8vector-set! header b1 b1v))) (define (u16decode header b0 b1) (let ((b0 (u8vector-ref header b0)) (b1 (u8vector-ref header b1))) (bitwise-ior (arithmetic-shift b1 8) b0))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; FCGI_Header ; allocate a new header (define (make-header type request-id) (let ((new-header (u8vector fcgi-version type 0 0 0 0 0 0))) (header-set! new-header 'request-id request-id) new-header)) ; set a field in the header to value (define (header-set! header field value) (select field (('request-id) (u16encode header value header-request-id-b0 header-request-id-b1)) (('content-length) (u16encode header value header-content-length-b0 header-content-length-b1)) (('padding-length) (u8vector-set! header header-padding-length value)) (else #f)) ) ; get a field in the header (define (get-header header field) (select field (('version) (u8vector-ref header header-version)) (('type) (u8vector-ref header header-type)) (('request-id) (u16decode header header-request-id-b0 header-request-id-b1)) (('content-length) (u16decode header header-content-length-b0 header-content-length-b1)) (('padding-length) (u8vector-ref header header-padding-length)) (else #f))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; get a procedure that encodes the body for a ws->app record of the given type. (define (get-ws->app type) (select type ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; FCGI_GET_VALUES ;;; WS->App, Management ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; FCGI_BEGIN_REQUEST ;;; WS->App ;;; ((fcgi-begin-request) ; 'discrete (lambda (role) (define (set-field content field value) (select field (('role) (u16encode content value 1 0)) (('flags) (u8vector-set! content 2 value)))) (assert (not (request-state))) ; one simultaneous request per request-id (let ((content (make-empty-record 8))) (set-field content 'role role) (set-field content 'flags fcgi-keep-conn) (u8vector->blob/shared content)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; FCGI_ABORT_REQUEST ;;; WS->App ;;; ((fcgi-abort-request) ; 'discrete (lambda () "")) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; FCGI_PARAMS ;;; WS->App, Stream ;;; ((fcgi-params) ; 'stream alist->name/value-pairs ) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; FCGI_STDIN ;;; WS->App, Stream ;;; ((fcgi-stdin) ; 'stream string->blob) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; FCGI_DATA ;;; WS->App, Stream ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; )) ; get a procedure that decodes the body for a app->ws record of the given type. (define (get-app->ws type) (select type ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; FCGI_GET_VALUES_RESULT ;;; Management ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; FCGI_UNKNOWN_TYPE ;;; Management ;;; ((fcgi-unknown-type) ; 'discrete (lambda (content) (define (get-field content field) (let ((content (blob->u8vector))) (select field (('type) (u8vector-ref content 0))))) (let ((type (get-field content 'type))) (log-to (error-log) "FCGI_UNKNOWN_TYPE: Application did not understand record type ~a." type)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; FCGI_END_REQUEST ;;; - ;;; ((fcgi-end-request) ; 'discrete (lambda (content) (define (get-field content field) (let ((content (blob->u8vector content))) (select field (('app-status) (u32decode content 3 2 1 0)) (('protocol-status) (u8vector-ref content 4))))) (let ((app-status (get-field content 'app-status)) (protocol-status (get-field content 'protocol-status))) (if (> protocol-status 0) (log-to (debug-log) "FCGI_END_REQUEST: Protocol Status: ~a." protocol-status)) (if (> app-status 0) (log-to (debug-log "FCGI_END_REQUEST: App Status: ~a." app-status))) (list app-status protocol-status)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; FCGI_STDOUT ;;; Stream ;;; ((fcgi-stdout) ; 'stream identity) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; FCGI_STDERR ;;; Stream ;;; ((fcgi-stderr) ; 'stream identity) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; )) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Socket Record / Packet Transport : Low Level FGI Socket Protocol ;;; ; send a single packet down the socket. (define (send-packet socket header content #!optional (start 0) (end #f)) (assert (socket? socket)) (assert (u8vector? header)) (assert (blob? content)) (assert (= fcgi-header-len (u8vector-length header))) (let ((content-length (if (and end start) (- end start) (blob-size content))) (padding-length 0)); (modulo (+ fcgi-header-length content-length) 8)) ; Don't bother with padding. (assert (< content-length 65536)) (header-set! header 'content-length content-length) (header-set! header 'padding-length padding-length) (socket-send-all socket (u8vector->blob/shared header)) (socket-send-all socket content start end))) ; receive a single packet from the socket. ; returns the type, request id and the content blob. (define (recv-packet socket) (assert (socket? socket)) (thread-wait-for-i/o! (socket-fileno socket) #:input) ;(printf "Waiting for header...\n") (let* ((header (make-empty-blob fcgi-header-len)) (received (socket-receive! socket header 0 fcgi-header-len)) (header (blob->u8vector/shared header)) ) (assert (= 8 received)) (let* ((version (get-header header 'version)) (_ (assert (= version fcgi-version))) (type (get-header header 'type)) ;(_ (printf "Got a header for a ~a record.\n" type)) (request-id (get-header header 'request-id)) (content-length (get-header header 'content-length)) (padding-length (get-header header 'padding-length)) (content (make-empty-blob content-length)) (padding (make-empty-blob padding-length)) ;(_ (printf "Waiting for ~a bytes of record.\n" content-length)) (content-received (if (> content-length 0) (socket-receive! socket content 0 content-length) 0)) ;(_ (printf "Waiting for ~a bytes of padding.\n" padding-length)) (padding-received (if (> padding-length 0) (socket-receive! socket padding 0 padding-length) 0))) ;(printf "Finished receiving record.\n") (assert (= content-length content-received)) (assert (= padding-length padding-received)) (values type request-id content)))) ; allocate a fresh record (define (make-empty-record X) (list->u8vector (make-list X 0))) ; allocate a nice, fresh bit of empty buffer (define (make-empty-blob X) (u8vector->blob/shared (make-empty-record X))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; FastCGI Application Process Management ;;; (define (fcgi-register-application name role filename socket prespawn maxspawn) (assert (<= prespawn maxspawn)) (let ((state (make-vector maxspawn #f)) (handler (select role ((fcgi-responder) fcgi-handler-responder) ((fcgi-authorizer) fcgi-handler-authorizer) ((fcgi-filter) #f)))) (do ((i 0 (+ i 1))) ((not (< i prespawn)) #t) (vector-set! state i (spawn-instance filename (conc socket "-" i)))) (set! fcgi-apps (alist-cons name (cons handler state) fcgi-apps)))) (foreign-declare "#include \"fork-exec.h\"") ; char** create_string_list(int n) (define create-string-list (foreign-lambda (c-pointer c-pointer) "create_string_list" int)) ; void free_string_list(char** p, int n) (define free-string-list (foreign-lambda void "free_string_list" (c-pointer c-pointer) int)) ; void insert_string(char** l, int n, char* s) (define insert-string (foreign-lambda void "insert_string" (c-pointer c-pointer) int c-string)) ; void inspect_string_list(char** lv, int n) { (define inspect-string-list (foreign-lambda void "inspect_string_list" (c-pointer c-pointer) int)) ; int fork_exec (int fcgi_fd, char* filename, char** args, char** env) (define fork-exec (foreign-lambda int "fork_exec" int (c-pointer c-pointer) (c-pointer c-pointer))) (define (insert-strings string-list strings #!optional (n 0)) (insert-string string-list n (car strings)) (if (not (eqv? (cdr strings) '())) (insert-strings string-list (cdr strings) (+ n 1)))) ; filename should be a string or a list of strings ; DOC: we expect to spawn the children. we don't support externally managed sockets. ; TODO: do somthing if the cgi is not present! (define (spawn-instance filename socket-file) (if (file-exists? socket-file) (begin (log-to (error-log) "Cannot spawn app: ~a already exists!" socket-file) (printf "Cannot spawn app: ~a already exists!" socket-file) #f) (let* ( (s (socket af/unix sock/stream)) (nargs (if (list? filename) (length filename) 1)) (args (create-string-list nargs)) (envl (alist->envlist (fcgi-build-initial-env filename))) (nenv (length envl)) (env (create-string-list nenv)) ) (if (list? filename) (insert-strings args filename) (insert-string args 0 filename)) (if (list? envl) (insert-strings env envl)) (set! (so-reuse-address? s) #t) (socket-bind s (unix-address socket-file)) (socket-listen s 1024) (let ((pid (fork-exec (socket-fileno s) args env))) (if pid (log-to (debug-log) "Started something: ~a : need to do that waitpid stuff" pid) (log-to (error-log) "Couldn't start!")) (free-string-list args nargs) (free-string-list env nenv) (socket-close s) (make-instance (make-mutex) (current-seconds) pid socket-file #f #f #f 0 0 0 0 0 0))))) (define (select-instance instances) (let* ((n (random (vector-length instances))) (instance (vector-ref instances n))) (if (not (mutex-lock! (instance-in-use instance) ));0.001)) ; if a request thread goes away then the mutex is abandoned. if someone ends up waiting here then by the time they lock the mutex the request may have gone away (select-instance instances) (begin ; TODO: accounting instance)))) (define (release-instance instance) ;TODO : accounting (mutex-unlock! (instance-in-use instance))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; )