1;;; url-cache.el --- Uniform Resource Locator retrieval tool
2
3;; Copyright (C) 1996-1999, 2004-2021 Free Software Foundation, Inc.
4
5;; Keywords: comm, data, processes, hypermedia
6
7;; This file is part of GNU Emacs.
8
9;; GNU Emacs is free software: you can redistribute it and/or modify
10;; it under the terms of the GNU General Public License as published by
11;; the Free Software Foundation, either version 3 of the License, or
12;; (at your option) any later version.
13
14;; GNU Emacs is distributed in the hope that it will be useful,
15;; but WITHOUT ANY WARRANTY; without even the implied warranty of
16;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
17;; GNU General Public License for more details.
18
19;; You should have received a copy of the GNU General Public License
20;; along with GNU Emacs.  If not, see <https://www.gnu.org/licenses/>.
21
22;;; Code:
23
24(require 'url-parse)
25(require 'url-util)
26(require 'url)                        ;E.g. for url-configuration-directory.
27
28(defcustom url-cache-directory
29  (expand-file-name "cache" url-configuration-directory)
30  "The directory where cache files should be stored."
31  :type 'directory
32  :group 'url-file)
33
34(defcustom url-cache-expire-time 3600
35  "Default maximum time in seconds before cache files expire.
36Used by the function `url-cache-expired'."
37  :version "24.1"
38  :type 'integer
39  :group 'url-cache)
40
41;; Cache manager
42(defun url-cache-file-writable-p (file)
43  "Follows the documentation of `file-writable-p', unlike `file-writable-p'."
44  (and (file-writable-p file)
45       (if (file-exists-p file)
46           (not (file-directory-p file))
47         (file-directory-p (file-name-directory file)))))
48
49(defun url-cache-prepare (file)
50  "Makes it possible to cache data in FILE.
51Creates any necessary parent directories, deleting any non-directory files
52that would stop this.  Returns nil if parent directories can not be
53created.  If FILE already exists as a non-directory, it changes
54permissions of FILE or deletes FILE to make it possible to write a new
55version of FILE.  Returns nil if this can not be done, or if FILE already
56exists as a directory.  Otherwise, returns t, indicating that
57FILE can be created or overwritten."
58  (cond
59   ((url-cache-file-writable-p file)
60    t)
61   ((file-directory-p file)
62    nil)
63   (t
64    (condition-case ()
65	(or (make-directory (file-name-directory file) t) t)
66      (error nil)))))
67
68;;;###autoload
69(defun url-store-in-cache (&optional buff)
70  "Store buffer BUFF in the cache."
71    (with-current-buffer (get-buffer (or buff (current-buffer)))
72      (let ((fname (url-cache-create-filename (url-view-url t))))
73        (if (url-cache-prepare fname)
74            (let ((coding-system-for-write 'binary))
75              (write-region (point-min) (point-max) fname nil 5))))))
76
77(defun url-fetch-from-cache (url)
78  "Fetch URL from cache and return a buffer with the content."
79  (with-current-buffer (generate-new-buffer " *temp*")
80    (url-cache-extract (url-cache-create-filename url))
81    (current-buffer)))
82
83;;;###autoload
84(defun url-is-cached (url)
85  "Return non-nil if the URL is cached.
86The actual return value is the last modification time of the cache file."
87  (let* ((fname (url-cache-create-filename url))
88	 (attribs (file-attributes fname)))
89    (and fname
90	 (file-exists-p fname)
91	 (not (eq (file-attribute-type attribs) t))
92	 (file-attribute-modification-time attribs))))
93
94(defun url-cache-create-filename-human-readable (url)
95  "Return a filename in the local cache for URL."
96  (if url
97      (let* ((urlobj (url-generic-parse-url url))
98	     (protocol (url-type urlobj))
99	     (hostname (url-host urlobj))
100	     (host-components
101	      (cons
102	       (user-real-login-name)
103	       (cons (or protocol "file")
104		     (reverse (split-string (or hostname "localhost")
105					    "\\.")))))
106	     (fname    (url-filename urlobj)))
107	(if (and fname (/= (length fname) 0) (= (aref fname 0) ?/))
108	    (setq fname (substring fname 1 nil)))
109	(if fname
110	    (let ((slash nil))
111	      (setq fname
112		    (mapconcat
113		     (function
114		      (lambda (x)
115			(cond
116			 ((and (= ?/ x) slash)
117			  (setq slash nil)
118			  "%2F")
119			 ((= ?/ x)
120			  (setq slash t)
121			  "/")
122			 (t
123			  (setq slash nil)
124			  (char-to-string x))))) fname ""))))
125
126	(setq fname (and fname
127			 (mapconcat
128			  (function (lambda (x)
129				      (if (= x ?~) "" (char-to-string x))))
130			  fname ""))
131	      fname (cond
132		     ((null fname) nil)
133		     ((or (string= "" fname) (string= "/" fname))
134		      url-directory-index-file)
135		     ((= (string-to-char fname) ?/)
136		      (if (string= (substring fname -1 nil) "/")
137			  (concat fname url-directory-index-file)
138			(substring fname 1 nil)))
139		     (t
140		      (if (string= (substring fname -1 nil) "/")
141			  (concat fname url-directory-index-file)
142			fname))))
143	(and fname
144	     (expand-file-name fname
145			       (expand-file-name
146				(mapconcat 'identity host-components "/")
147				url-cache-directory))))))
148
149(defun url-cache-create-filename-using-md5 (url)
150  "Create a cached filename using MD5.
151Very fast if you have an `md5' primitive function, suitably fast otherwise."
152  (if url
153      (let* ((checksum (md5 url))
154	     (urlobj (url-generic-parse-url url))
155	     (protocol (url-type urlobj))
156	     (hostname (url-host urlobj))
157	     (host-components
158	      (cons
159	       (user-real-login-name)
160	       (cons (or protocol "file")
161		     (nreverse
162		      (delq nil
163			    (split-string (or hostname "localhost")
164					  "\\."))))))
165	     (fname    (url-filename urlobj)))
166	(and fname
167	     (expand-file-name checksum
168			       (expand-file-name
169				(mapconcat 'identity host-components "/")
170				url-cache-directory))))))
171
172(defcustom url-cache-creation-function 'url-cache-create-filename-using-md5
173  "What function to use to create a cached filename."
174  :type '(choice (const :tag "MD5 of filename (low collision rate)"
175			:value url-cache-create-filename-using-md5)
176		 (const :tag "Human readable filenames (higher collision rate)"
177			:value url-cache-create-filename-human-readable)
178		 (function :tag "Other"))
179  :group 'url-cache)
180
181(defun url-cache-create-filename (url)
182  (funcall url-cache-creation-function
183           ;; We need to parse+recreate in order to remove the default port
184           ;; if it has been specified: e.g. http://www.example.com:80 will
185           ;; be transcoded as http://www.example.com
186           (url-recreate-url
187            (if (url-p url) url
188              (url-generic-parse-url url)))))
189
190;;;###autoload
191(defun url-cache-extract (fnam)
192  "Extract FNAM from the local disk cache."
193  (erase-buffer)
194  (set-buffer-multibyte nil)
195  (insert-file-contents-literally fnam))
196
197(defun url-cache-expired (url &optional expire-time)
198  "Return non-nil if a cached URL is older than EXPIRE-TIME seconds.
199The default value of EXPIRE-TIME is `url-cache-expire-time'.
200If `url-standalone-mode' is non-nil, cached items never expire."
201  (if url-standalone-mode
202      (not (file-exists-p (url-cache-create-filename url)))
203    (let ((cache-time (url-is-cached url)))
204      (or (not cache-time)
205	  (time-less-p
206	   (time-add
207	    cache-time
208	    (or expire-time url-cache-expire-time))
209	   nil)))))
210
211(defun url-cache-prune-cache (&optional directory)
212  "Remove all expired files from the cache.
213`url-cache-expire-time' says how old a file has to be to be
214considered \"expired\"."
215  (let ((now (current-time))
216	(total-files 0)
217	(deleted-files 0))
218    (setq directory (or directory url-cache-directory))
219    (when (file-exists-p directory)
220      (dolist (file (directory-files directory t))
221	(unless (member (file-name-nondirectory file) '("." ".."))
222	  (setq total-files (1+ total-files))
223	  (cond
224	   ((file-directory-p file)
225	    (when (url-cache-prune-cache file)
226	      (setq deleted-files (1+ deleted-files))))
227	   ((time-less-p
228	     (time-add
229	      (file-attribute-modification-time (file-attributes file))
230	      url-cache-expire-time)
231	     now)
232	    (delete-file file)
233	    (setq deleted-files (1+ deleted-files))))))
234      (if (< deleted-files total-files)
235	  nil
236	(delete-directory directory)
237	t))))
238
239(provide 'url-cache)
240
241;;; url-cache.el ends here
242