Mercurial > hg > xemacs-beta

comparison lisp/url/url-cookie.el @ 70:131b0175ea99 r20-0b30

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