mirror of
https://codeberg.org/cage/tinmop/
synced 2025-06-05 01:09:17 +02:00
109 lines
4.7 KiB
Common Lisp
109 lines
4.7 KiB
Common Lisp
;; 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)
|