;; tinmop module for utility move command in thread window ;; Copyright © 2022 cage ;; 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 . ;; this script generates a gemlog starting from an archive directory ;; containing posts in gemtext format ;; this script expect a bunch of input data to fill the gemlog templates. ;; Such data can be provided by the environment variables given below: ;; - GEMLOG_HEADER ;; The header of the gemlog ;; - GEMLOG_TOPIC_INDEX_HEADER ;; The header of the topic index page ;; - GEMLOG_URI_PATH_PREFIX ;; the root of the path for the gemlog (e.g: "gemini://example/cage/" → "/cage/" ;; - GEMLOG_URI_POST_HOME_BACKLINK ;; The URL added to the footer of each post ;; - GEMLOG_URI_POST_HOME_BACKLINK_NAME ;; The label for the URL added to the footer of each post ;; - GEMLOG_URI_INDICES_HOME_BACKLINK ;; The URL added to the footer of the gemlog and topic indices ;; - GEMLOG_URI_HOME_INDICES_BACKLINK_NAME ;; The label for the URL added to the footer of the gemlog and topic indices ;; - GEMLOG_POSTS_SOURCE ;; The source directory where the posts can be found to be processed by this script ;; - GEMLOG_POSTS_DESTINATION ;; the destination directory where the processed posts and generated indices are placed ;; - GEMLOG_ANTENNA_URL ;; the url of the antenna instance ;; - GEMLOG_ANTENNA_TARGET_URL ;; the url of the target url for antenna; that is, the url of your gemlog ;; METADATA ;; The source posts must contains metadata ;; the metadata must be wrapped in a preformatted block and the block's ;; alt-text must be exactly the string "META". The metadata must be ;; added one for line and contains a, colon separated, pair each. ;; So far the only valid metadata lines are: ;; - date: (the date of the post, format: YYY-MM-DD) ;; - topics: The post's' topics: a comma separated list of strings ;; For example ;; […] ;; ``` META ;; date: 2023-08-14 ;; topic: comics, cinema ;; ``` (defpackage :generate-gemlog (:use :cl :misc :fs :html-utils :gemini-parser :text-utils) (:local-nicknames (:a :alexandria))) (in-package :generate-gemlog) (a:define-constant +meta-node-attribute+ "META" :test #'string=) (a:define-constant +meta-topic-key+ :topic :test #'eq) (a:define-constant +meta-topic-values-delimiters+ "," :test #'string=) (a:define-constant +meta-date-key+ :date :test #'eq) (a:define-constant +meta-key-value-delimiter+ ": *" :test #'string=) (a:define-constant +archive-dir+ "archive" :test #'string=) (a:define-constant +archive-gemlog-file+ "gemlog.gmi" :test #'string=) (a:define-constant +archive-topic-file+ "topics.gmi" :test #'string=) (a:define-constant +post-valid-file-extension+ "gmi$" :test #'string=) (a:define-constant +environment-variable-gemlog-header+ "GEMLOG_HEADER" :test #'string=) (a:define-constant +environment-variable-gemlog-topic-index-header+ "GEMLOG_TOPIC_INDEX_HEADER" :test #'string=) (a:define-constant +environment-variable-gemlog-uri-path-prefix+ "GEMLOG_URI_PATH_PREFIX" :test #'string=) (a:define-constant +environment-variable-gemlog-post-home-backlink+ "GEMLOG_URI_POST_HOME_BACKLINK" :test #'string=) (a:define-constant +environment-variable-gemlog-post-home-backlink-name+ "GEMLOG_URI_POST_HOME_BACKLINK_NAME" :test #'string=) (a:define-constant +environment-variable-gemlog-indices-home-backlink+ "GEMLOG_URI_INDICES_HOME_BACKLINK" :test #'string=) (a:define-constant +environment-variable-gemlog-indices-home-backlink-name+ "GEMLOG_URI_HOME_INDICES_BACKLINK_NAME" :test #'string=) (a:define-constant +environment-variable-gemlog-posts-archive+ "GEMLOG_POSTS_SOURCE" :test #'string=) (a:define-constant +environment-variable-gemlog-posts-destination+ "GEMLOG_POSTS_DESTINATION" :test #'string=) (a:define-constant +environment-variable-antenna-url+ "GEMLOG_ANTENNA_URL" :test #'string=) (a:define-constant +environment-variable-antenna-target-url+ "GEMLOG_ANTENNA_TARGET_URL" :test #'string=) (defun getenv (key default) (os-utils:getenv key :default default)) (defparameter *gemlog-header* (getenv +environment-variable-gemlog-header+ (format nil "# Posts~2%"))) (defparameter *topic-index-header* (getenv +environment-variable-gemlog-topic-index-header+ (format nil "# Topics archive~2%"))) (defparameter *uri-path-prefix* (getenv +environment-variable-gemlog-uri-path-prefix+ nil)) (defparameter *post-home-backlink* (getenv +environment-variable-gemlog-post-home-backlink+ "../index.gmi")) (defparameter *post-home-backlink-name* (getenv +environment-variable-gemlog-post-home-backlink-name+ "home")) (defparameter *indices-home-backlink* (getenv +environment-variable-gemlog-indices-home-backlink+ "./index.gmi")) (defparameter *indices-home-backlink-name* (getenv +environment-variable-gemlog-indices-home-backlink-name+ "home")) (defun parse-date (timestring) (local-time:parse-timestring timestring)) (defun format-date-to-string (date) (with-output-to-string (stream) (local-time:format-timestring stream date :format '((:year 2) "-" (:month 2) "-" (:day 2))))) (defun meta-node-p (node) (a:when-let ((attribute (find-attribute :alt node))) (string= (trim-blanks (attribute-value attribute)) "META"))) (defun extract-meta (parsed) (let ((lines (mapcar (lambda (node) (trim-blanks (first (children node)))) (remove-if-not #'meta-node-p parsed)))) (loop for line in (rest lines) when line collect (let* ((key-value (mapcar #'trim-blanks (cl-ppcre:split +meta-key-value-delimiter+ line))) (key (a:make-keyword (string-upcase (first key-value)))) (raw-value (second key-value))) (cons key (ecase key (:topic (list (mapcar #'trim-blanks (cl-ppcre:split +meta-topic-values-delimiters+ raw-value)))) (:date (parse-date raw-value)))))))) (defun extract-non-meta (parsed) (remove-if #'meta-node-p parsed)) (defclass post () ((meta :initform nil :initarg :meta :accessor meta) (content :initform nil :initarg :content :accessor content) (original-file-path :initform nil :initarg :original-file-path :accessor original-file-path) (archive-file-path :initform nil :initarg :archive-file-path :accessor archive-file-path))) (defmethod print-object ((object post) stream) (with-accessors ((meta meta) (content content) (original-file-path original-file-path)) object (print-unreadable-object (object stream :type t) (format stream "~a ~a ~a~%" meta content original-file-path)))) (defun notify (control &rest args) (if (ui:tui-active-p) (ui:info-message (apply #'format nil control args)) (apply #'format t control args))) (defun bulk->posts (capsule-bulk-dir) (let* ((original-post-files (remove-if-not (lambda (a) (and (fs:regular-file-p a) (cl-ppcre:scan +post-valid-file-extension+ a))) (fs:collect-children capsule-bulk-dir))) (parsed-posts (mapcar (lambda (a) (handler-case (with-initialized-parser (parse-gemini-file (fs:slurp-file a))) (error (e) (notify "Unable to parse ~a: ~a~%" a e) nil))) original-post-files)) (all-meta (mapcar (lambda (a file) (handler-case (let ((meta (extract-meta a))) (if meta meta (progn (notify "Unable to find metadata for ~a~%" file) nil))) (error (e) (notify "Unable to parse metadata ~a: ~a~%" file e) nil))) parsed-posts original-post-files))) (loop for original-post-file in original-post-files for parsed-post in parsed-posts for meta in all-meta when (and parsed-post meta) collect (make-instance 'post :original-file-path original-post-file :content (extract-non-meta parsed-post) :meta meta)))) (defun post-topics (post) (with-accessors ((meta meta)) post (cadr (assoc +meta-topic-key+ meta)))) (defun collect-topics (posts) (let ((results '())) (loop for post in posts do (with-accessors ((meta meta)) post (a:when-let ((topics (post-topics post))) (loop for topic in topics do (pushnew topic results :test #'string-equal))))) (sort results #'string<))) (defun post-date (post) (with-accessors ((meta meta)) post (cdr (assoc +meta-date-key+ meta)))) (defun sexp->gmi (parsed stream) (loop for node in parsed do (let* ((child (first (children node))) (line (cond ((tag= :h1 node) (geminize-h1 child)) ((tag= :h2 node) (geminize-h2 child)) ((tag= :h3 node) (geminize-h3 child)) ((tag= :li node) (geminize-list child)) ((tag= :quote node) (geminize-quote child)) ((tag= :a node) (geminize-link (strcat " " (attribute-value (find-attribute :href node)) " " child))) ((or (tag= :pre node) (tag= :pre-end node)) "```") ((null (first (children node))) (format nil "~%")) (t (first (children node)))))) (format stream "~a~%" line)))) (defun create-archive (bulk-posts-dir output-directory) (let* ((posts (sort (bulk->posts bulk-posts-dir) (lambda (a b) (local-time:timestamp> (post-date a) (post-date b))))) (all-topics (collect-topics posts)) (archive-dir-path (strcat output-directory "/" +archive-dir+))) (fs:make-directory archive-dir-path) (loop for post in posts do (let* ((file-name (fs:strip-dirs-from-path (original-file-path post))) (file-path (fs:cat-parent-dir archive-dir-path file-name))) (setf (archive-file-path post) file-path) (handler-case (with-open-file (stream file-path :direction :output :if-does-not-exist :create :if-exists :supersede) (sexp->gmi (content post) stream) (write-sequence (geminize-link (strcat " " *post-home-backlink* " " *post-home-backlink-name*)) stream) (write-char #\Newline stream) (notify "Processed ~a~%" (original-file-path post))) (error (e) (format *error-output* "skipping ~a, reasons: ~a.~%" file-path e))))) (values posts all-topics))) (defun write-links (posts stream) (flet ((clean-link-filename (filename) (cl-ppcre:regex-replace "\\.gmi$" (cl-ppcre:regex-replace-all "-" filename " ") ""))) (loop for post in posts do (let* ((filename (strip-dirs-from-path (archive-file-path post))) (relative-archive-path (strcat *uri-path-prefix* (cat-parent-dir +archive-dir+ (percent-encode filename)))) (link-text (strcat (format-date-to-string (post-date post)) " " (clean-link-filename filename))) (link (geminize-link (format nil " ~a ~a~%" relative-archive-path link-text)))) (write-sequence link stream))))) (defun make-gemlog-index (all-posts output-directory) (let ((gemlog-index-path (cat-parent-dir output-directory +archive-gemlog-file+))) (with-open-file (gemlog-stream gemlog-index-path :direction :output :if-does-not-exist :create :if-exists :supersede) (format gemlog-stream *gemlog-header*) (write-char #\Newline gemlog-stream) (write-links all-posts gemlog-stream) (format gemlog-stream "~%") (write-sequence (geminize-link (strcat " " *indices-home-backlink* " " *indices-home-backlink-name*)) gemlog-stream) (write-char #\Newline gemlog-stream)))) (defun make-topic-index (all-posts output-directory all-topics) (let ((topics-index-path (cat-parent-dir output-directory +archive-topic-file+))) (with-open-file (stream topics-index-path :direction :output :if-does-not-exist :create :if-exists :supersede) (write-sequence *topic-index-header* stream) (write-char #\Newline stream) (loop for topic in all-topics do (format stream "~a~2%" (geminize-h2 topic)) (let ((in-topic-posts (remove-if-not (lambda (post) (let ((post-topics (post-topics post))) (find topic post-topics :test #'string-equal))) all-posts))) (write-links in-topic-posts stream) (format stream "~%"))) (write-sequence (geminize-link (strcat " " *indices-home-backlink* " " *indices-home-backlink-name*)) stream) (write-char #\Newline stream)))) (defun generate-gemlog (bulk-posts-dir output-directory) (multiple-value-bind (all-posts all-topics) (create-archive bulk-posts-dir output-directory) (make-topic-index all-posts output-directory all-topics) (make-gemlog-index all-posts output-directory))) (a:define-constant +bulk-dir-prompt+ "Original posts directory? " :test #'string=) (a:define-constant +output-dir-prompt+ "Output directory? " :test #'string=) (a:define-constant +root-dir-prompt+ "Type the root of the path for the gemlog (e.g: \"gemini://example/cage/\" → \"/cage/\") " :test #'string=) (defun generate-on-tui () (let ((bulk-posts-dir (getenv +environment-variable-gemlog-posts-archive+ nil)) (output-directory (getenv +environment-variable-gemlog-posts-destination+ nil))) (format t "Starting processing~%") (labels ((ask-output-directory () (ui:ask-string-input #'on-out-complete :prompt +output-dir-prompt+ :complete-fn #'complete:directory-complete)) (ask-path-prefix () (ui:ask-string-input #'on-root-completed :prompt +root-dir-prompt+)) (generate () (generate-gemlog bulk-posts-dir output-directory) (notify "Gemlog generated~%") (submit-antenna)) (submit-antenna () (when (and (getenv +environment-variable-antenna-target-url+ nil) (getenv +environment-variable-antenna-url+ nil)) (ui:ask-string-input #'on-submit-to-antenna :prompt (format nil "Antenna submit URL: ~a, submit? [y/N]" (to-s (generate-antenna-submit-url)))))) (on-submit-to-antenna (maybe-accepted) (ui-goodies::with-valid-yes-at-prompt (maybe-accepted y-pressed-p) (when y-pressed-p (gemini-client:slurp-gemini-url (to-s (generate-antenna-submit-url)))) (ui:open-gemini-address output-directory))) (on-bulk-complete (input-text) (ui::with-enqueued-process () (setf bulk-posts-dir input-text) (cond ((null output-directory) (ask-output-directory)) ((null *uri-path-prefix*) (ui::with-enqueued-process () (ask-path-prefix))) (t (generate))))) (on-out-complete (out-directory) (ui::with-enqueued-process () (setf output-directory out-directory) (if (null *uri-path-prefix*) (ask-path-prefix) (generate)))) (on-root-completed (root) (ui::with-enqueued-process () (setf *uri-path-prefix* root) (generate)))) (cond ((null bulk-posts-dir) (ui:ask-string-input #'on-bulk-complete :prompt +bulk-dir-prompt+ :complete-fn #'complete:directory-complete)) ((null output-directory) (ui::with-enqueued-process () (ask-output-directory))) ((null *uri-path-prefix*) (ui::with-enqueued-process () (ask-path-prefix))) (t (generate-gemlog bulk-posts-dir output-directory) (notify "Gemlog generated~%") (ui:open-gemini-address output-directory)))))) (defun ask-input-cli (prompt) (notify "~a~%" prompt) (finish-output) (read-line)) (defun generate-antenna-submit-url () (multiple-value-bind (actual-iri host path query port fragment) (gemini-client:displace-iri (iri-parser:iri-parse (getenv +environment-variable-antenna-url+ nil))) (declare (ignore actual-iri fragment query)) (iri-parser:make-iri gemini-constants:+gemini-scheme+ nil host port path (getenv +environment-variable-antenna-target-url+ nil)))) (if (ui:tui-active-p) (generate-on-tui) (let* ((bulk-posts-dir (or (getenv +environment-variable-gemlog-posts-archive+ nil) (ask-input-cli +bulk-dir-prompt+))) (output-directory (or (getenv +environment-variable-gemlog-posts-destination+ nil) (ask-input-cli +output-dir-prompt+)))) (when (null *uri-path-prefix*) (setf *uri-path-prefix* (ask-input-cli +root-dir-prompt+))) (generate-gemlog bulk-posts-dir output-directory) (when (and (getenv +environment-variable-antenna-target-url+ nil) (getenv +environment-variable-antenna-url+ nil)) (format t "Antenna submit URL:~%~a~%" (to-s (generate-antenna-submit-url))) (let ((submit (ask-input-cli "Submit the gemlog to antenna? [y/N]"))) (when (string= submit "y") (gemini-client:slurp-gemini-url (to-s (generate-antenna-submit-url))))))))