From 981cbdcfc745603be151086a9891660bd984aaf7 Mon Sep 17 00:00:00 2001 From: cage Date: Wed, 15 Jun 2022 14:33:56 +0200 Subject: [PATCH] - [gemini] added a script to generate a gemlog; - removed *tour-links-window*; - adding a new command: open-gemini-links-and-ask-tour. --- etc/init.lisp | 12 ++ scripts/generate-gemlog.lisp | 314 ++++++++++++++++++++++++++++++ src/open-message-link-window.lisp | 16 +- src/package.lisp | 3 +- src/specials.lisp | 2 - src/ui-goodies.lisp | 10 +- 6 files changed, 338 insertions(+), 19 deletions(-) create mode 100644 scripts/generate-gemlog.lisp diff --git a/etc/init.lisp b/etc/init.lisp index c9cd1d4..7537c02 100644 --- a/etc/init.lisp +++ b/etc/init.lisp @@ -133,6 +133,8 @@ ;; (define "C-x a e" #'bar) (defun gemini-search () + "Search the geminispace using keyword (note: will contact + \"gemini://geminispace.info/search\"" (gemini-viewer:load-gemini-url "gemini://geminispace.info/search")) ;; global keymap @@ -178,6 +180,16 @@ (define-key "M-g g b s" #'display-bookmark) +(defun open-gemini-links-and-ask-tour () + "Open the link window and ask for tour link indices" + (when (message-window:display-gemini-text-p specials:*message-window*) + (when (not specials:*open-message-link-window*) + (ui:open-message-link)) + (ui::focus-to-open-message-link-window) + (ui:tour-mode-link))) + +(define-key "M-t a" #'open-gemini-links-and-ask-tour) + (define-key "M-t t" #'next-tour-link) (define-key "M-t s" #'show-tour-links) diff --git a/scripts/generate-gemlog.lisp b/scripts/generate-gemlog.lisp new file mode 100644 index 0000000..0617626 --- /dev/null +++ b/scripts/generate-gemlog.lisp @@ -0,0 +1,314 @@ +;; 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 . + +(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=) + +(defparameter *gemlog-header* (format nil "# Posts~%")) + +(defparameter *topic-index-header* (format nil "# Topics archive~%")) + +(defparameter *uri-prefix-path* "/") + +(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 #'fs:regular-file-p + (fs:collect-children capsule-bulk-dir))) + (parsed-posts (mapcar (lambda (a) + (handler-case + (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) + (handler-case + (let ((meta (extract-meta a))) + meta) + (error (e) + (notify + "Unable to parse meta ~a: ~a" + a e) + nil))) + parsed-posts))) + (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))))) + results)) + +(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 ((line (cond + ((tag= :h1 node) + (geminize-h1 (first (children node)))) + ((tag= :h2 node) + (geminize-h2 (first (children node)))) + ((tag= :h3 node) + (geminize-h3 (first (children node)))) + ((tag= :li node) + (geminize-list (first (children node)))) + ((tag= :quote node) + (geminize-quote (first (children node)))) + ((tag= :a node) + (geminize-link (strcat " " + (attribute-value (find-attribute :href node)) + " " + (first (children node))))) + ((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) + (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) + (loop for post in posts do + (let* ((filename (strip-dirs-from-path (archive-file-path post))) + (relative-archive-path (strcat *uri-prefix-path* + (cat-parent-dir +archive-dir+ + (percent-encode filename)))) + (link-text (strcat (format-date-to-string (post-date post)) + " " + (cl-ppcre:regex-replace-all "-" + 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-links all-posts 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) + (loop for topic in all-topics do + (format stream "~a~%" (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)))))) + +(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://foo.net/cage/\" → \"/cage/\") " :test #'string=) + +(defun generate-on-tui () + (let ((bulk-posts-dir nil) + (output-directory nil)) + (format t "Starting processing~%") + (labels ((on-bulk-complete (input-text) + (ui::with-enqueued-process () + (setf bulk-posts-dir input-text) + (ui:ask-string-input #'on-out-complete + :prompt +output-dir-prompt+ + :complete-fn #'complete:directory-complete))) + (on-out-complete (out-directory) + (ui::with-enqueued-process () + (setf output-directory out-directory) + (ui:ask-string-input #'on-root-completed + :prompt +root-dir-prompt+))) + (on-root-completed (root) + (ui::with-enqueued-process () + (setf *uri-prefix-path* root) + (generate-gemlog bulk-posts-dir output-directory) + (notify "Gemlog generated~%") + (ui:open-gemini-address output-directory)))) + (ui:ask-string-input #'on-bulk-complete + :prompt +bulk-dir-prompt+ + :complete-fn #'complete:directory-complete)))) + +(defun ask-input-cli (prompt) + (notify "~a~%" prompt) + (finish-output) + (read-line)) + +(if (ui:tui-active-p) + (generate-on-tui) + (let* ((bulk-posts-dir (ask-input-cli +bulk-dir-prompt+)) + (output-directory (ask-input-cli +output-dir-prompt+))) + (setf *uri-prefix-path* (ask-input-cli +root-dir-prompt+)) + (generate-gemlog bulk-posts-dir output-directory))) diff --git a/src/open-message-link-window.lisp b/src/open-message-link-window.lisp index 714c22c..4463b46 100644 --- a/src/open-message-link-window.lisp +++ b/src/open-message-link-window.lisp @@ -226,7 +226,9 @@ screen." (defun init-tour-links (links &key (title (_ "Links")) (center-position nil)) (let* ((low-level-window (make-croatoan-window :enable-function-keys t))) - (setf *tour-links-window* + (when *open-message-link-window* + (win-close *open-message-link-window*)) + (setf *open-message-link-window* (make-instance 'open-gemini-document-link-window :center-position center-position :top-row-padding 0 @@ -237,12 +239,12 @@ screen." :uses-border-p t :keybindings keybindings:*open-message-link-keymap* :croatoan-window low-level-window)) - (refresh-config *tour-links-window*) - (resync-rows-db *tour-links-window* :redraw nil) - (when (not (line-oriented-window:rows-empty-p *tour-links-window*)) - (select-row *tour-links-window* 0)) - (draw *tour-links-window*) - *tour-links-window*)) + (refresh-config *open-message-link-window*) + (resync-rows-db *open-message-link-window* :redraw nil) + (when (not (line-oriented-window:rows-empty-p *open-message-link-window*)) + (select-row *open-message-link-window* 0)) + (draw *open-message-link-window*) + *open-message-link-window*)) (defclass open-chat-document-link-window (focus-marked-window simple-line-navigation-window diff --git a/src/package.lisp b/src/package.lisp index bee6fd8..5682b4d 100644 --- a/src/package.lisp +++ b/src/package.lisp @@ -1393,8 +1393,7 @@ :*gemini-toc-window* :*chats-list-window* :*gempub-library-window* - :*filesystem-explorer-window* - :*tour-links-window*)) + :*filesystem-explorer-window*)) (defpackage :complete (:use diff --git a/src/specials.lisp b/src/specials.lisp index 61f12bb..4c99f33 100644 --- a/src/specials.lisp +++ b/src/specials.lisp @@ -71,5 +71,3 @@ "The window that shows the gempub library.") (defparameter *filesystem-explorer-window* nil) - -(defparameter *tour-links-window* nil) diff --git a/src/ui-goodies.lisp b/src/ui-goodies.lisp index f843412..c651c35 100644 --- a/src/ui-goodies.lisp +++ b/src/ui-goodies.lisp @@ -468,8 +468,7 @@ Metadata includes: *open-attach-window* *gemini-streams-window* *gemini-certificates-window* - *filesystem-explorer-window* - *tour-links-window*)))) + *filesystem-explorer-window*)))) (defun find-window-focused () (stack:do-stack-element (window windows::*window-stack*) @@ -702,11 +701,6 @@ along the focused window." :documentation "Move focus on open-link window" :info-change-focus-message (_ "Focus passed on link window")) -(gen-focus-to-window tour-links-window - *tour-links-window* - :documentation "Move focus on tour links window" - :info-change-focus-message (_ "Focus passed on tour links")) - (gen-focus-to-window open-gemini-stream-windows *gemini-streams-window* :documentation "Move focus on open gemini streams window" @@ -2402,7 +2396,7 @@ gemini://gemini.circumlunar.space/docs/companion/subscription.gmi (open-message-link-window:init-tour-links (reverse tour) :title (_ "Current links tour") :center-position t) - (focus-to-tour-links-window)) + (focus-to-open-message-link-window)) (defun save-selected-message-in-tour () "Save the selected link in the tour queue"