My WIP Org-roam publish setup

zk-publish.el

;; I'm not quite sure why this isn't in by default :-/
;; Possibly the ambiguous list-head modifying specification?
(gv-define-simple-setter plist-get plist-put)

(defun my-format-drawer (name contents &rest args?)
  (if (string= name "TRANSCRIPTION")
      (let ((h (format "%x" (sxhash contents))))
        (concat
         "<a id=\"show-" h "\" "
         "onclick='"
         "document.getElementById(\"ts-" h "\").style.display = \"block\"; "
         "document.getElementById(\"show-" h "\").style.display = \"none\"; "
         "document.getElementById(\"hide-" h "\").style.display = null; "
         "return false;' "
         "href=\"#ts-" h "\">"
         "[show transcript]"
         "</a>"
         "<a id=\"hide-" h "\" "
         "onclick='"
         "document.getElementById(\"ts-" h "\").style.display = \"none\"; "
         "document.getElementById(\"show-" h "\").style.display = null; "
         "document.getElementById(\"hide-" h "\").style.display = \"none\"; "
         "return false;' "
         "style='display: none;' "
         "href=\"#show-" h "\">"
         "[hide transcript]"
         "</a>"
         "<div id='ts-" h "' style='display: none;'>"
         contents
         "</div>"))
    (apply org-html-format-drawer-function name contents args?)))

(let ((zk-prj
       '("zk"
         :components ("zk-notes" "zk-static")))

      (zk-notes
       '("zk-notes"
         :filter-parse-tree my-org-publish-attachment-filter
         :base-directory "~/Documents/ZK"
         :base-extension "org"
         :with-toc nil
         :html-doctype "html5"
         :html-html5-fancy t
         :auto-sitemap t
         :publishing-directory "~/tmp"
         :publishing-function org-html-publish-to-html))

      (zk-static
       '("zk-static"
         :base-directory "~/Documents/ZK"
         :base-extension "png"
         :publishing-directory "~/tmp"
         :publishing-function org-publish-attachment)))
  (setf (plist-get (cdr zk-notes) :html-format-drawer-function) #'my-format-drawer)
  (setq org-publish-project-alist (list zk-prj zk-notes zk-static)))

(defun my-org-publish-attachment-relative (plist filepath pub-dir)
  "Like `org-publish-attachment', but keep the attachment's relative path."
  (when (file-name-absolute-p filepath)
    ;; is absolute path, make relative again
    (setq filepath (org-publish-file-relative-name filepath plist)))
  (let* ((path (file-name-directory filepath))
         (pub-dir-deep (concat (file-name-as-directory pub-dir) path)))
    (org-publish-attachment plist filepath pub-dir-deep)))

(defun my-org-attach-file-dir-of (element)
  "Helper: return the attachment directory of a provided Org Element."
  (let ((pos (org-element-property :begin element)))
    (file-name-as-directory
     (save-excursion (goto-char pos) (org-attach-dir)))))

(defun my-org-publish-attachment-filter (tree backend plist)
  "Tree filter to scan for attachments and publish them in the
same relative directory they come from.  Returns the unchanged
tree.

To be used as a :filter-parse-tree in the
`org-publish-project-alist'."
  (let ((pub-dir (plist-get plist :publishing-directory)))
    (org-element-map tree 'headline
      (lambda (hl)
        (and (member "ATTACH" (org-element-property :tags hl))
             (let* ((dir (my-org-attach-file-dir-of hl))
                    (files (org-attach-file-list dir)))
               (dolist (file files)
                 (my-org-publish-attachment-relative
                  plist (expand-file-name file dir) pub-dir))))))
    (org-element-map tree 'link
      (lambda (link)
        (when (string= "attachment" (org-element-property :type link))
          (let* ((dir (my-org-attach-file-dir-of link))
                 (file (org-element-property :path link)))
            (org-element-put-property link :type "file")
            (org-element-put-property link :path (concat dir file)))))))
  tree)

(defvar my-attach-link nil
  "The attachment link target currently in scope, nil when none.")

(defun my-ox-html-attach-headline (old-func headline contents info &rest args)
  "Set `my-attach-link' to the attachment target location for the
scope of `org-html-headline'.

Intended as advice on `org-html-headline'."
  (if (member "ATTACH" (org-element-property :tags headline))
      (let* ((dir (my-org-attach-file-dir-of headline))
             (files (org-attach-file-list dir))
             (my-attach-link (concat "file:"
                                     (org-publish-file-relative-name
                                      (cond ((cdr files) dir)
                                            ((concat dir (car files))))
                                      info))))
        (apply old-func headline contents info args))
    (apply old-func headline contents info args)))
(advice-add 'org-html-headline :around #'my-ox-html-attach-headline)

(defun my-make-link (dest text)
  "Make an Org link element from a destination"
  (with-temp-buffer
    (save-excursion (insert (org-link-make-string dest text)))
    (org-element-link-parser)))

(defun my-ox-html-attach-tag (arglist)
  "Replace an ATTACH tag string with an HTML link.

Intended as advice on `org-html--tags'.

The link is to be setup in dynamic variable `my-attach-link' by
the `my-ox-html-attach-headline' advice."
  (let ((tags (car arglist))
        (info (cadr arglist)))
    (list
     (mapcar (lambda (tag)
               (if (string= tag "ATTACH")
                   (org-html-link (my-make-link my-attach-link tag)
                                  "ATTACH"
                                  (cons '(:html-inline-image-rules nil) info))
                 tag))
             tags)
     info)))
(advice-add 'org-html--tags :filter-args #'my-ox-html-attach-tag)