;;; 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 "![%s](%s)"
                (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