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
This commit is contained in:
mario
commit
e54a2384ae
|
|
@ -0,0 +1,68 @@
|
|||
;;;
|
||||
;;; Copyright (c) 2006, Alex Drummond <a.drummond@ucl.ac.uk>
|
||||
;;; 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 "<html><body>")
|
||||
|
||||
;; Look up the value of the SERVER_NAME environment variable
|
||||
;; and print it.
|
||||
(out "<b>This server is: </b>")
|
||||
(out (env "SERVER_NAME" "[unknown]"))
|
||||
(out "<br><br>")
|
||||
|
||||
;; Print the name and value of every environment variable.
|
||||
(out "<table><tr><th align=\"left\">Variable</th>")
|
||||
(out "<th align=\"left\")>Value</th></tr>")
|
||||
(for-each
|
||||
(lambda (k/v)
|
||||
(out "<tr><td>")
|
||||
(out (car k/v))
|
||||
(out "</td><td>")
|
||||
(out (cdr k/v))
|
||||
(out "</td></tr>"))
|
||||
(env))
|
||||
(out "</table>")
|
||||
(out "<br><br>")
|
||||
|
||||
;; 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:<br>")
|
||||
(out post-data)))
|
||||
(out "</body></html>")))
|
||||
|
||||
|
|
@ -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 <a.d.drummond@gmail.com>")
|
||||
(files "fastcgi.setup" "fastcgi.scm" "fastcgi.html" "example.scm"))
|
||||
|
||||
|
|
@ -0,0 +1,292 @@
|
|||
;;;
|
||||
;;; Copyright (c) 2006, Alex Drummond <a.d.drummond@googlemail.com>,
|
||||
;;; 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 <fcgi_config.h>")
|
||||
(foreign-declare "#include <fcgiapp.h>")
|
||||
(foreign-declare "#include <fcgi_stdio.h>")
|
||||
|
||||
;;;
|
||||
;;; 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)))
|
||||
|
||||
)
|
||||
|
|
@ -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")))
|
||||
|
||||
Loading…
Reference in New Issue