Re: [Chicken-users] Scope problem?

[Matt Gushee]

Peter Bex wrote:
> On Sun, May 31, 2009 at 04:11:27PM -0600, Matt Gushee wrote:
> > So, do I need further education, or should I report a bug?
>
> I think we need to see the actual code to your fastcgi port to know more.
> By the way, string-length is a R5RS procedure, so you shouldn't
> need srfi-13.  (which makes it extra-odd that it works when you load
> srfi-13)

Sorry, it wasn't string-length, it was string-index. Also, one more 
detail that may be relevant: in this exploratory phase of development, I 
am running the code script-style, i.e. the script begins w/

  #!/usr/local/bin/chicken -script

Anyway, the fastcgi module code follows. I didn't change much:

 * Replace the old unit declarations with appropriate module
   declarations.

 * Changed miscellaneous foreign types as necessary.

 * Replaced a define-foreign-record section w/
   define-foreign-record-type

 * Replaced all instances of make-property-condition with
   make-exn-condition

 * Replaced the byte-vector in (get-scheme-str) with a u8vector.

I think that's about it. I can't say that I completely understand the 
code, though I will certainly learn it better as needed.

-- BEGIN fastcgi.scm ------------------------------------------------

[ copyright notice omitted ]

(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
           matchable
           lolevel
           srfi-1
           srfi-4
           srfi-13
           foreign
           foreigners
           conditions )

;;; Stop the compiler complaining about implicit definitions.
(foreign-declare
  "
  struct fcgx_request;
  struct fcgx_stream;
  int FCGX_Init();
  int FCGX_OpenSocket(char *, int);
  int FCGX_InitRequest(struct fcgx_request *, int, int);
  int FCGX_Accept_r(struct fcgx_request *);
  int FCGX_Finish_r(struct fcgx_request *);
  char *FCGX_GetParam(char *, char **);
  int FCGX_PutStr(char *, int, struct fcgx_stream *);
  int FCGX_GetStr(char *, int, struct fcgx_stream *);
  int FCGX_HasSeenEOF(struct fcgx_stream *);
  ")

;;;
;;; Low-level bindings for types/functions.
;;;

(define-foreign-type fcgx-stream c-pointer)
(define-foreign-type fcgx-param-array (c-pointer c-string))

;; Apparently define-foreign-record no longer exists
(define-foreign-record-type fcgx_request
  (constructor: make-fcgx_request)
  (int requestId fcgx_request-requestId)
  (int role fcgx_request-role)
  (fcgx-stream in fcgx_request-in)
  (fcgx-stream out fcgx_request-out)
  (fcgx-stream error fcgx_request-error)
  (fcgx-param-array env fcgx_request-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 fcgx_request-params)
  (int ipcFd fcgx_request-ipcFd)
  (int isBeginProcessed fcgx_request-isBeginProcessed)
  (int keepConnection fcgx_request-keepConnection)
  (int appStatus fcgx_request-appStatus)
  (int nWriters fcgx_request-nWriters)
  (int flags fcgx_request-flags)
  (int listen_sock fcgx_request-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" fcgx_request))

(define fcgx-finish-r
  (foreign-lambda int "FCGX_Finish_r" 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))

(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-exn-condition
                'exn
                "Error writing to libfcgi stream"
                #f))
            (loop (- to-write n))))))))


(define *fcgi-slurp-chunk-size* 200)

(define (fcgi-get-scheme-str size s)
  (let*(
        (buf (make-u8vector size))
        (bufsz
         ((foreign-lambda*
           int
           ((u8vector buf)(int n)(fcgx-stream s))
           "
{
 unsigned char *i = buf, *ei = buf + n;
 int delta = 1;

 while(i < ei && delta > 0) i += (delta = FCGX_GetStr((char *)i, ei - 
i, s));
 if (delta < 0) C_return(delta); //error

 C_return(i - buf);
}"
           ) buf size s))
        (str (blob->string (u8vector->blob buf))))
    (cond
      ((< bufsz 0)
       (abort
        (make-exn-condition
         'exn
         "Error reading from libfcgi stream"
         #f)))
      ((= bufsz size) str)
      (#t (string-drop-right str (- size bufsz))))))

(define (wrap-in-stream s)
  (match-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)
  (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 (((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-exn-condition
                         'exn
                         "Internal error in libfcgi"
                         #f)))
                   (cons
                     (substring s 0 idx)
                     (substring s (+ 1 idx)))))
               strlist))))))))

(define *fcgi-has-been-initialised* #f)

(define (fcgi-accept-loop-proto open-socket callback)
  ;; Initialise the FCGX library if it hasn't already been initialised.
  (unless *fcgi-has-been-initialised*
    (unless (fcgx-init)
      (abort
        (make-exn-condition
          'exn
          "Unable to initialise libfcgi"
          #f)))
    (set! *fcgi-has-been-initialised* #t))
  ;; Open a socket.
  (let ((sock (open-socket)))
    (unless (>= sock 0)
      (abort
        (make-exn-condition
          'exn
          (string-append "Unable to open socket using libfcgi:" 
(number->string sock))
          #f)))
    ;; Initialise a request object.
    (let* ((req (make-fcgx_request))
           (r (fcgx-init-request req sock 0)))
      (unless (>= r 0)
        (abort
          (make-exn-condition
            'exn
            "Unable to initialise libfcgi request struct"
            #f)))
      (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
                 (let
                     ((i
                       (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)))))
                   (fcgi-discard-input (fcgx_request-in req))
                   i)
               ;; ... 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-exn-condition
                'exn
                "Error while waiting to accept request using libfcgi"
                #f))))))))

;;;
;;; 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)
          (make-exn-condition
            'exn
            "Value of HTTP_CONTENT_LENGTH or CONTENT_LENGTH is not an 
integer!"
            #f)))
      #f)))
)

-- END fastcgi.scm -----------------------------------------------------

--
Matt Gushee
: Bantam - lightweight file manager : matt.gushee.net/software/bantam/ :
: RASCL's A Simple Configuration Language :     matt.gushee.net/rascl/ :