1 ;;; url-cookie.el --- URL cookie support -*- lexical-binding:t -*-
3 ;; Copyright (C) 1996-1999, 2004-2018 Free Software Foundation, Inc.
5 ;; Keywords: comm, data, processes, hypermedia
7 ;; This file is part of GNU Emacs.
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.
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.
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/>.
30 (eval-when-compile (require 'cl-lib
))
32 (defgroup url-cookie nil
38 ;; A cookie is stored internally as a vector of 7 slots
39 ;; [ url-cookie NAME VALUE EXPIRES LOCALPART DOMAIN SECURE ]
41 (cl-defstruct (url-cookie
42 (:constructor url-cookie-create
)
46 name value expires localpart domain secure
)
48 (defvar url-cookie-storage nil
"Where cookies are stored.")
49 (defvar url-cookie-secure-storage nil
"Where secure cookies are stored.")
50 (defcustom url-cookie-file nil
51 "File where cookies are stored on disk."
52 :type
'(choice (const :tag
"Default" :value nil
) file
)
56 (defcustom url-cookie-confirmation nil
57 "If non-nil, confirmation by the user is required to accept HTTP cookies."
61 (defcustom url-cookie-multiple-line nil
62 "If nil, HTTP requests put all cookies for the server on one line.
63 Some web servers, such as http://www.hotmail.com/, only accept cookies
64 when they are on one line. This is broken behavior, but just try
65 telling Microsoft that."
69 (defvar url-cookies-changed-since-last-save nil
70 "Whether the cookies list has changed since the last save operation.")
72 (defun url-cookie-parse-file (&optional fname
)
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
))
77 (defun url-cookie-parse-file-netscape (filename &optional long-session
)
78 "Load cookies from FILENAME in Netscape/Mozilla format.
79 When LONG-SESSION is non-nil, session cookies (expiring at t=0
80 i.e. 1970-1-1) are loaded as expiring one year from now instead."
81 (interactive "fLoad Netscape/Mozilla cookie file: ")
84 (insert-file-contents-literally filename
)
85 (goto-char (point-min))
86 (when (not (looking-at-p "# Netscape HTTP Cookie File\n"))
87 (error (format "File %s doesn't look like a netscape cookie file" filename
)))
89 (when (not (looking-at-p (rx bol
(* space
) "#")))
90 (let* ((line (buffer-substring (point) (save-excursion (end-of-line) (point))))
91 (fields (split-string line
"\t")))
93 ;;((>= 1 (length line) 0)
94 ;; (message "skipping empty line"))
95 ((= (length fields
) 7)
96 (let ((dom (nth 0 fields
))
97 ;; (match (nth 1 fields))
99 (secure (string= (nth 3 fields
) "TRUE"))
100 ;; session cookies (expire time = 0) are supposed
101 ;; to be removed when the browser is closed, but
102 ;; the main point of loading external cookie is to
103 ;; reuse a browser session, so to prevent the
104 ;; cookie from being detected as expired straight
105 ;; away, make it expire a year from now
106 (expires (format-time-string
109 (let ((s (string-to-number (nth 4 fields
))))
110 (if (and (= s
0) long-session
)
111 (seconds-to-time (+ (* 365 24 60 60) (float-time)))
114 (val (nth 6 fields
)))
116 ;;(message "adding <%s>=<%s> exp=<%s> dom=<%s> path=<%s> sec=%S" key val expires dom path secure)
117 (url-cookie-store key val expires dom path secure
)
120 (message "ignoring malformed cookie line <%s>" line
)))))
123 (setq url-cookies-changed-since-last-save t
))
124 (message "added %d cookies from file %s" n filename
))))
126 (defun url-cookie-clean-up (&optional secure
)
127 (let ((var (if secure
'url-cookie-secure-storage
'url-cookie-storage
))
129 (dolist (cur (symbol-value var
))
130 (setq new-cookies nil
)
131 (dolist (cur-cookie (cdr cur
))
132 (or (not (url-cookie-p cur-cookie
))
133 (url-cookie-expired-p cur-cookie
)
134 (null (url-cookie-expires cur-cookie
))
135 (setq new-cookies
(cons cur-cookie new-cookies
))))
137 (setcdr cur new-cookies
)
138 (setq new
(cons cur new
))))
141 (defun url-cookie-write-file (&optional fname
)
142 (when (and url-cookies-changed-since-last-save
144 (or fname
(setq fname
(expand-file-name url-cookie-file
)))
145 (if (condition-case nil
147 (url-make-private-file fname
)
150 (message "Error accessing cookie file `%s'" fname
)
151 (url-cookie-clean-up)
152 (url-cookie-clean-up t
)
154 (insert ";; Emacs-W3 HTTP cookies file\n"
155 ";; Automatically generated file!!! DO NOT EDIT!!!\n\n"
156 "(setq url-cookie-storage\n '")
157 (let ((print-length nil
) (print-level nil
))
158 (pp url-cookie-storage
(current-buffer))
159 (insert ")\n(setq url-cookie-secure-storage\n '")
160 (pp url-cookie-secure-storage
(current-buffer)))
162 (insert "\f\n;; Local Variables:\n"
163 ";; version-control: never\n"
164 ";; no-byte-compile: t\n"
166 (set (make-local-variable 'version-control
) 'never
)
168 (setq url-cookies-changed-since-last-save nil
))))
170 (defun url-cookie-store (name value
&optional expires domain localpart secure
)
172 (when (> (length name
) 0)
173 (let ((storage (if secure url-cookie-secure-storage url-cookie-storage
))
175 ;; First, look for a matching domain.
176 (if (setq found-domain
(assoc domain storage
))
177 ;; Need to either stick the new cookie in existing domain storage
178 ;; or possibly replace an existing cookie if the names match.
179 (unless (dolist (cur (setq storage
(cdr found-domain
)) tmp
)
180 (and (equal localpart
(url-cookie-localpart cur
))
181 (equal name
(url-cookie-name cur
))
183 (setf (url-cookie-expires cur
) expires
)
184 (setf (url-cookie-value cur
) value
)
187 (setcdr found-domain
(cons
188 (url-cookie-create :name name
194 (cdr found-domain
))))
195 ;; Need to add a new top-level domain.
196 (setq tmp
(url-cookie-create :name name
203 (setcdr storage
(cons (list domain tmp
) (cdr storage
))))
205 (setq url-cookie-secure-storage
(list (list domain tmp
))))
207 (setq url-cookie-storage
(list (list domain tmp
)))))))))
209 (defun url-cookie-expired-p (cookie)
210 "Return non-nil if COOKIE is expired."
211 (let ((exp (url-cookie-expires cookie
)))
212 (and (> (length exp
) 0)
214 (time-less-p (date-to-time exp
) nil
)
217 (defun url-cookie-retrieve (host &optional localpart secure
)
218 "Retrieve all cookies for a specified HOST and LOCALPART."
219 (let ((storage (if secure
220 (append url-cookie-secure-storage url-cookie-storage
)
223 cookies retval localpart-match
)
224 (dolist (cur storage
)
225 (setq cookies
(cdr cur
))
230 ;; Remove the dot from wildcard domains
232 (if (eq ?.
(aref (car cur
) 0))
233 (substring (car cur
) 1)
236 ;; The domains match - a possible hit!
237 (dolist (cur cookies
)
238 (and (if (and (stringp
239 (setq localpart-match
(url-cookie-localpart cur
)))
241 (string-match (concat "^" (regexp-quote localpart-match
))
243 (equal localpart localpart-match
))
244 (not (url-cookie-expired-p cur
))
245 (setq retval
(cons cur retval
))))))
248 (defun url-cookie-generate-header-lines (host localpart secure
)
249 (let ((cookies (url-cookie-retrieve host localpart secure
))
251 ;; Have to sort this for sending most specific cookies first.
252 (setq cookies
(and cookies
255 (> (length (url-cookie-localpart x
))
256 (length (url-cookie-localpart y
)))))))
257 (dolist (cur cookies
)
258 (setq chunk
(format "%s=%s" (url-cookie-name cur
) (url-cookie-value cur
))
259 retval
(if (and url-cookie-multiple-line
260 (< 80 (+ (length retval
) (length chunk
) 4)))
261 (concat retval
"\r\nCookie: " chunk
)
263 (concat retval
"; " chunk
)
264 (concat "Cookie: " chunk
)))))
266 (concat retval
"\r\n")
269 (defcustom url-cookie-trusted-urls nil
270 "A list of regular expressions matching URLs to always accept cookies from."
271 :type
'(repeat regexp
)
274 (defcustom url-cookie-untrusted-urls nil
275 "A list of regular expressions matching URLs to never accept cookies from."
276 :type
'(repeat regexp
)
279 (defun url-cookie-host-can-set-p (host domain
)
281 ((string= host domain
) ; Apparently netscape lets you do this
283 ((zerop (length domain
))
286 ;; Remove the dot from wildcard domains before matching.
287 (when (eq ?.
(aref domain
0))
288 (setq domain
(substring domain
1)))
289 (and (url-domsuf-cookie-allowed-p domain
)
290 (string-suffix-p domain host
'ignore-case
)))))
292 (defun url-cookie-handle-set-cookie (str)
293 (setq url-cookies-changed-since-last-save t
)
294 (let* ((args (nreverse (url-parse-args str t
)))
296 (secure (and (assoc-string "secure" args t
) t
))
297 (domain (or (cdr-safe (assoc-string "domain" args t
))
298 (url-host url-current-object
)))
299 (current-url (url-view-url t
))
300 (trusted url-cookie-trusted-urls
)
301 (untrusted url-cookie-untrusted-urls
)
302 (max-age (cdr-safe (assoc-string "max-age" args t
)))
303 (localpart (or (cdr-safe (assoc-string "path" args t
))
305 (url-filename url-current-object
))))
307 (if (and max-age
(string-match "\\`-?[0-9]+\\'" max-age
))
308 (setq expires
(format-time-string "%a %b %d %H:%M:%S %Y GMT"
309 (time-add nil
(read max-age
))
311 (setq expires
(cdr-safe (assoc-string "expires" args t
))))
312 (while (consp trusted
)
313 (if (string-match (car trusted
) current-url
)
314 (setq trusted
(- (match-end 0) (match-beginning 0)))
316 (while (consp untrusted
)
317 (if (string-match (car untrusted
) current-url
)
318 (setq untrusted
(- (match-end 0) (match-beginning 0)))
320 (and trusted untrusted
321 ;; Choose the more specific match.
322 (set (if (> trusted untrusted
) 'untrusted
'trusted
) nil
))
325 ;; The site was explicitly marked as untrusted by the user.
327 ((or (eq url-privacy-level
'paranoid
)
328 (and (listp url-privacy-level
) (memq 'cookies url-privacy-level
)))
329 ;; User never wants cookies.
331 ((and url-cookie-confirmation
333 (save-window-excursion
334 (with-output-to-temp-buffer "*Cookie Warning*"
335 (princ (format "%s=\"%s\"\n" (caar args
) (cdar args
)))
336 (dolist (x (cdr args
))
337 (princ (format " %s=\"%s\"\n" (car x
) (cdr x
)))))
339 (not (funcall url-confirmation-func
340 (format "Allow %s to set these cookies? "
341 (url-host url-current-object
))))
342 (if (get-buffer "*Cookie Warning*")
343 (kill-buffer "*Cookie Warning*")))))
344 ;; User wants to be asked, and declined.
346 ((url-cookie-host-can-set-p (url-host url-current-object
) domain
)
347 ;; Cookie is accepted by the user, and passes our security checks.
348 (url-cookie-store (caar args
) (cdar args
)
349 expires domain localpart secure
))
351 (url-lazy-message "%s tried to set a cookie for domain %s - rejected."
352 (url-host url-current-object
) domain
)))))
354 (defvar url-cookie-timer nil
)
356 (defcustom url-cookie-save-interval
3600
357 "The number of seconds between automatic saves of cookies.
358 Default is 1 hour. Note that if you change this variable outside of
359 the `customize' interface after `url-do-setup' has been run, you need
360 to run the `url-cookie-setup-save-timer' function manually."
361 :set
#'(lambda (var val
)
362 (set-default var val
)
363 (if (bound-and-true-p url-setup-done
)
364 (url-cookie-setup-save-timer)))
368 (defun url-cookie-setup-save-timer ()
369 "Reset the cookie saver timer."
371 (ignore-errors (cancel-timer url-cookie-timer
))
372 (setq url-cookie-timer nil
)
373 (if url-cookie-save-interval
374 (setq url-cookie-timer
(run-at-time url-cookie-save-interval
375 url-cookie-save-interval
376 #'url-cookie-write-file
))))
378 (defun url-cookie-delete-cookies (&optional regexp keep
)
379 "Delete all cookies from the cookie store where the domain matches REGEXP.
380 If REGEXP is nil, all cookies are deleted. If KEEP is non-nil,
381 instead delete all cookies that do not match REGEXP."
382 (dolist (variable '(url-cookie-secure-storage url-cookie-storage
))
383 (let ((cookies (symbol-value variable
)))
384 (dolist (elem cookies
)
385 (when (or (and (null keep
)
387 (string-match regexp
(car elem
))))
390 (not (string-match regexp
(car elem
)))))
391 (setq cookies
(delq elem cookies
))))
392 (set variable cookies
)))
393 (setq url-cookies-changed-since-last-save t
)
394 (url-cookie-write-file))
396 ;;; Mode for listing and editing cookies.
398 (defvar url-cookie--deleted-cookies nil
)
400 (defun url-cookie-list ()
401 "Display a buffer listing the current URL cookies, if there are any.
402 Use \\<url-cookie-mode-map>\\[url-cookie-delete] to remove cookies."
404 (unless (or url-cookie-secure-storage
406 (error "No cookies are defined"))
408 (pop-to-buffer "*url cookies*")
410 (url-cookie--generate-buffer)
411 (goto-char (point-min)))
413 (defun url-cookie--generate-buffer ()
414 (let ((inhibit-read-only t
)
417 (append url-cookie-secure-storage
420 (string< (car e1
) (car e2
)))))
422 start name format domain
)
424 (dolist (elem domains
)
425 (setq domain-length
(max domain-length
(length (car elem
)))))
426 (setq format
(format "%%-%ds %%-20s %%s" domain-length
)
428 (concat " " (format format
"Domain" "Name" "Value")))
429 (dolist (elem domains
)
430 (setq domain
(car elem
))
431 (dolist (cookie (sort (copy-sequence (cdr elem
))
433 (string< (url-cookie-name c1
)
434 (url-cookie-name c2
)))))
436 name
(url-cookie-name cookie
))
437 (when (> (length name
) 20)
438 (setq name
(substring name
0 20)))
439 (insert (format format domain name
440 (url-cookie-value cookie
))
443 (put-text-property start
(1+ start
) 'url-cookie cookie
)))))
445 (defun url-cookie-delete ()
446 "Delete the cookie on the current line."
448 (let ((cookie (get-text-property (line-beginning-position) 'url-cookie
))
449 (inhibit-read-only t
)
452 (error "No cookie on the current line"))
453 (setq variable
(if (url-cookie-secure cookie
)
454 'url-cookie-secure-storage
455 'url-cookie-storage
))
456 (let* ((list (symbol-value variable
))
457 (elem (assoc (url-cookie-domain cookie
) list
)))
458 (setq elem
(delq cookie elem
))
459 (when (zerop (length (cdr elem
)))
460 (setq list
(delq elem list
)))
462 (setq url-cookies-changed-since-last-save t
)
463 (url-cookie-write-file)
464 (delete-region (line-beginning-position)
468 (let ((point (point)))
470 (url-cookie--generate-buffer)
472 (push cookie url-cookie--deleted-cookies
)))
474 (defun url-cookie-undo ()
475 "Undo deletion of a cookie."
477 (unless url-cookie--deleted-cookies
478 (error "No cookie deletions to undo"))
479 (let* ((cookie (pop url-cookie--deleted-cookies
))
480 (variable (if (url-cookie-secure cookie
)
481 'url-cookie-secure-storage
482 'url-cookie-storage
))
483 (list (symbol-value variable
))
484 (elem (assoc (url-cookie-domain cookie
) list
)))
486 (nconc elem
(list cookie
))
487 (setq elem
(list (url-cookie-domain cookie
) cookie
))
488 (set variable
(cons elem list
)))
489 (setq url-cookies-changed-since-last-save t
)
490 (url-cookie-write-file)
491 (let ((point (point))
492 (inhibit-read-only t
))
494 (url-cookie--generate-buffer)
497 (defvar url-cookie-mode-map
498 (let ((map (make-sparse-keymap)))
499 (define-key map
[delete] 'url-cookie-delete)
500 (define-key map [(control k)] 'url-cookie-delete)
501 (define-key map [(control _)] 'url-cookie-undo)
504 (define-derived-mode url-cookie-mode special-mode "URL Cookie"
505 "Mode for listing cookies.
507 \\{url-cookie-mode-map}"
508 (buffer-disable-undo)
509 (setq buffer-read-only t
512 (provide 'url-cookie)
514 ;;; url-cookie.el ends here