sunet/scheme/httpd/surflets/surflets.scm

;; utilities for surflet
;; Copyright 2002,2003, Andreas Bernauer
;; Copyright 2003, Martin Gasbichler

(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 q)
  (if q 
      (parse-html-form-query q) 
      '()))

;; 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 requests
;; are referenced by a weak pointer. Thread-safe as all threads use
;; the same lock.
(define *POST-bindings-cache* '())
(define *cache-lock* (make-lock))

(define (get-bindings surflet-request)
  (let ((request-method (surflet-request-method surflet-request)))
    (cond
     ((string=? request-method "GET")
      (form-query (http-url-search (surflet-request-url surflet-request))))
     ((string=? request-method "POST")
      (or (cached-bindings surflet-request)
	  (let* ((content-length (get-content-length (surflet-request-headers surflet-request)))
		 (input-port (surflet-request-input-port surflet-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 surflet-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. The cache is a list of pairs
;;; (surflet-request . computed-binding)
(define (cached-bindings surflet-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))
		      (s-req (weak-pointer-ref (car head))))
		 (if s-req
		     (if (eq? s-req surflet-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))

   
;; 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

;; get-bindings: Transformer will get all bindings of request, not
;; only the one concerning the input-field.
(define-record-type input-field :input-field
  (real-make-input-field name transformer HTML-tree get-bindings?)
  real-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))))

;; Have to do a trick to get around with SSAX: input-field is a list
;; whose first element is 'input-field and the last (next) one is a
;; real input-field.
(define (input-field? input-field)
  (and (pair? input-field)
       (eq? 'input-field (car input-field))
       (real-input-field? (cadr 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))

;; See note at input-field? for reasons for the list.
(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"
			rest-args)
	       (,%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
       (lambda (value)
	 (or (string=? value "on")
	     value))
       `(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-record-type address :address
  (really-make-address name annotated?)
  (name address-name)
  (annotated? address-annotated?))

(define (make-address)
  (let ((address (really-make-address
		  (generate-unique-name "return") #f)))
    (lambda (message)
      (cond
       ((string? message)
	(string-append message "?" (address-name address) "="))
       ((eq? message 'address)
	address)
       (else
	(error "address: unknown message/bad argument" 
	       message (address-name address)))))))

(define (make-annotated-address)
  (let ((address (really-make-address 
		  (generate-unique-name "return")
		  #t)))
    (lambda (message . annotation)
      (cond
       ((and (string? message)
	     (<= (length annotation) 1))
	(let ((escaped-annotation 
	       (if (null? annotation)
		   ""
		   (escape-uri (car annotation)))))
	  (string-append message "?" (address-name address)
			 "=" escaped-annotation)))
       ((eq? message 'address)
	address)
       (else
	(error "annotated-address: unknown message/bad argument(s)" 
	       message (address-name address)))))))

(define (returned-via return-object bindings)
  (if (input-field? return-object)
      (input-field-binding return-object bindings)
      ;; We assume we have a return-address-object instead.
      (let ((address (return-object 'address)))
	(cond 
	 ((assoc (address-name address) bindings) =>
	  (lambda (pair)
	    (if (address-annotated? address)
		(unescape-uri (cdr pair))
		#t)))
	 (else #f)))))

;; It depends on the object, if returned-via returns only boolean
;; values or string values as well. So let us have both names.
(define returned-via? returned-via)

;; This is from Martin Gasbichler
(define-syntax case-returned-via
  (syntax-rules (else)
    ((case-returned-via (%bindings ...) clauses ...)
     (let ((bindings (%bindings ...)))
       (case-returned-via bindings clauses ...)))
    ((case-returned-via bindings (else body ...))
     (begin body ...))
    ((case-returned-via bindings
                        ((%return-object ...) %body ...))
     (if (or (returned-via? %return-object bindings) ...)
         (begin %body ...)))
    ((case-returned-via bindings
                        ((%return-object ...) %body ...)
                        %clause %clauses ...)
     (if (or (returned-via? %return-object bindings) ...)
         (begin %body ...) 
         (case-returned-via bindings %clause %clauses ...)))))