<commit_before>(in-package :bknr.web)

(enable-interpol-syntax)

;; template expander

(defvar *template-expander*)
(defvar *template-env*)
(defparameter *template-dtd-catalog*
  (list (namestring (merge-pathnames #P"../../../../thirdparty/xhtml/catalog.xml" *load-pathname*))))

(eval-when (:load-toplevel :execute)
  (setf cxml:*catalog* (cxml:make-catalog *template-dtd-catalog*)
	cxml:*dtd-cache* (cxml:make-dtd-cache)
	cxml:*cache-all-dtds* t))

;; user-error is supposed to be raised when an error is provoked by
;; the user (i.e. by supplying invalid form data).

(define-condition user-error (simple-error)
  ())

(defun user-error (str &rest args)
  (error 'user-error :format-control str :format-arguments args))

;; template-not-found is raised when a template could not be found

(define-condition template-not-found (simple-error)
  ())

(defun template-not-found (&rest path)
  (error 'template-not-found :format-control "Template ~S not found" :format-arguments path))

(defclass template-expander ()
  ((command-packages :initarg :command-packages
		     :initform nil
		     :reader template-expander-command-packages)
   (destination :initarg :destination
		:reader template-expander-destination)
   (cached-templates :initform (make-hash-table :test 'equal)
                     :accessor template-expander-cached-templates)
   (default-template :initarg :default-template :initform nil
                     :reader template-expander-default-template
                     :documentation
                     "Name of the default template to use when no path
name has been specified.")))

(defmethod find-tag-function ((expander template-expander) name ns)
  (let ((package-name (cdr (find ns (template-expander-command-packages expander)
				 :test #'equal :key #'car)))
	(function-name (string-upcase name)))
    (or (gethash function-name (or (gethash (symbol-name package-name) *template-functions*)
				   (error "can't find package ~A in tag function registry" package-name)))
	(error "can't find tag function ~A:~A in command package ~A" ns name package-name))))

(defclass local-template-expander ()
  ((parent :initarg :parent :reader local-template-expander-parent)
   (functions :initform (make-hash-table :test #'equal) :reader local-template-expander-functions)))

(defmethod set-tag-function ((expander local-template-expander) name function)
  (setf (gethash name (local-template-expander-functions expander)) function))

(defmethod find-tag-function ((expander local-template-expander) name ns)
  (or (gethash name (local-template-expander-functions expander))
      (find-tag-function (local-template-expander-parent expander) name ns)))

(defmacro with-tag-expanders (tag-definitions &body body)
  `(let ((*template-expander* (make-instance 'local-template-expander :parent *template-expander*)))
     ,@(loop
	  for (name args body) in tag-definitions
	  collect `(set-tag-function *template-expander* (string-downcase (symbol-name ',name)) #'(lambda ,args ,body)))
     ,@body))

(defgeneric initial-template-environment (expander))

(defmethod initial-template-environment ((expander template-expander))
  (list* (mapcar #'(lambda (foo) (cons (make-keyword-from-string (car foo)) (cdr foo)))
                 (all-request-params))))

(defun get-template-var (var)
  (cdr (assoc var *template-env*)))

(defun (setf get-template-var) (newval var)
  (setf *template-env* (acons var newval *template-env*)))

;; xxx fixme setting variables has no effect on template-variables
(defmacro with-template-vars ((&rest vars) &body body)
  `(let (,@(loop for var in vars
                 collect
                   `(,var (get-template-var
                           ,(intern (symbol-name var) :keyword)))))
    ,@body))

(defun expand-variables (string lookup-variable)
  (if (find #\$ string)
      (regex-replace-all
       #?r"\$\(([\*_-\w]+)\)" string
       #'(lambda (target-string start end match-start match-end reg-starts reg-ends)
	   (declare (ignore start end match-start match-end))
	   (let* ((var (make-keyword-from-string
			(subseq target-string (aref reg-starts 0)
				(aref reg-ends 0))))
		  (val (funcall lookup-variable var)))
	     (cond
	       ((stringp val) val)
	       ((null val) "")
	       (t (format nil "~A" val))))))
      string))

(defun xmls-attributes-to-sax (fn attrs)
  (mapcar (lambda (a)
            (destructuring-bind (name value) a
	      (if (listp name)
		  (destructuring-bind (qname . namespace-uri) name
		    (sax:make-attribute :namespace-uri namespace-uri
					:qname qname
					:value (funcall fn value)
					:specified-p t))
		  (sax:make-attribute :qname name
				      :value (funcall fn value)
				      :specified-p t))))
	  attrs))

(defun parse-template (template-pathname)
  (let ((sax:*include-xmlns-attributes* t))
    (cxml:parse-file (namestring (probe-file template-pathname))
		     (cxml-xmls:make-xmls-builder)
                     :validate nil)))

(defvar *tag-children*)

(defun emit-tag-children ()
  "Function to be called by application defined tags to emit their children."
  (mapc (curry #'emit-template-node *template-expander*) *tag-children*))

(defun emit-template-node (expander node)
  (if (stringp node)
      (sax:characters *html-sink* (expand-variables node #'get-template-var))
      (let* ((name (node-name node))
             (ns (node-ns node))
             (children (node-children node))
             (attrs (cxml-xmls:node-attrs node))
             (ns-handler-package (and ns (find ns (template-expander-command-packages expander)
                                               :test #'equal :key #'car))))
        (cond
          (ns-handler-package
	   (let ((*tag-children* children))
	     (apply (find-tag-function expander name ns)
		    (append (loop for (key name) in attrs
                                  unless (consp key) ; ignore attributes with namespace
				  collect (make-keyword-from-string key)
                                  and collect (expand-variables name #'get-template-var))))))
          (t
           (sax:start-element *html-sink* nil nil name
                              (xmls-attributes-to-sax (rcurry #'expand-variables #'get-template-var) attrs))
           (dolist (child children)
             (emit-template-node expander child))
           (sax:end-element *html-sink* nil nil name))))))

(defun emit-parsed-template (expander toplevel)
  "Emit the given XMLS compatible structure as XML to *HTML-SINK*."
  ;; In order to generate xmlns attributes, we use the internal
  ;; CXML-XMLS::COMPUTE-ATTRIBUTES/LNAMES function.  This may need to
  ;; be revised with newer cxml releases.
  (sax:start-element *html-sink* (node-ns toplevel) (node-name toplevel) (node-name toplevel)
		     (cxml-xmls::compute-attributes/lnames toplevel t))
  (let ((*template-expander* expander))
    (emit-template-node expander toplevel))
  (sax:end-element *html-sink* (node-ns toplevel) (node-name toplevel) (node-name toplevel)))

(defun find-template (dir components)
  (if (null components)
      nil
      (let ((next-dir (merge-pathnames (make-pathname :directory (list :relative (first components)))
				       dir)))
	(when (probe-file next-dir)
	  (let ((result (multiple-value-list (find-template next-dir (cdr components)))))
	    (when (car result)
	      (return-from find-template (values-list result)))))
	(let ((file (merge-pathnames (make-pathname :type "xml"
						    :name (first components))
				     dir)))
	  (when (probe-file file)
	    (values file (cdr components)))))))

(defun split-path (path)
  "Split path into its components and return them as list.  Empty components are removed."
  (remove "" (split "/" path) :test #'equal))
<commit_msg>Fix bug that caused top-level element of a template to be output two times.<commit_after>(in-package :bknr.web)

(enable-interpol-syntax)

;; template expander

(defvar *template-expander*)
(defvar *template-env*)
(defparameter *template-dtd-catalog*
  (list (namestring (merge-pathnames #P"../../../../thirdparty/xhtml/catalog.xml" *load-pathname*))))

(eval-when (:load-toplevel :execute)
  (setf cxml:*catalog* (cxml:make-catalog *template-dtd-catalog*)
	cxml:*dtd-cache* (cxml:make-dtd-cache)
	cxml:*cache-all-dtds* t))

;; user-error is supposed to be raised when an error is provoked by
;; the user (i.e. by supplying invalid form data).

(define-condition user-error (simple-error)
  ())

(defun user-error (str &rest args)
  (error 'user-error :format-control str :format-arguments args))

;; template-not-found is raised when a template could not be found

(define-condition template-not-found (simple-error)
  ())

(defun template-not-found (&rest path)
  (error 'template-not-found :format-control "Template ~S not found" :format-arguments path))

(defclass template-expander ()
  ((command-packages :initarg :command-packages
		     :initform nil
		     :reader template-expander-command-packages)
   (destination :initarg :destination
		:reader template-expander-destination)
   (cached-templates :initform (make-hash-table :test 'equal)
                     :accessor template-expander-cached-templates)
   (default-template :initarg :default-template :initform nil
                     :reader template-expander-default-template
                     :documentation
                     "Name of the default template to use when no path
name has been specified.")))

(defmethod find-tag-function ((expander template-expander) name ns)
  (let ((package-name (cdr (find ns (template-expander-command-packages expander)
				 :test #'equal :key #'car)))
	(function-name (string-upcase name)))
    (or (gethash function-name (or (gethash (symbol-name package-name) *template-functions*)
				   (error "can't find package ~A in tag function registry" package-name)))
	(error "can't find tag function ~A:~A in command package ~A" ns name package-name))))

(defclass local-template-expander ()
  ((parent :initarg :parent :reader local-template-expander-parent)
   (functions :initform (make-hash-table :test #'equal) :reader local-template-expander-functions)))

(defmethod set-tag-function ((expander local-template-expander) name function)
  (setf (gethash name (local-template-expander-functions expander)) function))

(defmethod find-tag-function ((expander local-template-expander) name ns)
  (or (gethash name (local-template-expander-functions expander))
      (find-tag-function (local-template-expander-parent expander) name ns)))

(defmacro with-tag-expanders (tag-definitions &body body)
  `(let ((*template-expander* (make-instance 'local-template-expander :parent *template-expander*)))
     ,@(loop
	  for (name args body) in tag-definitions
	  collect `(set-tag-function *template-expander* (string-downcase (symbol-name ',name)) #'(lambda ,args ,body)))
     ,@body))

(defgeneric initial-template-environment (expander))

(defmethod initial-template-environment ((expander template-expander))
  (list* (mapcar #'(lambda (foo) (cons (make-keyword-from-string (car foo)) (cdr foo)))
                 (all-request-params))))

(defun get-template-var (var)
  (cdr (assoc var *template-env*)))

(defun (setf get-template-var) (newval var)
  (setf *template-env* (acons var newval *template-env*)))

;; xxx fixme setting variables has no effect on template-variables
(defmacro with-template-vars ((&rest vars) &body body)
  `(let (,@(loop for var in vars
                 collect
                   `(,var (get-template-var
                           ,(intern (symbol-name var) :keyword)))))
    ,@body))

(defun expand-variables (string lookup-variable)
  (if (find #\$ string)
      (regex-replace-all
       #?r"\$\(([\*_-\w]+)\)" string
       #'(lambda (target-string start end match-start match-end reg-starts reg-ends)
	   (declare (ignore start end match-start match-end))
	   (let* ((var (make-keyword-from-string
			(subseq target-string (aref reg-starts 0)
				(aref reg-ends 0))))
		  (val (funcall lookup-variable var)))
	     (cond
	       ((stringp val) val)
	       ((null val) "")
	       (t (format nil "~A" val))))))
      string))

(defun xmls-attributes-to-sax (fn attrs)
  (mapcar (lambda (a)
            (destructuring-bind (name value) a
	      (if (listp name)
		  (destructuring-bind (qname . namespace-uri) name
		    (sax:make-attribute :namespace-uri namespace-uri
					:qname qname
					:value (funcall fn value)
					:specified-p t))
		  (sax:make-attribute :qname name
				      :value (funcall fn value)
				      :specified-p t))))
	  attrs))

(defun parse-template (template-pathname)
  (let ((sax:*include-xmlns-attributes* t))
    (cxml:parse-file (namestring (probe-file template-pathname))
		     (cxml-xmls:make-xmls-builder)
                     :validate nil)))

(defvar *tag-children*)

(defun emit-tag-children ()
  "Function to be called by application defined tags to emit their children."
  (mapc (curry #'emit-template-node *template-expander*) *tag-children*))

(defun emit-template-node (expander node)
  (if (stringp node)
      (sax:characters *html-sink* (expand-variables node #'get-template-var))
      (let* ((name (node-name node))
             (ns (node-ns node))
             (children (node-children node))
             (attrs (cxml-xmls:node-attrs node))
             (ns-handler-package (and ns (find ns (template-expander-command-packages expander)
                                               :test #'equal :key #'car))))
        (cond
          (ns-handler-package
	   (let ((*tag-children* children))
	     (apply (find-tag-function expander name ns)
		    (append (loop for (key name) in attrs
                                  unless (consp key) ; ignore attributes with namespace
				  collect (make-keyword-from-string key)
                                  and collect (expand-variables name #'get-template-var))))))
          (t
           (sax:start-element *html-sink* nil nil name
                              (xmls-attributes-to-sax (rcurry #'expand-variables #'get-template-var) attrs))
           (dolist (child children)
             (emit-template-node expander child))
           (sax:end-element *html-sink* nil nil name))))))

(defun emit-parsed-template (expander toplevel)
  "Emit the given XMLS compatible structure as XML to *HTML-SINK*."
  ;; In order to generate xmlns attributes, we use the internal
  ;; CXML-XMLS::COMPUTE-ATTRIBUTES/LNAMES function.  This may need to
  ;; be revised with newer cxml releases.
  (sax:start-element *html-sink* (node-ns toplevel) (node-name toplevel) (node-name toplevel)
		     (cxml-xmls::compute-attributes/lnames toplevel t))
  (let ((*template-expander* expander))
    (dolist (node (node-children toplevel))
      (emit-template-node expander node)))
  (sax:end-element *html-sink* (node-ns toplevel) (node-name toplevel) (node-name toplevel)))

(defun find-template (dir components)
  (if (null components)
      nil
      (let ((next-dir (merge-pathnames (make-pathname :directory (list :relative (first components)))
				       dir)))
	(when (probe-file next-dir)
	  (let ((result (multiple-value-list (find-template next-dir (cdr components)))))
	    (when (car result)
	      (return-from find-template (values-list result)))))
	(let ((file (merge-pathnames (make-pathname :type "xml"
						    :name (first components))
				     dir)))
	  (when (probe-file file)
	    (values file (cdr components)))))))

(defun split-path (path)
  "Split path into its components and return them as list.  Empty components are removed."
  (remove "" (split "/" path) :test #'equal))

{'fraction_non_alphanumeric': 0.13929099916361062, 'fraction_numerical': 0.0002573505758219134, 'mean_word_length': 3.1089082738567275, 'pattern_counts': {'":': 0, '<': 3, '<?xml version=': 0, '>': 3, 'https://': 0, 'lorem ipsum': 0, 'www.': 0, 'xml': 40}, 'pii_count': 0, 'substrings_counts': 0, 'word_list_counts': {'cursed_substrings.json': 10, 'profanity_word_list.json': 0, 'sexual_word_list.json': 0, 'zh_pornsignals.json': 0}}
{'dir': 'git-commits-cleaned', 'id': '1438815', 'n_tokens_mistral': 5016, 'n_tokens_neox': 4775, 'n_words': 1347}