emacs lisp script to turn org-roam notes into blog posts
with acceptance tests
This commit is contained in:
Firehose Bot
@@ -0,0 +1,453 @@
|
||||
;;; roam-export-blog.el --- Export an org-roam note as a firehose blog post -*- lexical-binding: t; -*-
|
||||
|
||||
;;; Commentary:
|
||||
|
||||
;; M-x roam-export-blog, run from an org-roam note, converts the note to
|
||||
;; markdown and writes it directly into the firehose repo as a draft post:
|
||||
;;
|
||||
;; <repo>/app/priv/blog/engineering/<YYYY>/<MM>-<DD>-<slug>.md
|
||||
;;
|
||||
;; with `published: false' frontmatter, so the repo's git diff acts as the
|
||||
;; review mechanism.
|
||||
;;
|
||||
;; What happens during export:
|
||||
;;
|
||||
;; - `[[id:<uuid>][text]]' roam refs are resolved via org-id. When the
|
||||
;; target note carries a :ROAM_REFS: property, the link becomes a
|
||||
;; markdown link to the first URL; otherwise it degrades to plain text.
|
||||
;; - `[[attachment:...]]' links are resolved via the org-attach ID scheme
|
||||
;; (.attach/<xx>/<rest-of-id>/<file>). Images are copied into
|
||||
;; app/priv/static/images/blog/<YYYY>/ and referenced with the
|
||||
;; /images/blog/... web path. Non-image attachments are ignored.
|
||||
;; - Org syntax is converted to markdown with a derived ox-md backend
|
||||
;; (fenced code blocks with language, H2 top-level headings, no TOC).
|
||||
;; - Dropped refs, ignored attachments and unhandled constructs are
|
||||
;; reported as warnings.
|
||||
|
||||
;;; Code:
|
||||
|
||||
(require 'org)
|
||||
(require 'ox-md)
|
||||
(require 'org-id)
|
||||
(require 'cl-lib)
|
||||
|
||||
(defgroup roam-export-blog nil
|
||||
"Export org-roam notes as firehose blog posts."
|
||||
:group 'org)
|
||||
|
||||
(defcustom roam-export-blog-firehose-root "/Users/willem/dev/elixir/firehose"
|
||||
"Path to the firehose repository root."
|
||||
:type 'directory)
|
||||
|
||||
(defcustom roam-export-blog-author "Willem van den Ende"
|
||||
"Author name written into generated frontmatter."
|
||||
:type 'string)
|
||||
|
||||
(defcustom roam-export-blog-description-length 200
|
||||
"Maximum length of the generated description (before the ellipsis)."
|
||||
:type 'integer)
|
||||
|
||||
(defcustom roam-export-blog-image-extensions
|
||||
'("svg" "png" "jpg" "jpeg" "gif" "webp" "avif")
|
||||
"Attachment extensions that count as images."
|
||||
:type '(repeat string))
|
||||
|
||||
(defvar roam-export-blog--current-date nil
|
||||
"Override for the export date during tests, as a list (YEAR MONTH DAY).")
|
||||
|
||||
;;; Derived markdown backend
|
||||
|
||||
(defun roam-export-blog-md-src-block (src-block _contents info)
|
||||
"Transcode SRC-BLOCK into a fenced markdown code block with language."
|
||||
(let ((lang (org-element-property :language src-block))
|
||||
(value (org-export-format-code-default src-block info)))
|
||||
(concat "```" (or lang "") "\n" value "```")))
|
||||
|
||||
(defun roam-export-blog-md-link (link desc info)
|
||||
"Transcode LINK; file links to images become markdown images.
|
||||
|
||||
Everything else is delegated to `org-md-link'."
|
||||
(let* ((type (org-element-property :type link))
|
||||
(path (org-element-property :path link)))
|
||||
(if (and (equal type "file") (roam-export-blog--image-p path))
|
||||
(format ""
|
||||
(or (and desc (string-trim (substring-no-properties desc)))
|
||||
(file-name-base path))
|
||||
path)
|
||||
(org-md-link link desc info))))
|
||||
|
||||
(org-export-define-derived-backend 'firehose-md 'md
|
||||
:translate-alist '((src-block . roam-export-blog-md-src-block)
|
||||
(link . roam-export-blog-md-link)))
|
||||
|
||||
(defconst roam-export-blog--export-options
|
||||
'(:with-toc nil :section-numbers nil :md-toplevel-hlevel 2))
|
||||
|
||||
;;; Small helpers
|
||||
|
||||
(defun roam-export-blog--slug (title)
|
||||
"Derive a filename slug from TITLE."
|
||||
(let* ((lower (downcase title))
|
||||
(slugged (replace-regexp-in-string "[^a-z0-9]+" "-" lower)))
|
||||
(replace-regexp-in-string "\\`-+\\|-+\\'" "" slugged)))
|
||||
|
||||
(defun roam-export-blog--date-parts ()
|
||||
"Export date as a list of strings (YEAR MONTH DAY)."
|
||||
(or roam-export-blog--current-date
|
||||
(list (format-time-string "%Y")
|
||||
(format-time-string "%m")
|
||||
(format-time-string "%d"))))
|
||||
|
||||
(defun roam-export-blog--escape-elixir-string (text)
|
||||
"Escape TEXT for embedding in an Elixir double-quoted string."
|
||||
(replace-regexp-in-string
|
||||
"\"" "\\\\\""
|
||||
(replace-regexp-in-string "\\\\" "\\\\\\\\" text)))
|
||||
|
||||
(defun roam-export-blog--truncate-description (text)
|
||||
"Truncate TEXT to about `roam-export-blog-description-length' characters."
|
||||
(let ((max roam-export-blog-description-length))
|
||||
(if (<= (length text) max)
|
||||
text
|
||||
(let ((cut (cl-position ?\s (substring text 0 max) :from-end t)))
|
||||
(concat (if cut (substring text 0 cut) (substring text 0 max))
|
||||
"…")))))
|
||||
|
||||
(defun roam-export-blog--plain-text (element)
|
||||
"Return a plain-text approximation of org ELEMENT."
|
||||
(cond
|
||||
((stringp element) element)
|
||||
((memq (org-element-type element) '(code verbatim inline-src-block))
|
||||
(or (org-element-property :value element) ""))
|
||||
((eq (org-element-type element) 'entity)
|
||||
(or (org-element-property :utf8 element) ""))
|
||||
(t (mapconcat #'roam-export-blog--plain-text (org-element-contents element) ""))))
|
||||
|
||||
;;; Reading the note
|
||||
|
||||
(defun roam-export-blog--title (buffer)
|
||||
"Return the #+TITLE: keyword value in BUFFER, or nil."
|
||||
(with-current-buffer buffer
|
||||
(cadr (assoc "TITLE" (org-collect-keywords '("TITLE"))))))
|
||||
|
||||
(defun roam-export-blog--first-paragraph-text (buffer)
|
||||
"Return the plain text of the first paragraph in BUFFER."
|
||||
(with-current-buffer buffer
|
||||
(let ((para (org-element-map (org-element-parse-buffer) 'paragraph
|
||||
#'identity nil t)))
|
||||
(when para
|
||||
(replace-regexp-in-string
|
||||
"[ \t\n]+" " "
|
||||
(string-trim
|
||||
(substring-no-properties (roam-export-blog--plain-text para))))))))
|
||||
|
||||
(defun roam-export-blog--roam-refs (file)
|
||||
"Return the first :ROAM_REFS: URL of the note in FILE, or nil."
|
||||
(with-current-buffer (find-file-noselect file)
|
||||
(org-with-wide-buffer
|
||||
(goto-char (point-min))
|
||||
(let ((value (org-entry-get (point) "ROAM_REFS")))
|
||||
(when value (car (split-string value "[ \t]+")))))))
|
||||
|
||||
(defun roam-export-blog--note-title (file)
|
||||
"Return the #+TITLE: of the note in FILE, or nil."
|
||||
(roam-export-blog--title (find-file-noselect file)))
|
||||
|
||||
;;; Link processing
|
||||
|
||||
(defun roam-export-blog--vault-attach-dir (file)
|
||||
"Return the .attach directory dominating FILE, or nil."
|
||||
(when-let* ((root (locate-dominating-file file ".attach")))
|
||||
(expand-file-name ".attach" root)))
|
||||
|
||||
(defun roam-export-blog--image-p (file)
|
||||
"Return non-nil when FILE looks like an image attachment."
|
||||
(member (downcase (file-name-extension file))
|
||||
roam-export-blog-image-extensions))
|
||||
|
||||
(defun roam-export-blog--link-description (link)
|
||||
"Return the description text of LINK, or nil."
|
||||
(let ((begin (org-element-property :contents-begin link))
|
||||
(end (org-element-property :contents-end link)))
|
||||
(when (and begin end)
|
||||
(buffer-substring-no-properties begin end))))
|
||||
|
||||
(defun roam-export-blog--desc-or (desc fallback)
|
||||
"Return trimmed DESC, or FALLBACK when DESC is nil or empty.
|
||||
|
||||
An empty string is truthy in Elisp, so descriptions must be
|
||||
treated as absent explicitly."
|
||||
(let ((trimmed (when desc (string-trim desc))))
|
||||
(if (and trimmed (not (string-empty-p trimmed)))
|
||||
trimmed
|
||||
fallback)))
|
||||
|
||||
(defun roam-export-blog--desc-verbatim-or (desc fallback)
|
||||
"Return DESC unchanged, or FALLBACK when DESC is nil or blank.
|
||||
|
||||
Used for plain-text replacements: a description like \"Jev \"
|
||||
may carry the spacing that separated it from surrounding text in
|
||||
the org source."
|
||||
(if (and desc (not (string-empty-p (string-trim desc))))
|
||||
desc
|
||||
fallback))
|
||||
|
||||
(defun roam-export-blog--attachment-path (link vault-attach-dir note-id)
|
||||
"Return the absolute source path of attachment LINK, or nil.
|
||||
|
||||
Handles three shapes: file links already normalized by org to an
|
||||
absolute path under the vault's .attach directory, plain
|
||||
attachment: links and fuzzy links carrying an attachment: prefix.
|
||||
Resolution follows the org-attach ID scheme:
|
||||
.attach/<first two ID chars>/<rest of ID>/<path>."
|
||||
(let* ((type (org-element-property :type link))
|
||||
(path (org-element-property :path link))
|
||||
(bare (if (and (equal type "fuzzy")
|
||||
(string-prefix-p "attachment:" path))
|
||||
(substring path (length "attachment:"))
|
||||
path)))
|
||||
(cond
|
||||
((and (equal type "file") (file-name-absolute-p path)
|
||||
vault-attach-dir
|
||||
(string-prefix-p vault-attach-dir (expand-file-name path)))
|
||||
(expand-file-name path))
|
||||
((and vault-attach-dir note-id bare
|
||||
(>= (length note-id) 2))
|
||||
(let ((candidate (expand-file-name
|
||||
(concat (substring note-id 0 2)
|
||||
"/" (substring note-id 2)
|
||||
"/" bare)
|
||||
vault-attach-dir)))
|
||||
(when (file-exists-p candidate) candidate)))
|
||||
(t nil))))
|
||||
|
||||
(defun roam-export-blog--resolve-id (id)
|
||||
"Return the file containing org ID, or nil."
|
||||
(ignore-errors (org-id-find id)))
|
||||
|
||||
(defun roam-export-blog--link-replacement (link vault-attach-dir note-id)
|
||||
"Compute the replacement for LINK.
|
||||
|
||||
Return (REPLACEMENT WARNINGS IMAGES), where REPLACEMENT is org
|
||||
syntax to substitute for the link (nil leaves the link alone),
|
||||
WARNINGS is a list of warning strings and IMAGES is a list of
|
||||
(SOURCE . DEST) file copies to perform."
|
||||
(let* ((type (org-element-property :type link))
|
||||
(path (org-element-property :path link))
|
||||
(desc (roam-export-blog--link-description link))
|
||||
(replacement nil)
|
||||
(warnings nil)
|
||||
(images nil))
|
||||
(cond
|
||||
;; Roam refs: [[id:uuid][text]]
|
||||
((equal type "id")
|
||||
(let* ((target (roam-export-blog--resolve-id path))
|
||||
(refs (when target (roam-export-blog--roam-refs (car target))))) (cond
|
||||
((and target refs)
|
||||
(setq replacement (format "[[%s][%s]]"
|
||||
refs (roam-export-blog--desc-or desc refs))))
|
||||
(target
|
||||
(setq replacement (roam-export-blog--desc-verbatim-or
|
||||
desc (or (roam-export-blog--note-title (car target))
|
||||
"")))
|
||||
(push (format "dropped ref: id %s has no ROAM_REFS, kept plain text %S"
|
||||
path replacement)
|
||||
warnings))
|
||||
(t
|
||||
(setq replacement (roam-export-blog--desc-verbatim-or desc ""))
|
||||
(push (format "dropped ref: unresolved id %s, kept plain text %S"
|
||||
path replacement)
|
||||
warnings)))))
|
||||
;; Attachments (and file links that org normalized from attachments)
|
||||
((and vault-attach-dir
|
||||
(or (member type '("file" "attachment"))
|
||||
(and (equal type "fuzzy")
|
||||
(string-prefix-p "attachment:" path))))
|
||||
(let ((source (roam-export-blog--attachment-path link vault-attach-dir note-id)))
|
||||
(cond
|
||||
((and source (file-exists-p source) (roam-export-blog--image-p source))
|
||||
(let* ((name (file-name-nondirectory source))
|
||||
(year (car (roam-export-blog--date-parts)))
|
||||
(web-path (format "/images/blog/%s/%s" year name))
|
||||
(dest (expand-file-name
|
||||
(format "app/priv/static/images/blog/%s/%s" year name)
|
||||
roam-export-blog-firehose-root)))
|
||||
(setq images (list (cons source dest)))
|
||||
(setq replacement
|
||||
(format "[[file:%s][%s]]" web-path
|
||||
(roam-export-blog--desc-or desc
|
||||
(file-name-base name))))))
|
||||
((and source (file-exists-p source))
|
||||
(setq replacement (roam-export-blog--desc-verbatim-or desc ""))
|
||||
(push (format "ignored attachment (not an image): %s"
|
||||
(file-name-nondirectory source))
|
||||
warnings))
|
||||
(t
|
||||
(setq replacement (roam-export-blog--desc-verbatim-or desc ""))
|
||||
(push (format "unhandled link dropped: %s:%s" type path)
|
||||
warnings)))))
|
||||
;; Any other file: link points into the vault, not the blog.
|
||||
((equal type "file")
|
||||
(setq replacement (roam-export-blog--desc-verbatim-or desc ""))
|
||||
(push (format "unhandled link dropped: file:%s" path) warnings))
|
||||
;; Everything else (https, mailto, ...) passes through untouched.
|
||||
(t nil))
|
||||
(list replacement warnings images)))
|
||||
|
||||
(defun roam-export-blog--process-links (buffer vault-attach-dir)
|
||||
"Rewrite id/attachment/file links in BUFFER's text.
|
||||
|
||||
BUFFER is not modified; a processed copy of its text is returned.
|
||||
Return (TEXT WARNINGS IMAGES) where IMAGES is an alist of
|
||||
(SOURCE . DEST) image copies to perform."
|
||||
(with-current-buffer buffer
|
||||
(let ((text (buffer-string))
|
||||
(note-id (org-entry-get (point-min) "ID"))
|
||||
(warnings nil)
|
||||
(all-images nil))
|
||||
(let* ((tree (org-element-parse-buffer))
|
||||
(replacements
|
||||
(reverse
|
||||
(org-element-map tree 'link
|
||||
(lambda (link)
|
||||
(let* ((result (roam-export-blog--link-replacement
|
||||
link vault-attach-dir note-id))
|
||||
(replacement (nth 0 result))
|
||||
(warns (nth 1 result))
|
||||
(images (nth 2 result)))
|
||||
(setq warnings (append warnings warns)
|
||||
all-images (append all-images images))
|
||||
(when replacement
|
||||
(list (org-element-property :begin link)
|
||||
;; :end includes :post-blank (trailing
|
||||
;; whitespace); exclude it from the
|
||||
;; replaced region.
|
||||
(- (org-element-property :end link)
|
||||
(or (org-element-property :post-blank link) 0))
|
||||
replacement))))
|
||||
nil nil nil))))
|
||||
(dolist (r replacements)
|
||||
(let ((begin (nth 0 r))
|
||||
(end (nth 1 r))
|
||||
(replacement (nth 2 r)))
|
||||
(setq text (concat (substring text 0 (1- begin))
|
||||
replacement
|
||||
(substring text (1- end))))))
|
||||
(list text warnings all-images)))))
|
||||
|
||||
;;; Markdown generation
|
||||
|
||||
(defun roam-export-blog--to-markdown (text)
|
||||
"Export org TEXT to markdown with the firehose-md backend."
|
||||
(with-temp-buffer
|
||||
(insert text)
|
||||
(org-mode)
|
||||
(let ((out (org-export-to-buffer
|
||||
'firehose-md "*roam-export-blog export*"
|
||||
nil nil nil nil roam-export-blog--export-options)))
|
||||
(with-current-buffer out (buffer-string)))))
|
||||
|
||||
(defun roam-export-blog--cleanup (markdown)
|
||||
"Collapse runs of blank lines in MARKDOWN."
|
||||
(replace-regexp-in-string "\n\\(?:[ \t]*\n\\)+\\'" "\n"
|
||||
(replace-regexp-in-string "\n\\{3,\\}" "\n\n" markdown)))
|
||||
|
||||
;;; Frontmatter and writing
|
||||
|
||||
(defun roam-export-blog--frontmatter (title description image)
|
||||
"Build the Elixir-term frontmatter for the post."
|
||||
(concat "%{\n"
|
||||
(format " title: %S,\n" (roam-export-blog--escape-elixir-string title))
|
||||
(format " author: %S,\n" roam-export-blog-author)
|
||||
" tags: ~w(),\n"
|
||||
(format " description: %S,\n"
|
||||
(roam-export-blog--escape-elixir-string description))
|
||||
(format " image: %S,\n" image)
|
||||
" published: false\n"
|
||||
"}\n---\n"))
|
||||
|
||||
(defun roam-export-blog--post-path (slug)
|
||||
"Return the target post path for SLUG."
|
||||
(let ((year (car (roam-export-blog--date-parts)))
|
||||
(month (nth 1 (roam-export-blog--date-parts)))
|
||||
(day (nth 2 (roam-export-blog--date-parts))))
|
||||
(expand-file-name
|
||||
(format "app/priv/blog/engineering/%s/%s-%s-%s.md" year month day slug)
|
||||
roam-export-blog-firehose-root)))
|
||||
|
||||
(defun roam-export-blog--copy-images (images)
|
||||
"Copy IMAGES (alist of SOURCE . DEST), warning on basename clashes."
|
||||
(let ((copied nil)
|
||||
(warnings nil))
|
||||
(dolist (pair images)
|
||||
(let ((source (car pair))
|
||||
(dest (cdr pair)))
|
||||
(cond
|
||||
((member dest copied)
|
||||
(push (format "skipped duplicate image copy: %s"
|
||||
(file-name-nondirectory source))
|
||||
warnings))
|
||||
(t
|
||||
(make-directory (file-name-directory dest) t)
|
||||
(copy-file source dest t)
|
||||
(push dest copied)))))
|
||||
(nreverse warnings)))
|
||||
|
||||
;;; The command
|
||||
|
||||
(defun roam-export-blog--export-file (&optional file)
|
||||
"Export org-roam note FILE to a firehose blog post.
|
||||
|
||||
Return (OUTPUT-PATH . WARNINGS). Abort with `user-error' when the
|
||||
note has no title or the target file already exists."
|
||||
(setq file (or file (buffer-file-name)))
|
||||
(unless file
|
||||
(user-error "roam-export-blog: not visiting a file"))
|
||||
(let* ((buffer (find-file-noselect file))
|
||||
(title (roam-export-blog--title buffer)))
|
||||
(unless title
|
||||
(user-error "roam-export-blog: %s has no #+title: keyword, aborting" file))
|
||||
(let* ((slug (roam-export-blog--slug title))
|
||||
(post-path (roam-export-blog--post-path slug)))
|
||||
(when (file-exists-p post-path)
|
||||
(user-error "roam-export-blog: %s already exists, aborting" post-path))
|
||||
(let* ((processed (roam-export-blog--process-links
|
||||
buffer (roam-export-blog--vault-attach-dir file)))
|
||||
(text (nth 0 processed))
|
||||
(link-warnings (nth 1 processed))
|
||||
(images (nth 2 processed))
|
||||
(copy-warnings (roam-export-blog--copy-images images))
|
||||
(warnings (append (nreverse link-warnings) copy-warnings))
|
||||
(image (when images
|
||||
(let ((static (expand-file-name
|
||||
"app/priv/static"
|
||||
roam-export-blog-firehose-root)))
|
||||
(string-remove-prefix static (cdr (car images))))))
|
||||
(description (roam-export-blog--truncate-description
|
||||
(roam-export-blog--first-paragraph-text buffer)))
|
||||
(markdown (roam-export-blog--cleanup (roam-export-blog--to-markdown text))))
|
||||
(make-directory (file-name-directory post-path) t)
|
||||
(with-temp-file post-path
|
||||
(insert (roam-export-blog--frontmatter title description image)
|
||||
markdown))
|
||||
(cons post-path warnings)))))
|
||||
|
||||
;;;###autoload
|
||||
(defun roam-export-blog ()
|
||||
"Export the current org-roam note as a firehose blog post."
|
||||
(interactive)
|
||||
(let ((result (roam-export-blog--export-file (buffer-file-name))))
|
||||
(let ((path (car result))
|
||||
(warnings (cdr result)))
|
||||
(message "roam-export-blog: wrote %s%s" path
|
||||
(if warnings
|
||||
(format " (%d warning%s)" (length warnings)
|
||||
(if (= 1 (length warnings)) "" "s"))
|
||||
""))
|
||||
(when warnings
|
||||
(with-output-to-temp-buffer "*roam-export-blog warnings*"
|
||||
(dolist (w warnings)
|
||||
(princ (format "%s\n" w))))))))
|
||||
|
||||
(provide 'roam-export-blog)
|
||||
;;; roam-export-blog.el ends here
|
||||
Reference in New Issue
Block a user