ijp/render.scm

## render.scm
(define-module (render)
  #:use-module (sxml transform)
  #:use-module (web response)
  #:export (render-sxml universal-conversion-rules))

(define* (render-sxml sxml #:key (content-type 'text/html))
  (values
   (build-response #:code 200
                   #:headers `((content-type ,content-type)))
   (with-output-to-string
    (lambda ()
      (SRV:send-reply (pre-post-order sxml universal-conversion-rules))))))


(define universal-conversion-rules
  `(    ;;; mine
    (doctype . ,(lambda (tag) "<!doctype html>"))
    (raw *preorder* . ,(lambda (tag . rawstrings) rawstrings))
    (& . ,(lambda (tag str)
            (string-append "&" str ";")))
    ;; oleg's  universal-conversion-rules -- In the public domain
    (@
     ((*default*                         ; local override for attributes
       . ,(lambda (attr-key . value) (enattr attr-key value))))
     . ,(lambda (trigger . value) (cons '^ value)))
    (*default* . ,(lambda (tag . elems) (entag tag elems)))
    (*text* . ,(lambda (trigger str)
		 (if (string? str) (string->goodHTML str) str)))))


;;; All the code below is taken from ssax's SXML-to-HTML.scm and
;;; util.scm so I don't need to import (wak ssax html). Also in the
;;; public domain.
(define (inc x) (+ x 1))

(define (entag tag elems)
  (if (and (pair? elems) (pair? (car elems)) (eq? '^ (caar elems)))
    (list #\newline #\< tag (cdar elems) #\>
      (and (pair? (cdr elems))
	(list (cdr elems) "</" tag #\>)))
    (list #\newline #\< tag #\> (and (pair? elems) (list elems "</" tag #\>))
      )))

(define (enattr attr-key value)
  (if (null? value) (list #\space attr-key)
    (list #\space attr-key "=\"" value #\")))


(define (make-char-quotator char-encoding)
  (let ((bad-chars (map car char-encoding)))

    ; Check to see if str contains one of the characters in charset,
    ; from the position i onward. If so, return that character's index.
    ; otherwise, return #f
    (define (index-cset str i charset)
      (let loop ((i i))
	(and (< i (string-length str))
	     (if (memv (string-ref str i) charset) i
		 (loop (inc i))))))

    ; The body of the function
    (lambda (str)
      (let ((bad-pos (index-cset str 0 bad-chars)))
	(if (not bad-pos) str	; str had all good chars
	    (let loop ((from 0) (to bad-pos))
	      (cond
	       ((>= from (string-length str)) '())
	       ((not to)
		(cons (substring str from (string-length str)) '()))
	       (else
		(let ((quoted-char
		       (cdr (assv (string-ref str to) char-encoding)))
		      (new-to
		       (index-cset str (inc to) bad-chars)))
		  (if (< from to)
		      (cons
		       (substring str from to)
		       (cons quoted-char (loop (inc to) new-to)))
		      (cons quoted-char (loop (inc to) new-to))))))))))
))

(define string->goodHTML
  (make-char-quotator
   '((#\< . "&lt;") (#\> . "&gt;") (#\& . "&amp;") (#\" . "&quot;"))))
	(define-module (render)
	#:use-module (sxml transform)
	#:use-module (web response)
	#:export (render-sxml universal-conversion-rules))

	(define* (render-sxml sxml #:key (content-type 'text/html))
	(values
	(build-response #:code 200
	#:headers `((content-type ,content-type)))
	(with-output-to-string
	(lambda ()
	(SRV:send-reply (pre-post-order sxml universal-conversion-rules))))))


	(define universal-conversion-rules
	`( ;;; mine
	(doctype . ,(lambda (tag) "<!doctype html>"))
	(raw preorder . ,(lambda (tag . rawstrings) rawstrings))
	(& . ,(lambda (tag str)
	(string-append "&" str ";")))
	;; oleg's universal-conversion-rules -- In the public domain
	(@
	((default ; local override for attributes
	. ,(lambda (attr-key . value) (enattr attr-key value))))
	. ,(lambda (trigger . value) (cons '^ value)))
	(default . ,(lambda (tag . elems) (entag tag elems)))
	(text . ,(lambda (trigger str)
	(if (string? str) (string->goodHTML str) str)))))


	;;; All the code below is taken from ssax's SXML-to-HTML.scm and
	;;; util.scm so I don't need to import (wak ssax html). Also in the
	;;; public domain.
	(define (inc x) (+ x 1))

	(define (entag tag elems)
	(if (and (pair? elems) (pair? (car elems)) (eq? '^ (caar elems)))
	(list #\newline #\< tag (cdar elems) #\>
	(and (pair? (cdr elems))
	(list (cdr elems) "</" tag #\>)))
	(list #\newline #\< tag #\> (and (pair? elems) (list elems "</" tag #\>))
	)))

	(define (enattr attr-key value)
	(if (null? value) (list #\space attr-key)
	(list #\space attr-key "=\"" value #\")))


	(define (make-char-quotator char-encoding)
	(let ((bad-chars (map car char-encoding)))

	; Check to see if str contains one of the characters in charset,
	; from the position i onward. If so, return that character's index.
	; otherwise, return #f
	(define (index-cset str i charset)
	(let loop ((i i))
	(and (< i (string-length str))
	(if (memv (string-ref str i) charset) i
	(loop (inc i))))))

	; The body of the function
	(lambda (str)
	(let ((bad-pos (index-cset str 0 bad-chars)))
	(if (not bad-pos) str ; str had all good chars
	(let loop ((from 0) (to bad-pos))
	(cond
	((>= from (string-length str)) '())
	((not to)
	(cons (substring str from (string-length str)) '()))
	(else
	(let ((quoted-char
	(cdr (assv (string-ref str to) char-encoding)))
	(new-to
	(index-cset str (inc to) bad-chars)))
	(if (< from to)
	(cons
	(substring str from to)
	(cons quoted-char (loop (inc to) new-to)))
	(cons quoted-char (loop (inc to) new-to))))))))))
	))

	(define string->goodHTML
	(make-char-quotator
	'((#\< . "<") (#\> . ">") (#\& . "&") (#\" . """))))