|
14
|
1 ;;; url-cookie.el --- Netscape Cookie support
|
|
|
2 ;; Author: wmperry
|
|
116
|
3 ;; Created: 1997/03/26 00:06:01
|
|
|
4 ;; Version: 1.15
|
|
14
|
5 ;; Keywords: comm, data, processes, hypermedia
|
|
|
6
|
|
|
7 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
8 ;;; Copyright (c) 1996 by William M. Perry (wmperry@cs.indiana.edu)
|
|
82
|
9 ;;; Copyright (c) 1996, 1997 Free Software Foundation, Inc.
|
|
14
|
10 ;;;
|
|
|
11 ;;; This file is not part of GNU Emacs, but the same permissions apply.
|
|
|
12 ;;;
|
|
|
13 ;;; GNU Emacs is free software; you can redistribute it and/or modify
|
|
|
14 ;;; it under the terms of the GNU General Public License as published by
|
|
|
15 ;;; the Free Software Foundation; either version 2, or (at your option)
|
|
|
16 ;;; any later version.
|
|
|
17 ;;;
|
|
|
18 ;;; GNU Emacs is distributed in the hope that it will be useful,
|
|
|
19 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
|
20 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
|
|
21 ;;; GNU General Public License for more details.
|
|
|
22 ;;;
|
|
|
23 ;;; You should have received a copy of the GNU General Public License
|
|
|
24 ;;; along with GNU Emacs; see the file COPYING. If not, write to the
|
|
|
25 ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
|
|
|
26 ;;; Boston, MA 02111-1307, USA.
|
|
|
27 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
28
|
|
|
29 (require 'timezone)
|
|
|
30 (require 'cl)
|
|
|
31
|
|
82
|
32 (eval-and-compile
|
|
|
33 (let ((keywords
|
|
|
34 '(:name :value :expires :path :domain :test :secure)))
|
|
|
35 (while keywords
|
|
|
36 (or (boundp (car keywords))
|
|
|
37 (set (car keywords) (car keywords)))
|
|
|
38 (setq keywords (cdr keywords)))))
|
|
14
|
39
|
|
|
40 ;; See http://home.netscape.com/newsref/std/cookie_spec.html for the
|
|
|
41 ;; 'open standard' defining this crap.
|
|
|
42 ;;
|
|
|
43 ;; A cookie is stored internally as a vector of 7 slots
|
|
|
44 ;; [ 'cookie name value expires path domain secure ]
|
|
|
45
|
|
|
46 (defsubst url-cookie-name (cookie) (aref cookie 1))
|
|
|
47 (defsubst url-cookie-value (cookie) (aref cookie 2))
|
|
|
48 (defsubst url-cookie-expires (cookie) (aref cookie 3))
|
|
|
49 (defsubst url-cookie-path (cookie) (aref cookie 4))
|
|
|
50 (defsubst url-cookie-domain (cookie) (aref cookie 5))
|
|
|
51 (defsubst url-cookie-secure (cookie) (aref cookie 6))
|
|
|
52
|
|
|
53 (defsubst url-cookie-set-name (cookie val) (aset cookie 1 val))
|
|
|
54 (defsubst url-cookie-set-value (cookie val) (aset cookie 2 val))
|
|
|
55 (defsubst url-cookie-set-expires (cookie val) (aset cookie 3 val))
|
|
|
56 (defsubst url-cookie-set-path (cookie val) (aset cookie 4 val))
|
|
|
57 (defsubst url-cookie-set-domain (cookie val) (aset cookie 5 val))
|
|
|
58 (defsubst url-cookie-set-secure (cookie val) (aset cookie 6 val))
|
|
|
59 (defsubst url-cookie-retrieve-arg (key args) (nth 1 (memq key args)))
|
|
|
60
|
|
|
61 (defsubst url-cookie-create (&rest args)
|
|
|
62 (let ((retval (make-vector 7 nil)))
|
|
|
63 (aset retval 0 'cookie)
|
|
|
64 (url-cookie-set-name retval (url-cookie-retrieve-arg :name args))
|
|
|
65 (url-cookie-set-value retval (url-cookie-retrieve-arg :value args))
|
|
|
66 (url-cookie-set-expires retval (url-cookie-retrieve-arg :expires args))
|
|
|
67 (url-cookie-set-path retval (url-cookie-retrieve-arg :path args))
|
|
|
68 (url-cookie-set-domain retval (url-cookie-retrieve-arg :domain args))
|
|
|
69 (url-cookie-set-secure retval (url-cookie-retrieve-arg :secure args))
|
|
|
70 retval))
|
|
|
71
|
|
|
72 (defun url-cookie-p (obj)
|
|
|
73 (and (vectorp obj) (= (length obj) 7) (eq (aref obj 0) 'cookie)))
|
|
|
74
|
|
|
75 (defun url-cookie-parse-file (&optional fname)
|
|
|
76 (setq fname (or fname url-cookie-file))
|
|
|
77 (condition-case ()
|
|
|
78 (load fname nil t)
|
|
|
79 (error (message "Could not load cookie file %s" fname))))
|
|
|
80
|
|
|
81 (defun url-cookie-clean-up (&optional secure)
|
|
|
82 (let* (
|
|
|
83 (var (if secure 'url-cookie-secure-storage 'url-cookie-storage))
|
|
|
84 (val (symbol-value var))
|
|
|
85 (cur nil)
|
|
|
86 (new nil)
|
|
|
87 (cookies nil)
|
|
|
88 (cur-cookie nil)
|
|
|
89 (new-cookies nil)
|
|
|
90 )
|
|
|
91 (while val
|
|
|
92 (setq cur (car val)
|
|
|
93 val (cdr val)
|
|
|
94 new-cookies nil
|
|
|
95 cookies (cdr cur))
|
|
|
96 (while cookies
|
|
|
97 (setq cur-cookie (car cookies)
|
|
|
98 cookies (cdr cookies))
|
|
|
99 (if (or (not (url-cookie-p cur-cookie))
|
|
|
100 (url-cookie-expired-p cur-cookie)
|
|
|
101 (null (url-cookie-expires cur-cookie)))
|
|
|
102 nil
|
|
|
103 (setq new-cookies (cons cur-cookie new-cookies))))
|
|
|
104 (if (not new-cookies)
|
|
|
105 nil
|
|
|
106 (setcdr cur new-cookies)
|
|
|
107 (setq new (cons cur new))))
|
|
|
108 (set var new)))
|
|
|
109
|
|
82
|
110 ;;###autoload
|
|
14
|
111 (defun url-cookie-write-file (&optional fname)
|
|
|
112 (setq fname (or fname url-cookie-file))
|
|
|
113 (url-cookie-clean-up)
|
|
|
114 (url-cookie-clean-up t)
|
|
|
115 (save-excursion
|
|
|
116 (set-buffer (get-buffer-create " *cookies*"))
|
|
|
117 (erase-buffer)
|
|
|
118 (fundamental-mode)
|
|
|
119 (insert ";; Emacs-W3 HTTP cookies file\n"
|
|
|
120 ";; Automatically generated file!!! DO NOT EDIT!!!\n\n"
|
|
|
121 "(setq url-cookie-storage\n '")
|
|
|
122 (pp url-cookie-storage (current-buffer))
|
|
|
123 (insert ")\n(setq url-cookie-secure-storage\n '")
|
|
|
124 (pp url-cookie-secure-storage (current-buffer))
|
|
|
125 (insert ")\n")
|
|
|
126 (write-file fname)
|
|
|
127 (kill-buffer (current-buffer))))
|
|
|
128
|
|
|
129 (defun url-cookie-store (name value &optional expires domain path secure)
|
|
|
130 "Stores a netscape-style cookie"
|
|
|
131 (let* ((storage (if secure url-cookie-secure-storage url-cookie-storage))
|
|
|
132 (tmp storage)
|
|
|
133 (cur nil)
|
|
|
134 (found-domain nil))
|
|
|
135
|
|
|
136 ;; First, look for a matching domain
|
|
|
137 (setq found-domain (assoc domain storage))
|
|
|
138
|
|
|
139 (if found-domain
|
|
|
140 ;; Need to either stick the new cookie in existing domain storage
|
|
|
141 ;; or possibly replace an existing cookie if the names match.
|
|
|
142 (progn
|
|
|
143 (setq storage (cdr found-domain)
|
|
|
144 tmp nil)
|
|
|
145 (while storage
|
|
|
146 (setq cur (car storage)
|
|
|
147 storage (cdr storage))
|
|
|
148 (if (and (equal path (url-cookie-path cur))
|
|
|
149 (equal name (url-cookie-name cur)))
|
|
|
150 (progn
|
|
|
151 (url-cookie-set-expires cur expires)
|
|
|
152 (url-cookie-set-value cur value)
|
|
|
153 (setq tmp t))))
|
|
|
154 (if (not tmp)
|
|
|
155 ;; New cookie
|
|
|
156 (setcdr found-domain (cons
|
|
|
157 (url-cookie-create :name name
|
|
|
158 :value value
|
|
|
159 :expires expires
|
|
|
160 :domain domain
|
|
|
161 :path path
|
|
|
162 :secure secure)
|
|
|
163 (cdr found-domain)))))
|
|
|
164 ;; Need to add a new top-level domain
|
|
|
165 (setq tmp (url-cookie-create :name name
|
|
|
166 :value value
|
|
|
167 :expires expires
|
|
|
168 :domain domain
|
|
|
169 :path path
|
|
|
170 :secure secure))
|
|
|
171 (cond
|
|
|
172 (storage
|
|
|
173 (setcdr storage (cons (list domain tmp) (cdr storage))))
|
|
|
174 (secure
|
|
|
175 (setq url-cookie-secure-storage (list (list domain tmp))))
|
|
|
176 (t
|
|
|
177 (setq url-cookie-storage (list (list domain tmp))))))))
|
|
|
178
|
|
|
179 (defun url-cookie-expired-p (cookie)
|
|
|
180 (let* (
|
|
|
181 (exp (url-cookie-expires cookie))
|
|
|
182 (cur-date (and exp (timezone-parse-date (current-time-string))))
|
|
|
183 (exp-date (and exp (timezone-parse-date exp)))
|
|
|
184 (cur-greg (and cur-date (timezone-absolute-from-gregorian
|
|
|
185 (string-to-int (aref cur-date 1))
|
|
|
186 (string-to-int (aref cur-date 2))
|
|
|
187 (string-to-int (aref cur-date 0)))))
|
|
|
188 (exp-greg (and exp (timezone-absolute-from-gregorian
|
|
|
189 (string-to-int (aref exp-date 1))
|
|
|
190 (string-to-int (aref exp-date 2))
|
|
|
191 (string-to-int (aref exp-date 0)))))
|
|
|
192 (diff-in-days (and exp (- cur-greg exp-greg)))
|
|
|
193 )
|
|
|
194 (cond
|
|
|
195 ((not exp) nil) ; No expiry == expires at browser quit
|
|
|
196 ((< diff-in-days 0) nil) ; Expires sometime after today
|
|
|
197 ((> diff-in-days 0) t) ; Expired before today
|
|
|
198 (t ; Expires sometime today, check times
|
|
|
199 (let* ((cur-time (timezone-parse-time (aref cur-date 3)))
|
|
|
200 (exp-time (timezone-parse-time (aref exp-date 3)))
|
|
|
201 (cur-norm (+ (* 360 (string-to-int (aref cur-time 2)))
|
|
|
202 (* 60 (string-to-int (aref cur-time 1)))
|
|
|
203 (* 1 (string-to-int (aref cur-time 0)))))
|
|
|
204 (exp-norm (+ (* 360 (string-to-int (aref exp-time 2)))
|
|
|
205 (* 60 (string-to-int (aref exp-time 1)))
|
|
|
206 (* 1 (string-to-int (aref exp-time 0))))))
|
|
|
207 (> (- cur-norm exp-norm) 1))))))
|
|
|
208
|
|
82
|
209 ;;###autoload
|
|
14
|
210 (defun url-cookie-retrieve (host path &optional secure)
|
|
|
211 "Retrieves all the netscape-style cookies for a specified HOST and PATH"
|
|
|
212 (let ((storage (if secure
|
|
|
213 (append url-cookie-secure-storage url-cookie-storage)
|
|
|
214 url-cookie-storage))
|
|
|
215 (case-fold-search t)
|
|
|
216 (cookies nil)
|
|
|
217 (cur nil)
|
|
|
218 (retval nil)
|
|
|
219 (path-regexp nil))
|
|
|
220 (while storage
|
|
|
221 (setq cur (car storage)
|
|
|
222 storage (cdr storage)
|
|
|
223 cookies (cdr cur))
|
|
|
224 (if (and (car cur)
|
|
|
225 (string-match (concat "^.*" (regexp-quote (car cur)) "$") host))
|
|
|
226 ;; The domains match - a possible hit!
|
|
|
227 (while cookies
|
|
|
228 (setq cur (car cookies)
|
|
|
229 cookies (cdr cookies)
|
|
|
230 path-regexp (concat "^" (regexp-quote
|
|
|
231 (url-cookie-path cur))))
|
|
|
232 (if (and (string-match path-regexp path)
|
|
|
233 (not (url-cookie-expired-p cur)))
|
|
|
234 (setq retval (cons cur retval))))))
|
|
|
235 retval))
|
|
|
236
|
|
82
|
237 ;;###autolaod
|
|
14
|
238 (defun url-cookie-generate-header-lines (host path secure)
|
|
|
239 (let* ((cookies (url-cookie-retrieve host path secure))
|
|
|
240 (retval nil)
|
|
|
241 (cur nil)
|
|
|
242 (chunk nil))
|
|
|
243 ;; Have to sort this for sending most specific cookies first
|
|
|
244 (setq cookies (and cookies
|
|
|
245 (sort cookies
|
|
|
246 (function
|
|
|
247 (lambda (x y)
|
|
|
248 (> (length (url-cookie-path x))
|
|
|
249 (length (url-cookie-path y))))))))
|
|
|
250 (while cookies
|
|
|
251 (setq cur (car cookies)
|
|
|
252 cookies (cdr cookies)
|
|
|
253 chunk (format "%s=%s" (url-cookie-name cur) (url-cookie-value cur))
|
|
|
254 retval (if (< 80 (+ (length retval) (length chunk) 4))
|
|
|
255 (concat retval "\r\nCookie: " chunk)
|
|
|
256 (if retval
|
|
|
257 (concat retval "; " chunk)
|
|
|
258 (concat "Cookie: " chunk)))))
|
|
|
259 (if retval
|
|
|
260 (concat retval "\r\n")
|
|
|
261 "")))
|
|
|
262
|
|
|
263 (defvar url-cookie-two-dot-domains
|
|
|
264 (concat "\\.\\("
|
|
|
265 (mapconcat 'identity (list "com" "edu" "net" "org" "gov" "mil" "int")
|
|
|
266 "\\|")
|
|
|
267 "\\)$")
|
|
|
268 "A regular expression of top-level domains that only require two matching
|
|
|
269 '.'s in the domain name in order to set a cookie.")
|
|
|
270
|
|
114
|
271 (defvar url-cookie-trusted-urls nil
|
|
|
272 "*A list of regular expressions matching URLs to always accept cookies from.")
|
|
|
273
|
|
|
274 (defvar url-cookie-untrusted-urls nil
|
|
|
275 "*A list of regular expressions matching URLs to never accept cookies from.")
|
|
|
276
|
|
14
|
277 (defun url-cookie-host-can-set-p (host domain)
|
|
|
278 (let ((numdots 0)
|
|
|
279 (tmp domain)
|
|
|
280 (last nil)
|
|
|
281 (case-fold-search t)
|
|
|
282 (mindots 3))
|
|
|
283 (while (setq last (string-match "\\." host last))
|
|
|
284 (setq numdots (1+ numdots)
|
|
|
285 last (1+ last)))
|
|
|
286 (if (string-match url-cookie-two-dot-domains domain)
|
|
|
287 (setq mindots 2))
|
|
|
288 (cond
|
|
|
289 ((string= host domain) ; Apparently netscape lets you do this
|
|
|
290 t)
|
|
|
291 ((< numdots mindots) ; Not enough dots in domain name!
|
|
|
292 nil)
|
|
|
293 (t
|
|
|
294 (string-match (concat (regexp-quote domain) "$") host)))))
|
|
|
295
|
|
|
296 (defun url-header-comparison (x y)
|
|
|
297 (string= (downcase x) (downcase y)))
|
|
|
298
|
|
82
|
299 ;;###autoload
|
|
14
|
300 (defun url-cookie-handle-set-cookie (str)
|
|
|
301 (let* ((args (mm-parse-args str nil t)) ; Don't downcase names
|
|
|
302 (case-fold-search t)
|
|
|
303 (secure (and (assoc* "secure" args :test 'url-header-comparison) t))
|
|
|
304 (domain (or (cdr-safe (assoc* "domain" args :test
|
|
|
305 'url-header-comparison))
|
|
102
|
306 (url-host url-current-object)))
|
|
114
|
307 (current-url (url-view-url t))
|
|
|
308 (trusted url-cookie-trusted-urls)
|
|
|
309 (untrusted url-cookie-untrusted-urls)
|
|
14
|
310 (expires (cdr-safe (assoc* "expires" args :test
|
|
|
311 'url-header-comparison)))
|
|
|
312 (path (or (cdr-safe (assoc* "path" args :test
|
|
|
313 'url-header-comparison))
|
|
102
|
314 (file-name-directory
|
|
|
315 (url-filename url-current-object))))
|
|
14
|
316 (rest nil))
|
|
|
317 (while args
|
|
|
318 (if (not (member (downcase (car (car args)))
|
|
|
319 '("secure" "domain" "expires" "path")))
|
|
|
320 (setq rest (cons (car args) rest)))
|
|
|
321 (setq args (cdr args)))
|
|
|
322
|
|
|
323 ;; Sometimes we get dates that the timezone package cannot handle very
|
|
|
324 ;; gracefully - take care of this here, instead of in url-cookie-expired-p
|
|
|
325 ;; to speed things up.
|
|
|
326 (if (and expires
|
|
|
327 (string-match
|
|
|
328 (concat "^[^,]+, +\\(..\\)-\\(...\\)-\\(..\\) +"
|
|
|
329 "\\(..:..:..\\) +\\[*\\([^\]]+\\)\\]*$")
|
|
|
330 expires))
|
|
|
331 (setq expires (concat (url-match expires 1) " "
|
|
|
332 (url-match expires 2) " "
|
|
|
333 (url-match expires 3) " "
|
|
|
334 (url-match expires 4) " ["
|
|
|
335 (url-match expires 5) "]")))
|
|
114
|
336 (while (consp trusted)
|
|
|
337 (if (string-match (car trusted) current-url)
|
|
|
338 (setq trusted (- (match-end 0) (match-beginning 0)))
|
|
|
339 (pop trusted)))
|
|
|
340 (while (consp untrusted)
|
|
|
341 (if (string-match (car untrusted) current-url)
|
|
|
342 (setq untrusted (- (match-end 0) (match-beginning 0)))
|
|
|
343 (pop untrusted)))
|
|
|
344 (if (and trusted untrusted)
|
|
|
345 ;; Choose the more specific match
|
|
|
346 (if (> trusted untrusted)
|
|
|
347 (setq untrusted nil)
|
|
|
348 (setq trusted nil)))
|
|
14
|
349 (cond
|
|
114
|
350 (untrusted
|
|
|
351 ;; The site was explicity marked as untrusted by the user
|
|
|
352 nil)
|
|
14
|
353 ((and (listp url-privacy-level) (memq 'cookies url-privacy-level))
|
|
|
354 ;; user never wants cookies
|
|
|
355 nil)
|
|
|
356 ((and url-cookie-confirmation
|
|
114
|
357 (not trusted)
|
|
|
358 (save-window-excursion
|
|
|
359 (with-output-to-temp-buffer "*Cookie Warning*"
|
|
|
360 (mapcar
|
|
|
361 (function
|
|
|
362 (lambda (x)
|
|
|
363 (princ (format "%s - %s" (car x) (cdr x))))) rest))
|
|
|
364 (prog1
|
|
|
365 (not (funcall url-confirmation-func
|
|
|
366 (format "Allow %s to set these cookies? "
|
|
|
367 (url-host url-current-object))))
|
|
|
368 (if (get-buffer "*Cookie Warning*")
|
|
|
369 (kill-buffer "*Cookie Warning*")))))
|
|
14
|
370 ;; user wants to be asked, and declined.
|
|
|
371 nil)
|
|
102
|
372 ((url-cookie-host-can-set-p (url-host url-current-object) domain)
|
|
14
|
373 ;; Cookie is accepted by the user, and passes our security checks
|
|
86
|
374 (let ((cur nil))
|
|
|
375 (while rest
|
|
|
376 (setq cur (pop rest))
|
|
|
377 (url-cookie-store (car cur) (cdr cur)
|
|
|
378 expires domain path secure))))
|
|
14
|
379 (t
|
|
|
380 (url-warn 'url (format
|
|
|
381 (concat "%s tried to set a cookie for domain %s\n"
|
|
|
382 "Permission denied - cookie rejected.\n"
|
|
|
383 "Set-Cookie: %s")
|
|
102
|
384 (url-host url-current-object) domain str))))))
|
|
14
|
385
|
|
|
386 (provide 'url-cookie)
|
