From e54a2384aeed8e31b9291bac1eb60a2000c4eed7 Mon Sep 17 00:00:00 2001 From: mario Date: Wed, 1 Sep 2010 23:31:08 +0000 Subject: [PATCH] fastcgi: switching to tags/trunk layout git-svn-id: https://code.call-cc.org/svn/chicken-eggs/release/4/fastcgi/trunk@19967 fca3e652-9b03-0410-8d7b-ac86a6ce46c4 --- example.scm | 68 ++++++++++++ fastcgi.meta | 8 ++ fastcgi.scm | 292 ++++++++++++++++++++++++++++++++++++++++++++++++++ fastcgi.setup | 9 ++ 4 files changed, 377 insertions(+) create mode 100644 example.scm create mode 100644 fastcgi.meta create mode 100644 fastcgi.scm create mode 100644 fastcgi.setup diff --git a/example.scm b/example.scm new file mode 100644 index 0000000..4f66a30 --- /dev/null +++ b/example.scm @@ -0,0 +1,68 @@ +;;; +;;; Copyright (c) 2006, Alex Drummond +;;; All rights reserved. +;;; +;;; Redistribution and use in source and binary forms, with or without +;;; modification, are permitted provided that the following conditions +;;; are met: +;;; +;;; * Redistributions of source code must retain the above copyright +;;; notice, this list of conditions and the following disclaimer. +;;; * 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. +;;; * The name of the author(s) may not 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 OWNER 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. +;;; + +(require-extension fastcgi) + +(fcgi-accept-loop + "/tmp/fastcgi-socket-0" + 0 + (lambda (in out err env) + (out "Content-type: text/html\r\n\r\n") + (out "") + + ;; Look up the value of the SERVER_NAME environment variable + ;; and print it. + (out "This server is: ") + (out (env "SERVER_NAME" "[unknown]")) + (out "

") + + ;; Print the name and value of every environment variable. + (out "") + (out "") + (for-each + (lambda (k/v) + (out "")) + (env)) + (out "
VariableValue
") + (out (car k/v)) + (out "") + (out (cdr k/v)) + (out "
") + (out "

") + + ;; Print POST data, if there is any. + (let ((post-data (fcgi-get-post-data in env))) + (when post-data + (out "The following post data was given:
") + (out post-data))) + (out ""))) + diff --git a/fastcgi.meta b/fastcgi.meta new file mode 100644 index 0000000..27c3ac0 --- /dev/null +++ b/fastcgi.meta @@ -0,0 +1,8 @@ +((egg "fastcgi.egg") + (synopsis "Bindings for the FCGX API of libfcgi") + (category web) + (license "BSD") + (doc-from-wiki) + (author "Alex Drummond ") + (files "fastcgi.setup" "fastcgi.scm" "fastcgi.html" "example.scm")) + diff --git a/fastcgi.scm b/fastcgi.scm new file mode 100644 index 0000000..8970d89 --- /dev/null +++ b/fastcgi.scm @@ -0,0 +1,292 @@ +;;; +;;; Copyright (c) 2006, Alex Drummond , +;;; with contributions from Maria Rekouts, Nikolay Zavaritsky and +;;; Joachim Schipper. All rights reserved. +;;; +;;; Redistribution and use in source and binary forms, with or without +;;; modification, are permitted provided that the following conditions +;;; are met: +;;; +;;; * Redistributions of source code must retain the above copyright +;;; notice, this list of conditions and the following disclaimer. +;;; * 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. +;;; * The name of the author(s) may not 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 OWNER 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. +;;; + +(module fastcgi + (fcgi-external-server-accept-loop + fcgi-dynamic-server-accept-loop + fcgi-accept-loop + fcgi-get-post-data + *fcgi-slurp-chunk-size*) + +(import chicken scheme foreign) +(use srfi-1 srfi-13) + +(foreign-declare "#include ") +(foreign-declare "#include ") +(foreign-declare "#include ") + +;;; +;;; Low-level bindings for types/functions. +;;; + +(define-foreign-type fcgx-stream c-pointer) +(define-foreign-type fcgx-param-array (pointer c-string)) + +(define (fcgx-init-if-necessary!) + (unless (or *fcgi-has-been-initialised* + (= ((foreign-lambda int "FCGX_Init")) 0)) + (abort + (make-property-condition + 'exn + 'message "Unable to initialise libfcgi")) + (set! *fcgi-has-been-initialised* #t))) + +(define (fcgx-open-socket filename/port backlog) + (let ((sock ((foreign-lambda int "FCGX_OpenSocket" c-string int) + filename/port backlog))) + (if (= sock -1) + (abort + (make-property-condition + 'exn + 'message "Unable to open socket using libfcgi!")) + sock))) + +(define-foreign-type fcgx_request (c-pointer (struct "FCGX_Request"))) + +(define-record fcgi-request ptr) + +(define (fcgi-request-in req) + ((foreign-lambda* fcgx-stream ((fcgx_request r)) "C_return(r->in);") + (fcgi-request-ptr req))) + +(define (fcgi-request-out req) + ((foreign-lambda* fcgx-stream ((fcgx_request r)) "C_return(r->out);") + (fcgi-request-ptr req))) + +(define (fcgi-request-error req) + ((foreign-lambda* fcgx-stream ((fcgx_request r)) "C_return(r->err);") + (fcgi-request-ptr req))) + +(define (fcgi-request-envp req) + ((foreign-lambda* fcgx-stream ((fcgx_request r)) "C_return(r->envp);") + (fcgi-request-ptr req))) + +(define (fcgx-make-request socket) + (let ((req ((foreign-lambda* fcgx_request ((int s)) + "int retval = 0;" + "struct FCGX_Request *r;" + "r = malloc(sizeof(struct FCGX_Request));" + "if (r == NULL) " + " C_return(r);" + "if (FCGX_InitRequest(r, s, 0) != 0) {" + " free(r);" + " r = NULL;" + "}" + "C_return(r);") socket))) + (unless req + (abort + (make-property-condition + 'exn + 'message "Unable to initialise libfcgi request struct"))) + (set-finalizer! + req (foreign-lambda* void ((fcgx_request r)) "free(r);")) + (make-fcgi-request req))) + +(define (fcgi-accept-request! req) + (let ((ptr (fcgi-request-ptr req))) + (when (not (= ((foreign-lambda int "FCGX_Accept_r" fcgx_request) ptr) 0)) + ;; There was an error, so cleanup and raise an exception. + ((foreign-lambda void "FCGX_Finish_r" fcgx_request) ptr) + (make-property-condition + 'exn + 'message "Error while waiting to accept request using libfcgi")))) + +(define fcgx-get-param + (foreign-lambda c-string "FCGX_GetParam" c-string fcgx-param-array)) + +(define fcgx-put-str + (foreign-lambda int "FCGX_PutStr" c-string int fcgx-stream)) + +(define fcgx-has-seen-eof + (foreign-lambda bool "FCGX_HasSeenEOF" fcgx-stream)) + +(define fcgi-discard-input + (foreign-lambda* void ((fcgx-stream s)) + "char buf[1024];while(FCGX_GetStr(buf,sizeof buf,s)>0);")) + +;;; +;;; The (relatively) high-level Scheme interface. +;;; + +(define (wrap-out-stream s) + (lambda (o) + ;; Keep writing until all the characters in o have been written, or + ;; until fcgx-put-str returns < 0, in which case we raise an exception. + (let loop ((to-write (string-length o))) + (unless (= 0 to-write) + (let ((n (fcgx-put-str o to-write s))) + (if (< n 0) + (abort + (make-property-condition + 'exn + 'message "Error writing to libfcgi stream")) + (loop (- to-write n)))))))) + + +(define *fcgi-slurp-chunk-size* 200) + +(define (fcgi-get-scheme-str size s) + (let* ((buf (make-blob size)) + (bufsz + ((foreign-lambda* int ((blob buf) (int n) (fcgx-stream s)) + "char *i = (char *)buf, *ei = buf + n;" + "int delta = 1;" + "while(i < ei && delta > 0)" + " i += (delta = FCGX_GetStr(i, ei - i, s));" + "if (delta < 0)" + " C_return(delta); /* error */" + "else" + " C_return(i - (char *)buf);") buf size s)) + (str (blob->string buf))) + (cond + ((< bufsz 0) + (abort + (make-property-condition + 'exn + 'message "Error reading from libfcgi stream"))) + ((= bufsz size) str) + (#t (string-drop-right str (- size bufsz)))))) + +(define (wrap-in-stream s) + (case-lambda + ;; If an integer argument is given, read that + ;; number of characters. + ;; If #f or a negative integer is given, discard the entire POST input. + ;; (Negative integer is allowed as well as #f, since earlier versions only + ;; allowed negative integers.) + ((n) (if (or (and (boolean? n) (not n)) (< n 0)) + (begin (fcgi-discard-input s) "") ; Discard the entire input. + (fcgi-get-scheme-str n s))) + ;; ...otherwise, read the entire stream. + (() + (string-concatenate + (unfold + (lambda(seed) (fcgx-has-seen-eof s)) + (lambda(seed) (fcgi-get-scheme-str (inexact->exact(round seed)) s)) + (lambda(seed) (* seed 1.33)) + *fcgi-slurp-chunk-size*))))) + +;;; Utility function for incrementing a char**. +(define sarray-pointer+1 + (foreign-lambda* + (pointer c-string) + (((pointer c-string) p)) + "return(p + 1);")) + +(define (wrap-env e) + (case-lambda + ((k alternative) + (or (fcgx-get-param k e) alternative)) + ((k) + (fcgx-get-param k e)) + (() + ;; Convert the char ** array into a list of key/value cons pairs. + (let loop ((strlist '()) (p e)) + (let ((deref + ((foreign-lambda* c-string (((pointer c-string) ps)) "return(*ps);") + p))) + (cond + (deref + (loop (cons deref strlist) (sarray-pointer+1 p))) + (else + (map + (lambda (s) + (let ((idx (string-index s #\=))) + (unless idx + (abort + (make-property-condition + 'exn + 'message "Internal error in libfcgi"))) + (cons + (substring s 0 idx) + (substring s (+ 1 idx))))) + strlist)))))))) + +(define *fcgi-has-been-initialised* #f) + +(define (fcgi-accept-loop-proto open-socket callback) + (fcgx-init-if-necessary!) + ;; Open a socket. + (let* ((sock (open-socket)) + (req (fcgx-make-request sock))) + (let loop () + ;; Wait for a connection from the webserver. + (fcgi-accept-request! req) + (and-let* (((callback + (wrap-in-stream (fcgi-request-in req)) + (wrap-out-stream (fcgi-request-out req)) + (wrap-out-stream (fcgi-request-error req)) + (wrap-env (fcgi-request-envp req))))) + ;; wait for another connection if the callback didn't return #f. + (fcgi-discard-input (fcgi-request-in req)) + (loop))))) + +;;; +;;; Open the brand new listener socket - for external servers +;;; +(define (fcgi-external-server-accept-loop filename/port backlog callback) + (let ((open-socket-closure + (lambda () + (fcgx-open-socket + (if (string? filename/port) + filename/port + ;; To pass a port to FCGX_OpenSocket, you pass it a string + ;; of the form ":PORT_NUMBER". + (string-append ":" (number->string filename/port))) + backlog)))) + ;; body + (fcgi-accept-loop-proto open-socket-closure callback))) + +;;; +;;; Open nothing but return FCGI_LISTENSOCK_FILENO - for static (dynamic) servers +;;; http://fastcgi.com/devkit/doc/fcgi-spec.html#S2.2 +;;; +(define (fcgi-dynamic-server-accept-loop callback) + (fcgi-accept-loop-proto (lambda () 0) callback)) + +;;; For compatibility with earlier versions of this library. +(define fcgi-accept-loop fcgi-external-server-accept-loop) + +(define (fcgi-get-post-data in env) + ;; Some servers set HTTP_CONTENT_LENGTH, others CONTENT_LENGTH. + (let ((cl (env "HTTP_CONTENT_LENGTH" (env "CONTENT_LENGTH")))) + (if cl + (let ((icl (string->number cl))) + (if icl + (in icl) + (abort (make-property-condition + 'exn + 'message "Value of HTTP_CONTENT_LENGTH or CONTENT_LENGTH is not an integer!")))) + #f))) + +) diff --git a/fastcgi.setup b/fastcgi.setup new file mode 100644 index 0000000..424aa88 --- /dev/null +++ b/fastcgi.setup @@ -0,0 +1,9 @@ +;;;; fastcgi.setup -*- Scheme -*- + +(compile -s -O2 fastcgi.scm -j fastcgi -lfcgi) +(compile -s -O2 fastcgi.import.scm) + +(install-extension 'fastcgi '("fastcgi.so" "fastcgi.import.so") + '((documentation "fastcgi.html") + (version "1.1"))) +