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 (get-bindings request)
  (form-query (http-url:search (request:url request))))

(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
		  (reformat html-tree)))

(define (reformat html-tree)
  (pre-post-order 
   html-tree
   `(
     ;; Universal transformation rules. Works for every HTML,
     ;; present and future
     ,@default-rules
     (input-field 
      *preorder*
      . ,(lambda (trigger input-field)
	   (reformat (input-field-HTML-tree input-field))))
     
     (servlet-form 
       ;; Must do something to prevent the callback-function string to
       ;; be HTML escaped.
       *preorder*
       . ,(lambda (trigger call-back-function . elems)
	     (if (and (pair? elems)
		      (XML-attribute? (car elems)))
		 (make-servlet-form call-back-function (cdar elems) (cdr elems))
		 (make-servlet-form call-back-function'() elems)))))
  ))

(define (make-servlet-form call-back-function attributes elems)
  `("<form" ,@(map (lambda (attribute-value)
		     ((enattr (car attribute-value)) (cadr attribute-value)))
		   `((method "GET")
		     (action ,call-back-function)
		     ,@attributes))
    #\> #\newline
    ,(reformat elems)
    "</form>"))

(define (XML-attribute? thing)
  (and (pair? thing)
       (eq? '@ (car thing))))

(define attribute-rule
  `(@		; local override for attributes
    ((*default*       
      . ,(lambda (attr-key . value) ((enattr attr-key) value))))
    . ,(lambda (trigger . value) (list '@ value))))

(define text-rule
  `(*text*
    . ,(lambda (trigger str) 
	 (if (string? str) (string->goodHTML str) str))))

(define URL-rule
  (cons 'URL 
	(lambda (tag URI text) (list "<a href=\"" URI "\">" text "</a>"))))

(define default-rules
 `(,attribute-rule
   (*default* 
    . ,(lambda (tag . elems) (apply (entag tag) elems)))
   ,text-rule
   ,URL-rule))

(define (make-callback function)
  (call-with-current-continuation
   (lambda (exit)
     (let* ((req (send/suspend (lambda (new-url)
				 (exit new-url)))))
       (function req)))))









;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; input-fields
;;; defines input-fields for servlets

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

(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-input-field name transformer HTML-tree)
  (list 'input-field (real-make-input-field name transformer HTML-tree #f)))

(define (make-upper-input-field transformer HTML-tree)
  (list 'input-field (real-make-input-field #f transformer HTML-tree #t)))

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

(define (make-checkbox-input-field . maybe-further-attributes)
  (let* ((name (generate-input-field-name "checkbox"))
	 (value (if (and (pair? maybe-further-attributes)
			 (string? (car maybe-further-attributes)))
		    (car maybe-further-attributes)
		    #f))
	 (further-attributes (if value 
				 (cdr maybe-further-attributes)
				 maybe-further-attributes)))
    (make-input-field
     name
     identity
     `(input (@ ((type "checkbox")
		 (name ,name)
		 ,(if value `(value ,value) '())
		 ,@further-attributes))))))
       

;; 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)
  (let ((input-field (cadr input-field)))
    (cond
     ((input-field-get-bindings? input-field)
      ((input-field-transformer input-field) bindings))
     ((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)))))




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