-[TUI] added module to remove query trackers parameters from URLs (before opening or copying to clipboard).

Makefile.am

@@ -85,6 +85,7 @@ data/modules/delete-by-regex.lisp \
 data/modules/expand-abbrev-command-window.lisp \
 data/modules/fetch-expired-poll.lisp \
 data/modules/next-previous-open.lisp \
+data/modules/remove-url-tracking.lisp \
 data/modules/rewrite-message-urls.lisp \
 data/modules/share-gemini-link.lisp \
 data/scripts/delete-old-posts.lisp \

Makefile.in

@@ -462,6 +462,7 @@ data/modules/delete-by-regex.lisp \
 data/modules/expand-abbrev-command-window.lisp \
 data/modules/fetch-expired-poll.lisp \
 data/modules/next-previous-open.lisp \
+data/modules/remove-url-tracking.lisp \
 data/modules/rewrite-message-urls.lisp \
 data/modules/share-gemini-link.lisp \
 data/scripts/delete-old-posts.lisp \

data/modules/remove-url-tracking.lisp

@@ -0,0 +1,108 @@
+;; tinmop module for remove query url trackers parameters
+;; Copyright © 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/>.
+
+;; IMPORTANT NOTE: loading this module will contact, via HTTP, the network resource hosted on github, exposing your client's data (the actual url is bound to the constant '+tracker-url-tracker-data+') below.
+
+(in-package :modules)
+
+(a:define-constant +tracker-url-tracker-data+ "https://raw.githubusercontent.com/Smile4ever/Neat-URL/refs/heads/master/data/default-params-by-category.json"
+  :test #'string=)
+
+(a:define-constant +tracker-url-json-root-key+ "categories" :test #'string=)
+
+(a:define-constant +tracker-url-json-tracker-key+ "params" :test #'string=)
+
+(a:define-constant +tracker-url-json-tracker-file+ "tracker-url-json-trackers.json"
+  :test #'string=)
+
+(defun tracker-url-parse-json (json-file)
+  (ignore-errors
+   (let* ((json (fs:slurp-file json-file))
+          (parsed-json (gethash +tracker-url-json-root-key+
+                                (yason:parse json)))
+          (results     '()))
+     (loop for row in parsed-json do
+       (let ((parameters (gethash +tracker-url-json-tracker-key+ row)))
+         (loop for parameter in parameters do
+           (let ((splitted (cl-ppcre:split "@" parameter)))
+             (if (= (length splitted)
+                    1)
+                 (push parameter results)
+                 (push (cons (first splitted)
+                             (second splitted))
+                       results))))))
+     results)))
+
+(defun tracker-url-ensure-tracker-file ()
+  (let ((file (handler-bind ((error
+                               (lambda (e)
+                                 (declare (ignore e))
+                                 (invoke-restart 'res:return-home-filename))))
+                (res:get-data-file +tracker-url-json-tracker-file+))))
+    (if (fs:file-exists-p file)
+        file
+        (with-open-file (stream
+                         file
+                         :direction :output
+                         :if-exists :supersede)
+          (ignore-errors
+           (let ((json (misc-utils::get-url-content-body +tracker-url-tracker-data+)))
+             (write-string json stream)))
+          (tracker-url-ensure-tracker-file)))))
+
+(defun tracker-url-fetch-tracker-data ()
+  (let ((json-file (tracker-url-ensure-tracker-file)))
+    (tracker-url-parse-json json-file)))
+
+(defparameter *tracker-url-trackers-probes* (tracker-url-fetch-tracker-data))
+
+(defgeneric tracker-url-match (probe host query-key))
+
+(defmethod tracker-url-match ((probe string) host (query-key string))
+  (string= probe query-key))
+
+(defmethod tracker-url-match ((probe cons) (host string) (query-key string))
+  (and (tracker-url-match (car probe) nil query-key)
+       (filesystem-utils:filename-pattern-match (cdr probe)
+                                                host)))
+
+(defun tracker-url-remove-tracker (text)
+  (handler-case
+      (let ((parsed-url (iri:iri-parse text)))
+        (with-accessors ((host  iri:host)
+                         (query iri:query)) parsed-url
+          (let ((clean-query-pairs '())
+                (splitted-query (cl-ppcre:split "&" query)))
+            (loop for query-pair in splitted-query do
+              (let ((tracker-found nil))
+                (loop named inner
+                      for tracker-probe in *tracker-url-trackers-probes*
+                      with query-pair-splitted = (cl-ppcre:split "=" query-pair)
+                      do (when (tracker-url-match tracker-probe
+                                                  host
+                                                  (first query-pair-splitted))
+                           (setf tracker-found t)
+                           (return-from inner t)))
+                (when (not tracker-found)
+                  (push query-pair clean-query-pairs))))
+            (let ((clean-query (text-utils:join-with-strings (reverse clean-query-pairs)
+                                                             "&")))
+              (setf (iri:query parsed-url) clean-query)
+              (text-utils:to-s parsed-url)))))
+    (error ()
+      text)))
+
+(hooks:add-hook 'hooks:*before-copying-to-clipboard* #'tracker-url-remove-tracker)

etc/init.lisp

@@ -53,6 +53,15 @@
 
 (load-module "fetch-expired-poll.lisp")
 
+;; remove the trackers parameters from url
+
+;; IMPORTANT NOTE:  loading this  module will  contact, via  HTTP, the
+;; network resource hosted on github, exposing your client's data (the
+;; actual url  is bound to the  constant '+tracker-url-tracker-data+')
+;; below.
+
+;; (load-module "remove-url-tracking.lisp")
+
 ;; keybindings syntax:
 
 ;; a command is executed after a sequence  of one or more keys.  a key

src/hooks.lisp

@@ -145,3 +145,9 @@ open the links")
 
 (defparameter *after-getting-all-fediverse-notifications* '()
   "Run these hooks for all notifications got")
+
+(defparameter *before-copying-to-clipboard* '()
+  "Run these hooks before copying the text to clipboard, the elements of this list are function that get the text to be copied and must return a string")
+
+(defparameter *before-opening-url* '()
+    "Run these hooks before opening a link, the elements of this list are function that get the text to be copied and must return a string")

src/open-message-link-window.lisp

@@ -96,6 +96,9 @@
 
 (defun open-message-link (url enqueue)
   (tui-utils:with-notify-errors
+    (when hooks:*before-opening-url*
+      (setf url
+            (hooks:run-hook-compose 'hooks:*before-opening-url* url)))
     (cond
       ((text-utils:string-starts-with-p gopher-parser:+gopher-scheme+ url)
        (multiple-value-bind (host port type selector)

src/os-utils.lisp

@@ -410,4 +410,7 @@ numerical user ID, as an assoc-list."
         (error (format nil (_ "Compressing directory ~s failed") dir))))))
 
 (defun copy-to-clipboard (text)
+  (when hooks:*before-copying-to-clipboard*
+    (setf text
+          (hooks:run-hook-compose 'hooks:*before-copying-to-clipboard* text)))
   (trivial-clipboard:text text))

src/package.lisp

@@ -2011,7 +2011,9 @@
    :*after-titan-socket*
    :*after-titan-request-sent*
    :*after-getting-fediverse-notification*
-   :*after-getting-all-fediverse-notifications*))
+   :*after-getting-all-fediverse-notifications*
+   :*before-copying-to-clipboard*
+   :*before-opening-url*))
 
 (defpackage :keybindings
   (:use