sunet/scheme/httpd/surflets/surflets.scm

;; utilities for plugin (servlets)
;; Copyright 2002, Andreas Bernauer

(define (send-html/suspend html-tree-maker)
  (send/suspend 
   (lambda (new-url)
     (make-usual-html-response
      (lambda (out options)
	(servlet-XML->HTML out (html-tree-maker new-url)))))))

(define (send-html/finish html-tree)
  (do-sending send/finish html-tree))

(define (send-html html-tree)
  (do-sending send html-tree))

(define (do-sending send html-tree)
  (send (make-usual-html-response
	 (lambda (out options)
	   (servlet-XML->HTML out html-tree)))))

(define (make-usual-html-response writer-proc)
  (make-response
   http-status/ok
   (status-code->text http-status/ok)
   (time)
   "text/html"
   '()
   (make-writer-body writer-proc)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; from cgi-script:
;;; Return the form data as an alist of decoded strings.
;;; So a query string like "button=on&reply=Oh,%20yes" becomes alist
;;;     (("button" . "on") ("reply" . "Oh, yes"))
;;; This only works for GET and POST methods.

(define form-query parse-html-form-query)

(define (extract-bindings bindings key)
  (let ((key (if (symbol? key) (symbol->string key) key)))
    (filter (lambda (binding) 
	      (equal? (car binding) key))
	    bindings)))

(define (extract-single-binding bindings key)
  (let ((key-bindings (extract-bindings bindings key)))
    (if (= 1 (length key-bindings))
	(cdar key-bindings)
	(error "extract-one-binding: more than one or zero bindings found"
	       (length key-bindings)
	       key bindings))))


;; adapted from Oleg's SXML-tree-trans.scm 
;; extended by port argument
;; #t: current-output-port
;; #f: string
;; port: port
;; else: error
(define (formated-reply port . fragments)
  (cond 
   ((not port)
    (call-with-string-output-port
     (lambda (port)
       (real-formated-reply port fragments))))
   ((eq? port #t)
    (real-formated-reply (current-output-port) fragments))
   ((output-port? port)
    (real-formated-reply port fragments))
   (else
    (error "invalid port argument to FORMATED-REPLY" port))))

(define (real-formated-reply port fragments)
  (let loop ((fragments fragments) (result #f))
    (cond
     ((null? fragments) result)
     ((not (car fragments)) (loop (cdr fragments) result))
     ((null? (car fragments)) (loop (cdr fragments) result))
     ((pair? (car fragments))
      (loop (cdr fragments) (loop (car fragments) result)))
     ((procedure? (car fragments))
      ((car fragments))
      (loop (cdr fragments) #t))
     (else
      (display (car fragments) port)
      (loop (cdr fragments) #t)))))

;; adapted from Oleg's SXML-to-HTML.scm
;; extended by additional port argument
(define (servlet-XML->HTML out html-tree)
 (formated-reply out
   (pre-post-order html-tree
	       ;; Universal transformation rules. Work for every HTML,
               ;; present and future
    `(,@default-rules
      (form *preorder* . 
	    ,(lambda (trigger call-back-function . elems)
	       (list "<form method=\"GET\" action=\"" call-back-function 
		     (if (and (pair? elems) (pair? (car elems)) (eq? '@ (caar elems)))
			 (list (car elems) "\">\n" (parse-form-elems (cdr elems)) "</form>")
			 (list "\">\n" (parse-form-elems elems) "</form>"))))))
    
    )))

(define (parse-form-elems elems)
  (map (lambda (elem)
	 (if (input-field? elem)
	     (post-order (input-field-HTML-tree elem) default-rules)
	     (post-order elem default-rules)))
       elems))

(define text-html-rule
  `(*text* . ,(lambda (trigger str) 
		(if (string? str) (string->goodHTML str) str))))
(define default-rules
  `((@		; local override for attributes
     ((*default*       
       . ,(lambda (attr-key . value) ((enattr attr-key) value))))
     . ,(lambda (trigger . value) (list '@ value)))
    (*default* . ,(lambda (tag . elems) (apply (entag tag) elems)))
    ,text-html-rule
    (URL . ,(lambda (tag URI text) (list "<a href=\"" URI "\">" text "</a>"))))
  )

(define (make-callback function)
  (call-with-current-continuation
   (lambda (exit)
     (let* ((req (send/suspend (lambda (new-url)
				 (exit new-url))))
	    (bindings (form-query (http-url:search (request:url req)))))
       (function bindings)))))

(define-record-type input-field :input-field
  (make-input-field name transformer HTML-tree)
  input-field?
  (name input-field-name)
  (transformer input-field-transformer)
  (attributes input-field-attributes)
  (HTML-tree input-field-HTML-tree))

(define-record-discloser :input-field
  (lambda (input-field)
    (list 'input-field (input-field-name input-field))))

;; FIXME: consider creating small names
(define generate-input-field-name
  (let ((id 0))
    (lambda (type-string)
      (set! id (+ 1 id))
      (string-append type-string (number->string id)))))

(define identity (lambda (a) a))

(define (make-text-input-field . maybe-further-attributes)
  (let ((name (generate-input-field-name "text")))
    (make-input-field name
		      identity
		      `(input (@ (type "text")
				 (name ,name)
				 ,@maybe-further-attributes)))))

(define (make-number-input-field . maybe-further-attributes)
  (let ((name (generate-input-field-name "number")))
    (make-input-field name
		      (lambda (string)
			(or (string->number string)
			    (error "wrong type")))
		      `(input (@ (type "text")
				 (name ,name)
				 ,@maybe-further-attributes)))))

(define (make-password-input-field . maybe-further-attributes)
  (let ((name (generate-input-field-name "password")))
    (make-input-field name
		      identity
		      `(input (@ (type "password")
				 (name ,name)
				 ,@maybe-further-attributes)))))

(define (make-textarea-input-field .  maybe-further-attributes)
  (let ((name (generate-input-field-name "textarea"))
	(default-text (if (and (pair? maybe-further-attributes)
			       (string? (car maybe-further-attributes)))
			  (car maybe-further-attributes)
			  '())))
    (make-input-field name
		      identity
		      `(textarea (@ (type "textarea")
				    (name ,name)
				    ,@maybe-further-attributes)
				 ,default-text))))

(define (make-select-input-field options . maybe-further-attributes)
  (let ((name (generate-input-field-name "select")))
    (make-input-field name
		      (lambda (select)
			select)		;FIXME[extension] refer to list elements
		      `(select (@ ((name ,name)
				   ,@maybe-further-attributes))
			       #\newline
			       ,@(map (lambda (option)
					(if (pair? option) ; with attributes?
					    `(option (@ ,@(cdr option)) ,(car option))
					    `(option ,option)))
				      options)))))

;; in work
(define (make-radio-input-field values . maybe-further-attributes)
  (let ((name (generate-input-field-name "radio")))
    (make-input-field name
		      (lambda (select)
			select)	;FIXME refer to list elements
		      (map (lambda (value)
			     `((input (@ ((type "radio")
					  (name ,name)
					  ,@maybe-further-attributes
					  ,(if (pair? value) ; with attributes?
					       (cdr value)
					       '())))) ;FIXME: add value field
			       ,(if (pair? value) ; with attributes?
				    (car value)
				    value)))
			   values))))




		      

(define (make-submit-button . maybe-further-attributes)
  (if (and (pair? maybe-further-attributes)
	   (string? (car maybe-further-attributes)))
      `(input (@ (type "submit")
		 (value ,(car maybe-further-attributes))
		 ,@maybe-further-attributes))
      `(input (@ (type "submit")
		 ,@maybe-further-attributes))))
		    
(define (input-field-value input-field bindings)
  (cond
   ((assoc (input-field-name input-field) bindings) =>
    (lambda (binding)
      ((input-field-transformer input-field) (cdr binding))))
   (else
    (error "no such input-field" input-field bindings))))


(define number-input-field (make-number-input-field))

(define test 
  `(html
    (title "My Title")
    (body 
     (p (URL "reset" "click here to reset"))
     (p (form "return-URI" (table (tr (td "Enter a number ") (td ,number-input-field )))
	      ,(make-submit-button))))))