cage
/
tinmop
mirror of https://codeberg.org/cage/tinmop/
1
0
Fork 0
Code Issues

- added 'run-hook-compose'; 

- added a module to rewrite URLs.
This commit is contained in:
cage 2020-12-31 14:58:40 +01:00
parent b8d7af915c
commit 8dae8ddac2
6 changed files with 124 additions and 2 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
etc/init.lisp
View File

@ -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)

16
modules/next-previous-open.lisp
View File

@ -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 ()

82
modules/rewrite-message-urls.lisp Normal file
View File

@ -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)

15
src/hooks.lisp
View File

@ -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")

3
src/open-message-link-window.lisp
View File

@ -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))

5
src/package.lisp
View File

@ -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