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