Clean up org-mode-reader

3 files changed, 119 insertions, 51 deletions

diff --git a/.gitmodules b/.gitmodules
index c94555d..61814de 100644
--- a/.gitmodules
+++ b/.gitmodules
@@ -1,3 +1,6 @@
 [submodule "ext-srfi-197"]
 	path = haunt/ext-srfi-197
 	url = https://github.com/ar-nelson/srfi-197
+[submodule "haunt/emacs-htmlize"]
+	path = haunt/emacs-htmlize
+	url = https://github.com/hniksic/emacs-htmlize
diff --git a/haunt/emacs-htmlize b/haunt/emacs-htmlize
new file mode 160000
+Subproject ed5e5b05fd260e8f161a488d56f10e7f6e01fb7
diff --git a/haunt/jakob/reader/org-mode.scm b/haunt/jakob/reader/org-mode.scm
index 2faeef3..7f064f1 100644
--- a/haunt/jakob/reader/org-mode.scm
+++ b/haunt/jakob/reader/org-mode.scm
@@ -19,38 +19,62 @@
 ;;; Reader 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 reader org-mode)
+  #:use-module (haunt reader)
   #:use-module (ice-9 match)
   #:use-module (ice-9 popen)
-  #:use-module (ice-9 regex)
   #: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 (haunt reader)
-  #:use-module (ice-9 match)
+  #:use-module (srfi-197)
   #:use-module (sxml simple)
-  #:export (org-mode-reader))
+  #:export (render-org-mode-file
+            extract-org-mode-metadata
+            org-mode-reader))
+
+;; 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/"))))
+
+;; Additional Org-mode keywords to include in the extracted metadata.
+(define %additional-keys
+  (make-parameter '("CROSSPOST" "SCRIPTS" "META-TAGS")))
 
-(define (rewrite-image-urls subtree)
-  (match subtree
-    (('img ('@ ('src src) attrs ...))
-     (let* ((src (if (string-prefix? "./" src)
-                     (substring src 2)
-                     src))
-            (src (string-append "/static/image/" src)))
-     `(img (@ (src ,src) ,@attrs))))
-    ((elems ...)
-     (map rewrite-image-urls elems))
-    (elem elem)))
+;; Whether to use a running Emacs daemon to evaluate elisp forms.
+(define %use-emacsclient
+  (make-parameter (getenv "HAUNT_ORG_READER_USE_EMACSCLIENT")))
 
 (define (eval-in-emacs form)
-  "Evaluate FORM in the current Emacs (daemon) session and return the result"
-  (let* ((stringified (call-with-output-string (cut write form <>)))
-         (port       (open-pipe* OPEN_READ "emacsclient" "-e" stringified))
+  "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* (;; 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)))
@@ -59,10 +83,13 @@
         (error "could not eval" form))))
 
 (define (render-org-mode-file file-name)
-  (define output-port (mkstemp! (string-copy "/tmp/emacs-eval-XXXXXX")))
+  "Export FILE-NAME as an HTML document string"
+  (define output-file-name (tmpnam))
   (define result
     (eval-in-emacs
      `(save-excursion
+       (load-file "./emacs-htmlize/htmlize.el")
+       (setq org-html-htmlize-output-type 'css)
        (let ((enable-local-variables :all))
          (set-buffer (find-file-noselect ,file-name)))
        (setq-local org-export-filter-latex-fragment-functions
@@ -71,42 +98,80 @@
        (let ((result (org-export-as 'html nil nil t)))
          (with-temp-buffer
           (insert result)
-          (write-region (point-min) (point-max) ,(port-filename output-port)))))))
-  (define parsed (call-with-input-file (port-filename output-port) get-string-all))
-  (format #f "<html>~a</html>" parsed))
+          (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-post-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-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 %default-additional-keys
-  '("CROSSPOST" "SCRIPTS" "META-TAGS"))
+(define (read-org-mode-post-cached hash)
+  (values (parse-metadata (call-with-input-file (metadata-file-name hash) read))
+          (call-with-input-file (sxml-file-name hash) read)))
 
-(define* (extract-org-mode-metadata file-name
-                                    #:optional
-                                    (additional-keys %default-additional-keys))
-  `(,@(map (match-lambda
-             (("DATE" date) `(date . ,(string->date date "<~Y-~m-~d ~a ~H:~M>"))))
-           (eval-in-emacs
-            `(save-excursion
-              (let ((enable-local-variables :all))
-                (set-buffer (find-file-noselect ,file-name)))
-              (org-collect-keywords '("DATE")))))
-    ,@(map (match-lambda
-             (("TAGS" tags) `(tags . ,(string-split tags #\space))))
-           (eval-in-emacs
-            `(save-excursion
-              (let ((enable-local-variables :all))
-                (set-buffer (find-file-noselect ,file-name)))
-              (org-collect-keywords '("TAGS")))))
-    ,@(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-collect-keywords ',(append '("TITLE") additional-keys)))))))
+(define (read-org-mode-post-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-post file-name)
-  (values (extract-org-mode-metadata file-name)
-          (match (call-with-input-string (render-org-mode-file file-name) xml->sxml)
-            (('*TOP* ('html sxml ...)) (rewrite-image-urls sxml)))))
+  (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-post-cached hash)
+      (read-org-mode-post-fresh hash file-name)))
 
 (define org-mode-reader
   (make-reader (make-file-extension-matcher "org")