From mboxrd@z Thu Jan 1 00:00:00 1970 Path: news.gmane.io!.POSTED.blaine.gmane.org!not-for-mail From: Alex Bochannek Newsgroups: gmane.emacs.bugs Subject: bug#49033: 28.0.50; [PATCH] Feature suggestion, url-cache-expiry-alist to override expire time for cache pruning Date: Tue, 15 Jun 2021 15:55:54 -0700 Message-ID: References: <87r1h3tdys.fsf@gnus.org> Mime-Version: 1.0 Content-Type: multipart/mixed; boundary="=-=-=" Injection-Info: ciao.gmane.io; posting-host="blaine.gmane.org:116.202.254.214"; logging-data="16674"; mail-complaints-to="usenet@ciao.gmane.io" User-Agent: Gnus/5.13 (Gnus v5.13) Emacs/28.0.50 (darwin) Cc: 49033@debbugs.gnu.org To: Lars Ingebrigtsen Original-X-From: bug-gnu-emacs-bounces+geb-bug-gnu-emacs=m.gmane-mx.org@gnu.org Wed Jun 16 00:57:11 2021 Return-path: Envelope-to: geb-bug-gnu-emacs@m.gmane-mx.org Original-Received: from lists.gnu.org ([209.51.188.17]) by ciao.gmane.io with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.92) (envelope-from ) id 1ltHza-00045v-Tf for geb-bug-gnu-emacs@m.gmane-mx.org; Wed, 16 Jun 2021 00:57:11 +0200 Original-Received: from localhost ([::1]:57182 helo=lists1p.gnu.org) by lists.gnu.org with esmtp (Exim 4.90_1) (envelope-from ) id 1ltHzZ-0007cM-Jp for geb-bug-gnu-emacs@m.gmane-mx.org; Tue, 15 Jun 2021 18:57:09 -0400 Original-Received: from eggs.gnu.org ([2001:470:142:3::10]:56406) by lists.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.90_1) (envelope-from ) id 1ltHzS-0007bz-Ad for bug-gnu-emacs@gnu.org; Tue, 15 Jun 2021 18:57:02 -0400 Original-Received: from debbugs.gnu.org ([209.51.188.43]:39477) by eggs.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_128_GCM_SHA256:128) (Exim 4.90_1) (envelope-from ) id 1ltHzS-0001s8-1I for bug-gnu-emacs@gnu.org; Tue, 15 Jun 2021 18:57:02 -0400 Original-Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1ltHzR-0006D3-Ux for bug-gnu-emacs@gnu.org; Tue, 15 Jun 2021 18:57:01 -0400 X-Loop: help-debbugs@gnu.org Resent-From: Alex Bochannek Original-Sender: "Debbugs-submit" Resent-CC: bug-gnu-emacs@gnu.org Resent-Date: Tue, 15 Jun 2021 22:57:01 +0000 Resent-Message-ID: Resent-Sender: help-debbugs@gnu.org X-GNU-PR-Message: followup 49033 X-GNU-PR-Package: emacs X-GNU-PR-Keywords: patch Original-Received: via spool by 49033-submit@debbugs.gnu.org id=B49033.162379776323802 (code B ref 49033); Tue, 15 Jun 2021 22:57:01 +0000 Original-Received: (at 49033) by debbugs.gnu.org; 15 Jun 2021 22:56:03 +0000 Original-Received: from localhost ([127.0.0.1]:51023 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1ltHyU-0006Bq-Oq for submit@debbugs.gnu.org; Tue, 15 Jun 2021 18:56:03 -0400 Original-Received: from ns.lapseofthought.com ([50.0.39.240]:56169 helo=mail.lapseofthought.com) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1ltHyQ-0006BO-EW for 49033@debbugs.gnu.org; Tue, 15 Jun 2021 18:56:01 -0400 Original-Received: from awb-mbp.local (unknown [IPv6:2601:646:4200:b470:489a:eae4:d7dc:db39]) (using TLSv1.2 with cipher ECDHE-RSA-AES256-GCM-SHA384 (256/256 bits)) (No client certificate requested) by mail.lapseofthought.com (Postfix) with ESMTPSA id 4G4Nvv3gdfz3pdqP; Tue, 15 Jun 2021 15:55:55 -0700 (PDT) In-Reply-To: <87r1h3tdys.fsf@gnus.org> (Lars Ingebrigtsen's message of "Tue, 15 Jun 2021 16:11:23 +0200") Authentication-Results: ORIGINATING; auth=pass smtp.auth=alex smtp.mailfrom=alex@bochannek.com X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.18 Precedence: list X-BeenThere: bug-gnu-emacs@gnu.org List-Id: "Bug reports for GNU Emacs, the Swiss army knife of text editors" List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: bug-gnu-emacs-bounces+geb-bug-gnu-emacs=m.gmane-mx.org@gnu.org Original-Sender: "bug-gnu-emacs" Xref: news.gmane.io gmane.emacs.bugs:208607 Archived-At: --=-=-= Content-Type: text/plain Lars Ingebrigtsen writes: >> - ;; Twelve hours. >> - (* 12 60 60)))) >> + gravatar-cache-ttl))) > > I don't mind that -- but is this really something that somebody would > want to control? It just seemed unlikely to me. I tend to find it difficult to reason about functionality if constants like this are in the code and not in variables. It may be unlikely that many people will want to customize it, but I'd rather expose this as a configuration variable than hide a static value in the code. As far as the URL caching code is concerned, I cleaned it up a bit and added some simple tests and documentation. Support URL-specific cache expiration * test/lisp/url/url-cache-tests.el: Test URL-to-filename and filename-to-URL mappings used by URL caching. * lisp/url/url-cache.el (url-cache-expiry-alist) (url-cache-create-url-from-file, url-cache-expired) (url-cache-prune-cache): Expire cache entries based on regular expressions matching URLs defined in new customizable variable url-cache-expire-alist. * doc/misc/url.texi (Disk Caching): Mention url-cache-expiry-alist variable. --=-=-= Content-Type: text/x-patch Content-Disposition: inline diff --git a/doc/misc/url.texi b/doc/misc/url.texi index 8f15e11007..2ea34e0d03 100644 --- a/doc/misc/url.texi +++ b/doc/misc/url.texi @@ -923,6 +923,12 @@ Disk Caching expire-time argument of the function @code{url-cache-expired}. @end defopt +@defopt url-cache-expiry-alist +This variable is an alist of regular expressions matching @var{url}'s +and their associated expiration delay in seconds. It is used by the +functions @code{url-cache-expired} and @code{url-cache-prune-cache}. +@end defopt + @defun url-fetch-from-cache This function takes a URL as its argument and returns a buffer containing the data cached for that URL. diff --git a/lisp/url/url-cache.el b/lisp/url/url-cache.el index 830e6ba9dc..48f315a5cc 100644 --- a/lisp/url/url-cache.el +++ b/lisp/url/url-cache.el @@ -38,6 +38,15 @@ url-cache-expire-time :type 'integer :group 'url-cache) +(defcustom url-cache-expiry-alist nil + "Alist of URL regular expressions to override the `url-cache-expire-time'. +The key is a string to be matched against the URL of the cached entry and the +value is the expire time in seconds. Only the protocol and hostname of the URL +are available for matching." + :version "28.1" + :type 'alist + :group 'url-cache) + ;; Cache manager (defun url-cache-file-writable-p (file) "Follows the documentation of `file-writable-p', unlike `file-writable-p'." @@ -186,6 +195,31 @@ url-cache-create-filename (if (url-p url) url (url-generic-parse-url url))))) +(defun url-cache-create-url-from-file (file) + (let* ((url-path-list + (split-string + (file-name-directory + (string-trim-left file (concat "^.*/" (user-real-login-name)))) + "/" t)) + (protocol (pop url-path-list)) + (hostname + (string-join (reverse url-path-list) ".")) + (url (string-join (list protocol hostname) "://"))) + url)) + +(defun url-cache-expiry-by-url (url) + (let ((expire-time + (remove nil + (mapcar + (lambda (alist) + (let ((key (car alist)) + (value (cdr alist))) + (if (string-match + key url) + value))) + url-cache-expiry-alist)))) + (if (consp expire-time) (apply 'min expire-time) nil))) + ;;;###autoload (defun url-cache-extract (fnam) "Extract FNAM from the local disk cache." @@ -204,7 +238,9 @@ url-cache-expired (time-less-p (time-add cache-time - (or expire-time url-cache-expire-time)) + (or expire-time + (url-cache-expiry-by-url url) + url-cache-expire-time)) nil))))) (defun url-cache-prune-cache (&optional directory) @@ -226,8 +262,10 @@ url-cache-prune-cache ((time-less-p (time-add (file-attribute-modification-time (file-attributes file)) - url-cache-expire-time) - now) + (or (url-cache-expiry-by-url + (url-cache-create-url-from-file file)) + url-cache-expire-time)) + now) (delete-file file) (setq deleted-files (1+ deleted-files)))))) (if (< deleted-files total-files) diff --git a/test/lisp/url/url-cache-tests.el b/test/lisp/url/url-cache-tests.el new file mode 100644 index 0000000000..f4e49ce3b9 --- /dev/null +++ b/test/lisp/url/url-cache-tests.el @@ -0,0 +1,76 @@ +;;; url-cache-tests.el --- Test suite for url-cache. -*- lexical-binding:t -*- + +;; Copyright (C) 2021 Free Software Foundation, Inc. + +;; Author: Alex Bochannek +;; Keywords: data + +;; This file is part of GNU Emacs. + +;; GNU Emacs 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. + +;; GNU Emacs 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 GNU Emacs. If not, see . + +;;; Code: + +(require 'ert) +(require 'url-cache) + +(ert-deftest url-cache-url-to-filename-tests () + "Test the URL to filename resolution for the URL cache" + (should (equal (file-name-directory + (url-cache-create-filename "http://www.fsf.co.uk")) + (string-join + (list url-cache-directory (user-real-login-name) + "http/uk/co/fsf/www/") "/"))) + (should (equal (file-name-directory + (url-cache-create-filename "https://www.fsf.co.uk")) + (string-join + (list url-cache-directory (user-real-login-name) + "https/uk/co/fsf/www/") "/"))) + (should (equal (file-name-directory + (url-cache-create-filename "http://host")) + (string-join + (list url-cache-directory (user-real-login-name) + "http/host/") "/"))) + (should (equal (file-name-directory + (url-cache-create-filename "http://host:80")) + (string-join + (list url-cache-directory (user-real-login-name) + "http/host/") "/"))) + (should (equal (file-name-directory + (url-cache-create-filename "http://host#fragment")) + (string-join + (list url-cache-directory (user-real-login-name) + "http/host/") "/")))) + +(ert-deftest url-cache-filename-to-url-tests () + "Test the filename to URL resolution for the URL cache" + (should (equal (url-cache-create-url-from-file + (string-join + (list url-cache-directory (user-real-login-name) + "http/uk/co/fsf/www/") "/")) + "http://www.fsf.co.uk")) + (should (equal (url-cache-create-url-from-file + (string-join + (list url-cache-directory (user-real-login-name) + "https/uk/co/fsf/www/") "/")) + "https://www.fsf.co.uk")) + (should (equal (url-cache-create-url-from-file + (string-join + (list url-cache-directory (user-real-login-name) + "http/host/") "/")) + "http://host"))) + +(provide 'url-cache-tests) + +;;; url-cache-tests.el ends here --=-=-= Content-Type: text/plain -- Alex. --=-=-=--