sunet/scheme/httpd/surflets/surflets.scm

;; utilities for servlet
;; 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)
  (let ((request-method (request:method request)))
    (cond
     ((string=? request-method "GET")
      (form-query (http-url:search (request:url request))))
     ((string=? request-method "POST")
      (let* ((content-length (get-content-length (request:headers request)))
	     (input-port (socket:inport (request:socket request)))
	     (form-data (read-string content-length input-port)))
	(form-query form-data)))
     (else
      (error "unsupported request type")))))

;; Will be needed when we handle POST requests.
(define (get-content-length headers)
  (cond ((get-header headers 'content-length) =>
	 ;; adopted from httpd/cgi-server.scm
	 (lambda (content-length)	; Skip initial whitespace (& other non-digits).
	   (let ((first-digit (string-index content-length char-set:digit))
		 (content-length-len (string-length content-length)))
	     (if first-digit
		 (string->number (substring content-length first-digit 
					    content-length-len))
		 ;; http-status/bad-request req 
		 `(error "Illegal `Content-length:' header.")))))
	(else 
	 (error "No Content-length specified for POST data."))))

(define (extract-bindings bindings key)
  (let ((key (if (symbol? key) (symbol->string key) key)))
    (map cdr
	 (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))
	(car 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 "POST")
		     (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 . maybe-text) (list "<a href=\"" URI "\">" 
					     (if (pair? maybe-text)
						 maybe-text
						 URI)"</a>"))))

(define plain-html-rule
  `(plain-html
    *preorder*
    . ,(lambda (tag . text) text)))

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

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




;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; outdater

(define-record-type outdater :outdater
  (real-make-outdater outdated?)
  outdater?
  (outdated? outdater-outdated? set-outdater-outdated?!))

(define (make-outdater)
  (real-make-outdater #f))

(define-syntax if-outdated
  (syntax-rules ()
    ((if-outdated outdater consequence alternative)
     (if (outdater-outdated? outdater)
	 consequence
	 (begin
	   (set-outdater-outdated?! outdater #t)
	   alternative)))))

(define (show-outdated url)
  (send-html 
   `(html (title "Outdated Data")
	  (body (h1 "Outdated Data")
		(p "The page or action you requested relies on outdated data")
		(p "Try to " 
		   (URL ,url "reload") 
		   " the page to get current data.")))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; 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-unique-name
  (let ((id 0))
    (lambda (type-string)
      (set! id (+ 1 id))
      (string-append type-string (number->string id)))))
(define generate-input-field-name generate-unique-name)

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

;; PRED-LIST contains list of predicates that recognizes optional
;; leading parameters. FURTHER-ATTRIBUTES is the optional parameter
;; list as got by procedure call. TYPED-OPTIONALS returns two values:
;; a list of the same length as PRED-LIST and a list containing the
;; left arguments that did not fit the predicates.
;;
;; With the help of TYPED-OPTIONALS you can define a function
;; like `make-submit-button [string] [further-attributes]' this way:
;; (define (make-submit-button . args)
;;   (receive (params rest-args) 
;;     (prefix-optionals (list string? XML-attribute?) args)
;;     (if (pair? rest-args)
;;         (error "too many arguments to make-submit-button))
;;         (let ((value (first params))
;;               (attributes (second params)))
;;           ...))))
;;
(define (typed-optionals pred-list args)
  (let loop ((results '())
	     (pred-list pred-list)
	     (args args))
    (cond
     ((null? pred-list)
      (values (reverse results) args))
     ((null? args)
      (values (rev-append results (make-list (length pred-list) #f)) '()))
     (((car pred-list) (car args))
      (loop (cons (car args) results)
	    (cdr pred-list)
	    (cdr args)))
     (else
      (loop (cons #f results)
	    (cdr pred-list)
	    args)))))


(define-syntax optionals
  (lambda (exp rename compare)
    (let ((%receive (rename 'receive))
	  (%typed-optionals (rename 'typed-optionals))
	  (%list (rename 'list))
	  (%if (rename 'if))
	  (%pair? (rename 'pair?))
	  (%error (rename 'error))
	  (%let (rename 'let))
	  (%list-ref (rename 'list-ref))

	  (args (cadr exp))
	  (var-list (caddr exp))
	  (body (cadddr exp)))
      `(,%receive (params rest-args)
	   (,%typed-optionals (,%list ,@(map cadr var-list)) ,args)
         (,%if (pair? rest-args)
	       (,%error "optionals: too many arguments and/or argument type mismatch")
	       (,%let (,@(let loop ((counter 0)
				    (var-list var-list))
			   (if (null? var-list)
			       '()
			       (cons (cons (caar var-list) `((,%list-ref params ,counter)))
				     (loop (+ 1 counter)
					   (cdr var-list))))))
		      ,body))))))

;; from uri.scm
(define (rev-append a b)		; (append (reverse a) b)
  (let rev-app ((a a) (b b))		; Should be defined in a list-proc
    (if (pair? a)			; package, not here.
	(rev-app (cdr a) (cons (car a) b))
	b)))

(define (make-text-input-field . maybe-further-attributes)
  (let ((name (generate-input-field-name "text")))
    (optionals maybe-further-attributes 
	((default-text string?)
	 (attributes XML-attribute?))
      (make-input-field name
			identity
			`(input (@ (type "text")
				   (name ,name)
				   ,(and default-text `(value ,default-text))
				   ;; this will insert a list, but
				   ;; XML->HTML doesn't care about it
				   ,(and attributes (cdr attributes))
				   ))))))

(define make-number-input-field
  (let ((number-input-field-transformer
	 (lambda (string)
	   (or (string->number string)
	       (error "wrong type")))
	 ))
    (lambda maybe-further-attributes
      (let ((name (generate-input-field-name "number")))
	(optionals maybe-further-attributes
	    ((default (lambda (a) (or (number? a)
				      (string-or-symbol? a))))
	     (attributes XML-attribute?))
	  (make-input-field 
	   name
	   number-input-field-transformer
	   `(input (@ (type "text")
		      (name ,name)
		      (value ,default)
		      ,(and attributes (cdr attributes))))))))))

(define (make-password-input-field . maybe-further-attributes)
  (let ((name (generate-input-field-name "password")))
    (optionals maybe-further-attributes
	((attributes XML-attribute?))
      (make-input-field 
       name
       identity
       `(input (@ (type "password")
		  (name ,name)
		  ,@(and attributes (cdr attributes))))))))

(define (make-textarea-input-field .  maybe-further-attributes)
  (let ((name (generate-input-field-name "textarea")))
    (optionals maybe-further-attributes
	((default-text string?)
	 (attributes XML-attribute?))
      (make-input-field 
       name
       identity
       `(textarea (@ (type "textarea")
		     (name ,name)
		     ,(and attributes (cdr attributes)))
		  ,(and default-text))))))

;(make-select-input-fields '("this" "that" "those") '(@ ((id "sushi"))))
;(make-select-input-fields '("this" ("that" '(@ (selected))) "those"))
;; dropdown: (size 1)
;; multiple choice: (multiple)
;; preselected option: (selected)
;; changed return value: (value new-value)
;; returns a select input field with several options
(define (make-select-input-field options . maybe-further-attributes)
  (let ((name (generate-input-field-name "select")))
    (optionals maybe-further-attributes
	((attributes XML-attribute?))
      (make-input-field 
       name
       identity				;FIXME[extension] refer to list elements
       `(select (@ ((name ,name)
		    ,(and attributes (cdr attributes))))
		#\newline
		,@(map (lambda (option)
			 (cond
			  ((string? option)
			   (list 'option option))
			  ((list? option)
			   (cond
			    ((null? (cdr option))
			     `(option ,option))
			    ((XML-attribute? (cadr option)) ; with attributes?
			     `(option ,(cadr option) ,(car option)))
			    (else
			     (error "not an attribute" (cdr option)))))
			  (else
			   (error "not an option" option))))
		       options))))))

;; returns a *list* of radio buttons
(define (make-radio-input-fields values . maybe-further-attributes)
  (let ((name (generate-input-field-name "radio")))
    (optionals maybe-further-attributes
	((attributes XML-attribute?))
      (map (lambda (value)
	     (let ((value-value (if (pair? value) (car value) value))
		   (value-attributes (if (pair? value)
					 (if (XML-attribute? (cadr value))
					     (cdadr value)
					     (error "not an attribute" cadr value))
					 #f)))
	       (make-input-field
		name
		(lambda (select)
		  select)	;FIXME refer to list elements
		`(input (@ ((type "radio")
			    (name ,name)
			    (value ,value-value)
			    ,(and value-attributes)
			    ,(and attributes (cdr attributes))))))))
	   values))))
       
;; returns a checkbox input field
(define (make-checkbox-input-field . maybe-further-attributes)
  (let* ((name (generate-input-field-name "checkbox")))
    (optionals maybe-further-attributes
	((value (lambda (a) (or (string? a) 
				(number? a)
				(symbol? a))))
	 (attributes XML-attribute?))
      (make-input-field
       name
       identity
       `(input (@ ((type "checkbox")
		   (name ,name)
		   ,(if value `(value ,value) '())
		   ,(and attributes (cdr attributes)))))))))
			   

(define (make-hidden-input-field value . maybe-further-attributes)
  (let ((name (generate-input-field-name "hidden")))
    (optionals maybe-further-attributes
	((attributes XML-attribute?))
      (make-input-field name
			identity
			`(input (@ (type "hidden")
				   (name ,name)
				   (value ,value)
				   ,(and attributes (cdr attributes))))))))

(define (make-button type name button-caption attributes)
  (make-input-field name
		    identity
		    `(input (@ (type ,type)
			       (name ,name)
			       ,(and button-caption `(value ,button-caption))
			       ,(and attributes (cdr attributes))))))

(define (string-or-symbol? a) 
  (or (string? a)
      (symbol? a)))

(define (make-submit-button . maybe-further-attributes)
  (optionals maybe-further-attributes
      ((button-caption string-or-symbol?)
       (attributes XML-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-or-symbol?)
       (attributes XML-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 XML-attribute?))
    (make-button "image"  (generate-input-field-name "imgbtn")
		 #f `(@ (src ,image-source) 
			,@(if attributes (cdr 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))
     ((real-input-field-binding input-field bindings) =>
      (lambda (binding)
	((input-field-transformer input-field) (cdr binding))))
     (else
      (error "no such input-field" input-field bindings)))))

(define (real-input-field-binding input-field bindings)
  (assoc (input-field-name input-field) bindings))

(define (input-field-binding input-field bindings)
  (real-input-field-binding (cadr input-field) bindings))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; return address

;; generates an unique return-addres
;; may be used like 
;; (let ((address (make-address)))
;;   (send-html/suspend 
;;     (lambda (new-url)
;;       ...
;;       (URL (address new-url) "Click here to get more")...)                
(define (make-address)
  (let ((name (generate-unique-name "return")))
    (lambda (message)
      (cond
       ((string? message)
	(string-append message "?" name "="))
       ((eq? message 'name)
	name)
       (else				;maybe we want more later...
	(error "unknown message" message name))))))
	

(define (returned-via? return-address bindings)
  (assoc (return-address 'name) bindings))