454 lines
18 KiB
EmacsLisp
454 lines
18 KiB
EmacsLisp
;;; 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
|