300 lines
10 KiB
Scheme
300 lines
10 KiB
Scheme
;;;
|
|
;;; 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 scheme
|
|
(chicken base)
|
|
(chicken condition)
|
|
(chicken blob)
|
|
(chicken foreign)
|
|
(chicken gc)
|
|
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 (c-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" scheme-pointer 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*
|
|
(c-pointer c-string)
|
|
(((c-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 (((c-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* ((_ (fcgi-request-out req))
|
|
((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)))
|
|
|
|
)
|