bug#49033: 28.0.50; [PATCH] Feature suggestion, url-cache-expiry-alist to override expire time for cache pruning

[Alex Bochannek]

Lars Ingebrigtsen <larsi@gnus.org> 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.

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 <alex@bochannek.com>
+;; 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 <https://www.gnu.org/licenses/>.
+
+;;; 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

-- 
Alex.