com.paskvil.uhttp-html.lisp

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98

;;; -*- Lisp -*- mode

(in-package #:com.paskvil.uhttp)

(defun str-replace (str tr-rules)
  (with-output-to-string (new-str)
    (let (tr)
      (loop for c across str
         do (if (setf tr (assoc c tr-rules))
                (write-string (cdr tr) new-str)
                (write-char c new-str))))))

(defun escape-html-chars (str)
  (with-output-to-string (new-str)
    (let ((pos1 0)
          (pos2 -1))
      (loop for c across str
         do (case c
              (#\< (when (<= pos1 pos2)
                     (write-string (subseq str pos1 (1+ pos2)) new-str))
                   (write-string "&lt;" new-str)
                   (setf pos1 (+ pos2 2))
                   (incf pos2))
              (#\> (when (<= pos1 pos2)
                     (write-string (subseq str pos1 (1+ pos2)) new-str))
                   (write-string "&gt;" new-str)
                   (setf pos1 (+ pos2 2))
                   (incf pos2))
              (t (incf pos2))))
      (when (<= pos1 pos2)
        (write-string (subseq str pos1 (1+ pos2)) new-str)))))

(defparameter *html-tags*
  '(:a :applet :area :b :big :blockquote :body :br :button
    :caption :center :code :dd :del :div :em :font :form :frame
    :h1 :h2 :h3 :h4 :h5 :h6 :head :hr :html :i :iframe :img :input
    :labe :li :map :meta :noscript :object :ol :option
    :p :param :pre :s :script :select :small :span :strike
    :strong :style :sub :sup :table :tbody :td :textarea :tfoot
    :th :thead :title :tr :tt :u :ul :var))
(defparameter *html-single-tags*
  '(:a :area :br :frame :hr :img :input :meta :param))

(defun to-html-string (obj)
  (escape-html-chars (format nil "~a" obj)))

(defmacro html (forms)
  "Emits HTML code based on provided forms.

   If the form starts with a keyword that denotes HTML tag,
   appropriate HTML code is printed to *html-stream* stream.
   If it's any other designator, the whole form is considered
   to be a form to execute, potentially containing more html.

   Example usage:

   (html (:p \"hello\"))
   (html ((:p :style \"font-size: 12px;\") \"hello\"))
   (html (:img :src \"/images/img.jpg\"))
   (html (:body (:ul (dotimes (x 10) (html (:li x)))))"
  (labels ((is-html-tag (tag) (find tag *html-tags*))
           (is-html-single-tag (tag) (find tag *html-single-tags*)))
    (cond ((atom forms) ; atom - presume it's contents to print
           `(format t "~a" (to-html-string ,forms)))
          ((and forms (listp forms)) ; list - either tag definition, or code
           (let ((fhead (car forms))
                 (ftail (cdr forms)))
             (cond ((and (listp fhead) ; starts with list - should be tag with attributes
                         (keywordp (car fhead))
                         (is-html-tag (car fhead)))
                    `(progn
                       (format t "<~a" (car ',fhead))
                       ,@(do ((res '())
                              (att (cdr fhead) (cddr att)))
                             ((null att) (nreverse res))
                             (push `(format t " ~a='~a'" (car ',att) (to-html-string (cadr ',att))) res))
                       (format t ">")
                       ,@(loop for x in ftail collecting `(html ,x))
                       (format t "</~a>~%" (car ',fhead))))
                   ((and (atom fhead) ; single tag - followed by attributes
                         (keywordp fhead)
                         (is-html-single-tag fhead))
                    `(progn
                       (format t "<~a" ,fhead)
                       ,@(do ((res '())
                              (att ftail (cddr att)))
                             ((null att) (nreverse res))
                             (push `(format t " ~a='~a'" (car ',att) (to-html-string (cadr ',att))) res))
                       (format t "/>~%")))
                   ((and (atom fhead) ; normal tag, followed by contents
                         (keywordp fhead)
                         (is-html-tag fhead))
                    `(progn
                       (format t "<~a>" ,fhead)
                       ,@(loop for x in ftail collecting `(html ,x))
                       (format t "</~a>~%" ,fhead)))
                   (t ; presume it's a code to execute
                    forms)))))))