[Top][All Lists]
[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Chicken-users] FastCGI interface
|
From: |
Alex Drummond |
|
Subject: |
[Chicken-users] FastCGI interface |
|
Date: |
Thu, 13 Jul 2006 21:55:22 +0100 |
I couldn't find a FastCGI library for Chicken, so I had a go at putting
together some bindings to the FCGX API of libfcgi. The result is only
~200 lines, but I thought I would post it here in case someone finds it
useful. Here's some example code (tested with lighttpd), followed by the
code for the bindings:
----- example -----
(declare (uses fastcgi))
(fluid-let ((*fcgi-slurp-chunk-size* 200))
(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
(match-lambda
((key . value)
(out "<tr><td>")
(out key)
(out "</td><td>")
(out value)
(out "</td></tr>")))
(env))
(out "</table>")
(out "<br><br>")
;; Print POST data, if there is any.
(let ((post-data (in)))
(when post-data
(out "The following post data was given:<br>")
(out post-data)))
(out "</body></html>"))))
----------
----- bindings -----
(declare
(unit fastcgi)
(uses lolevel srfi-1 srfi-13)
(export fcgi-accept-loop
*fcgi-slurp-chunk-size*))
;;;
;;; Low-level bindings for types/functions.
;;;
(define-foreign-type fcgx-stream c-pointer)
(define-foreign-type fcgx-param-array (pointer c-string))
(define-foreign-record fcgx_request
(constructor: make-fcgx_request)
(int requestId)
(int role)
(fcgx-stream in)
(fcgx-stream out)
(fcgx-stream error)
(fcgx-param-array env)
;; This is private stuff which in theory could change in future
;; (though AFAIK libfcgi hasn't changed significantly for years.)
;; We don't access these fields, but we need to allocate the correct
;; amount of memory when creating an FCGX_Request struct.
(c-pointer params)
(int ipcFd)
(int isBeginProcssed)
(int keepConnection)
(int appStatus)
(int nWriters)
(int flags)
(int listen_sock))
(define fcgx-init
(foreign-lambda int "FCGX_Init"))
(define fcgx-open-socket
(foreign-lambda int "FCGX_OpenSocket" c-string int))
(define fcgx-init-request
(foreign-lambda int "FCGX_InitRequest" fcgx_request int int))
(define fcgx-accept-r
(foreign-lambda int "FCGX_Accept_r" (pointer fcgx_request)))
(define fcgx-finish-r
(foreign-lambda int "FCGX_Finish_r" (pointer fcgx_request)))
(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-get-str
(foreign-lambda
int
"FCGX_GetStr"
c-pointer int fcgx-stream))
;;; A couple of utility functions for incrementing pointers.
(define s-pointer+1
(foreign-lambda*
c-pointer
((c-pointer p))
"return(((char *)p) + 1);"))
(define sarray-pointer+1
(foreign-lambda*
(pointer c-string)
(((pointer c-string) p))
"return(p + 1);"))
;;;
;;; 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))))))))
;;;
;;; This determines how large a buffer to allocate when reading in
;;; an entire input stream. (This does not place any limit on the length
;;; of stream which can be read in -- multiple buffers will be used
;;; if the entire stream cannot fit in a single buffer.)
;;;
(define *fcgi-slurp-chunk-size* 200)
(define (wrap-in-stream s)
;; Convert a buffer to a Scheme string.
(define buf->string
(foreign-lambda*
c-string
((c-pointer s) (int end))
"
((char *)s)[end] = '\\0';
return((char*)s);
"))
(lambda n
(cond
;; If an integer argument is given, read that
;; number of characters...
((not (null? n))
(let* ((n (car n))
(buffer (allocate (+ 1 n))))
(let loop ((r 0))
(if (= r n)
;; We've finished reading.
(buf->string buffer n)
;; Otherwise, try to read the remaining bytes.
(let ((r2 (fcgx-get-str (s-pointer+1 buffer) (- n r) s)))
(if (< r2 0)
(abort
(make-property-condition
'exn
'message "Error reading from libfcgi stream"))
(loop (+ r r2))))))))
(else
;; ...otherwise, read the entire stream.
(let loop ((c-string-stack `((,(allocate (+ 1
*fcgi-slurp-chunk-size*))
.
0))))
(let ((r (fcgx-get-str (caar c-string-stack)
*fcgi-slurp-chunk-size* s)))
(cond
((< r 0)
(abort
(make-property-condition
'exn
'message "Error reading from libfcgi stream")))
((< r *fcgi-slurp-chunk-size*)
(set-cdr! (car c-string-stack) r)
(let ((entire-stream
(apply string-append
(map
(lambda (pr) (buf->string (car pr) (cdr pr)))
(reverse c-string-stack)))))
(if (string=? "" entire-stream)
#f
entire-stream)))
(else
(set-cdr! (car c-string-stack) r)
(loop (cons (cons (allocate *fcgi-slurp-chunk-size*) 0)
c-string-stack))))))))))
(define (wrap-env e)
(match-lambda*
((k . alternative)
(let ((r (fcgx-get-param k e)))
(if r
r
(:optional alternative #f))))
(()
;; 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)
;;;
;;; Given EITHER a filename or a port as its first argument,
;;; fcgi-accept-loop opens a suitable socket and listens on it.
;;; The second argument specifies the 'backlog' argument
;;; to pass to listen(...). The third argument is a callback,
;;; as described below.
;;; Exceptions are raised for all errors which may occur in the course
of
;;; opening the socket/listening for a connection.
;;;
;;; If a connection is made, the callback argument is called
;;; with four arguments.
;;;
;;; First argument to callback:
;;; A procedure which reads from the input stream, returning a string.
;;; If called with no arguments, it reads the entire stream,
;;; returning #f if the stream is empty. If called with a single integer
;;; argument, it reads the specified number of bytes.
;;;
;;; Second and third arguments to callback:
;;; Procedures for writing strings to the output and
;;; error streams respectively.
;;;
;;; Fourth argument to callback:
;;; A lookup procedure for the environment specified
;;; by the server. If called with no arguments, it returns a list
;;; of (name . value) conses. If called with a single string argument,
;;; it returns the relevant value in the environment.
;;; An optional second argument specifies
;;; a default value to be returned if the environment variable specified
;;; by the first argument isn't set.
;;; If only the first argument is passed, #f is returned
;;; if the environment variable isn't set.
;;;
;;; Each of the reading/writing procedures raises an exception
;;; if there is an error reading/writing.
;;;
;;; If the callback returns #f, everything is shut down (no more
listening
;;; for connections) and fcgi-accept-loop returns.
;;;
(define (fcgi-accept-loop filename/port backlog callback)
;; Initialise the FCGX library if it hasn't already been initialised.
(unless *fcgi-has-been-initialised*
(unless (fcgx-init)
(abort
(make-property-condition
'exn
'message "Unable to initialise libfcgi")))
(set! *fcgi-has-been-initialised* #t))
;; Open a socket.
(let ((sock
(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)))
(unless (>= sock 0)
(abort
(make-property-condition
'exn
'message "Unable to open socket using libfcgi")))
;; Initialise a request object.
(let* ((req (make-fcgx_request))
(r (fcgx-init-request req sock 0)))
(unless (>= r 0)
(abort
(make-property-condition
'exn
'message "Unable to initialise libfcgi request struct")))
(let loop ()
;; Wait for a connection from the webserver.
(let ((ar (fcgx-accept-r req)))
(cond
((>= ar 0)
;; The connection was successful, so call the callback...
(when (callback
(wrap-in-stream (fcgx_request-in req))
(wrap-out-stream (fcgx_request-out req))
(wrap-out-stream (fcgx_request-error req))
(wrap-env (fcgx_request-env req)))
;; ... and wait for another connection if the callback
didn't
;; return #f.
(loop)))
(else
;; There was an error, so cleanup and raise an exception.
(fcgx-finish-r req)
(make-property-condition
'exn
'message "Error while waiting to accept request using\
libfcgi"))))))))
----------
Alex
- [Chicken-users] FastCGI interface,
Alex Drummond <=