add some tests

sanitize.asd

@@ -1,10 +1,20 @@
 ;;;; sanitize.asd
 
-(defsystem sanitize
+(defsystem #:sanitize
   :depends-on (#:cl-libxml2)
-  :components
-  ((:module "src"
-            :components
-            ((:file "packages")
-             (:file "mode" :depends-on ("packages"))
-             (:file "clean" :depends-on ("mode"))))))
+  :components ((:module "src"
+                        :components
+                        ((:file "packages")
+                         (:file "mode" :depends-on ("packages"))
+                         (:file "clean" :depends-on ("mode"))))))
+
+(defsystem #:sanitize-test
+  :depends-on (#:sanitize #:eos)
+  :components ((:module "t"
+                        :components
+                        ((:file "suite")))))
+
+(defmethod perform ((o test-op) (c (eql (find-system '#:sanitize))))
+  (operate 'load-op '#:sanitize)
+  (operate 'test-op '#:sanitize-test))
+

src/clean.lisp

@@ -2,19 +2,22 @@
 
 (in-package #:sanitize)
 
-(defgeneric clean (html mode)
-  (:documentation "Return sanitize copy of HTML"))
+(defun clean (html &optional (mode +default+))
+  "Return sanitize copy of HTML"
+  (html:with-parse-html (doc (format nil "<div>~A</div>" html))
+    (let ((entry (xtree:first-child (xtree:first-child (xtree:root doc)))))
+      (xtree:with-object (fragment (xtree:make-document-fragment doc))
+        (dolist (item (xtree:all-childs entry))
+          (xtree:append-child fragment
+                              (xtree:detach item)))
+        (clean-node fragment mode)
+        (html:serialize-html fragment :to-string)))))
 
-(defmethod clean ((html string) mode)
-  (html:with-parse-html-fragment (fragment html)
-    (clean fragment mode)
-    (html:serialize-html fragment :to-string)))
-
-(defmethod clean ((node xtree:node) mode)
+(defmethod clean-node ((node xtree:node) mode)
   (case (xtree:node-type node)
     (:xml-document-fragment-node
      (dolist (item (xtree:all-childs node))
-       (clean item mode)))
+       (clean-node item mode)))
     (:xml-text-node node)
     (:xml-cdata-section-node
      (xtree:replace-child node
@@ -33,17 +36,18 @@
 (defun clean-element (element mode
                       &aux (tagname (xtree:local-name element)))
   (dolist (node (xtree:all-childs element))
-    (clean node mode))
+    (clean-node node mode))
 
   (unless (element-allowed-p mode tagname)
-    (let ((w (whitespace-element-p mode tagname)))
+    (let ((w (whitespace-element-p mode tagname))
+          (child (xtree:all-childs element)))
       (when w
         (xtree:insert-child-before (xtree:make-text " ") element))
 
-      (dolist (node (xtree:all-childs element))
+      (dolist (node child)
         (xtree:insert-child-before (xtree:detach node) element))
 
-      (when w
+      (when (and w child)
         (xtree:insert-child-before (xtree:make-text " ") element))
 
       (xtree:remove-child element)
@@ -53,6 +57,17 @@
     (unless (attribute-allowed-p mode tagname (xtree:local-name attr))
       (xtree:remove-child attr)))
 
+  (let ((attr-protocols (element-protocols mode tagname)))
+    (dolist (attr (xtree:all-attribute-nodes element))
+      (let ((protocols (assoc (string-downcase (xtree:local-name attr))
+                              attr-protocols
+                              :test #'string-equal)))
+        (when (and protocols
+                   (not (ignore-errors (member (or (puri:uri-scheme (puri:parse-uri (xtree:text-content attr)))
+                                                   :relative)
+                                               protocols))))
+          (xtree:remove-child attr)))))
+
   (dolist (attr/value (element-additional-attributes mode tagname))
     (setf (xtree:attribute-value element (car attr/value))
           (cdr attr/value))))

src/mode.lisp

@@ -49,9 +49,12 @@
 
 (defun attribute-allowed-p (mode tagname attrname)
   (member attrname
-          (cdr (assoc tagname
-                      (mode-attributes mode)
-                      :test #'string-equal))
+          (concatenate 'list
+                       (cdr (assoc tagname
+                                   (mode-attributes mode)
+                                   :test #'string-equal))
+                       (cdr (assoc :all
+                                   (mode-attributes mode))))
           :test #'string-equal))
 
 (defun whitespace-element-p (mode tagname)
@@ -63,7 +66,11 @@
   (cdr (assoc tagname
               (mode-add-attributes mode)
               :test #'string-equal)))
-
+
+(defun element-protocols (mode tagname)
+  (cdr (assoc tagname
+              (mode-protocols mode)
+              :test #'string-equal)))
 
 (defmacro define-sanitize-mode (name &key
                                 allow-comments add-attributes attributes elements
@@ -94,9 +101,9 @@
 
     :add-attributes (("a" . (("rel" . "nofollow"))))
 
-    :protocols (("a"           . (("href" . ("ftp" "http" "https" "mailto" :relative))))
-                ("blockquote"  . (("cite" . ("http" "https" :relative))))
-                ("q"           . (("cite" . ("http" "https" :relative))))))
+    :protocols (("a"           . (("href" . (:ftp :http :https :mailto :relative))))
+                ("blockquote"  . (("cite" . (:http :https :relative))))
+                ("q"           . (("cite" . (:http :https :relative))))))
 
 
 (define-sanitize-mode +relaxed+
@@ -122,12 +129,12 @@
                  ("time"       . ("datetime" "pubdate"))
                  ("ul"         . ("type")))
 
-    :protocols (("a"           . (("href" . ("ftp" "http" "https" "mailto" :relative))))
-                ("blockquote"  . (("cite" . ("http" "https" :relative))))
-                ("del"         . (("cite" . ("http" "https" :relative))))
-                ("img"         . (("src"  . ("http" "https" :relative))))
-                ("ins"         . (("cite" . ("http" "https" :relative))))
-                ("q"           . (("cite" . ("http" "https" :relative))))))
+    :protocols (("a"           . (("href" . (:ftp :http :https :mailto :relative))))
+                ("blockquote"  . (("cite" . (:http :https :relative))))
+                ("del"         . (("cite" . (:http :https :relative))))
+                ("img"         . (("src"  . (:http :https :relative))))
+                ("ins"         . (("cite" . (:http :https :relative))))
+                ("q"           . (("cite" . (:http :https :relative))))))
 
 (define-sanitize-mode +restricted+
     :elements ("b" "em" "i" "strong" "u"))