- added 'run-hook-compose';

- added a module to rewrite URLs.

etc/init.lisp

@@ -452,6 +452,11 @@
 
 ;;;; hooks
 
+;; this module  will install an  hook to  rewrite urls; By  default it
+;; does nothing, see the source for configuration
+
+(load-module "rewrite-message-urls.lisp")
+
 ;;; this hooks will skips toots with contain less than 20 words
 ;;; (note: it is commented out)
 

modules/next-previous-open.lisp

@@ -1,3 +1,19 @@
+;; tinmop module for utility move command in thread window
+;; 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 open-next ()

modules/rewrite-message-urls.lisp

@@ -0,0 +1,82 @@
+;; tinmop module for rewrite link URLs before opening
+;; 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)
+
+(defparameter *rewriting-link-rules* ()
+  "Before  displaying  messages that  module  will  rewrites the  first
+  element of each item of this list with the second
+
+Example
+
+   (\"foo\" \"bar\")
+      ^^^
+      first
+              ^^^
+              second
+
+will replace 'foo' with 'bar'.
+
+So the whole list is like: '((\"foo\" \"bar\") (\"old\" \"new\") ...)")
+
+(defun rewriting-link-add-rule (from to)
+  (push (list from to)
+        *rewriting-link-rules*))
+
+(defun rewriting-link-messages-links-rules (old-links)
+  (let ((results ()))
+    (loop for old-link in old-links do
+      (loop named inner
+            for rule in *rewriting-link-rules*
+            do
+               (let ((rewritten-link (cl-ppcre:regex-replace (first rule)
+                                                             old-link
+                                                             (second rule))))
+                 (when (string/= rewritten-link old-link)
+                   (push (cons old-link rewritten-link)
+                         results)
+                   (return-from inner t)))))
+    results))
+
+(defun rewriting-link-message-hook-fn (message-window)
+  (with-accessors ((source-text message-window:source-text)) message-window
+    (let* ((all-links      (text-utils:collect-links source-text))
+           (links-mapping  (rewriting-link-messages-links-rules all-links)))
+      (loop for mapping in links-mapping do
+        (setf source-text
+              (cl-ppcre:regex-replace-all (car mapping)
+                                          source-text
+                                          (cdr mapping)))))))
+
+(defun rewriting-link-links-window-hook-fn (all-links)
+  (let ((links-mapping  (rewriting-link-messages-links-rules all-links))
+        (results        ()))
+    (loop for link in all-links do
+      (let* ((mapping (find-if (lambda (a) (string= link (car a))) links-mapping))
+             (mapped  (if mapping
+                          (cl-ppcre:regex-replace-all (car mapping)
+                                                      link
+                                                      (cdr mapping))
+                          link)))
+
+        (push mapped results)))
+    (reverse results)))
+
+(hooks:add-hook 'hooks:*before-prepare-for-rendering-message*
+                #'rewriting-link-message-hook-fn)
+
+(hooks:add-hook 'hooks:*before-displaying-links-hook*
+                #'rewriting-link-links-window-hook-fn)

src/hooks.lisp

@@ -51,6 +51,17 @@ run."
       (with-hook-restart
         (apply fn args)))))
 
+(defgeneric run-hook-compose (hook &rest args)
+  (:documentation "Apply first function in HOOK to ARGS, second hook
+to the results of first function applied and so on,
+returns the results of af the last hook.")
+  (:method ((*hook* symbol) &rest args)
+    (let ((results args))
+      (dolist (fn (symbol-value *hook*))
+        (with-hook-restart
+          (setf results (apply fn results))))
+      results)))
+
 (defgeneric run-hook-until-failure (hook &rest args)
   (:documentation "Like `run-hook-with-args', but quit once a function returns nil.")
   (:method ((*hook* symbol) &rest args)
@@ -88,3 +99,7 @@ all hooks must returns nil for this message to be not skipped
 
 Each function takes 4 parameters: status, timeline, folder, kind (:home :public)
 localp")
+
+(defparameter *before-displaying-links-hook* '()
+  "Run this hooks before sending the list of URLs to the window that allow the user to
+open the links")

src/open-message-link-window.lisp

@@ -42,6 +42,9 @@
       (let* ((message (db:find-status-id status-id))
              (links   (text-utils:collect-links (db:row-message-rendered-text message))))
         (with-croatoan-window (croatoan-window object)
+          (when hooks:*before-displaying-links-hook*
+            (setf links
+                  (hooks:run-hook-compose 'hooks:*before-displaying-links-hook* links)))
           (setf rows (make-rows links
                                 selected-line-bg
                                 selected-line-fg))

src/package.lisp

@@ -1444,14 +1444,15 @@
    :remove-hook
    :run-hooks
    :run-hook
-   :run-hook
+   :run-hook-compose
    :run-hook-until-failure
    :run-hook-until-success
    :*before-main-loop*
    :*before-quit*
    :*before-prepare-for-rendering-message*
    :*before-sending-message*
-   :*skip-message-hook*))
+   :*skip-message-hook*
+   :*before-displaying-links-hook*))
 
 (defpackage :keybindings
   (:use