[org] Updates to about pages

1 files changed, 189 insertions, 0 deletions

diff --git a/jakob/utils/org-mode.scm b/jakob/utils/org-mode.scm
new file mode 100644
index 0000000..fdaaa06
--- /dev/null
+++ b/jakob/utils/org-mode.scm
@@ -0,0 +1,189 @@
+;;; Copyright © 2019 - 2024 Jakob L. Kreuze <zerodaysfordays@sdf.org>
+;;;
+;;; This program is free software; you can redistribute it and/or
+;;; modify it under the terms of the GNU General Public License as
+;;; published by the Free Software Foundation; either version 3 of the
+;;; License, or (at your option) any later version.
+;;;
+;;; This program is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;; General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with this program. If not, see
+;;; <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+;;;
+;;; Parser for Org syntax which invokes `org-export' via the Emacs daemon for
+;;; rendering and metadata extraction.
+;;;
+;;; The choice to leverage Emacs, rather than writing a parser in Guile, was
+;;; made because it enabled us to leverage other Emacs facilities such as
+;;; `font-lock' and `htmlize' for syntax highlighting.
+;;;
+;;; Code:
+
+(define-module (jakob utils org-mode)
+  #:use-module (ice-9 match)
+  #:use-module (ice-9 popen)
+  #:use-module (ice-9 textual-ports)
+  #:use-module (jakob utils)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-19)
+  #:use-module (srfi srfi-26)
+  #:use-module (srfi-197)
+  #:use-module (sxml simple)
+  #:export (%additional-keys
+            read-org-mode-file))
+
+;; Directory to store cached artifacts in.
+;;
+;; Caching is disabled if this is `#f'.
+(define %cache-directory
+  (make-parameter (if (getenv "HAUNT_ORG_READER_DISABLE_CACHE")
+                      #f
+                      (or (getenv "HAUNT_ORG_READER_CACHE_DIR")
+                          "./.org-mode-reader-cache/"))))
+
+;; File name of Elisp script to execute before anything else
+(define %additional-emacs-preamble
+  (make-parameter (getenv "HAUNT_ORG_READER_EMACS_PREAMBLE")))
+
+;; Additional Org-mode keywords to include in the extracted metadata.
+(define %additional-keys
+  (make-parameter '("CROSSPOST" "SCRIPTS" "META-TAGS")))
+
+;; Whether to use a running Emacs daemon to evaluate elisp forms.
+(define %use-emacsclient
+  (make-parameter (getenv "HAUNT_ORG_READER_USE_EMACSCLIENT")))
+
+(define (htmlize-path)
+  (string-append (dirname (current-filename)) "../../../emacs-htmlize/htmlize.el"))
+
+(define (eval-in-emacs form)
+  "Evaluate s-exp FORM in Emacs and return the result
+
+If `%use-emacsclient' is truthy, evaluate FORM in the current running Emacs
+daemon. Assumes that FORM does not write to `standard-output'."
+  (let* (;; If `HAUNT_ORG_READER_PREAMBLE' is specified, load that.
+         (form (if (%additional-emacs-preamble)
+                   `(progn
+                     (load-file ,(%additional-emacs-preamble))
+                     ,form)
+                   form))
+         ;; We need to explicitly request that Emacs write the result if using
+         ;; Emacs batch mode (which is how we evaluate forms without
+         ;; `emacsclient'.)
+         (form (if (not (%use-emacsclient))
+                   `(print ,form)
+                   form))
+         (stringified (call-with-output-string (cut write form <>)))
+         (port       (if (%use-emacsclient)
+                         (open-pipe* OPEN_READ "emacsclient" "-e" stringified)
+                         (open-pipe* OPEN_READ "emacs" "--batch" "--eval" stringified)))
+         (result     (read port))
+         ;; The symbol `nil' doesn't have the same semantics in Scheme, so we'll
+         ;; convert it to the empty list.
+         (result     (if (eqv? result 'nil)
+                         '()
+                         result)))
+    (if (eqv? 0 (status:exit-val (close-pipe port)))
+        result
+        (error "could not eval" form))))
+
+(define (render-org-mode-file file-name)
+  "Export FILE-NAME as an HTML document string"
+  (define output-file-name (tmpnam))
+  (define result
+    (eval-in-emacs
+     `(save-excursion
+       (load-file ,(htmlize-path))
+       (setq org-html-htmlize-output-type 'css)
+       (setq enable-local-variables :all)
+       (set-buffer (find-file-noselect ,file-name))
+       ;; (let ((enable-local-variables :all))
+       ;;   (set-buffer (find-file-noselect ,file-name)))
+       (setq-local org-export-filter-latex-fragment-functions
+                   (list (lambda (data backend channel)
+                           (org-html-encode-plain-text data))))
+       (org-mode)
+       (let ((result (org-export-as 'html nil nil t)))
+         (with-temp-buffer
+          (insert result)
+          (write-region (point-min) (point-max) ,output-file-name))))))
+  (define parsed (call-with-input-file output-file-name get-string-all))
+  (delete-file output-file-name)
+  ;; We wrap in a `div' because when we call `xml->sxml' later on in
+  ;; `read-org-mode-file-fresh', it is expecting a single element.
+  (format #f "<div>~a</div>" parsed))
+
+(define (extract-org-mode-metadata-raw file-name)
+  (map (match-lambda
+         ((key value) `(,(string->symbol (string-downcase key)) . ,value)))
+       (eval-in-emacs
+        `(save-excursion
+          (let ((enable-local-variables :all))
+            (set-buffer (find-file-noselect ,file-name)))
+          (org-mode)
+          (org-collect-keywords ',(append '("TITLE" "DATE" "TAGS")
+                                          (%additional-keys)))))))
+
+(define (parse-metadata metadata-alist)
+  (chain metadata-alist
+         (assq-map! _ 'date (cut string->date <> "<~Y-~m-~d ~a ~H:~M>"))
+         (assq-map! _ 'tags (cut string-split <> #\space))))
+
+;; This is the public-facing interface. Because dates aren't serializable with
+;; `write', the internal interface has extraction and parsing broken out into
+;; separate procedures.
+(define (extract-org-mode-metadata file-name)
+  "Parse the metadata out of FILE-NAME as an alist"
+  (chain file-name
+         (extract-org-mode-metadata-raw _)
+         (parse-metadata _)))
+
+(define (metadata-file-name hash)
+  (string-append (%cache-directory)
+                 file-name-separator-string
+                 hash
+                 "-metadata"))
+(define (sxml-file-name hash)
+  (string-append (%cache-directory)
+                 file-name-separator-string
+                 hash
+                 "-sxml"))
+
+(define (read-org-mode-file-cached hash)
+  (values (parse-metadata (call-with-input-file (metadata-file-name hash) read))
+          (call-with-input-file (sxml-file-name hash) read)))
+
+(define (read-org-mode-file-fresh hash file-name)
+  (let ((metadata (extract-org-mode-metadata-raw file-name))
+        (sxml (match (call-with-input-string (render-org-mode-file file-name) xml->sxml)
+                (('*TOP* ('div sxml ...)) sxml))))
+    (when (%cache-directory)
+      (call-with-output-file (metadata-file-name hash) (cut write metadata <>))
+      (call-with-output-file (sxml-file-name hash)     (cut write sxml <>)))
+    (values (parse-metadata metadata) sxml)))
+
+(define (read-org-mode-file file-name)
+  (define hash
+    (let* ((port (open-pipe* OPEN_READ "md5sum" file-name))
+           (result (string-trim-both (get-string-all port))))
+      (unless (eqv? 0 (status:exit-val (close-pipe port)))
+        (error "cannot hash file"))
+      (first (string-split result #\ ))))
+  (when (%cache-directory)
+    (cond ((and (file-exists? (%cache-directory))
+                (not (eqv? 'directory (stat:type (stat (%cache-directory))))))
+           (error "cache directory exists but is not a directory"
+                  (%cache-directory)))
+          ((not (file-exists? (%cache-directory)))
+           (mkdir (%cache-directory)))))
+  (if (and (%cache-directory)
+           (file-exists? (metadata-file-name hash))
+           (file-exists? (sxml-file-name hash)))
+      (read-org-mode-file-cached hash)
+      (read-org-mode-file-fresh hash file-name)))