Commit | Line | Data |
---|---|---|
105a786f | 1 | ;;; url-cookie.el --- URL cookie support |
10c3c720 | 2 | |
ba318903 | 3 | ;; Copyright (C) 1996-1999, 2004-2014 Free Software Foundation, Inc. |
10c3c720 | 4 | |
8c8b8430 SM |
5 | ;; Keywords: comm, data, processes, hypermedia |
6 | ||
10c3c720 SM |
7 | ;; This file is part of GNU Emacs. |
8 | ;; | |
4936186e | 9 | ;; GNU Emacs is free software: you can redistribute it and/or modify |
10c3c720 | 10 | ;; it under the terms of the GNU General Public License as published by |
4936186e GM |
11 | ;; the Free Software Foundation, either version 3 of the License, or |
12 | ;; (at your option) any later version. | |
13 | ||
10c3c720 SM |
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. | |
4936186e | 18 | |
10c3c720 | 19 | ;; You should have received a copy of the GNU General Public License |
4936186e | 20 | ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. |
10c3c720 SM |
21 | |
22 | ;;; Commentary: | |
23 | ||
24 | ;;; Code: | |
8c8b8430 | 25 | |
8c8b8430 SM |
26 | (require 'url-util) |
27 | (require 'url-parse) | |
9ea49b28 | 28 | (require 'url-domsuf) |
8c8b8430 | 29 | |
a464a6c7 | 30 | (eval-when-compile (require 'cl-lib)) |
3cbc281e | 31 | |
8c8b8430 | 32 | (defgroup url-cookie nil |
5d9f30c6 | 33 | "URL cookies." |
8c8b8430 SM |
34 | :prefix "url-" |
35 | :prefix "url-cookie-" | |
36 | :group 'url) | |
37 | ||
495fa7db | 38 | ;; A cookie is stored internally as a vector of 7 slots |
b1c83d95 | 39 | ;; [ url-cookie NAME VALUE EXPIRES LOCALPART DOMAIN SECURE ] |
495fa7db | 40 | |
a464a6c7 | 41 | (cl-defstruct (url-cookie |
495fa7db SM |
42 | (:constructor url-cookie-create) |
43 | (:copier nil) | |
b1c83d95 LL |
44 | (:type vector) |
45 | :named) | |
495fa7db SM |
46 | name value expires localpart domain secure) |
47 | ||
8c8b8430 SM |
48 | (defvar url-cookie-storage nil "Where cookies are stored.") |
49 | (defvar url-cookie-secure-storage nil "Where secure cookies are stored.") | |
9f8a95cd | 50 | (defcustom url-cookie-file nil |
bc684c16 | 51 | "File where cookies are stored on disk." |
8c8b8430 SM |
52 | :type '(choice (const :tag "Default" :value nil) file) |
53 | :group 'url-file | |
54 | :group 'url-cookie) | |
55 | ||
56 | (defcustom url-cookie-confirmation nil | |
bc684c16 | 57 | "If non-nil, confirmation by the user is required to accept HTTP cookies." |
8c8b8430 SM |
58 | :type 'boolean |
59 | :group 'url-cookie) | |
60 | ||
61 | (defcustom url-cookie-multiple-line nil | |
bc684c16 | 62 | "If nil, HTTP requests put all cookies for the server on one line. |
8c8b8430 | 63 | Some web servers, such as http://www.hotmail.com/, only accept cookies |
eb88139e | 64 | when they are on one line. This is broken behavior, but just try |
93c8c9cd JB |
65 | telling Microsoft that." |
66 | :type 'boolean | |
67 | :group 'url-cookie) | |
8c8b8430 SM |
68 | |
69 | (defvar url-cookies-changed-since-last-save nil | |
70 | "Whether the cookies list has changed since the last save operation.") | |
71 | ||
8c8b8430 | 72 | (defun url-cookie-parse-file (&optional fname) |
105a786f GM |
73 | "Load FNAME, default `url-cookie-file'." |
74 | ;; It's completely normal for the cookies file not to exist yet. | |
75 | (load (or fname url-cookie-file) t t)) | |
8c8b8430 SM |
76 | |
77 | (defun url-cookie-clean-up (&optional secure) | |
105a786f GM |
78 | (let ((var (if secure 'url-cookie-secure-storage 'url-cookie-storage)) |
79 | new new-cookies) | |
80 | (dolist (cur (symbol-value var)) | |
81 | (setq new-cookies nil) | |
82 | (dolist (cur-cookie (cdr cur)) | |
83 | (or (not (url-cookie-p cur-cookie)) | |
84 | (url-cookie-expired-p cur-cookie) | |
85 | (null (url-cookie-expires cur-cookie)) | |
86 | (setq new-cookies (cons cur-cookie new-cookies)))) | |
87 | (when new-cookies | |
8c8b8430 SM |
88 | (setcdr cur new-cookies) |
89 | (setq new (cons cur new)))) | |
90 | (set var new))) | |
91 | ||
8c8b8430 | 92 | (defun url-cookie-write-file (&optional fname) |
4e44324a GM |
93 | (when url-cookies-changed-since-last-save |
94 | (or fname (setq fname (expand-file-name url-cookie-file))) | |
95 | (if (condition-case nil | |
96 | (progn | |
97 | (url-make-private-file fname) | |
98 | nil) | |
99 | (error t)) | |
100 | (message "Error accessing cookie file `%s'" fname) | |
8c8b8430 SM |
101 | (url-cookie-clean-up) |
102 | (url-cookie-clean-up t) | |
4e44324a | 103 | (with-temp-buffer |
8c8b8430 SM |
104 | (insert ";; Emacs-W3 HTTP cookies file\n" |
105 | ";; Automatically generated file!!! DO NOT EDIT!!!\n\n" | |
106 | "(setq url-cookie-storage\n '") | |
107 | (pp url-cookie-storage (current-buffer)) | |
108 | (insert ")\n(setq url-cookie-secure-storage\n '") | |
109 | (pp url-cookie-secure-storage (current-buffer)) | |
110 | (insert ")\n") | |
7660c02f | 111 | (insert "\f\n;; Local Variables:\n" |
bc684c16 SM |
112 | ";; version-control: never\n" |
113 | ";; no-byte-compile: t\n" | |
114 | ";; End:\n") | |
7660c02f | 115 | (set (make-local-variable 'version-control) 'never) |
4e44324a GM |
116 | (write-file fname)) |
117 | (setq url-cookies-changed-since-last-save nil)))) | |
8c8b8430 | 118 | |
9f8a95cd | 119 | (defun url-cookie-store (name value &optional expires domain localpart secure) |
105a786f GM |
120 | "Store a cookie." |
121 | (let ((storage (if secure url-cookie-secure-storage url-cookie-storage)) | |
122 | tmp found-domain) | |
123 | ;; First, look for a matching domain. | |
124 | (if (setq found-domain (assoc domain storage)) | |
8c8b8430 SM |
125 | ;; Need to either stick the new cookie in existing domain storage |
126 | ;; or possibly replace an existing cookie if the names match. | |
105a786f GM |
127 | (unless (dolist (cur (setq storage (cdr found-domain)) tmp) |
128 | (and (equal localpart (url-cookie-localpart cur)) | |
129 | (equal name (url-cookie-name cur)) | |
130 | (progn | |
131 | (setf (url-cookie-expires cur) expires) | |
132 | (setf (url-cookie-value cur) value) | |
133 | (setq tmp t)))) | |
134 | ;; New cookie. | |
135 | (setcdr found-domain (cons | |
136 | (url-cookie-create :name name | |
137 | :value value | |
138 | :expires expires | |
139 | :domain domain | |
140 | :localpart localpart | |
141 | :secure secure) | |
142 | (cdr found-domain)))) | |
143 | ;; Need to add a new top-level domain. | |
8c8b8430 SM |
144 | (setq tmp (url-cookie-create :name name |
145 | :value value | |
146 | :expires expires | |
147 | :domain domain | |
9f8a95cd | 148 | :localpart localpart |
8c8b8430 | 149 | :secure secure)) |
105a786f GM |
150 | (cond (storage |
151 | (setcdr storage (cons (list domain tmp) (cdr storage)))) | |
152 | (secure | |
153 | (setq url-cookie-secure-storage (list (list domain tmp)))) | |
154 | (t | |
155 | (setq url-cookie-storage (list (list domain tmp)))))))) | |
8c8b8430 SM |
156 | |
157 | (defun url-cookie-expired-p (cookie) | |
c4ae64d1 GM |
158 | "Return non-nil if COOKIE is expired." |
159 | (let ((exp (url-cookie-expires cookie))) | |
14e1d9ea LMI |
160 | (and (> (length exp) 0) |
161 | (> (float-time) (float-time (date-to-time exp)))))) | |
8c8b8430 | 162 | |
033535de | 163 | (defun url-cookie-retrieve (host &optional localpart secure) |
37bf6ce2 | 164 | "Retrieve all cookies for a specified HOST and LOCALPART." |
8c8b8430 SM |
165 | (let ((storage (if secure |
166 | (append url-cookie-secure-storage url-cookie-storage) | |
167 | url-cookie-storage)) | |
168 | (case-fold-search t) | |
105a786f GM |
169 | cookies retval localpart-match) |
170 | (dolist (cur storage) | |
171 | (setq cookies (cdr cur)) | |
8c8b8430 | 172 | (if (and (car cur) |
b4ddc815 CY |
173 | (string-match |
174 | (concat "^.*" | |
175 | (regexp-quote | |
176 | ;; Remove the dot from wildcard domains | |
177 | ;; before matching. | |
178 | (if (eq ?. (aref (car cur) 0)) | |
179 | (substring (car cur) 1) | |
180 | (car cur))) | |
181 | "$") host)) | |
8c8b8430 | 182 | ;; The domains match - a possible hit! |
105a786f GM |
183 | (dolist (cur cookies) |
184 | (and (if (and (stringp | |
185 | (setq localpart-match (url-cookie-localpart cur))) | |
186 | (stringp localpart)) | |
187 | (string-match (concat "^" (regexp-quote localpart-match)) | |
188 | localpart) | |
189 | (equal localpart localpart-match)) | |
190 | (not (url-cookie-expired-p cur)) | |
191 | (setq retval (cons cur retval)))))) | |
8c8b8430 SM |
192 | retval)) |
193 | ||
9f8a95cd | 194 | (defun url-cookie-generate-header-lines (host localpart secure) |
105a786f GM |
195 | (let ((cookies (url-cookie-retrieve host localpart secure)) |
196 | retval chunk) | |
197 | ;; Have to sort this for sending most specific cookies first. | |
8c8b8430 SM |
198 | (setq cookies (and cookies |
199 | (sort cookies | |
105a786f GM |
200 | (lambda (x y) |
201 | (> (length (url-cookie-localpart x)) | |
202 | (length (url-cookie-localpart y))))))) | |
203 | (dolist (cur cookies) | |
204 | (setq chunk (format "%s=%s" (url-cookie-name cur) (url-cookie-value cur)) | |
8c8b8430 SM |
205 | retval (if (and url-cookie-multiple-line |
206 | (< 80 (+ (length retval) (length chunk) 4))) | |
207 | (concat retval "\r\nCookie: " chunk) | |
208 | (if retval | |
209 | (concat retval "; " chunk) | |
210 | (concat "Cookie: " chunk))))) | |
211 | (if retval | |
212 | (concat retval "\r\n") | |
213 | ""))) | |
214 | ||
8c8b8430 | 215 | (defcustom url-cookie-trusted-urls nil |
bc684c16 | 216 | "A list of regular expressions matching URLs to always accept cookies from." |
8c8b8430 SM |
217 | :type '(repeat regexp) |
218 | :group 'url-cookie) | |
219 | ||
220 | (defcustom url-cookie-untrusted-urls nil | |
bc684c16 | 221 | "A list of regular expressions matching URLs to never accept cookies from." |
8c8b8430 SM |
222 | :type '(repeat regexp) |
223 | :group 'url-cookie) | |
224 | ||
225 | (defun url-cookie-host-can-set-p (host domain) | |
9ea49b28 LMI |
226 | (let ((last nil) |
227 | (case-fold-search t)) | |
228 | (if (string= host domain) ; Apparently netscape lets you do this | |
229 | t | |
230 | ;; Remove the dot from wildcard domains before matching. | |
231 | (when (eq ?. (aref domain 0)) | |
232 | (setq domain (substring domain 1))) | |
233 | (and (url-domsuf-cookie-allowed-p domain) | |
234 | ;; Need to check and make sure the host is actually _in_ the | |
235 | ;; domain it wants to set a cookie for though. | |
236 | (string-match (concat (regexp-quote domain) | |
237 | "$") host))))) | |
8c8b8430 | 238 | |
8c8b8430 SM |
239 | (defun url-cookie-handle-set-cookie (str) |
240 | (setq url-cookies-changed-since-last-save t) | |
241 | (let* ((args (url-parse-args str t)) | |
242 | (case-fold-search t) | |
6e56e526 JPW |
243 | (secure (and (assoc-string "secure" args t) t)) |
244 | (domain (or (cdr-safe (assoc-string "domain" args t)) | |
8c8b8430 SM |
245 | (url-host url-current-object))) |
246 | (current-url (url-view-url t)) | |
247 | (trusted url-cookie-trusted-urls) | |
248 | (untrusted url-cookie-untrusted-urls) | |
6e56e526 | 249 | (expires (cdr-safe (assoc-string "expires" args t))) |
9f8a95cd RS |
250 | (localpart (or (cdr-safe (assoc-string "path" args t)) |
251 | (file-name-directory | |
252 | (url-filename url-current-object)))) | |
8c8b8430 | 253 | (rest nil)) |
105a786f GM |
254 | (dolist (this args) |
255 | (or (member (downcase (car this)) '("secure" "domain" "expires" "path")) | |
256 | (setq rest (cons this rest)))) | |
8c8b8430 SM |
257 | |
258 | ;; Sometimes we get dates that the timezone package cannot handle very | |
259 | ;; gracefully - take care of this here, instead of in url-cookie-expired-p | |
260 | ;; to speed things up. | |
105a786f GM |
261 | (and expires |
262 | (string-match | |
263 | (concat "^[^,]+, +\\(..\\)-\\(...\\)-\\(..\\) +" | |
264 | "\\(..:..:..\\) +\\[*\\([^\]]+\\)\\]*$") | |
265 | expires) | |
266 | (setq expires (concat (match-string 1 expires) " " | |
267 | (match-string 2 expires) " " | |
268 | (match-string 3 expires) " " | |
269 | (match-string 4 expires) " [" | |
270 | (match-string 5 expires) "]"))) | |
8c8b8430 SM |
271 | |
272 | ;; This one is for older Emacs/XEmacs variants that don't | |
273 | ;; understand this format without tenths of a second in it. | |
274 | ;; Wednesday, 30-Dec-2037 16:00:00 GMT | |
275 | ;; - vs - | |
276 | ;; Wednesday, 30-Dec-2037 16:00:00.00 GMT | |
105a786f GM |
277 | (and expires |
278 | (string-match | |
279 | "\\([0-9]+\\)-\\([A-Za-z]+\\)-\\([0-9]+\\)[ \t]+\\([0-9]+:[0-9]+:[0-9]+\\)\\(\\.[0-9]+\\)*[ \t]+\\([-+a-zA-Z0-9]+\\)" | |
280 | expires) | |
281 | (setq expires (concat (match-string 1 expires) "-" ; day | |
282 | (match-string 2 expires) "-" ; month | |
283 | (match-string 3 expires) " " ; year | |
284 | (match-string 4 expires) ".00 " ; hour:minutes:seconds | |
285 | (match-string 6 expires)))) ":" ; timezone | |
6e56e526 | 286 | |
8c8b8430 SM |
287 | (while (consp trusted) |
288 | (if (string-match (car trusted) current-url) | |
289 | (setq trusted (- (match-end 0) (match-beginning 0))) | |
290 | (pop trusted))) | |
291 | (while (consp untrusted) | |
292 | (if (string-match (car untrusted) current-url) | |
293 | (setq untrusted (- (match-end 0) (match-beginning 0))) | |
294 | (pop untrusted))) | |
105a786f GM |
295 | (and trusted untrusted |
296 | ;; Choose the more specific match. | |
297 | (set (if (> trusted untrusted) 'untrusted 'trusted) nil)) | |
8c8b8430 SM |
298 | (cond |
299 | (untrusted | |
333f9019 | 300 | ;; The site was explicitly marked as untrusted by the user. |
8c8b8430 SM |
301 | nil) |
302 | ((or (eq url-privacy-level 'paranoid) | |
303 | (and (listp url-privacy-level) (memq 'cookies url-privacy-level))) | |
105a786f | 304 | ;; User never wants cookies. |
8c8b8430 SM |
305 | nil) |
306 | ((and url-cookie-confirmation | |
307 | (not trusted) | |
308 | (save-window-excursion | |
309 | (with-output-to-temp-buffer "*Cookie Warning*" | |
9952e40b JB |
310 | (dolist (x rest) |
311 | (princ (format "%s - %s" (car x) (cdr x))))) | |
8c8b8430 SM |
312 | (prog1 |
313 | (not (funcall url-confirmation-func | |
314 | (format "Allow %s to set these cookies? " | |
315 | (url-host url-current-object)))) | |
316 | (if (get-buffer "*Cookie Warning*") | |
317 | (kill-buffer "*Cookie Warning*"))))) | |
105a786f | 318 | ;; User wants to be asked, and declined. |
8c8b8430 SM |
319 | nil) |
320 | ((url-cookie-host-can-set-p (url-host url-current-object) domain) | |
105a786f GM |
321 | ;; Cookie is accepted by the user, and passes our security checks. |
322 | (dolist (cur rest) | |
323 | (url-cookie-store (car cur) (cdr cur) expires domain localpart secure))) | |
8c8b8430 | 324 | (t |
82b9f9f5 LMI |
325 | (url-lazy-message "%s tried to set a cookie for domain %s - rejected." |
326 | (url-host url-current-object) domain))))) | |
8c8b8430 SM |
327 | |
328 | (defvar url-cookie-timer nil) | |
329 | ||
330 | (defcustom url-cookie-save-interval 3600 | |
bc684c16 | 331 | "The number of seconds between automatic saves of cookies. |
8c8b8430 SM |
332 | Default is 1 hour. Note that if you change this variable outside of |
333 | the `customize' interface after `url-do-setup' has been run, you need | |
334 | to run the `url-cookie-setup-save-timer' function manually." | |
0c069924 RS |
335 | :set #'(lambda (var val) |
336 | (set-default var val) | |
337 | (if (bound-and-true-p url-setup-done) | |
338 | (url-cookie-setup-save-timer))) | |
8c8b8430 | 339 | :type 'integer |
bc684c16 | 340 | :group 'url-cookie) |
8c8b8430 | 341 | |
8c8b8430 SM |
342 | (defun url-cookie-setup-save-timer () |
343 | "Reset the cookie saver timer." | |
344 | (interactive) | |
0c069924 | 345 | (ignore-errors (cancel-timer url-cookie-timer)) |
10c3c720 SM |
346 | (setq url-cookie-timer nil) |
347 | (if url-cookie-save-interval | |
0c069924 RS |
348 | (setq url-cookie-timer (run-at-time url-cookie-save-interval |
349 | url-cookie-save-interval | |
350 | #'url-cookie-write-file)))) | |
8c8b8430 | 351 | |
843571cb LMI |
352 | ;;; Mode for listing and editing cookies. |
353 | ||
354 | (defun url-cookie-list () | |
645586dc GM |
355 | "Display a buffer listing the current URL cookies, if there are any. |
356 | Use \\<url-cookie-mode-map>\\\[url-cookie-delete] to remove cookies." | |
843571cb | 357 | (interactive) |
843571cb LMI |
358 | (when (and (null url-cookie-secure-storage) |
359 | (null url-cookie-storage)) | |
360 | (error "No cookies are defined")) | |
361 | ||
362 | (pop-to-buffer "*url cookies*") | |
363 | (let ((inhibit-read-only t) | |
364 | (domains (sort | |
365 | (copy-sequence | |
366 | (append url-cookie-secure-storage | |
367 | url-cookie-storage)) | |
368 | (lambda (e1 e2) | |
369 | (string< (car e1) (car e2))))) | |
370 | (domain-length 0) | |
371 | start name format domain) | |
372 | (erase-buffer) | |
373 | (url-cookie-mode) | |
374 | (dolist (elem domains) | |
375 | (setq domain-length (max domain-length (length (car elem))))) | |
376 | (setq format (format "%%-%ds %%-20s %%s" domain-length) | |
377 | header-line-format | |
378 | (concat " " (format format "Domain" "Name" "Value"))) | |
379 | (dolist (elem domains) | |
380 | (setq domain (car elem)) | |
381 | (dolist (cookie (sort (copy-sequence (cdr elem)) | |
382 | (lambda (c1 c2) | |
383 | (string< (url-cookie-name c1) | |
384 | (url-cookie-name c2))))) | |
385 | (setq start (point) | |
386 | name (url-cookie-name cookie)) | |
387 | (when (> (length name) 20) | |
388 | (setq name (substring name 0 20))) | |
389 | (insert (format format domain name | |
390 | (url-cookie-value cookie)) | |
391 | "\n") | |
392 | (setq domain "") | |
393 | (put-text-property start (1+ start) 'url-cookie cookie))) | |
394 | (goto-char (point-min)))) | |
395 | ||
396 | (defun url-cookie-delete () | |
397 | "Delete the cookie on the current line." | |
398 | (interactive) | |
399 | (let ((cookie (get-text-property (line-beginning-position) 'url-cookie)) | |
400 | (inhibit-read-only t) | |
401 | variable) | |
402 | (unless cookie | |
403 | (error "No cookie on the current line")) | |
404 | (setq variable (if (url-cookie-secure cookie) | |
405 | 'url-cookie-secure-storage | |
406 | 'url-cookie-storage)) | |
407 | (let* ((list (symbol-value variable)) | |
408 | (elem (assoc (url-cookie-domain cookie) list))) | |
409 | (setq elem (delq cookie elem)) | |
410 | (when (zerop (length (cdr elem))) | |
411 | (setq list (delq elem list))) | |
412 | (set variable list)) | |
413 | (setq url-cookies-changed-since-last-save t) | |
414 | (url-cookie-write-file) | |
415 | (delete-region (line-beginning-position) | |
416 | (progn | |
417 | (forward-line 1) | |
418 | (point))))) | |
419 | ||
420 | (defun url-cookie-quit () | |
421 | "Kill the current buffer." | |
422 | (interactive) | |
423 | (kill-buffer (current-buffer))) | |
424 | ||
425 | (defvar url-cookie-mode-map | |
426 | (let ((map (make-sparse-keymap))) | |
427 | (suppress-keymap map) | |
428 | (define-key map "q" 'url-cookie-quit) | |
429 | (define-key map [delete] 'url-cookie-delete) | |
2b4f0506 | 430 | (define-key map [(control k)] 'url-cookie-delete) |
843571cb LMI |
431 | map)) |
432 | ||
2b4f0506 | 433 | (define-derived-mode url-cookie-mode nil "URL Cookie" |
843571cb LMI |
434 | "Mode for listing cookies. |
435 | ||
436 | \\{url-cookie-mode-map}" | |
437 | (buffer-disable-undo) | |
438 | (setq buffer-read-only t | |
439 | truncate-lines t)) | |
440 | ||
8c8b8430 SM |
441 | (provide 'url-cookie) |
442 | ||
10c3c720 | 443 | ;;; url-cookie.el ends here |