Anonymous avatar Anonymous committed 3bb6c1e

cgi-handler and fcgi-handler eggs to accompany spiffy

CGI and FastCGI handlers for a small but powerful web server.

cgi-handler has been factored out of spiffy.
Proposals to add fcgi-handler to spiffy resulted in the decision to
maintain these handlers in a dedicated egg.

Signed-off-by: Andy Bennett <andyjpb@knodium.com>;

Comments (0)

Files changed (8)

LICENSE.TERMS.fcgi

+This FastCGI application library source and object code (the
+"Software") and its documentation (the "Documentation") are
+copyrighted by Open Market, Inc ("Open Market").  The following terms
+apply to all files associated with the Software and Documentation
+unless explicitly disclaimed in individual files.
+
+Open Market permits you to use, copy, modify, distribute, and license
+this Software and the Documentation for any purpose, provided that
+existing copyright notices are retained in all copies and that this
+notice is included verbatim in any distributions.  No written
+agreement, license, or royalty fee is required for any of the
+authorized uses.  Modifications to this Software and Documentation may
+be copyrighted by their authors and need not follow the licensing
+terms described here.  If modifications to this Software and
+Documentation have new licensing terms, the new terms must be clearly
+indicated on the first page of each file where they apply.
+
+OPEN MARKET MAKES NO EXPRESS OR IMPLIED WARRANTY WITH RESPECT TO THE
+SOFTWARE OR THE DOCUMENTATION, INCLUDING WITHOUT LIMITATION ANY
+WARRANTY OF MERCHANTABILITY OR FITNESS FOR A PARTICULAR PURPOSE.  IN
+NO EVENT SHALL OPEN MARKET BE LIABLE TO YOU OR ANY THIRD PARTY FOR ANY
+DAMAGES ARISING FROM OR RELATING TO THIS SOFTWARE OR THE
+DOCUMENTATION, INCLUDING, WITHOUT LIMITATION, ANY INDIRECT, SPECIAL OR
+CONSEQUENTIAL DAMAGES OR SIMILAR DAMAGES, INCLUDING LOST PROFITS OR
+LOST DATA, EVEN IF OPEN MARKET HAS BEEN ADVISED OF THE POSSIBILITY OF
+SUCH DAMAGES.  THE SOFTWARE AND DOCUMENTATION ARE PROVIDED "AS IS".
+OPEN MARKET HAS NO LIABILITY IN CONTRACT, TORT, NEGLIGENCE OR
+OTHERWISE ARISING OUT OF THIS SOFTWARE OR THE DOCUMENTATION.
+;;;; 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.
+;
+; CGI file handler
+; See the spec at http://hoohoo.ncsa.uiuc.edu/cgi/interface.html
+; Newer CGI spec: RFC 3875 at http://www.ietf.org/rfc/rfc3875
+
+(module cgi-handler
+  (cgi-handler cgi-handler* cgi-default-environment)
+
+(import chicken scheme extras files posix regex data-structures)
+(use spiffy srfi-1 srfi-13 intarweb uri-common (prefix uri-generic generic:))
+
+(define (cgi-handler* #!optional interp)
+  (lambda (fn) (cgi-handler fn interp)))
+
+(define (alist->envlist alist)
+  (map (lambda (entry)
+         (conc (car entry) "=" (or (cdr entry) "")))
+       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 (cgi-build-env req fn)
+  (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 ... ))
+            ("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))))
+            ("PATH_INFO" . ,(and (current-pathinfo)
+                                 (string-join (current-pathinfo) "/")))
+            ("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))
+            ("SCRIPT_NAME" . ,(current-file))
+            ("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
+            ("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)))
+            ;; 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" . ,fn)
+            ;; Nonstandard but reasonably widely used Apache extension
+            ("HTTPS" . ,(and (secure-connection?) "on"))))
+         (header-env (create-header-env (request-headers req))))
+    (alist->envlist (append (cgi-default-environment) header-env server-env))))
+
+(define (copy-port in out #!optional limit)
+  (let ((bufsize 1024))
+   (let loop ((data (read-string (min (or limit bufsize) bufsize) in)))
+     (unless (string-null? data)
+             (display data out)
+             (when limit (set! limit (- limit (string-length data))))
+             (loop (read-string (min (or limit bufsize) bufsize) in))))))
+
+;; Read a port and discard all data
+(define (discard-inport in)
+  (let ((bufsize 1024))
+    (let loop ((data (read-string bufsize in)))
+      (unless (string-null? data)
+        (loop (read-string bufsize in))))))
+
+;; "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 (cgi-handler fn #!optional interp)
+  (let* ((path (if (absolute-pathname? fn) fn (make-pathname (root-path) fn)))
+         (req (current-request))
+         (len (header-value 'content-length (request-headers req) 0))
+	 (interp (or interp (make-pathname (root-path)
+                                           (string-join (cdr (uri-path (request-uri req))) "/"))))
+	 (env (cgi-build-env req path)))
+    ;; TODO: stderr should be linked to spiffy error log
+    (if (file-execute-access? interp)
+        ;; XXX The script should be called with the query args on the
+        ;; commandline but only if those do not contain any unencoded '='
+        ;; characters. Otherwise, it should pass no commandline arguments.
+        ;; XXX Current working directory should be the dir with the script.
+	(let-values (((i o pid) (process interp (list path) env)))
+          (log-to (debug-log) "(cgi) started program ~a(~a) ..." interp path)
+          (copy-port (request-port (current-request)) o len)
+          (close-output-port o)
+          ;; TODO: Implement read timeout
+          (let* ((script-headers (parameterize
+                                     ((header-parsers
+                                       `((status . ,(single status-parser))
+                                         ,@(header-parsers))))
+                                   (read-headers i)))
+                 (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)))
+            (parameterize ((current-response
+                            (update-response (current-response)
+                                             headers:  (sanitize-headers
+                                                        script-headers)
+                                             code: code
+                                             reason: reason)))
+              (write-logged-response)
+              (if (eq? 'HEAD (request-method (current-request)))
+                  (discard-inport i)
+                  (copy-port i (response-port (current-response))))
+              (close-input-port i))))
+          (error (sprintf "Invalid interpreter: ~A\n" interp)))))
+
+(define cgi-default-environment
+  (make-parameter `(("GATEWAY_INTERFACE" . "CGI/1.1"))))
+)
+/* 
+ * fastcgi.h --
+ *
+ *	Defines for the FastCGI protocol.
+ *
+ *
+ * Copyright (c) 1995-1996 Open Market, Inc.
+ *
+ * See the file "LICENSE.TERMS" for information on usage and redistribution
+ * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+ *
+ * $Id: fastcgi.h,v 1.1.1.1 1997/09/16 15:36:32 stanleyg Exp $
+ */
+
+#ifndef _FASTCGI_H
+#define _FASTCGI_H
+
+/*
+ * Listening socket file number
+ */
+#define FCGI_LISTENSOCK_FILENO 0
+
+typedef struct {
+    unsigned char version;
+    unsigned char type;
+    unsigned char requestIdB1;
+    unsigned char requestIdB0;
+    unsigned char contentLengthB1;
+    unsigned char contentLengthB0;
+    unsigned char paddingLength;
+    unsigned char reserved;
+} FCGI_Header;
+
+#define FCGI_MAX_LENGTH 0xffff
+
+/*
+ * Number of bytes in a FCGI_Header.  Future versions of the protocol
+ * will not reduce this number.
+ */
+#define FCGI_HEADER_LEN  8
+
+/*
+ * Value for version component of FCGI_Header
+ */
+#define FCGI_VERSION_1           1
+
+/*
+ * Values for type component of FCGI_Header
+ */
+#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)
+
+/*
+ * Value for requestId component of FCGI_Header
+ */
+#define FCGI_NULL_REQUEST_ID     0
+
+
+typedef struct {
+    unsigned char roleB1;
+    unsigned char roleB0;
+    unsigned char flags;
+    unsigned char reserved[5];
+} FCGI_BeginRequestBody;
+
+typedef struct {
+    FCGI_Header header;
+    FCGI_BeginRequestBody body;
+} FCGI_BeginRequestRecord;
+
+/*
+ * Mask for flags component of FCGI_BeginRequestBody
+ */
+#define FCGI_KEEP_CONN  1
+
+/*
+ * Values for role component of FCGI_BeginRequestBody
+ */
+#define FCGI_RESPONDER  1
+#define FCGI_AUTHORIZER 2
+#define FCGI_FILTER     3
+
+
+typedef struct {
+    unsigned char appStatusB3;
+    unsigned char appStatusB2;
+    unsigned char appStatusB1;
+    unsigned char appStatusB0;
+    unsigned char protocolStatus;
+    unsigned char reserved[3];
+} FCGI_EndRequestBody;
+
+typedef struct {
+    FCGI_Header header;
+    FCGI_EndRequestBody body;
+} FCGI_EndRequestRecord;
+
+/*
+ * Values for protocolStatus component of FCGI_EndRequestBody
+ */
+#define FCGI_REQUEST_COMPLETE 0
+#define FCGI_CANT_MPX_CONN    1
+#define FCGI_OVERLOADED       2
+#define FCGI_UNKNOWN_ROLE     3
+
+
+/*
+ * Variable names for FCGI_GET_VALUES / FCGI_GET_VALUES_RESULT records
+ */
+#define FCGI_MAX_CONNS  "FCGI_MAX_CONNS"
+#define FCGI_MAX_REQS   "FCGI_MAX_REQS"
+#define FCGI_MPXS_CONNS "FCGI_MPXS_CONNS"
+
+
+typedef struct {
+    unsigned char type;    
+    unsigned char reserved[7];
+} FCGI_UnknownTypeBody;
+
+typedef struct {
+    FCGI_Header header;
+    FCGI_UnknownTypeBody body;
+} FCGI_UnknownTypeRecord;
+
+#endif	/* _FASTCGI_H */
+
+;;;; fcgi-handler.scm
+;
+; Copyright (c) 2012, Andy Bennett <andyjpb@knodium.com>
+
+; 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 (current-request)))) "/")))
+            ("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
+       (for-each ; we're still collecting headers for sanitization
+	 (lambda (m)
+	   (if (or (string-null? m) (equal? "\r" m))
+	     (let* ; we've reached the end of the headers
+	       ((_ (set! headers (string-append headers m "\n")))
+		(script-headers (with-input-from-string 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)))
+	       (current-response
+		 (update-response (current-response)
+				  headers: (sanitize-headers script-headers)
+				  code: code
+				  reason: reason))
+	       (write-logged-response)
+	       (set! headers #f))
+	     (if headers
+	       (set! headers (string-append headers m "\n"))
+	       (send-body (string-append m "\n"))
+	       )))
+	 (string-split (blob->string m) "\n"))
+	 (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
+	(for-each ; we're still collecting headers for Status, 'Variable-'s and sanitization.
+	  (lambda (m)
+	   (printf "Message:~a\n" m)
+	    (if (or (string-null? m) (equal? "\r" m))
+	      (let* ; we've reached the end of the headers
+		((_ (set! headers (string-append headers m "\n")))
+		 (script-headers (with-input-from-string 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)))
+		(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)))
+		(set! headers #f))
+	      (if headers
+		(let ((header (string-match "^Variable-([^ ]+): ([^\r]+)\r?" m)))
+		  (if header ; Is it a Variable- header
+		    (set! variables (cons (cons (second header) (third header)) variables))
+		    (set! headers (string-append headers m "\n"))))
+		(send-body (string-append m "\n"))
+		)))
+	  (string-split (blob->string m) "\n"))
+	(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)))
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+)
+
+/* We need this helper to ensure that the fork/exec is atomic because, unlike
+ * pthreads, srfi-18 threads are not killed off in the child.
+ *
+ * based on mod_fastcgi.c from lighttpd-1.4.31
+ */
+
+#include <unistd.h>
+#include <signal.h>
+#include <errno.h>
+#include <stdlib.h>
+#include <stdio.h>
+#include <string.h>
+#include "fastcgi.h"
+#include "fork-exec.h"
+
+void* create_string_list(int n) {
+	if (n > 0) {
+		return calloc(n+1, sizeof(char*)); /* Extra one for NULL */
+	} else {
+		return NULL;
+	}
+
+}
+
+void free_string_list(void* pv, int n) {
+	int i;
+	char** p = (char**)(pv);
+
+	for (i = 0; i <= n; i++) { /* Free the extra one incase it got used. */
+		if (p[i]) free(p[i]);
+	}
+	free(p);
+}
+
+void insert_string(void* lv, int n, char* s) {
+	char** l = (char**)(lv);
+
+	l[n] = strdup((const char*)(s));
+}
+
+void inspect_string_list(void* lv, int n) {
+	int i;
+	char** l = (char**)(lv);
+
+	for (i = 0; i < n; i++) {
+		printf("%d: <%s>\n", i, l[i]);
+	}
+	if (l[n])
+		printf("Not NULL terminated!\n");
+	else
+		printf("NULL terminated!\n");
+
+}
+
+int fork_exec (int fcgi_fd, void* argsv, void* envv)  {
+	pid_t child;
+	char** args = (char**)(argsv);
+	char** env  = (char**)(envv);
+
+	switch ((child = fork())) {
+		case 0: { /* Child */
+				size_t i = 0;
+
+				if (fcgi_fd != FCGI_LISTENSOCK_FILENO) {
+					close(FCGI_LISTENSOCK_FILENO);
+					dup2(fcgi_fd, FCGI_LISTENSOCK_FILENO);
+					close(fcgi_fd);
+				}
+
+				for (i = 3; i < 256; i++) {
+					close(i);
+				}
+
+				/* reset signals */
+#ifdef SIGTTOU
+				signal(SIGTTOU, SIG_DFL);
+#endif
+#ifdef SIGTTIN
+				signal(SIGTTIN, SIG_DFL);
+#endif
+#ifdef SIGTSTP
+				signal(SIGTSTP, SIG_DFL);
+#endif
+				signal(SIGHUP, SIG_DFL);
+				signal(SIGPIPE, SIG_DFL);
+				signal(SIGUSR1, SIG_DFL);
+
+				errno = 0;
+				execve(args[0], args, env); /* args[0] might not be a basename! */
+				exit(errno);
+
+				break;
+			}
+		case -1: { /* Error */
+				 return 0;
+			 }
+		default: { /* Parent */
+				 return child;
+			 }
+	}
+}
+
+
+void* create_string_list(int n);
+void free_string_list(void* pv, int n);
+void insert_string(void* l, int n, char* s);
+void free_string_list(void* pv, int n);
+int fork_exec (int fcgi_fd, void* args, void* env);
+

spiffy-cgi-handlers.meta

+;;; spiffy-cgi-handlers.meta -*- Hen -*-
+
+((egg "spiffy-cgi-handlers.egg")
+ (synopsis "CGI and FastCGI handlers for a small but powerful web server.")
+ (author "Felix Winkelmann, Peter Bex & Andy Bennett")
+ (maintainer "Peter Bex & Andy Bennett")
+ (category web)
+ (license "BSD")
+ (doc-from-wiki)
+ (depends spiffy (intarweb 0.7) uri-common regex socket records)
+ (test-depends test)
+ (files "spiffy-cgi-handlers.release-info" "spiffy-cgi-handlers.setup" "cgi-handler.scm" "fcgi-handler.scm" "spiffy-cgi-handlers.meta"))

spiffy-cgi-handlers.setup

+(compile -s -O2 cgi-handler.scm -j cgi-handler)
+(compile -s -O2 cgi-handler.import.scm)
+
+(compile -s -O2 -d1 -inline -local fcgi-handler.scm fork-exec.c -j fcgi-handler)
+(compile -s -O2 fcgi-handler.import.scm)
+
+(install-extension
+  'spiffy-cgi-handlers
+  '("cgi-handler.so" "cgi-handler.import.so"
+    "fcgi-handler.so" "fcgi-handler.import.so")
+  `((version "0.1")))
+
Tip: Filter by directory path e.g. /media app.js to search for public/media/app.js.
Tip: Use camelCasing e.g. ProjME to search for ProjectModifiedEvent.java.
Tip: Filter by extension type e.g. /repo .js to search for all .js files in the /repo directory.
Tip: Separate your search with spaces e.g. /ssh pom.xml to search for src/ssh/pom.xml.
Tip: Use ↑ and ↓ arrow keys to navigate and return to view the file.
Tip: You can also navigate files with Ctrl+j (next) and Ctrl+k (previous) and view the file with Ctrl+o.
Tip: You can also navigate files with Alt+j (next) and Alt+k (previous) and view the file with Alt+o.