;;;
;;; 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 (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)))

)