Update FSF's address.
[bpt/emacs.git] / lisp / url / url-cookie.el
1 ;;; url-cookie.el --- Netscape Cookie support
2
3 ;; Copyright (c) 1996 - 1999,2004 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 2, or (at your option)
12 ;; 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; see the file COPYING. If not, write to the
21 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
22 ;; Boston, MA 02110-1301, USA.
23
24 ;;; Commentary:
25
26 ;;; Code:
27
28 (require 'timezone)
29 (require 'url-util)
30 (require 'url-parse)
31 (eval-when-compile (require 'cl))
32
33 ;; See http://home.netscape.com/newsref/std/cookie_spec.html for the
34 ;; 'open standard' defining this crap.
35 ;;
36 ;; A cookie is stored internally as a vector of 7 slots
37 ;; [ cookie NAME VALUE EXPIRES LOCALPART DOMAIN SECURE ]
38
39 (defsubst url-cookie-name (cookie) (aref cookie 1))
40 (defsubst url-cookie-value (cookie) (aref cookie 2))
41 (defsubst url-cookie-expires (cookie) (aref cookie 3))
42 (defsubst url-cookie-localpart (cookie) (aref cookie 4))
43 (defsubst url-cookie-domain (cookie) (aref cookie 5))
44 (defsubst url-cookie-secure (cookie) (aref cookie 6))
45
46 (defsubst url-cookie-set-name (cookie val) (aset cookie 1 val))
47 (defsubst url-cookie-set-value (cookie val) (aset cookie 2 val))
48 (defsubst url-cookie-set-expires (cookie val) (aset cookie 3 val))
49 (defsubst url-cookie-set-localpart (cookie val) (aset cookie 4 val))
50 (defsubst url-cookie-set-domain (cookie val) (aset cookie 5 val))
51 (defsubst url-cookie-set-secure (cookie val) (aset cookie 6 val))
52 (defsubst url-cookie-retrieve-arg (key args) (nth 1 (memq key args)))
53
54 (defsubst url-cookie-create (&rest args)
55 "Create a cookie vector object from keyword-value pairs ARGS.
56 The keywords allowed are
57 :name NAME
58 :value VALUE
59 :expires TIME
60 :localpart LOCALPAR
61 :domain DOMAIN
62 :secure ???
63 Could someone fill in more information?"
64 (let ((retval (make-vector 7 nil)))
65 (aset retval 0 'cookie)
66 (url-cookie-set-name retval (url-cookie-retrieve-arg :name args))
67 (url-cookie-set-value retval (url-cookie-retrieve-arg :value args))
68 (url-cookie-set-expires retval (url-cookie-retrieve-arg :expires args))
69 (url-cookie-set-localpart retval (url-cookie-retrieve-arg :localpart args))
70 (url-cookie-set-domain retval (url-cookie-retrieve-arg :domain args))
71 (url-cookie-set-secure retval (url-cookie-retrieve-arg :secure args))
72 retval))
73
74 (defun url-cookie-p (obj)
75 "Return non-nil if OBJ is a cookie vector object.
76 These objects represent cookies in the URL package.
77 A cookie vector object is a vector of 7 slots:
78 [cookie NAME VALUE EXPIRES LOCALPART DOMAIN SECURE]."
79 (and (vectorp obj) (= (length obj) 7) (eq (aref obj 0) 'cookie)))
80
81 (defgroup url-cookie nil
82 "URL cookies."
83 :prefix "url-"
84 :prefix "url-cookie-"
85 :group 'url)
86
87 (defvar url-cookie-storage nil "Where cookies are stored.")
88 (defvar url-cookie-secure-storage nil "Where secure cookies are stored.")
89 (defcustom url-cookie-file nil
90 "*File where cookies are stored on disk."
91 :type '(choice (const :tag "Default" :value nil) file)
92 :group 'url-file
93 :group 'url-cookie)
94
95 (defcustom url-cookie-confirmation nil
96 "*If non-nil, confirmation by the user is required to accept HTTP cookies."
97 :type 'boolean
98 :group 'url-cookie)
99
100 (defcustom url-cookie-multiple-line nil
101 "*If nil, HTTP requests put all cookies for the server on one line.
102 Some web servers, such as http://www.hotmail.com/, only accept cookies
103 when they are on one line. This is broken behavior, but just try
104 telling Microsoft that."
105 :type 'boolean
106 :group 'url-cookie)
107
108 (defvar url-cookies-changed-since-last-save nil
109 "Whether the cookies list has changed since the last save operation.")
110
111 ;;;###autoload
112 (defun url-cookie-parse-file (&optional fname)
113 (setq fname (or fname url-cookie-file))
114 (condition-case ()
115 (load fname nil t)
116 (error (message "Could not load cookie file %s" fname))))
117
118 (defun url-cookie-clean-up (&optional secure)
119 (let* (
120 (var (if secure 'url-cookie-secure-storage 'url-cookie-storage))
121 (val (symbol-value var))
122 (cur nil)
123 (new nil)
124 (cookies nil)
125 (cur-cookie nil)
126 (new-cookies nil)
127 )
128 (while val
129 (setq cur (car val)
130 val (cdr val)
131 new-cookies nil
132 cookies (cdr cur))
133 (while cookies
134 (setq cur-cookie (car cookies)
135 cookies (cdr cookies))
136 (if (or (not (url-cookie-p cur-cookie))
137 (url-cookie-expired-p cur-cookie)
138 (null (url-cookie-expires cur-cookie)))
139 nil
140 (setq new-cookies (cons cur-cookie new-cookies))))
141 (if (not new-cookies)
142 nil
143 (setcdr cur new-cookies)
144 (setq new (cons cur new))))
145 (set var new)))
146
147 ;;;###autoload
148 (defun url-cookie-write-file (&optional fname)
149 (setq fname (or fname url-cookie-file))
150 (cond
151 ((not url-cookies-changed-since-last-save) nil)
152 ((not (file-writable-p fname))
153 (message "Cookies file %s (see variable `url-cookie-file') is unwritable." fname))
154 (t
155 (url-cookie-clean-up)
156 (url-cookie-clean-up t)
157 (save-excursion
158 (set-buffer (get-buffer-create " *cookies*"))
159 (erase-buffer)
160 (fundamental-mode)
161 (insert ";; Emacs-W3 HTTP cookies file\n"
162 ";; Automatically generated file!!! DO NOT EDIT!!!\n\n"
163 "(setq url-cookie-storage\n '")
164 (pp url-cookie-storage (current-buffer))
165 (insert ")\n(setq url-cookie-secure-storage\n '")
166 (pp url-cookie-secure-storage (current-buffer))
167 (insert ")\n")
168 (write-file fname)
169 (kill-buffer (current-buffer))))))
170
171 (defun url-cookie-store (name value &optional expires domain localpart secure)
172 "Store a netscape-style cookie."
173 (let* ((storage (if secure url-cookie-secure-storage url-cookie-storage))
174 (tmp storage)
175 (cur nil)
176 (found-domain nil))
177
178 ;; First, look for a matching domain
179 (setq found-domain (assoc domain storage))
180
181 (if found-domain
182 ;; Need to either stick the new cookie in existing domain storage
183 ;; or possibly replace an existing cookie if the names match.
184 (progn
185 (setq storage (cdr found-domain)
186 tmp nil)
187 (while storage
188 (setq cur (car storage)
189 storage (cdr storage))
190 (if (and (equal localpart (url-cookie-localpart cur))
191 (equal name (url-cookie-name cur)))
192 (progn
193 (url-cookie-set-expires cur expires)
194 (url-cookie-set-value cur value)
195 (setq tmp t))))
196 (if (not tmp)
197 ;; New cookie
198 (setcdr found-domain (cons
199 (url-cookie-create :name name
200 :value value
201 :expires expires
202 :domain domain
203 :localpart localpart
204 :secure secure)
205 (cdr found-domain)))))
206 ;; Need to add a new top-level domain
207 (setq tmp (url-cookie-create :name name
208 :value value
209 :expires expires
210 :domain domain
211 :localpart localpart
212 :secure secure))
213 (cond
214 (storage
215 (setcdr storage (cons (list domain tmp) (cdr storage))))
216 (secure
217 (setq url-cookie-secure-storage (list (list domain tmp))))
218 (t
219 (setq url-cookie-storage (list (list domain tmp))))))))
220
221 (defun url-cookie-expired-p (cookie)
222 (let* (
223 (exp (url-cookie-expires cookie))
224 (cur-date (and exp (timezone-parse-date (current-time-string))))
225 (exp-date (and exp (timezone-parse-date exp)))
226 (cur-greg (and cur-date (timezone-absolute-from-gregorian
227 (string-to-number (aref cur-date 1))
228 (string-to-number (aref cur-date 2))
229 (string-to-number (aref cur-date 0)))))
230 (exp-greg (and exp (timezone-absolute-from-gregorian
231 (string-to-number (aref exp-date 1))
232 (string-to-number (aref exp-date 2))
233 (string-to-number (aref exp-date 0)))))
234 (diff-in-days (and exp (- cur-greg exp-greg)))
235 )
236 (cond
237 ((not exp) nil) ; No expiry == expires at browser quit
238 ((< diff-in-days 0) nil) ; Expires sometime after today
239 ((> diff-in-days 0) t) ; Expired before today
240 (t ; Expires sometime today, check times
241 (let* ((cur-time (timezone-parse-time (aref cur-date 3)))
242 (exp-time (timezone-parse-time (aref exp-date 3)))
243 (cur-norm (+ (* 360 (string-to-number (aref cur-time 2)))
244 (* 60 (string-to-number (aref cur-time 1)))
245 (* 1 (string-to-number (aref cur-time 0)))))
246 (exp-norm (+ (* 360 (string-to-number (aref exp-time 2)))
247 (* 60 (string-to-number (aref exp-time 1)))
248 (* 1 (string-to-number (aref exp-time 0))))))
249 (> (- cur-norm exp-norm) 1))))))
250
251 ;;;###autoload
252 (defun url-cookie-retrieve (host localpart &optional secure)
253 "Retrieve all the netscape-style cookies for a specified HOST and LOCALPART."
254 (let ((storage (if secure
255 (append url-cookie-secure-storage url-cookie-storage)
256 url-cookie-storage))
257 (case-fold-search t)
258 (cookies nil)
259 (cur nil)
260 (retval nil)
261 (localpart-regexp nil))
262 (while storage
263 (setq cur (car storage)
264 storage (cdr storage)
265 cookies (cdr cur))
266 (if (and (car cur)
267 (string-match (concat "^.*" (regexp-quote (car cur)) "$") host))
268 ;; The domains match - a possible hit!
269 (while cookies
270 (setq cur (car cookies)
271 cookies (cdr cookies)
272 localpart-regexp (concat "^" (regexp-quote
273 (url-cookie-localpart cur))))
274 (if (and (string-match localpart-regexp localpart)
275 (not (url-cookie-expired-p cur)))
276 (setq retval (cons cur retval))))))
277 retval))
278
279 ;;;###autoload
280 (defun url-cookie-generate-header-lines (host localpart secure)
281 (let* ((cookies (url-cookie-retrieve host localpart secure))
282 (retval nil)
283 (cur nil)
284 (chunk nil))
285 ;; Have to sort this for sending most specific cookies first
286 (setq cookies (and cookies
287 (sort cookies
288 (function
289 (lambda (x y)
290 (> (length (url-cookie-localpart x))
291 (length (url-cookie-localpart y))))))))
292 (while cookies
293 (setq cur (car cookies)
294 cookies (cdr cookies)
295 chunk (format "%s=%s" (url-cookie-name cur) (url-cookie-value cur))
296 retval (if (and url-cookie-multiple-line
297 (< 80 (+ (length retval) (length chunk) 4)))
298 (concat retval "\r\nCookie: " chunk)
299 (if retval
300 (concat retval "; " chunk)
301 (concat "Cookie: " chunk)))))
302 (if retval
303 (concat retval "\r\n")
304 "")))
305
306 (defvar url-cookie-two-dot-domains
307 (concat "\\.\\("
308 (mapconcat 'identity (list "com" "edu" "net" "org" "gov" "mil" "int")
309 "\\|")
310 "\\)$")
311 "A regexp of top level domains that only require two matching
312 '.'s in the domain name in order to set a cookie.")
313
314 (defcustom url-cookie-trusted-urls nil
315 "*A list of regular expressions matching URLs to always accept cookies from."
316 :type '(repeat regexp)
317 :group 'url-cookie)
318
319 (defcustom url-cookie-untrusted-urls nil
320 "*A list of regular expressions matching URLs to never accept cookies from."
321 :type '(repeat regexp)
322 :group 'url-cookie)
323
324 (defun url-cookie-host-can-set-p (host domain)
325 (let ((numdots 0)
326 (tmp domain)
327 (last nil)
328 (case-fold-search t)
329 (mindots 3))
330 (while (setq last (string-match "\\." domain last))
331 (setq numdots (1+ numdots)
332 last (1+ last)))
333 (if (string-match url-cookie-two-dot-domains domain)
334 (setq mindots 2))
335 (cond
336 ((string= host domain) ; Apparently netscape lets you do this
337 t)
338 ((>= numdots mindots) ; We have enough dots in domain name
339 ;; Need to check and make sure the host is actually _in_ the
340 ;; domain it wants to set a cookie for though.
341 (string-match (concat (regexp-quote domain) "$") host))
342 (t
343 nil))))
344
345 ;;;###autoload
346 (defun url-cookie-handle-set-cookie (str)
347 (setq url-cookies-changed-since-last-save t)
348 (let* ((args (url-parse-args str t))
349 (case-fold-search t)
350 (secure (and (assoc-string "secure" args t) t))
351 (domain (or (cdr-safe (assoc-string "domain" args t))
352 (url-host url-current-object)))
353 (current-url (url-view-url t))
354 (trusted url-cookie-trusted-urls)
355 (untrusted url-cookie-untrusted-urls)
356 (expires (cdr-safe (assoc-string "expires" args t)))
357 (localpart (or (cdr-safe (assoc-string "path" args t))
358 (file-name-directory
359 (url-filename url-current-object))))
360 (rest nil))
361 (while args
362 (if (not (member (downcase (car (car args)))
363 '("secure" "domain" "expires" "path")))
364 (setq rest (cons (car args) rest)))
365 (setq args (cdr args)))
366
367 ;; Sometimes we get dates that the timezone package cannot handle very
368 ;; gracefully - take care of this here, instead of in url-cookie-expired-p
369 ;; to speed things up.
370 (if (and expires
371 (string-match
372 (concat "^[^,]+, +\\(..\\)-\\(...\\)-\\(..\\) +"
373 "\\(..:..:..\\) +\\[*\\([^\]]+\\)\\]*$")
374 expires))
375 (setq expires (concat (match-string 1 expires) " "
376 (match-string 2 expires) " "
377 (match-string 3 expires) " "
378 (match-string 4 expires) " ["
379 (match-string 5 expires) "]")))
380
381 ;; This one is for older Emacs/XEmacs variants that don't
382 ;; understand this format without tenths of a second in it.
383 ;; Wednesday, 30-Dec-2037 16:00:00 GMT
384 ;; - vs -
385 ;; Wednesday, 30-Dec-2037 16:00:00.00 GMT
386 (if (and expires
387 (string-match
388 "\\([0-9]+\\)-\\([A-Za-z]+\\)-\\([0-9]+\\)[ \t]+\\([0-9]+:[0-9]+:[0-9]+\\)\\(\\.[0-9]+\\)*[ \t]+\\([-+a-zA-Z0-9]+\\)"
389 expires))
390 (setq expires (concat (match-string 1 expires) "-" ; day
391 (match-string 2 expires) "-" ; month
392 (match-string 3 expires) " " ; year
393 (match-string 4 expires) ".00 " ; hour:minutes:seconds
394 (match-string 6 expires)))) ":" ; timezone
395
396 (while (consp trusted)
397 (if (string-match (car trusted) current-url)
398 (setq trusted (- (match-end 0) (match-beginning 0)))
399 (pop trusted)))
400 (while (consp untrusted)
401 (if (string-match (car untrusted) current-url)
402 (setq untrusted (- (match-end 0) (match-beginning 0)))
403 (pop untrusted)))
404 (if (and trusted untrusted)
405 ;; Choose the more specific match
406 (if (> trusted untrusted)
407 (setq untrusted nil)
408 (setq trusted nil)))
409 (cond
410 (untrusted
411 ;; The site was explicity marked as untrusted by the user
412 nil)
413 ((or (eq url-privacy-level 'paranoid)
414 (and (listp url-privacy-level) (memq 'cookies url-privacy-level)))
415 ;; user never wants cookies
416 nil)
417 ((and url-cookie-confirmation
418 (not trusted)
419 (save-window-excursion
420 (with-output-to-temp-buffer "*Cookie Warning*"
421 (mapcar
422 (function
423 (lambda (x)
424 (princ (format "%s - %s" (car x) (cdr x))))) rest))
425 (prog1
426 (not (funcall url-confirmation-func
427 (format "Allow %s to set these cookies? "
428 (url-host url-current-object))))
429 (if (get-buffer "*Cookie Warning*")
430 (kill-buffer "*Cookie Warning*")))))
431 ;; user wants to be asked, and declined.
432 nil)
433 ((url-cookie-host-can-set-p (url-host url-current-object) domain)
434 ;; Cookie is accepted by the user, and passes our security checks
435 (let ((cur nil))
436 (while rest
437 (setq cur (pop rest))
438 (url-cookie-store (car cur) (cdr cur)
439 expires domain localpart secure))))
440 (t
441 (message "%s tried to set a cookie for domain %s - rejected."
442 (url-host url-current-object) domain)))))
443
444 (defvar url-cookie-timer nil)
445
446 (defcustom url-cookie-save-interval 3600
447 "*The number of seconds between automatic saves of cookies.
448 Default is 1 hour. Note that if you change this variable outside of
449 the `customize' interface after `url-do-setup' has been run, you need
450 to run the `url-cookie-setup-save-timer' function manually."
451 :set (function (lambda (var val)
452 (set-default var val)
453 (and (featurep 'url)
454 (fboundp 'url-cookie-setup-save-timer)
455 (url-cookie-setup-save-timer))))
456 :type 'integer
457 :group 'url)
458
459 ;;;###autoload
460 (defun url-cookie-setup-save-timer ()
461 "Reset the cookie saver timer."
462 (interactive)
463 (ignore-errors
464 (cond ((fboundp 'cancel-timer) (cancel-timer url-cookie-timer))
465 ((fboundp 'delete-itimer) (delete-itimer url-cookie-timer))))
466 (setq url-cookie-timer nil)
467 (if url-cookie-save-interval
468 (setq url-cookie-timer
469 (cond
470 ((fboundp 'run-at-time)
471 (run-at-time url-cookie-save-interval
472 url-cookie-save-interval
473 'url-cookie-write-file))
474 ((fboundp 'start-itimer)
475 (start-itimer "url-cookie-saver" 'url-cookie-write-file
476 url-cookie-save-interval
477 url-cookie-save-interval))))))
478
479 (provide 'url-cookie)
480
481 ;; arch-tag: 2568751b-6452-4398-aa2d-303edadb54d7
482 ;;; url-cookie.el ends here