diff --git a/etc/init.lisp b/etc/init.lisp
index b3d0b73..4c48a2b 100644
--- a/etc/init.lisp
+++ b/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)
diff --git a/modules/next-previous-open.lisp b/modules/next-previous-open.lisp
index f55bd42..36d53fe 100644
--- a/modules/next-previous-open.lisp
+++ b/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 .
+
(in-package :modules)
(defun open-next ()
diff --git a/modules/rewrite-message-urls.lisp b/modules/rewrite-message-urls.lisp
new file mode 100644
index 0000000..077c255
--- /dev/null
+++ b/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 .
+
+(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)
diff --git a/src/hooks.lisp b/src/hooks.lisp
index 78db44c..2578214 100644
--- a/src/hooks.lisp
+++ b/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")
diff --git a/src/open-message-link-window.lisp b/src/open-message-link-window.lisp
index f9a7066..8785a4d 100644
--- a/src/open-message-link-window.lisp
+++ b/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))
diff --git a/src/package.lisp b/src/package.lisp
index e0453b8..b27e042 100644
--- a/src/package.lisp
+++ b/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