Mercurial > hg > xemacs-beta

comparison lisp/w3/url-cookie.el @ 14:9ee227acff29 r19-15b90

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r19-15b90
author cvs
date Mon, 13 Aug 2007 08:48:42 +0200
parents
children 0293115a14e9 6a378aca36af
comparison
equal deleted inserted replaced
13:13c6d0aaafe5 14:9ee227acff29
1 ;;; url-cookie.el --- Netscape Cookie support
2 ;; Author: wmperry
3 ;; Created: 1996/10/09 19:00:59
4 ;; Version: 1.5
5 ;; Keywords: comm, data, processes, hypermedia
6
7 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
8 ;;; Copyright (c) 1996 by William M. Perry (wmperry@cs.indiana.edu)
9 ;;; Copyright (c) 1996 Free Software Foundation, Inc.
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
32 (let ((keywords
33 '(:name :value :expires :path :domain :test :secure)))
34 (while keywords
35 (or (boundp (car keywords))
36 (set (car keywords) (car keywords)))
37 (setq keywords (cdr keywords))))
38
39 ;; See http://home.netscape.com/newsref/std/cookie_spec.html for the
40 ;; 'open standard' defining this crap.
41 ;;
42 ;; A cookie is stored internally as a vector of 7 slots
43 ;; [ 'cookie name value expires path domain secure ]
44
45 (defsubst url-cookie-name (cookie) (aref cookie 1))
46 (defsubst url-cookie-value (cookie) (aref cookie 2))
47 (defsubst url-cookie-expires (cookie) (aref cookie 3))
48 (defsubst url-cookie-path (cookie) (aref cookie 4))
49 (defsubst url-cookie-domain (cookie) (aref cookie 5))
50 (defsubst url-cookie-secure (cookie) (aref cookie 6))
51
52 (defsubst url-cookie-set-name (cookie val) (aset cookie 1 val))
53 (defsubst url-cookie-set-value (cookie val) (aset cookie 2 val))
54 (defsubst url-cookie-set-expires (cookie val) (aset cookie 3 val))
55 (defsubst url-cookie-set-path (cookie val) (aset cookie 4 val))
56 (defsubst url-cookie-set-domain (cookie val) (aset cookie 5 val))
57 (defsubst url-cookie-set-secure (cookie val) (aset cookie 6 val))
58 (defsubst url-cookie-retrieve-arg (key args) (nth 1 (memq key args)))
59
60 (defsubst url-cookie-create (&rest args)
61 (let ((retval (make-vector 7 nil)))
62 (aset retval 0 'cookie)
63 (url-cookie-set-name retval (url-cookie-retrieve-arg :name args))
64 (url-cookie-set-value retval (url-cookie-retrieve-arg :value args))
65 (url-cookie-set-expires retval (url-cookie-retrieve-arg :expires args))
66 (url-cookie-set-path retval (url-cookie-retrieve-arg :path args))
67 (url-cookie-set-domain retval (url-cookie-retrieve-arg :domain args))
68 (url-cookie-set-secure retval (url-cookie-retrieve-arg :secure args))
69 retval))
70
71 (defvar url-cookie-storage nil "Where cookies are stored.")
72 (defvar url-cookie-secure-storage nil "Where secure cookies are stored.")
73 (defvar url-cookie-file nil "*Where cookies are stored on disk.")
74
75 (defun url-cookie-p (obj)
76 (and (vectorp obj) (= (length obj) 7) (eq (aref obj 0) 'cookie)))
77
78 (defun url-cookie-parse-file (&optional fname)
79 (setq fname (or fname url-cookie-file))
80 (condition-case ()
81 (load fname nil t)
82 (error (message "Could not load cookie file %s" fname))))
83
84 (defun url-cookie-clean-up (&optional secure)
85 (let* (
86 (var (if secure 'url-cookie-secure-storage 'url-cookie-storage))
87 (val (symbol-value var))
88 (cur nil)
89 (new nil)
90 (cookies nil)
91 (cur-cookie nil)
92 (new-cookies nil)
93 )
94 (while val
95 (setq cur (car val)
96 val (cdr val)
97 new-cookies nil
98 cookies (cdr cur))
99 (while cookies
100 (setq cur-cookie (car cookies)
101 cookies (cdr cookies))
102 (if (or (not (url-cookie-p cur-cookie))
103 (url-cookie-expired-p cur-cookie)
104 (null (url-cookie-expires cur-cookie)))
105 nil
106 (setq new-cookies (cons cur-cookie new-cookies))))
107 (if (not new-cookies)
108 nil
109 (setcdr cur new-cookies)
110 (setq new (cons cur new))))
111 (set var new)))
112
113 (defun url-cookie-write-file (&optional fname)
114 (setq fname (or fname url-cookie-file))
115 (url-cookie-clean-up)
116 (url-cookie-clean-up t)
117 (save-excursion
118 (set-buffer (get-buffer-create " *cookies*"))
119 (erase-buffer)
120 (fundamental-mode)
121 (insert ";; Emacs-W3 HTTP cookies file\n"
122 ";; Automatically generated file!!! DO NOT EDIT!!!\n\n"
123 "(setq url-cookie-storage\n '")
124 (pp url-cookie-storage (current-buffer))
125 (insert ")\n(setq url-cookie-secure-storage\n '")
126 (pp url-cookie-secure-storage (current-buffer))
127 (insert ")\n")
128 (write-file fname)
129 (kill-buffer (current-buffer))))
130
131 (defun url-cookie-store (name value &optional expires domain path secure)
132 "Stores a netscape-style cookie"
133 (let* ((storage (if secure url-cookie-secure-storage url-cookie-storage))
134 (tmp storage)
135 (cur nil)
136 (found-domain nil))
137
138 ;; First, look for a matching domain
139 (setq found-domain (assoc domain storage))
140
141 (if found-domain
142 ;; Need to either stick the new cookie in existing domain storage
143 ;; or possibly replace an existing cookie if the names match.
144 (progn
145 (setq storage (cdr found-domain)
146 tmp nil)
147 (while storage
148 (setq cur (car storage)
149 storage (cdr storage))
150 (if (and (equal path (url-cookie-path cur))
151 (equal name (url-cookie-name cur)))
152 (progn
153 (url-cookie-set-expires cur expires)
154 (url-cookie-set-value cur value)
155 (setq tmp t))))
156 (if (not tmp)
157 ;; New cookie
158 (setcdr found-domain (cons
159 (url-cookie-create :name name
160 :value value
161 :expires expires
162 :domain domain
163 :path path
164 :secure secure)
165 (cdr found-domain)))))
166 ;; Need to add a new top-level domain
167 (setq tmp (url-cookie-create :name name
168 :value value
169 :expires expires
170 :domain domain
171 :path path
172 :secure secure))
173 (cond
174 (storage
175 (setcdr storage (cons (list domain tmp) (cdr storage))))
176 (secure
177 (setq url-cookie-secure-storage (list (list domain tmp))))
178 (t
179 (setq url-cookie-storage (list (list domain tmp))))))))
180
181 (defun url-cookie-expired-p (cookie)
182 (let* (
183 (exp (url-cookie-expires cookie))
184 (cur-date (and exp (timezone-parse-date (current-time-string))))
185 (exp-date (and exp (timezone-parse-date exp)))
186 (cur-greg (and cur-date (timezone-absolute-from-gregorian
187 (string-to-int (aref cur-date 1))
188 (string-to-int (aref cur-date 2))
189 (string-to-int (aref cur-date 0)))))
190 (exp-greg (and exp (timezone-absolute-from-gregorian
191 (string-to-int (aref exp-date 1))
192 (string-to-int (aref exp-date 2))
193 (string-to-int (aref exp-date 0)))))
194 (diff-in-days (and exp (- cur-greg exp-greg)))
195 )
196 (cond
197 ((not exp) nil) ; No expiry == expires at browser quit
198 ((< diff-in-days 0) nil) ; Expires sometime after today
199 ((> diff-in-days 0) t) ; Expired before today
200 (t ; Expires sometime today, check times
201 (let* ((cur-time (timezone-parse-time (aref cur-date 3)))
202 (exp-time (timezone-parse-time (aref exp-date 3)))
203 (cur-norm (+ (* 360 (string-to-int (aref cur-time 2)))
204 (* 60 (string-to-int (aref cur-time 1)))
205 (* 1 (string-to-int (aref cur-time 0)))))
206 (exp-norm (+ (* 360 (string-to-int (aref exp-time 2)))
207 (* 60 (string-to-int (aref exp-time 1)))
208 (* 1 (string-to-int (aref exp-time 0))))))
209 (> (- cur-norm exp-norm) 1))))))
210
211 (defun url-cookie-retrieve (host path &optional secure)
212 "Retrieves all the netscape-style cookies for a specified HOST and PATH"
213 (let ((storage (if secure
214 (append url-cookie-secure-storage url-cookie-storage)
215 url-cookie-storage))
216 (case-fold-search t)
217 (cookies nil)
218 (cur nil)
219 (retval nil)
220 (path-regexp nil))
221 (while storage
222 (setq cur (car storage)
223 storage (cdr storage)
224 cookies (cdr cur))
225 (if (and (car cur)
226 (string-match (concat "^.*" (regexp-quote (car cur)) "$") host))
227 ;; The domains match - a possible hit!
228 (while cookies
229 (setq cur (car cookies)
230 cookies (cdr cookies)
231 path-regexp (concat "^" (regexp-quote
232 (url-cookie-path cur))))
233 (if (and (string-match path-regexp path)
234 (not (url-cookie-expired-p cur)))
235 (setq retval (cons cur retval))))))
236 retval))
237
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
271 (defun url-cookie-host-can-set-p (host domain)
272 (let ((numdots 0)
273 (tmp domain)
274 (last nil)
275 (case-fold-search t)
276 (mindots 3))
277 (while (setq last (string-match "\\." host last))
278 (setq numdots (1+ numdots)
279 last (1+ last)))
280 (if (string-match url-cookie-two-dot-domains domain)
281 (setq mindots 2))
282 (cond
283 ((string= host domain) ; Apparently netscape lets you do this
284 t)
285 ((< numdots mindots) ; Not enough dots in domain name!
286 nil)
287 (t
288 (string-match (concat (regexp-quote domain) "$") host)))))
289
290 (defun url-header-comparison (x y)
291 (string= (downcase x) (downcase y)))
292
293 (defun url-cookie-handle-set-cookie (str)
294 (let* ((args (mm-parse-args str nil t)) ; Don't downcase names
295 (case-fold-search t)
296 (secure (and (assoc* "secure" args :test 'url-header-comparison) t))
297 (domain (or (cdr-safe (assoc* "domain" args :test
298 'url-header-comparison))
299 url-current-server))
300 (expires (cdr-safe (assoc* "expires" args :test
301 'url-header-comparison)))
302 (path (or (cdr-safe (assoc* "path" args :test
303 'url-header-comparison))
304 (file-name-directory url-current-file)))
305 (rest nil))
306 (while args
307 (if (not (member (downcase (car (car args)))
308 '("secure" "domain" "expires" "path")))
309 (setq rest (cons (car args) rest)))
310 (setq args (cdr args)))
311
312 ;; Sometimes we get dates that the timezone package cannot handle very
313 ;; gracefully - take care of this here, instead of in url-cookie-expired-p
314 ;; to speed things up.
315 (if (and expires
316 (string-match
317 (concat "^[^,]+, +\\(..\\)-\\(...\\)-\\(..\\) +"
318 "\\(..:..:..\\) +\\[*\\([^\]]+\\)\\]*$")
319 expires))
320 (setq expires (concat (url-match expires 1) " "
321 (url-match expires 2) " "
322 (url-match expires 3) " "
323 (url-match expires 4) " ["
324 (url-match expires 5) "]")))
325 (cond
326 ((and (listp url-privacy-level) (memq 'cookies url-privacy-level))
327 ;; user never wants cookies
328 nil)
329 ((and url-cookie-confirmation
330 (not (funcall url-confirmation-func
331 (format "Allow %s to set a cookie? "
332 url-current-server))))
333 ;; user wants to be asked, and declined.
334 nil)
335 ((url-cookie-host-can-set-p url-current-server domain)
336 ;; Cookie is accepted by the user, and passes our security checks
337 (while rest
338 (url-cookie-store (car (car rest)) (cdr (car rest))
339 expires domain path secure)
340 (setq rest (cdr rest))))
341 (t
342 (url-warn 'url (format
343 (concat "%s tried to set a cookie for domain %s\n"
344 "Permission denied - cookie rejected.\n"
345 "Set-Cookie: %s")
346 url-current-server domain str))))))
347
348 (provide 'url-cookie)