;; $Id: cgi.scm 867 2004-07-27 05:31:04Z azul $
;;
;; This file is in the public domain and may be reproduced or copied without
;; permission from its author.  Citation of the source is appreciated.
;;
;; Alejandro Forero Cuervo <address@hidden>
;;
;; Library with functionality useful for creating applications that run under
;; Common Gateway Interface
;;
;; Documentation is available in HTML format.
;;
;; Newer versions might be available at:
;;
;;    http://anonymous:@afc.no-ip.info:8000/svn/home/src/chicken-eggs/cgi
;;
;; Version history:
;;
;; 1.0 (r877) - First public release

(declare (export cgi-main))
(require-extension srfi-40 stream-ext)

; A name:value pair comming from an HTML form through the query string or the
; body of a POST request.  name is the actual name.  Values shorter than a
; given length are kept in memory as a string in the value field.  Otherwise,
; they are saved in disk in the temporary file file.  Either value or file
; must be #f in any given argument.

(define-record argument name value file)

(define (char->hex str pos)
  (let ((c (char->integer (stream-ref str pos))))
    (cond
      ((<= (char->integer #\0) c (char->integer #\9)) (- c (char->integer #\0)))
      ((<= (char->integer #\A) c (char->integer #\F)) (+ 10 (- c (char->integer #\A))))
      (else 0))))

(define (hex-char-get str)
  (if (and (equal? (stream-car str) #\%) (stream-length>= str 3))
    (values (integer->char (+ (* 16 (char->hex str 1)) (char->hex str 2))) (stream-cdddr str))
    (values (if (equal? #\+ (stream-car str)) #\space (stream-car str)) (stream-cdr str))))

(define value-end (cut equal? <> #\&))
(define name-end  (disjoin (cut equal? <> #\=) value-end))

(define (write-content str out)
  (cond
    ((or (stream-null? str) (equal? (stream-car str) #\&)) (close-output-port out) str)
    (else
      (receive (char rest) (hex-char-get str)
        (write-char char out)
        (write-content rest out)))))

; Read characters from the stream of characters str, accumulating them at the
; head object.

(define (read-stream-until str stop maxlen head)
  (let ((success (or (stream-null? str) (stop (stream-car str)))))
    (if (or success (zero? maxlen))
      (values success (list->string (reverse head)) str)
      (receive (char rest) (hex-char-get str)
        (read-stream-until rest stop (- maxlen 1) (cons char head))))))

(define (arg-name str maxlen hash)
  (if (stream-null? str)
    hash
    (receive (success name str) (read-stream-until (stream-cdr str) name-end maxlen '())
      (let ((after (stream-drop-while (complement name-end) str)))
        (arg-value (string->symbol name) (if (stream-prefix= after '(#\=)) (stream-cdr after) after) maxlen hash)))))

; Be careful: you want your implementation to be able to GC the stream while
; you are traversing it.

(define (arg-value name str maxlen hash)
  (receive (success value after) (read-stream-until str value-end maxlen '())
    (if (and (equal? name "") (equal? value ""))
      (arg-name after maxlen hash)
      (let ((obj (make-argument-smart name success value)))
        (accum-value obj hash)
        (arg-name (if success after (write-content str (open-output-file (argument-file obj)))) maxlen hash)))))

(define (accum-value obj hash)
  (hash-table-set! hash (argument-name obj) (cons obj (hash-table-ref hash (argument-name obj) '()))))

(define (make-argument-smart name success value)
  (make-argument name (and success value) (and (not success) (create-temporary-file "chicken-cgi-input"))))

(define (make-cgi-info . rest)
  (let-optionals rest ((in (or (getenv "QUERY_STRING") "")) (hash (make-hash-table)) (maxlen 2048))
    (arg-name (stream-cons #\& (->stream-char in)) maxlen hash)))
 
(define (make-cgi-info-read . rest)
  (let-optionals rest ((hash (make-hash-table)) (maxlen 2048))
    (if (equal? (getenv "CONTENT_TYPE") "application/x-www-form-urlencoded")
        (make-cgi-info (port->stream (current-input-port)) hash maxlen)
        hash)))

(define (cgi-info-get info name)
  (map argument-return (hash-table-ref info name '())))

(define (argument-return v)
  (or (argument-value v)
      (port->stream (open-input-file (argument-file v)))))

(define (cgi-main proc)
  (let ((input (make-cgi-info-read (make-cgi-info))))
    (write-stream (proc (cut cgi-info-get input <>)))
    (for-each (compose delete-file argument-file) (filter argument-file input))))