sunet/scheme/httpd/surflets/surflet-input-fields.scm

;;; SUrflets' input fields
;;; Copyright 2002, 2003 Andreas Bernauer
;;; With additions from Eric Knauel (2003)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Functions to create simple input fields

;; The interface for input-fields does not prescribe what the type of
;; attributes has to be. We choose a record here.

(define-record-type input-field-attributes :input-field-attributes
  (make-input-field-attributes default others)
  input-field-attributes?
  (default input-field-attributes-default set-input-field-attributes-default!)
  (others input-field-attributes-others set-input-field-attributes-others!))

;; A simple input-field is a prototype for other input-fields.
;; REPORTED-TYPE is the type of the input-field in HTML, TYPE the
;; internal referenced type and TRANSFORMER the function that
;; translates the HTTP-string of the request into a scheme value.
(define (simple-input-field-maker reported-type type default-pred transformer)
  (lambda maybe-further-attributes
    (let ((name (generate-input-field-name type)))
      (optionals maybe-further-attributes 
	  ((default default-pred)
	   (attributes sxml-attribute?))
	(make-input-field name type
			  transformer
			  (make-input-field-attributes
			   (and default `(value ,default))
			   (sxml-attribute-attributes attributes))
			  (simple-input-field-maker-html-tree-maker 
			   reported-type))))))

(define (simple-input-field-maker-html-tree-maker reported-type)
  (lambda (input-field)
    (let ((attributes (input-field-attributes input-field)))
      `(input (@ (type ,reported-type)
		 (name ,(input-field-name input-field))
		 ,(input-field-attributes-default attributes)
		 ,(input-field-attributes-others attributes))))))

(define (make-simple-input-field-default-setter default-pred? wrap?)
  (lambda (input-field value)
    (if (default-pred? value)
	(set-input-field-attributes-default! 
	 (input-field-attributes input-field) 
	 (if wrap? `(value ,value) value))
	(error "Default value must be a number or a string or a symbol." 
	       value))
    (touch-input-field! input-field)))

(define (string-or-symbol? thing) 
  (or (string? thing) (symbol? thing)))
(define simple-default? string-or-symbol?)

(define set-simple-input-field-default!
  (make-simple-input-field-default-setter simple-default? #t))

;;;;;;;;;;;;;;;;;;;;
;;; Text input field
(define make-text-input-field 
  (simple-input-field-maker "text" "text" 
			    simple-default? identity))
(define set-text-input-field-value! set-simple-input-field-default!)

;;;;;;;;;;;;;;;;;;;;;;
;;; Number input field
(define (number-input-field-default? value)
  (or (number? value)
      (simple-default? value)))
(define (number-input-field-transformer string)
  (or (string->number string)
      (error "wrong type")))
(define make-number-input-field
  (simple-input-field-maker "text" "number"
			    number-input-field-default?
			    number-input-field-transformer))
(define set-number-input-field-value!
  (make-simple-input-field-default-setter number-input-field-default? #t))

;;;;;;;;;;;;;;;;;;;;;;
;;; hidden input-field
;; Little workaraound, as a hidden input-field needs a value. This
;; value is propagated in the slot "default value".
(define make-hidden-input-field
  (let ((hidden-input-field-generator 
	 (simple-input-field-maker "hidden" "text" 
				   simple-default? identity)))
    (lambda (value . maybe-further-attributes)
      (apply hidden-input-field-generator
	     (cons value maybe-further-attributes)))))
(define set-hidden-input-field-value! 
  set-simple-input-field-default!)

;;;;;;;;;;;;;;;;;;;;;;;;
;;; Password input field
(define make-password-input-field 
  (simple-input-field-maker "password" "password" 
			    simple-default? identity))
(define set-password-input-field-value!
  set-simple-input-field-default!)

;;; That's it for simple input fields.

;;;;;;;;;;;;;;;;;;;;;;;;
;;; Textarea input field
(define (make-textarea-input-field .  maybe-further-attributes)
  (let ((name (generate-input-field-name "textarea")))
    (optionals maybe-further-attributes
	((default-text simple-default?)
	 (rows number?)
	 (cols number?)
	 (readonly symbol?)
	 (attributes sxml-attribute?))
      (let ((extra-attributes '()))
	(if (eq? readonly 'readonly)
	    (set! extra-attributes (cons '(readonly) extra-attributes)))
	(if cols (set! extra-attributes (cons `(cols ,cols) extra-attributes)))
	(if rows (set! extra-attributes (cons `(rows ,rows) extra-attributes)))
	(make-input-field 
	 name "textarea"
	 identity
	 (make-input-field-attributes
	  (and default-text)
	  (cons extra-attributes (sxml-attribute-attributes attributes)))
	 make-textarea-input-field-html-tree)))))

(define (make-textarea-input-field-html-tree input-field)
  (let ((attributes (input-field-attributes input-field)))
    `(textarea (@ (type "textarea")
		  (name ,(input-field-name input-field))
		  ,(input-field-attributes-others attributes))
	       ,(input-field-attributes-default attributes))))

(define set-textarea-input-field-value!
  (let ((textarea-default-setter!
	 (make-simple-input-field-default-setter simple-default? #f)))
    (lambda (textarea-input-field value)
      (textarea-default-setter! textarea-input-field value))))

;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Selection input field

;; sel-if == select-input-field
;(make-select-input-fields '("this" "that" "those") '(@ ((id "sushi"))))
;(make-select-input-fields '("this" ("that" '(@ (selected))) "those"))
;; dropdown: (size 1)

;;; A selection input field shows a list of options that can be
;;; selected. For this purpose, we introduce an sel-if-option record,
;;; that contains all the information for each option. This is
;;; justified by the fact, that the options list is seperated in HTML,
;;; too. The TAG is the string that is displayed in the website, the
;;; VALUE is the value that is returned by input-field-value, if this
;;; option was selected. TAG is assumed to be unique by some functions
;;; (e.g. select and unselect) SELECTED? tells us, if this option is
;;; preselected.
(define-record-type sel-if-option :sel-if-option
  (really-make-sel-if-option tag value selected? attributes)
  sel-if-option?
  (tag sel-if-option-tag)
  (value sel-if-option-value)
  (selected? sel-if-option-selected? set-sel-if-option-selected?!)
  (attributes sel-if-option-attributes set-sel-if-option-attributes!))

(define (make-sel-if-option tag value selected? attributes)
  (if (string? tag)
      (really-make-sel-if-option tag value selected?
				 (sxml-attribute-attributes attributes))
      (error "Select-input-field-option's tag must be a string." tag)))

;; Constructor for valued select input-field option.
(define (make-annotated-sel-if-option tag value . maybe-attributes)
  (optionals maybe-attributes
      ((selected? boolean?)
       (attributes sxml-attribute?))
    (make-sel-if-option tag value selected? attributes)))

;; Constructor for a simple select input-field option (not annotated).
(define (make-simple-sel-if-option tag . maybe-attributes)
  (optionals maybe-attributes
      ((selected? boolean?)
       (attributes sxml-attribute?))
    (make-sel-if-option tag tag selected? attributes)))

(define-record-discloser :sel-if-option
  (lambda (sel-if-option)
    (list 'select-input-field-option
	  (sel-if-option-tag sel-if-option)
	  (sel-if-option-value sel-if-option)
	  (sel-if-option-selected? sel-if-option)
	  (sel-if-option-attributes sel-if-option)
	  )))

;; Selecting / Unselecting of an option in an select input-field,
;; chosen by tag.
(define (select-sel-if-option! tag sel-if)
  (set-select-input-field-option-selected?! tag sel-if #t))

(define (unselect-sel-if-option! tag sel-if)
  (set-select-input-field-option-selected?! tag sel-if #f))

(define (set-select-input-field-option-selected?! tag sel-if selected?)
  (let ((options (input-field-attributes-default 
		  (input-field-attributes sel-if))))
    (if (number? tag)			; is tag an index?
	(set-sel-if-option-selected?! (list-ref options tag) 
				      selected?)
	(let lp ((options options))
	  (if (null? options)
	      (error "No such option" tag sel-if)
	      (if (tag=sel-if-option? tag (car options))
		  (set-sel-if-option-selected?! (car options) selected?)
		  (lp (cdr options))))))
    (touch-input-field! sel-if)))

;; Find sel-if-option in a list by its tag.
(define (tag=sel-if-option? tag sel-if-option)
  (string=? tag (sel-if-option-tag sel-if-option)))

(define (find-sel-if-option tag sel-if-options)
  (cond ((member/srfi-1 tag sel-if-options tag=sel-if-option?)
	 => car)			
	;; MEMBER/SRFI-1 returns the sublist that starts with the
	;; searched element.
	(else #f)))

(define (find-sel-if-option-value tag sel-if-options)
  (cond ((find-sel-if-option tag sel-if-options)
	 => sel-if-option-value)
	(else #f)))

(define (add-sel-if-option! sel-if sel-if-option)
  (let ((attributes (input-field-attributes sel-if)))
    (set-input-field-attributes-default!
     attributes
     (cons sel-if-option
	   (input-field-attributes-default attributes)))
    (touch-input-field! sel-if)))

(define (delete-sel-if-option! sel-if sel-if-option)
  (let* ((attributes (input-field-attributes sel-if))
	 (sel-if-options (input-field-attributes-default attributes)))
    (if (sel-if-option? sel-if-option)
	(set-input-field-attributes-default!
	 attributes
	 (delete sel-if-option sel-if-options))
	(let ((tag sel-if-option))
	  (set-input-field-attributes-default!
	   attributes
	   (delete tag sel-if-options tag=sel-if-option?))))
    (touch-input-field! sel-if)))

;; To be compatible with previous versions of MAKE-SELECT-INPUT-FIELD,
;; we accept also a simple list as an option-list. New programs should
;; use sel-if-options-list (easily createable with 
;; (map make-simple-sel-if-option option-list))
(define (tolerate-old-sel-if-options sel-if-options)
  (if (and (list? sel-if-options)
	   (every sel-if-option? sel-if-options))
      sel-if-options
      (map make-simple-sel-if-option sel-if-options)))

(define (make-select-input-field sel-if-options . maybe-further-attributes)
  (really-make-select-input-field (tolerate-old-sel-if-options sel-if-options)
				  maybe-further-attributes))

(define (make-annotated-select-input-field sel-if-options . 
					   maybe-further-attributes)
  (really-make-select-input-field sel-if-options maybe-further-attributes))

(define (really-make-select-input-field sel-if-options
					maybe-further-attributes)
  (let ((real-sel-if-options (tolerate-old-sel-if-options sel-if-options)))
    (optionals maybe-further-attributes
	((multiple? boolean?)
	 (attributes sxml-attribute?))
      (let ((name (generate-input-field-name "select")))
	(if multiple?
	    (make-multiple-select-input-field name sel-if-options attributes)
	    (make-single-select-input-field name sel-if-options 
					    attributes))))))

;; internal
(define (make-multiple-select-input-field name sel-if-options attributes)
  (make-multi-input-field name "mult-select"
			  sel-if-multiple-transformer
			  (make-input-field-attributes
			   sel-if-options 
			   (list '(multiple) 
				 (sxml-attribute-attributes attributes)))
			  make-sel-if-html-tree))

;; internal
(define (make-single-select-input-field name sel-if-options attributes)
  (make-input-field name "select" 
		    (lambda (tag)
		      (cond ((find-sel-if-option-value tag sel-if-options)
			     => identity)
			    (else (error "no such option." tag))))
		    (make-input-field-attributes
		     sel-if-options 
		     (sxml-attribute-attributes attributes))
		    make-sel-if-html-tree))

(define (sel-if-multiple-transformer input-field bindings)
  (let ((name (input-field-name input-field))
	(sel-if-options (input-field-attributes-default 
			 (input-field-attributes input-field))))
    (let* ((my-bindings (filter (lambda (binding)
			       (equal? (car binding) name))
			     bindings))
	   (tags (map cdr my-bindings)))
      (filter-map (lambda (tag)
		    (find-sel-if-option-value tag sel-if-options))
		  tags))))

(define (make-sel-if-html-tree sel-if)
  (let ((attributes (input-field-attributes sel-if)))
    `(select (@ (name ,(input-field-name sel-if))
		,(input-field-attributes-others attributes))
	     #\newline
	     ,@(make-sel-if-options-html-tree 
		(input-field-attributes-default attributes)))))

(define (make-sel-if-options-html-tree sel-if-options)
  (map (lambda (sel-if-option)
	 `(option (@ ,(and (sel-if-option-selected? sel-if-option) '(selected))
		     ,(sel-if-option-attributes sel-if-option))
		  ,(sel-if-option-tag sel-if-option)))
       sel-if-options))

;;;;;;;;;;;;;;;;;;;;;;
;;; radio input-fields	    
;; Because grouped radio input-fields must use the same name, we
;; cannot just return one radio input-field object, but we must
;; generate several ones with the same name.
(define (make-radio-input-field-group)
  (let ((name (generate-input-field-name "radio")))
    (lambda (value-string . maybe-further-attributes)
      (optionals maybe-further-attributes
	  ((checked? boolean?)
	   (attributes sxml-attribute?))
	(make-input-field name "radio"
			  identity
			  (make-input-field-attributes 
			   (if checked? '(checked) #f)
			   (list `(value ,value-string)
				 (sxml-attribute-attributes attributes)))
			  radio-input-field-html-tree-maker)))))

(define (make-annotated-radio-input-field-group)
  (let* ((name (generate-input-field-name "radio"))
	 (value-table (make-integer-table))
	 (transformer (make-radio-input-field-transformer value-table)))
    (lambda (value . maybe-further-attributes)
      (optionals maybe-further-attributes
	  ((checked? boolean?)
	   (attributes sxml-attribute?))
	(let ((number (generate-unique-number)))
	  (table-set! value-table number value)
	  (make-input-field name "radio"
			    transformer
			    (make-input-field-attributes 
			     (if checked? '(checked) #f)
			     (list`(value ,(number->string number))
				  (sxml-attribute-attributes attributes)))
			    radio-input-field-html-tree-maker))))))

(define (make-radio-input-fields values . maybe-further-attributes)
  (optionals maybe-further-attributes
      ((attributes sxml-attribute?))
    (let ((radio-gen (make-annotated-radio-input-field-group)))
      (map (lambda (value)
	     (if attributes
		 (radio-gen value attributes)
		 (radio-gen value)))
	   values))))


(define (make-radio-input-field-transformer value-table)
  (lambda (tag)
    (cond 
     ((string->number tag) =>
      (lambda (number)
	(let ((value (table-ref value-table number)))
	  (if value
	      value
	      (error "Unknown tag number for radio input-field" tag)))))
     (else
      (error "Unknown tag number for radio input-field" tag)))))

(define (radio-input-field-html-tree-maker radio-input-field)
  (let* ((attributes (input-field-attributes radio-input-field)))
    `(input (@ ((type "radio")
		(name ,(input-field-name radio-input-field))
		,(input-field-attributes-default attributes)
		,(input-field-attributes-others attributes))))))

(define (set-input-field-checked?! input-field checked?)
  (let ((attributes (input-field-attributes input-field)))
    (set-input-field-attributes-default! 
     attributes
     (if checked? '(checked) #f))
    (touch-input-field! input-field)))
     
(define set-radio-input-field-checked?! set-input-field-checked?!)
(define (check-radio-input-field! radio)
  (set-radio-input-field-checked?! radio #t))
(define (uncheck-radio-input-field! radio)
  (set-radio-input-field-checked?! radio #f))
;;;;;;;;;;;;;;;;;;;;;;;;
;;; checkbox input-field
(define (make-checkbox-input-field . maybe-further-attributes)
  (really-make-checkbox-input-field #t
				    checkbox-transformer
				    maybe-further-attributes))

(define (make-annotated-checkbox-input-field value . maybe-further-attributes)
  (really-make-checkbox-input-field value 
				    (make-checkbox-transformer value)
				    maybe-further-attributes))

(define (really-make-checkbox-input-field value transformer attributes)
  (let ((name (generate-input-field-name "checkbox")))
    (optionals attributes
	((checked? boolean?)
	 (attributes sxml-attribute?))
      (make-input-field name "checkbox"
			transformer
			(make-input-field-attributes
			 (if checked? '(checked) #f)
			 (sxml-attribute-attributes attributes))
			checkbox-input-field-html-tree-maker))))

(define (make-checkbox-transformer value)
  (lambda (tag)
    (if (string=? tag "on")
	value
	#f)))

(define checkbox-transformer
  (make-checkbox-transformer #t))

(define (checkbox-input-field-html-tree-maker cb-if)
  (let ((attributes (input-field-attributes cb-if)))
    `(input (@ ((type "checkbox")
		(name ,(input-field-name cb-if))
		,(input-field-attributes-default attributes)
		,(input-field-attributes-others attributes))))))

(define set-checkbox-input-field-checked?! set-input-field-checked?!)
(define (check-checkbox-input-field! checkbox)
  (set-checkbox-input-field-checked?! checkbox #t))
(define (uncheck-checkbox-input-field! checkbox)
  (set-checkbox-input-field-checked?! checkbox #f))
;;;;;;;;;;;;;;;;;;;;;;
;; button input-fields
(define (make-button type name button-caption attributes)
  (make-input-field name type
		    identity
		    (make-input-field-attributes
		     (and button-caption `(value ,button-caption))
		     (sxml-attribute-attributes attributes))
		    make-button-html-tree))

(define (make-button-html-tree button-input-field)
  (let ((attributes (input-field-attributes button-input-field)))
    `(input (@ (type ,(input-field-type button-input-field))
	       (name ,(input-field-name button-input-field))
	       ,(input-field-attributes-default attributes)
	       ,(input-field-attributes-others attributes)))))

(define (make-submit-button . maybe-further-attributes)
  (optionals maybe-further-attributes
      ((button-caption string?)
       (attributes sxml-attribute?))
    (make-button "submit" (generate-input-field-name "submit")
		 button-caption attributes)))

(define (make-reset-button . maybe-further-attributes)
  (optionals maybe-further-attributes
      ((button-caption string?)
       (attributes sxml-attribute?))
    (make-button "reset" (generate-input-field-name "reset")  
		 button-caption attributes)))

(define (make-image-button image-source . maybe-further-attributes)
  (optionals maybe-further-attributes
      ((attributes sxml-attribute?))
    (make-button "image"  (generate-input-field-name "imgbtn")
		 #f `(@ (src ,image-source) 
			,@(sxml-attribute-attributes attributes)))))

;; Image buttons cannot be simple buttons, as the browser does not
;; send their simple name, but the coordinates where the user clicked
;; into. Thanks to Eric Knauel for reporting this bug.
(define (make-image-button image-source . maybe-further-attributes)
  (optionals maybe-further-attributes
      ((attributes sxml-attribute?))
    (make-multi-input-field (generate-input-field-name "imgbtn")
			    "image"
			    image-button-transformer
			    (make-input-field-attributes
			     `(src ,image-source) 
			     (sxml-attribute-attributes attributes))
			    make-button-html-tree)))

;; The following two functions are from Eric Knauel's fix for the
;; image-button bug:
(define (image-button-transformer image-button bindings)
  (let ((x (find-image-button-coordinate image-button bindings ".x"))
	(y (find-image-button-coordinate image-button bindings ".y")))
    (let ((x-number (string->number x))
	  (y-number (string->number y))) 
    (and x y
	 (if (and x-number y-number)
	     (cons x-number y-number)
	     (error "Image button coordinates aren't numbers. " x y))))))

(define (find-image-button-coordinate image-button bindings suffix)
  (let* ((name (input-field-name image-button)))
    (cond 
     ((assoc (string-append name suffix) bindings)
      => (lambda (pair)
	   (cdr pair)))
     (else #f))))
 

;;EOF