diff --git a/exepub.el b/exepub.el new file mode 100644 index 0000000..38c07a5 --- /dev/null +++ b/exepub.el @@ -0,0 +1,928 @@ +;;; exepub.el --- Org‑Mode asset workflow management -*- lexical-binding: t -*- + +;; Author: Emmanuele Somma +;; Maintainer: Emmanuele Somma +;; Version: 0.1 +;; Package‑Requires: ((emacs "25.1") (org "9.0")) +;; Keywords: org, publishing, workflow, assets +;; URL: https://git.xed.it/exedre/exepub.el +;; License: GNU GPL 3.0 + +;;; Commentary: + +;; This library implements a complete workflow for creating, drafting, +;; publishing, archiving, and disseminating Org‑Mode assets. +;; +;; Commands provided include: +;; • exepub/article-create — create a new draft asset with metadata; +;; • exepub/regenerate-slug — recompute #+SLUG from TITLE and KEYWORDS; +;; • exepub/disseminate — atomically move a draft into archive, +;; update STATUS and PUBLISHED headers; +;; • exepub/open-drafts +;; • exepub/open-archive +;; • exepub/open-year +;; • exepub/open-attic — quickly jump to respective directories; +;; • exepub/export-to — generate a format‑specific manifestation +;; for a given correspondent. +;; +;; All operations preserve atomicity (with rollback on failure), enforce +;; a clear directory structure under `exepub/home-directory`, and maintain +;; consistent metadata in Org headers. + +;;; Code: +(require 'ox-org) +(require 'uuidgen) + +(defgroup exepub nil + "Configuration for the exepub workflow: asset production and dissemination." + :group 'applications) + +(defcustom exepub/home-directory + "~/Dropbox/LIFE/10-projects/10.70 exepub/container/" + "Base directory for exepub. +Contains the subdirectories: attic, draft, archive, template." + :type 'directory + :group 'exepub) + +(defcustom exepub/log-publishing-project + "net.exedre" + "Base project for publishing log." + :type 'string + :group 'exepub) + +(defun exepub--ensure-dirs () + "Ensure the existence of the required subdirectories under `exepub/home-directory`." + (dolist (sub '("attic" "draft" "archive" "template")) + (let ((dir (expand-file-name sub exepub/home-directory))) + (unless (file-directory-p dir) + (make-directory dir t))))) + +(defun exepub/article-create (slug keywords) + "Create a new asset under the `draft/` directory. + +SLUG is a string where spaces (including multiple) are replaced by hyphens. +KEYWORDS is a comma-separated list; commas become underscores, spaces become hyphens." + (interactive + (list (read-string "Create new article draft with slug: ") ; + (read-string "Keywords (comma-separated): "))) + (exepub--ensure-dirs) + (let* ((timestamp (format-time-string "%Y%m%dT%H%M%S")) + (clean-slug + (downcase + (replace-regexp-in-string + "[[:space:]]+" "-" + (string-trim slug)))) + (kw-list (split-string keywords "," t "[ \t\n]*")) + (clean-kws + (mapconcat + (lambda (kw) + (downcase + (replace-regexp-in-string "[[:space:]]+" "-" + (string-trim kw)))) + kw-list "_")) + (dirname (format "%s--%s__%s" timestamp clean-slug clean-kws)) + (draft-root (expand-file-name "draft" exepub/home-directory)) + (template-dir (expand-file-name "template" exepub/home-directory)) + (asset-dir (expand-file-name dirname draft-root)) + (org-file (expand-file-name "draft.org" asset-dir))) + (make-directory asset-dir t) + (with-temp-buffer + ;; Import shared #+OPTIONS from template/options.org if available + (let ((options-file (expand-file-name "options.org" template-dir))) + (when (file-readable-p options-file) + (insert-file-contents options-file) + (unless (bolp) (insert "\n")))) + ;; Insert basic headers + (insert (format "#+TITLE: %s\n" + (replace-regexp-in-string "-" " " clean-slug))) + (insert (format "#+CREATED: %s\n" + (format-time-string "%Y-%m-%d"))) + (insert "#+STATUS: draft\n") + (insert (format "#+SLUG: %s\n" clean-slug)) + (insert (format "#+KEYWORDS: %s\n\n" keywords)) + (write-file org-file)) + (find-file org-file) + (message "New asset created in %s" asset-dir))) + +(defun exepub/regenerate-slug () + "Regenerate the #+SLUG: value from #+TITLE: and #+KEYWORDS: in the current buffer." + (interactive) + (save-excursion + (goto-char (point-min)) + (let (title keywords slug-base kw-list kw-part final-slug) + (unless (re-search-forward "^#\\+TITLE:[ \t]*\\(.+\\)$" nil t) + (user-error "No #+TITLE: found")) + (setq title (match-string 1)) + (when (re-search-forward "^#\\+KEYWORDS:[ \t]*\\(.*\\)$" nil t) + (setq keywords (match-string 1))) + ;; Build slug from TITLE + (setq slug-base + (downcase + (replace-regexp-in-string + "[:'[:space:]]+" "-" + (string-trim title)))) + ;; Append keyword part if present + (when keywords + (setq kw-list (split-string keywords "," t "[ \t\n]*") + kw-part + (mapconcat + (lambda (kw) + (downcase + (replace-regexp-in-string "[[:space:]]+" "-" + (string-trim kw)))) + kw-list "_"))) + (setq final-slug + (if kw-part + (concat slug-base "__" kw-part) + slug-base)) + ;; Replace or insert the #+SLUG: header + (goto-char (point-min)) + (if (re-search-forward "^#\\+SLUG:[ \t]*\\(.*\\)$" nil t) + (replace-match (concat "#+SLUG: " final-slug) t t) + (when (re-search-forward "^#\\+STATUS:" nil t) + (beginning-of-line) + (insert (format "#+SLUG: %s\n" final-slug)))) + (message "Slug updated to: %s" final-slug)))) + +(defcustom exepub/default-created + (format-time-string "%Y-%m-%d") + "Default value for #+CREATED: header." + :type 'string + :group 'exepub) + +(defcustom exepub/default-status + "draft" + "Default value for #+STATUS: header." + :type 'string + :group 'exepub) + +(defcustom exepub/default-published + "" + "Default value for #+PUBLISHED: header." + :type 'string + :group 'exepub) + +(defcustom exepub/default-embargo-start + "" + "Default value for #+EMBARGO_START: header." + :type 'string + :group 'exepub) + +(defcustom exepub/default-embargo-end + "" + "Default value for #+EMBARGO_END: header." + :type 'string + :group 'exepub) + +(defcustom exepub/default-keywords + "" + "Default value for #+KEYWORDS: header." + :type 'string + :group 'exepub) + +(defcustom exepub/default-secs + "" + "Default value for #+SECS: header." + :type 'string + :group 'exepub) + +(defcustom exepub/default-dissemination + "" + "Default value for #+DISSEMINATION: header." + :type 'string + :group 'exepub) + +(defcustom exepub/default-type + "article" + "Default value for #+TYPE: header." + :type 'string + :group 'exepub) + +(defcustom exepub/default-bibliography + "../../bibliografia.bib" + "Default value for #+BIBLIOGRAPHY: header." + :type 'string + :group 'exepub) + +(defcustom exepub/default-slug + "" + "Default value for #+SLUG: header." + :type 'string + :group 'exepub) + +(defcustom exepub/default-license + "CC BY-NC-ND" + "Default value for :LICENSE: property." + :type 'string + :group 'exepub) + +(defcustom exepub/default-channels + "" + "Default value for #+CHANNELS: header." + :type 'string + :group 'exepub) + +(defun exepub/org-export-insert-default-template (orig-fn &rest args) + "Extend `C-c C-e #` export template with all EXEPUB headers." + (let ((org-export-options-alist + (append org-export-options-alist + `((:created "CREATED" nil ,exepub/default-created nil) + (:status "STATUS" nil ,exepub/default-status nil) + (:published "PUBLISHED" nil ,exepub/default-published nil) + (:embargo_start "EMBARGO_START" nil ,exepub/default-embargo-start nil) + (:embargo_end "EMBARGO_END" nil ,exepub/default-embargo-end nil) + (:keywords "KEYWORDS" nil ,exepub/default-keywords nil) + (:secs "SECS" nil ,exepub/default-secs nil) + (:dissemination "DISSEMINATION" nil ,exepub/default-dissemination nil) + (:type "TYPE" nil ,exepub/default-type nil) + (:bibliography "BIBLIOGRAPHY" nil ,exepub/default-bibliography nil) + (:slug "SLUG" nil ,exepub/default-slug nil) + (:channels "CHANNELS" nil ,exepub/default-channels nil))))) + (apply orig-fn args))) +(advice-add 'org-export-insert-default-template :around + #'exepub/org-export-insert-default-template) + +(defun exepub/update-header (key value) + "Set or update the Org header #+KEY: VALUE in the current buffer. +If VALUE is a function, call it with the previous header value (or nil) +and use its return as the new value. Otherwise VALUE must be a string." + (save-excursion + (goto-char (point-min)) + (let* ((key-up (upcase key)) + (regexp (format "^#\\+%s:[ \t]*\\(.*\\)$" key-up)) + prev new-val) + (if (re-search-forward regexp nil t) + (progn + (setq prev (match-string 1)) + (setq new-val (if (functionp value) + (funcall value prev) + value)) + (replace-match (format "#+%s: %s" key-up new-val) t t)) + ;; Insert new header at top if none found + (setq prev nil) + (setq new-val (if (functionp value) + (funcall value prev) + value)) + (goto-char (point-min)) + (if (re-search-forward "^#\\+\\w+:" nil t) + (progn + (beginning-of-line) + (insert (format "#+%s: %s\n" key-up new-val))) + (insert (format "#+%s: %s\n" key-up new-val))))))) + +(defun exepub/disseminate () + "Atomically move the current asset from draft to archive and update metadata. +If any step fails, rollback to the original draft state, and set STATUS to 'dissemination'." + (interactive) + (let* ((orig-file (buffer-file-name)) + (draft-root (expand-file-name "draft/" exepub/home-directory))) + (unless (and orig-file + (string-prefix-p draft-root + (file-name-directory orig-file))) + (user-error "This must be called on an asset under %sdraft/" + exepub/home-directory)) + ;; Save buffer if modified + (when (buffer-modified-p) + (save-buffer)) + ;; Regenerate slug from title and keywords + (exepub/regenerate-slug) + ;; Gather paths and names + (let* ((new-slug (save-excursion + (goto-char (point-min)) + (if (re-search-forward + "^#\\+SLUG:[ \t]*\\(.+\\)$" nil t) + (match-string 1) + (user-error "No #+SLUG: header")))) + (orig-dir (directory-file-name + (file-name-directory orig-file))) + (created-name (file-name-nondirectory orig-dir)) + (creation-ts (car (split-string created-name "--"))) + (new-dir-name (concat creation-ts "--" new-slug)) + (timestamp (format-time-string "%Y%m%dT%H%M%S")) + (pub-date (format-time-string "%Y-%m-%d")) + (year (format-time-string "%Y")) + (archive-root (expand-file-name "archive/" exepub/home-directory)) + (year-dir (expand-file-name year archive-root)) + (new-filename (concat timestamp "--" new-slug ".org")) + (draft-new-dir (expand-file-name new-dir-name draft-root)) + (archive-new-dir (expand-file-name new-dir-name year-dir)) + (temp-file (expand-file-name new-filename orig-dir)) + (final-file (expand-file-name new-filename archive-new-dir)) + ;; stack of rollback actions + (rollback-actions '()) + (success nil)) + (kill-buffer) + (condition-case err + (progn + ;; 1) rename draft.org → temp-file + (rename-file orig-file temp-file) + (push (lambda () (ignore-errors + (rename-file temp-file orig-file))) + rollback-actions) + ;; 2) rename orig-dir → draft-new-dir + (unless (string= orig-dir draft-new-dir) + (rename-file orig-dir draft-new-dir) + (push (lambda () (ignore-errors + (rename-file draft-new-dir orig-dir))) + rollback-actions)) + ;; 3) ensure year-dir exists + (unless (file-directory-p year-dir) + (make-directory year-dir t) + (push (lambda () (ignore-errors + (delete-directory year-dir))) + rollback-actions)) + ;; 4) move draft-new-dir → archive-new-dir + (rename-file draft-new-dir archive-new-dir) + (push (lambda () (ignore-errors + (rename-file archive-new-dir draft-new-dir))) + rollback-actions) + ;; 5) open final file, update headers, save + (find-file final-file) + (exepub/update-header "PUBLISHED" pub-date) + (exepub/update-header "STATUS" "dissemination") + (save-buffer) + (setq success t) + (message "Asset disseminated to %s" archive-new-dir)) + (error + ;; rollback on error + (unless success + (dolist (act rollback-actions) + (funcall act))) + (error "Dissemination failed: %s" (error-message-string err))))))) + +(defun exepub/open-drafts () + "Open dired in the `draft` directory of `exepub/home-directory`." + (interactive) + (exepub--ensure-dirs) + (dired (expand-file-name "draft" exepub/home-directory))) + +(defun exepub/open-archive () + "Open dired in the `archive` directory of `exepub/home-directory`." + (interactive) + (exepub--ensure-dirs) + (dired (expand-file-name "archive" exepub/home-directory))) + +(defun exepub/open-year (year) + "Open dired in the YEAR subdirectory under `archive`. +Create the YEAR directory if it does not exist." + (interactive + (let* ((archive-root (expand-file-name "archive" exepub/home-directory)) + (years (when (file-directory-p archive-root) + (cl-remove-if-not + #'file-directory-p + (directory-files archive-root t "^[0-9]\\{4\\}$")))) + (choices (mapcar #'file-name-nondirectory years)) + (default-year (format-time-string "%Y")) + (year (completing-read + (format "Year (default %s): " default-year) + choices nil nil nil nil default-year))) + (list year))) + (exepub--ensure-dirs) + (let ((dir (expand-file-name year + (expand-file-name "archive" + exepub/home-directory)))) + (unless (file-directory-p dir) + (make-directory dir t)) + (dired dir))) + +(defun exepub/open-attic () + "Open dired in the `attic` directory of `exepub/home-directory`." + (interactive) + (exepub--ensure-dirs) + (dired (expand-file-name "attic" exepub/home-directory))) + + + +;; Keybindings for exepub under prefix C-c q +(defvar exepub-command-map + (let ((map (make-sparse-keymap))) + map) + "Keymap for exepub commands under C-c q.") + +;; Bind the prefix +(define-key global-map (kbd "C-c q") exepub-command-map) + +;; Primary commands +(define-key exepub-command-map (kbd "c") 'exepub/article-create) +(define-key exepub-command-map (kbd "r") 'exepub/regenerate-slug) +(define-key exepub-command-map (kbd "s") 'exepub/disseminate) +(define-key exepub-command-map (kbd "e") 'exepub/export-to) + +;; Directory navigation commands (two-letter suffix) +(define-key exepub-command-map (kbd "od") 'exepub/open-drafts) +(define-key exepub-command-map (kbd "oa") 'exepub/open-archive) +(define-key exepub-command-map (kbd "oy") 'exepub/open-year) +(define-key exepub-command-map (kbd "ot") 'exepub/open-attic) + +;; If you use `which-key`, you can add descriptive labels: +(with-eval-after-load 'which-key + (which-key-add-key-based-replacements + "C-c q" "exepub" + "C-c q c" "create article" + "C-c q r" "regenerate slug" + "C-c q s" "disseminate asset" + "C-c q e" "export to format" + "C-c q od" "open drafts" + "C-c q oa" "open archive" + "C-c q oy" "open year" + "C-c q ot" "open attic")) + + +(defun exepub/update-option (option value) + "Set or update OPTION in the #+OPTIONS line to VALUE in the current buffer. +If VALUE is a function, it is called with the previous OPTION value (or nil) +and its return is used as the new setting." + (save-excursion + (goto-char (point-min)) + (if (re-search-forward "^#\\+OPTIONS:[ \t]*\\(.*\\)$" nil t) + (let* ((opts (split-string (match-string 1) "[ \t]+" t)) + ;; find previous value for OPTION + (prev (catch 'found + (dolist (opt opts) + (when (string-prefix-p (concat option ":") opt) + (throw 'found + (substring opt (1+ (length option))))) + ) + nil)) + ;; compute new value + (new-val (if (functionp value) + (funcall value prev) + value)) + ;; remove any existing OPTION entries + (filtered (cl-remove-if + (lambda (opt) + (string-prefix-p (concat option ":") opt)) + opts)) + ;; append the new OPTION + (new-opts (append filtered (list (concat option ":" new-val)))) + (joined (string-join new-opts " "))) + ;; replace the entire #+OPTIONS: line + (goto-char (point-min)) + (if (re-search-forward "^#\\+OPTIONS:[ \t]*\\(.*\\)$" nil t) + (replace-match (concat "#+OPTIONS: " joined) t t))) + ;; no OPTIONS line: insert one + (let ((new-val (if (functionp value) (funcall value nil) value))) + (insert (format "#+OPTIONS: %s:%s\n" option new-val)))))) + +;; export + +(defun exepub--license-info (license) + "Parse LICENSE and return plist (:url URL :icons ICON-LIST). +Supports Creative Commons (CC), GNU GPL and GNU FDL. +LICENSE may omit the version (defaults: CC→4.0, GPL→3.0, FDL→1.3)." + (let* ((s (downcase (string-trim license))) + (parts (split-string s "[ \t]+" t)) + (first (car parts))) + (cond + ;; Creative Commons + ((string= first "cc") + (let* ((rest (cdr parts)) + ;; if last part is numeric, take it as version + (lasttok (car (last rest))) + (version (if (string-match-p "^[0-9]+\\(?:\\.[0-9]+\\)?$" lasttok) + lasttok "4.0")) + ;; scheme tokens exclude version + (scheme-toks (if (string= version lasttok) + (butlast rest) rest)) + (scheme (mapconcat 'identity + (mapcar #'downcase scheme-toks) "-")) + (url (format "https://creativecommons.org/licenses/%s/%s/" + scheme version)) + ;; always CC icon plus each element of scheme + (icons (cons "cc" + (mapcar (lambda (tok) tok) + scheme-toks)))) + (list :url url + :icons icons))) + ;; GNU licenses + ((and (member first '("gnu")) + (>= (length parts) 2)) + (let* ((family (nth 1 parts)) ; "gpl" or "fdl" + (rest (nthcdr 2 parts)) + (lasttok (car (last rest))) + (defaults '(("gpl" . "3.0") ("fdl" . "1.3"))) + (default (or (cdr (assoc family defaults)) "")) + (version (if (and lasttok + (string-match-p "^[0-9]+\\(?:\\.[0-9]+\\)?$" + lasttok)) + lasttok default)) + (url-base (pcase family + ("gpl" "https://www.gnu.org/licenses/gpl-%s.html") + ("fdl" "https://www.gnu.org/licenses/fdl-%s.html") + (_ ""))) + (url (if (and url-base (not (string-empty-p version))) + (format url-base version) + ""))) + (list :url url + :icons nil))) + ((string= s "©") + ;; Copyright symbol → All Rights Reserved + (list :url "" :icons nil :label "All Rights Reserved")) + ;; fallback: no specific license info + (t + (list :url "" + :icons nil))))) + +(defun exepub--format-org-ts (time) + "Return org active timestamp for TIME with Italian weekday." + (let* ((dow-num (string-to-number (format-time-string "%w" time))) + (dows ["dom" "lun" "mar" "mer" "gio" "ven" "sab"]) + (dow (aref dows dow-num))) + (format "<%s %s>" + (format-time-string "%Y-%m-%d" time) + dow))) + +(defun exepub--ensure-manifestations-section () + "Ensure a top-level * Manifestations :noexport: exists." + (save-excursion + (goto-char (point-min)) + (unless (re-search-forward "^\\*+ Manifestations" nil t) + (goto-char (point-max)) + (insert "\n* Manifestations :noexport:\n")))) + +(defun exepub--find-end-of-subtree () + "Move to end of current Org subtree and return point." + (save-excursion + (org-end-of-subtree t t) + (point))) + +(defun exepub--ensure-format-subsection (fmt corr) + "Under * Manifestations, ensure a ** FMT:CORR heading exists." + (save-excursion + (goto-char (point-min)) + (re-search-forward "^\\*+ Manifestations" nil t) + (let* ((limit (exepub--find-end-of-subtree)) + (heading (format "** %s:%s" fmt corr))) + (unless (save-excursion + (re-search-forward (concat "^" (regexp-quote heading) "$") + limit t)) + (goto-char limit) + (insert (concat "\n" heading "\n\n")))))) + +(defun exepub--goto-format-subtree (fmt corr) + "Position point at beginning of ** FMT:CORR subtree." + (goto-char (point-min)) + (re-search-forward (format "^\\*+ Manifestations" ) nil t) + (let ((limit (exepub--find-end-of-subtree)) + (re (format "^** %s:%s" fmt corr))) + (unless (re-search-forward re limit t) + (error "Subsection %s:%s not found" fmt corr)) + + (point))) + + + +(defun exepub--update-property (prop value) + "In the PROPERTIES drawer at point, set PROP to VALUE. +If PROP exists, replace its entire line; otherwise insert it before :END:." + (save-excursion + (let ((drawer-beg (re-search-forward "^:PROPERTIES:" nil t)) + drawer-end) + (unless drawer-beg + ;; create drawer if missing + (goto-char (point-max)) + (insert "\n:PROPERTIES:\n:END:\n") + (setq drawer-beg (save-excursion + (re-search-backward "^:PROPERTIES:" nil t)))) + (setq drawer-end (save-excursion + (goto-char drawer-beg) + (re-search-forward "^:END:" nil t))) + (goto-char drawer-beg) + (if (re-search-forward (format "^:%s:.*$" prop) drawer-end t) + ;; replace existing line + (let ((beg (line-beginning-position)) + (end (line-end-position))) + (delete-region beg (1+ end)) + (goto-char beg) + (insert (format ":%s: %s\n" prop value))) + ;; insert new line before :END: + (goto-char drawer-end) + (beginning-of-line) + (insert (format ":%s: %s\n" prop value)))))) + + + +(defun exepub/org-timestamp-to-pretty (ts) + "Restituisce TS (stringa Org like ) formattata più leggibile." + (let* ((plain (replace-regexp-in-string "<[<>]" "" ts)) ; togli ‹‹›› + (time-list (org-parse-time-string plain)) + ;; sec min hour day month year dow ... zone + (time (apply #'encode-time time-list))) + (format-time-string "%A, %e %B %Y" time))) + +(defun exepub--insert-license-footer (uuid slug author title year license licensed-to embargoed-to) + "Append an Org-formatted license footer given SLUG, TITLE, YEAR, LICENSE." + (let* ((info (exepub--license-info license)) + (url (plist-get info :url)) + (icons (plist-get info :icons))) + ;; link to object and author/license text + (insert "#+ATTR_HTML: :class license-footer\n") + (insert (format "[[https://exedre.net/objects/%s][%s]] © %s di \ +[[https://exedre.org/about][%s]] " uuid title year author)) + (if (string= license "©") + (insert (format "Tutti i diritti riservati %s" (if (null licensed-to) "" (format ", questo contenuto è concesso a %s e non può essere destinato ad altri." licensed-to)))) + (insert (format "è concesso%s sotto licenza [[%s][%s]] " + (if (null licensed-to) "" (format " a %s" licensed-to)) + url license))) + ;; icons as inline Org links + (when icons + (dolist (ic icons) + (insert (format "[[https://mirrors.creativecommons.org/presskit/icons/%s.svg]] " + ic)))) + (unless (null embargoed-to) + (insert "\n#+ATTR_HTML: :class embargo-footer\n") + (insert (format "Quest'articolo è coperto da embargo \ +fino a %s. Per favore non divulgarlo pubblicamente \ +online o in stampa fino a quella data. Dopo quella data potrai trovare +la versione definitiva da distribuire al link https://exedre.net/objects/%s" (exepub/org-timestamp-to-pretty embargoed-to) uuid))))) + + +(defun exepub--property-exists-p (prop) + "Return non-nil if PROP exists in the current PROPERTIES drawer." + (not (null (exepub--get-property prop)))) + +(defun exepub--get-bool-property (prop) + "Return the value of PROP in the current PROPERTIES drawer, or nil." + (let ((prop-v (exepub--get-property prop))) + (when prop-v + (string= prop-v "t")))) + +(defun exepub--get-property (prop) + "Return the value of PROP in the current PROPERTIES drawer, or nil. +Uses `org-entry-get` instead of manual regexp parsing." + (let ((val (org-entry-get (point) prop))) + (and val (not (string= val "")) val))) + +(defun exepub--collect-properties () + "Restituisce un’alist di tutte le proprietà PROPERTIES nel buffer corrente." + (save-excursion + (when (re-search-forward "^:PROPERTIES:" nil t) + (let ((end (re-search-forward "^:END:" nil t)) + props) + (goto-char (match-beginning 0)) + (while (re-search-forward "^:\\([^:]+\\):[ \t]*\\(.*\\)$" end t) + (push (cons (match-string 1) (match-string 2)) props)) + props)))) + +(defun exepub/export-to (format correspondent) + "Create a manifestation of the current asset in FORMAT for CORRESPONDENT, using LICENSE. + +Also update the source Org with a * Manifestations section, update its +** FORMAT:CORRESPONDENT properties and then generate the manifest Org, +disable its title export, set STATUS to \"manifestation\" and append +a dynamic license footer." + (interactive + (list (read-string "Format (e.g. html, latex, md, org): " "html") + (read-string "Correspondent (e.g. agenda-digitale): " "personal"))) + (let ((orig-file (buffer-file-name))) + (let ((status + (save-excursion + (goto-char (point-min)) + (when (re-search-forward "^#\\+STATUS:[ \t]*\\(.*\\)$" nil t) + (string-trim (match-string 1)))))) + (unless (string= status "dissemination") + (user-error "export-to only runs when STATUS is dissemination (current: %s)" + status))) + ;; 1) ensure we are in archive/ + (unless (and orig-file + (string-prefix-p + (expand-file-name "archive/" exepub/home-directory) + (file-name-directory orig-file))) + (user-error "This must be called on a file in archive/")) + (save-buffer) + ;; 2) update source Org's *Manifestations* subtree + (let (license-val licensed-to embargoed-to uuid + (prop-hash (make-hash-table :test 'equal))) + (with-current-buffer (find-file-noselect orig-file) + (exepub--ensure-manifestations-section) + (let* ((fmt-down (downcase format)) + (corr-root (car (split-string correspondent "--"))) + (corr-clean (replace-regexp-in-string + "[^[:alnum:]-]" "" corr-root)) + (corr-safe (downcase + (replace-regexp-in-string + "[[:space:]]+" "-" corr-clean))) + (manifest-id (format "%s-%s" fmt-down corr-safe))) + (exepub--ensure-format-subsection fmt-down corr-safe) + (exepub--goto-format-subtree fmt-down corr-safe) + (let ((lock (exepub--get-property "LOCK"))) + (when (string= lock "t") + (user-error "Manifestation %s is locked, aborting export" manifest-id))) + (setq licensed-to + (exepub--get-property "LICENSED-TO")) + (setq license-val + (or (exepub--get-property "LICENSE") + exepub/default-license)) + (unless (exepub--property-exists-p "LICENSE") + (exepub--update-property "LICENSE" license-val)) + (unless (exepub--property-exists-p "UUID") + (exepub--update-property "UUID" (uuidgen-1))) + (exepub--update-property "DELIVERED" + (exepub--format-org-ts (current-time))) + (exepub--update-property "EMBARGO" + (exepub--format-org-ts + (time-add (current-time) + (days-to-time 22)))) + (setq embargoed-to + (when (exepub--get-bool-property "SHOW-EMBARGO") + (exepub--get-property "EMBARGO"))) + (setq uuid (exepub--get-property "UUID")) + (exepub--goto-format-subtree fmt-down corr-safe) + (dolist (kv (org-entry-properties)) + (unless (member (car kv) + '("CATEGORY" "BLOCKED" "ALLTAGS" + "FILE" "PRIORITY" "ITEM")) + (puthash (car kv) (cdr kv) prop-hash))) + (save-buffer) + ;; 3) build paths for the manifest + (let* ((asset-dir (file-name-directory orig-file)) + (man-root (expand-file-name "manifestation" asset-dir)) + (man-dir (expand-file-name manifest-id man-root)) + (slug-full (save-excursion + (find-file-noselect orig-file) + (goto-char (point-min)) + (and (re-search-forward + "^#\\+SLUG:[[:space:]]*\\(.+\\)$" + nil t) + (match-string 1)))) + (slug-root (car (split-string slug-full "__"))) + (org-copy (expand-file-name (concat slug-root ".org") man-dir)) + (title (save-excursion + (find-file-noselect orig-file) + (goto-char (point-min)) + (and (re-search-forward + "^#\\+TITLE:[[:space:]]*\\(.+\\)$" + nil t) + (match-string 1)))) + (author (save-excursion + (find-file-noselect orig-file) + (goto-char (point-min)) + (and (re-search-forward + "^#\\+AUTHOR:[[:space:]]*\\(.+\\)$" + nil t) + (match-string 1)))) + (year (format-time-string "%Y"))) + ;; 4) prepare and perform Org→Org export + (make-directory man-dir t) + (condition-case _ + (org-export-to-file 'org org-copy nil nil nil nil + '(:exclude-tags ("noexport"))) + (error (copy-file orig-file org-copy t))) + ;; 5) adjust the manifest Org + (with-current-buffer (find-file-noselect org-copy) + (maphash (lambda (k v) + (exepub/update-header k v)) + prop-hash) + (exepub/update-option "title" "nil") + (exepub/update-header "STATUS" "manifestation") + (goto-char (point-max)) + (exepub--insert-license-footer uuid slug-root author title year license-val licensed-to embargoed-to) + (save-buffer)) + ;; 6) final export or placeholder + (let ((buf (find-file-noselect org-copy))) + (unwind-protect + (with-current-buffer buf + (pcase fmt-down + ("html" (let ((out (org-html-export-to-html nil nil nil nil nil))) + (browse-url-of-file (expand-file-name out man-dir)))) + ("md" (org-md-export-to-markdown nil nil nil nil nil)) + ("latex" (org-latex-export-to-pdf nil nil nil nil nil)) + ("org" (message "Org manifest dissemination: %s" org-copy)) + (_ (with-temp-file + (expand-file-name + (format "need-to-be-exported-to-%s" fmt-down) + man-dir))))) + (kill-buffer buf))) + (message "Manifestation %s created in %s" manifest-id man-dir))))))) + +;;; exepub-save-hook.el --- Regenerate slug and rename directory on save + + +(defun exepub--maybe-regenerate-slug-and-rename-on-save () + "On save under `exepub/home-directory`, adjust slug and rename. +If STATUS is \"manifestation\", rename only the Org file to .org. +If STATUS is \"dissemination\", rename both containing directory to -- +and the Org file to .org. +Otherwise, rename only the containing directory." + (when (and buffer-file-name + (derived-mode-p 'org-mode) + (string-prefix-p + (file-name-as-directory (expand-file-name exepub/home-directory)) + (file-name-as-directory (file-name-directory buffer-file-name)))) + ;; Regenerate slug + (exepub/regenerate-slug) + ;; Read STATUS + (let* ((status (save-excursion + (goto-char (point-min)) + (when (re-search-forward + "^#\\+STATUS:[ \t]*\\(.*\\)$" nil t) + (string-trim (match-string 1))))) + (file buffer-file-name) + (dir (file-name-directory file)) + (parent (directory-file-name dir)) + ;; extract creation timestamp from dirname "TS--slug" + (base (file-name-nondirectory parent)) + (parts (split-string base "--")) + (creation (car parts)) + ;; get full slug and root (before __) + (full-slug (save-excursion + (goto-char (point-min)) + (when (re-search-forward + "^#\\+SLUG:[ \t]*\\(.+\\)$" nil t) + (match-string 1)))) + (slug-root (car (split-string full-slug "__"))) + ;; new names + (new-dir-name (concat creation "--" full-slug)) + (new-parent (expand-file-name new-dir-name + (file-name-directory parent))) + (new-file-name (concat slug-root ".org")) + (new-file-path (expand-file-name new-file-name + (if (member status '("dissemination" "default")) + new-parent + parent)))) + (pcase status + ("manifestation" + ;; only rename file + (unless (string= (file-name-nondirectory file) new-file-name) + (rename-file file new-file-path t) + (set-visited-file-name new-file-path t t))) + ("dissemination" + ;; rename directory, then rename file inside it + (unless (string= parent new-parent) + (rename-file parent new-parent)) + (unless (string= (file-name-nondirectory file) new-file-name) + (rename-file + (expand-file-name (file-name-nondirectory file) new-parent) + new-file-path t) + (set-visited-file-name new-file-path t t))) + (_ + ;; other: rename directory only + (unless (string= parent new-parent) + (rename-file parent new-parent) + (let ((file-in-new (expand-file-name + (file-name-nondirectory file) + new-parent))) + (set-visited-file-name file-in-new t t)))))))) + +(add-hook 'before-save-hook + #'exepub--maybe-regenerate-slug-and-rename-on-save) + + +(defcustom exepub/git-base-url + "https://git.xed.it/org.exedre/exepub-repo/src/branch/main" + "Base URL for links to the Git repository." + :type 'string + :group 'exepub) + +(defun exepub/log-publish-manifestation () + "Create a log entry org-file for the current manifestation. +The entry is saved under the base directory of `exepub/log-publishing-project'. +Filename is TIMESTAMP–UUID.org. Fields TITLE, AUTHOR, DATE, LICENSE, +and a Git link are recorded." + (interactive) + (let* ((orig (buffer-file-name)) + (proj exepub/log-publishing-project) + ;; retrieve project plist + (plist (cdr (assoc proj org-publish-project-alist))) + (base (plist-get plist :base-directory))) + (unless (and orig base (file-directory-p base)) + (user-error "Cannot find publishing project %s or its base-dir" proj)) + ;; gather metadata from buffer + (let* ((uuid (or (org-entry-get nil "ID") + (org-entry-get nil "UUID") + (user-error "No ID/UUID in buffer"))) + (ts (format-time-string "%Y%m%dT%H%M%S")) + (fn (format "%s-%s.org" ts uuid)) + (dest (expand-file-name fn base)) + (title (or (org-entry-get nil "TITLE") + (user-error "No #+TITLE: found"))) + (author (or (org-entry-get nil "AUTHOR") + user-full-name)) + (license (or (org-entry-get nil "LICENSE") + exepub/default-license)) + (reldir (file-relative-name orig exepub/home-directory)) + (giturl (concat (file-name-as-directory exepub/git-base-url) + reldir))) + ;; write the log file + (with-temp-file dest + ;; header options + (insert "#+OPTIONS: toc:nil num:nil html-style:nil\n") + (insert "#+HTML_HEAD: \n") + (insert "#+HTML_HEAD_EXTRA: \n\n") + ;; metadata + (insert (format "#+TITLE: %s\n" title)) + (insert (format "#+AUTHOR: %s\n" author)) + (insert (format "#+DATE: %s\n" ts)) + (insert (format "#+LICENSE: %s\n\n" license)) + ;; git link + (insert (format "[[%s][View source in Git]]\n" giturl))) + ;; optionally open the new log file + (find-file dest) + (message "Published log entry %s" fn)))) + + +;;; exepub-save-hook.el ends here + +(provide 'exepub) + +;; End Code