sunet/scheme/httpd/surflets/surflets.scm

;; utilities for surflet
;; Copyright 2002, Andreas Bernauer

(define (send-html/suspend html-tree-maker)
  (send/suspend 
   (lambda (new-url)
     (make-usual-html-response
      (surflet-XML->HTML #f (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 
	 (surflet-XML->HTML #f html-tree))))

(define (make-usual-html-response html-string)
  (make-surflet-response
   (status-code ok)
   "text/html"
   '(("Cache-Control" . "no-cache"))
   html-string))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; 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 works only for GET and POST methods.

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

;; Bindings of POST requests can be read only once, since they are
;; read from an input port. So we have to cache them, for the case of
;; a later GET-BINDINGS call on the same POST request. The request are
;; referenced by a weak pointer.
(define *POST-bindings-cache* '())
(define *cache-lock* (make-lock))

(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")
      (or (cached-bindings request)
	  (let* ((content-length (get-content-length (request-headers request)))
		 (input-port (socket:inport (request-socket request)))
		 (form-data (read-string content-length input-port)))
	    (let ((form-bindings (form-query form-data)))
	      (obtain-lock *cache-lock*)
	      (set! *POST-bindings-cache* (cons (cons (make-weak-pointer request)
						      form-bindings)
						*POST-bindings-cache*))
	      (release-lock *cache-lock*)
	      form-bindings))))
     (else
      (error "unsupported request type")))))

;; Looking up, if we have cached this request. While going through the
;; list, we remove entries to request objects, that are no longer
;; valid. Expecting a call for an uncached request every now and then,
;; it is guaranteed, that the list is cleaned up every now and then.
(define (cached-bindings request)
  (obtain-lock *cache-lock*)
  (let ((result 
	 (let loop ((cache *POST-bindings-cache*))
	   (if (null? cache)
	       #f			; no such request cached
	       (let* ((head (car cache))
		      (req (weak-pointer-ref (car head))))
		 (if req
		     (if (eq? req request)
			 (cdar cache)	; request is cached
			 (loop (cdr cache))) ; request isn't cached
		     (begin
		       ;; request object is gone ==> remove it from list
		       (set! cache (cdr cache))
		       (loop cache))))))))
    (release-lock *cache-lock*)
    result))

(define (get-header headers tag)
  (cond ((assq tag headers) => cdr)
	(else #f)))
	 
   
;; 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))
		 ;; (status-code bad-request) req 
		 (error "Illegal `Content-length:' header.")))))
	(else 
	 (error "No Content-length specified for POST data."))))

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

(define (extract-single-binding key bindings)
  (let ((key-bindings (extract-bindings key bindings)))
    (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 (surflet-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))))
     
     (surflet-form 
       ;; Must do something to prevent the callback-function string to
       ;; be HTML escaped.
       *preorder*
       . ,(lambda (trigger call-back-function . args)
	    (receive (parameters elems)
		(typed-optionals (list symbol? XML-attribute?) args)
	      (make-surflet-form call-back-function 
				 (car parameters)
				 (cadr parameters)
				 elems)))))
  ))

(define (make-surflet-form call-back-function method attributes elems)
  (let ((real-method (case method
		       ((get GET) "GET")
		       ((post POST) "POST")
		       ((#f) "GET")
		       (else
			(error "invalid method type" method)))))
    `("<form" ,@(map (lambda (attribute-value)
		       ((enattr (car attribute-value)) (cadr attribute-value)))
		     `((method ,real-method)
		       (action ,call-back-function)
		       ;; We have to divide attributes explicitly.
		       ,@(if attributes (cdr 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")
		,(if url
		     `(p "Try to " 
			 (URL ,url "reload") 
			 " the page to get current data.")
		     '())))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; input-fields
;;; defines input-fields for surflets

(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-higher-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)
		      ,(and default `(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 
  (let ((make-multiple-transformer
	 (lambda (name)
	   (lambda (bindings)
	     (map cdr
		  (filter (lambda (binding)
			    (equal? (car binding) name))
			  bindings))))))

    (lambda (options . maybe-further-attributes)
      (optionals maybe-further-attributes
	    ((multiple? boolean?)
	     (attributes XML-attribute?))
	(let* ((name (generate-input-field-name "select"))
	       (SXML-options 
		(map (lambda (option)
		       (cond
			((string-or-symbol? option) 
			 (list 'option option))
			((list? option) 
			 (cond
			  ((null? (cdr option))
			   `(option ,option))
			  ((XML-attribute? (cdr option)) ; w/attribs?
			   `(option ,(cdr option) ,(car option)))
			  (else
			   (error "not an attribute" (cdr option)))))
			(else
			 (error "not an option" option))))
		     options))
	       (SXML `(select (@ ((name ,name)
				 ,(if multiple? '(multiple) '())
				 ,(and attributes (cdr attributes))))
			     #\newline
			     ,SXML-options)))
	  (if multiple?
	      (make-higher-input-field (make-multiple-transformer name) SXML)
	      (make-input-field name identity SXML)))))))

;; 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? (cdr value))
					     (cddr value)
					     (error "not an attribute" cdr value))
					 #f)))
	       (make-input-field
		name
		(lambda (select)
		  select)
		`(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
	((checked? boolean?)
	 (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) '())
		   ,(if checked? '(checked) '())
		   ,(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) '())))))

;; <input-field>: '(input-field . <real-input-field>)
;; <real-input-field>: #{Input-field "name"}
(define (raw-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)))))

;; Trys to get a value for INPUT-FIELD in BINDINGS. If this fails
;; (i.e. RAW-INPUT-FIELD-VALUE returns an error), the default-value is
;; returned. The default-value defaults to #f. NOTE: If you do this
;; with input-fields whose valid values may be the same as the default
;; value, you cannot determine by the result if there was such a value
;; or not. Keep in mind, that RAW-INPUT-FIELD-VALUE returns also an
;; error, if there was not such an input field. This makes
;; INPUT-FIELD-VALUE working with checkbox input fields because they
;; miss if they are not checked.
(define (input-field-value input-field bindings . maybe-default)
  (let ((default (:optional maybe-default #f)))
    (with-fatal-error-handler
     (lambda (condition more)
       default)
     (raw-input-field-value 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))