Create a gist now

Instantly share code, notes, and snippets.

What would you like to do?
(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;"))))
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment