#lang scheme

(require scheme/foreign) (unsafe!)
(require (rename-in scheme/contract (-> -->)))
(require (lib "cgi.ss" "net")
         (lib "misc.ss" "swindle")) ; For list-of

(define-syntax define/provide
  (syntax-rules ()
    ((_ (x y ...) . z) (begin (define (x y ...) . z) (provide x)))
    ((_ x y) (begin (define x y) (provide x)))))

;;; The library.
;; ES: Providing temporarily
(provide fcgi-lib)
(define fcgi-lib
  (with-handlers
      ((exn:fail? (lambda (e)
                    (with-handlers
                        ((exn:fail? (λ (e) #f)))
                      (ffi-lib "cygfcgi-0")))))
    (ffi-lib "libfcgi")))

;;; Simplified wrapper to get-ffi-obj.
(define (my-ffi-obj name type)
  (if fcgi-lib
      (get-ffi-obj name fcgi-lib type)
      ; For debugging purposes, assign the name to the symbol.
      (string-append "libfcgi needed for: " name)))

(provide/contract [fcgx-is-cgi? (--> boolean?)])
(define fcgx-is-cgi?
  (let ([answer (delay
                  (or
                   (not fcgi-lib)
                   ((my-ffi-obj "FCGX_IsCGI" (_fun -> _bool)))))])
    (lambda () (force answer))))


(define fcgx-init (my-ffi-obj "FCGX_Init" (_fun -> _int)))

;;; Returns:
;;;  - result: Zero on success, nonzero on failure.
;;;  - in: Standard input.
;;;  - out: Standard output.
;;;  - envp: Environment pointer to use with fcgi-getenv
(provide fcgx-accept)
(define fcgx-accept
  (my-ffi-obj "FCGX_Accept"
              (_fun (in : (_ptr o _pointer)) (out : (_ptr o _pointer))
                    (err : (_ptr o _pointer)) (envp : (_ptr o _pointer))
                    -> (result : _int)
                    -> (values result in out err envp))))

(provide fcgx-puts)
(define fcgx-puts (my-ffi-obj "FCGX_PutS" (_fun _string _pointer -> _int)))

(provide fcgx-fprintf)
(define (fcgx-fprintf stream format-string . args)
  (fcgx-puts (apply format format-string args) stream))

(define fcgx-get-param (my-ffi-obj "FCGX_GetParam"
                                   (_fun (name : _string) (envp : _pointer) -> _string)))

(define fcgx-get-char (my-ffi-obj "FCGX_GetChar"
                                  (_fun (stream : _pointer) -> _int)))

(define fcgx-get-str (my-ffi-obj "FCGX_GetStr"
                                 (_fun (str : _bytes) (_int = (bytes-length str)) (stream : _pointer) -> _int)))

(define fcgx-put-char (my-ffi-obj "FCGX_PutChar"
                                  (_fun _int (stream : _pointer) -> _void)))

(define/provide (fcgx-process-envp envp) ; envp is char**
  (let ([val (ptr-ref envp _string)]) ; val is char*
    (if val
        (cons val (fcgx-process-envp (ptr-add envp 1 _string)))
        '())))

(define (fcgx-make-output-port out)
  (make-output-port
   "FCGI output port"
   always-evt ; ES: Check into potential blocking behavior
   ; The write-proc
   (lambda (bytes start end no-block allow-breaks)
     (fcgx-puts (bytes->string/latin-1 bytes #f start end) out))
   ; The close-proc
   (lambda () #f)))

#|
     (lambda (byte-str)
       (let loop ([nread 0] [b (fcgx-get-char in)])
         (if (negative? b)
             nread
             (begin
               (bytes-set! byte-str nread b)
               (if (>= nread (bytes-length b))
                   nread
                   (loop (add1 nread) (fcgx-get-char in)))))))
|#

(define (fcgx-make-input-port in)
  (make-input-port
   "FCGI input port"
   ; The read-proc
   (lambda (byte-str)
     (let ([ret (fcgx-get-str byte-str in)])
       (if (zero? ret)
           eof
           ret)))
   ; The optional-peek-proc. ES: Think about filling in.
   #f
   ; The close proc
   (lambda () #f)))

(provide fcgi-getenv)
(define (fcgi-getenv name-string envp)
  (if (or (fcgx-is-cgi?) (not envp))
      (getenv name-string)
      (fcgx-get-param name-string envp)))

(provide fcgi-accept-safe)
(define fcgi-accept-safe
  (let ([called #f])
    (lambda ()
      (if (fcgx-is-cgi?)
          (if called
              (values -1 #f #f #f #f)
              (begin
                (set! called #t)
                (values 0 (current-input-port) (current-output-port) (current-error-port) #f)))
          (let-values ([(ret in out err envp) (fcgx-accept)])
            (values ret
                    (fcgx-make-input-port in)
                    (fcgx-make-output-port out)
                    (fcgx-make-output-port err)
                    envp))))))

(provide my-get-environment)
(define (my-get-environment)
  (if (eq? (system-type) 'windows)
      ; ES: For some reason, this crashes.
      ;(let ([envp ((get-ffi-obj "GetEnvironmentStrings" #f (_fun -> _pointer)))])
      ;  ; Reuse the fcgx-process-envp, since it's in the same format.
      ;  (let ([ret (fcgx-process-envp envp)])
      ;    ((get-ffi-obj "FreeEnvironmentStrings" #f (_fun _pointer -> _void)) envp)
      ;    ret))
      '()
      (let ([envp (get-ffi-obj "environ" #f _pointer)])
        (fcgx-process-envp envp))))

(provide fcgi-get-environment)
(define (fcgi-get-environment envp)
  (if (or (fcgx-is-cgi?) (not envp))
      (my-get-environment)
      (fcgx-process-envp envp)))

(provide fcgi-fake-environment)
(define (fcgi-fake-environment envp)
  (when (and (not (fcgx-is-cgi?)) envp)
    (for-each
     (lambda (name-string)
       (putenv name-string (fcgi-getenv name-string envp)))
     '("REQUEST_METHOD" "QUERY_STRING" "PATH_INFO"))))

(provide fcgi-loop)
(define (fcgi-loop fun)
  (let-values ([(ret in out err envp) (fcgi-accept-safe)])
    (when (>= ret 0)
      (parameterize ([current-input-port in]
                     [current-output-port out]
                     [current-error-port err])
        (fcgi-fake-environment envp)
        (with-handlers
            ([exn:fail? html-stack-dump])
          (fun))
        (fcgi-loop fun)))))

;; -- string is either GET or POST (though future extension is possible)
(provide fcgi-get-cgi-method)
(define (fcgi-get-cgi-method envp)
  (fcgi-getenv "REQUEST_METHOD" envp))


(require xml)

;;; Useful as an exception hander.
(provide/contract [html-stack-dump (--> exn:fail? any)])
(define (html-stack-dump e)
  (display "content-type:text/html\n\n")
  (display
   (xexpr->string
    `(html
      (head (title "An error was hit"))
      (body
       (h1 ,(format "An error was encountered: ~a" e))
       (ul
        ,@(map (λ (st)
                 `(li (pre ,(let ([srcloc (cdr st)])
                              (format "Function ~a:  ~a:~a:~a\n"
                                      (car st)
                                      (if srcloc (srcloc-source srcloc) "<unknown>")
                                      (if srcloc (srcloc-line srcloc) "<unknown>")
                                      (if srcloc (srcloc-column srcloc) "<unknown>"))))))
               (continuation-mark-set->context (exn-continuation-marks e)))))))))