- added a module to share a gemini page on pleroma.

etc/init.lisp

@@ -37,6 +37,10 @@
 
 (load-module "next-previous-open.lisp")
 
+;; share a gemini page
+
+(load-module "share-gemini-link.lisp")
+
 ;; keybindings syntax:
 
 ;; a command is executed after a sequence  of one or more keys.  a key

modules/share-gemini-link.lisp

@@ -0,0 +1,35 @@
+;; Tinmop module to share the link pointing to the current gemini page
+;; on pleroma.
+;; Copyright © 2020 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 <http://www.gnu.org/licenses/>.
+
+(in-package :modules)
+
+(defun gemini-window-p ()
+  (gemini-viewer:gemini-metadata-p (message-window:metadata specials:*message-window*)))
+
+(defun share-gemini-link ()
+  "Share the link pointing to the current gemini page on pleroma."
+  (if (gemini-window-p)
+      (let* ((metadata    (message-window:metadata specials:*message-window*))
+             (link        (last-elt (gemini-viewer:gemini-metadata-history metadata)))
+             (source      (gemini-viewer:gemini-metadata-source-file metadata))
+             (source-head (with-input-from-string (stream source)
+                            (read-line stream nil "...")))
+             (headline    (format nil "~a~2%~a~%" source-head link)))
+        (compose-message :message-header-text headline))
+      (error-message (_ "The window is not displaying a gemini document"))))
+
+(define-key "M-x s l" #'share-gemini-link *gemini-message-keymap*)

src/package.lisp

@@ -2104,6 +2104,7 @@
    :make-gemini-metadata
    :gemini-metadata-links
    :gemini-metadata-source-file
+   :gemini-metadata-history
    :gemini-metadata-p
    :copy-gemini-metadata
    :append-metadata-link
@@ -2342,6 +2343,7 @@
    :text-utils
    :resources-utils
    :specials
+   :db-utils
    :windows
    :sending-message
    :keybindings

src/ui-goodies.lisp

@@ -931,7 +931,7 @@ Force the checking for new message in the thread the selected message belong."
                              exceeding)
                          exceeding)))
 
-(defun compose-message (&optional timeline folder reply-id subject (visibility +status-public-visibility+))
+(defun compose-message (&key timeline folder reply-id subject (visibility +status-public-visibility+) (message-header-text nil))
   "Compose a new message"
   (setf *message-to-send* (make-instance 'sending-message:message-ready-to-send
                                          :visibility visibility
@@ -992,8 +992,16 @@ Force the checking for new message in the thread the selected message belong."
                                 :element-type 'character
                                 :if-exists    :append)
                  (write-sequence signature stream))))
+           (insert-header-text (file)
+             (when (string-not-empty-p file)
+               (with-open-file (stream file
+                                       :if-exists    :append
+                                       :direction    :output
+                                       :element-type 'character)
+                 (format stream "~a~%" message-header-text))))
            (add-body ()
              (let ((temp-file (fs:temporary-file)))
+               (insert-header-text temp-file)
                (prepare-reply-body temp-file)
                (add-signature temp-file)
                (let ((reference-open-file (get-universal-time)))
@@ -1025,7 +1033,11 @@ Force the checking for new message in the thread the selected message belong."
               (visibility       (db:row-message-visibility actual-message))
               (reply-id         (actual-author-message-id  actual-message)))
     (let* ((subject (db:row-message-subject actual-message)))
-      (compose-message timeline folder reply-id subject visibility))))
+      (compose-message :timeline   timeline
+                       :folder     folder
+                       :reply-id   reply-id
+                       :subject    subject
+                       :visibility visibility))))
 
 (defun send-message ()
   "Send message"