Mercurial > hg > xemacs-beta

comparison lisp/url/url-cookie.el @ 0:376386a54a3c r19-14

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r19-14
author cvs
date Mon, 13 Aug 2007 08:45:50 +0200
parents
children ac2d302a0011
comparison
equal deleted inserted replaced
-1:000000000000 0:376386a54a3c
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
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))))
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 (defvar url-cookie-storage nil "Where cookies are stored.")
73 (defvar url-cookie-secure-storage nil "Where secure cookies are stored.")
74 (defvar url-cookie-file nil "*Where cookies are stored on disk.")
75
76 (defun url-cookie-p (obj)
77 (and (vectorp obj) (= (length obj) 7) (eq (aref obj 0) 'cookie)))
78
79 (defun url-cookie-parse-file (&optional fname)
80 (setq fname (or fname url-cookie-file))
81 (condition-case ()
82 (load fname nil t)
83 (error (message "Could not load cookie file %s" fname))))
84
85 (defun url-cookie-clean-up (&optional secure)
86 (let* (
87 (var (if secure 'url-cookie-secure-storage 'url-cookie-storage))
88 (val (symbol-value var))
89 (cur nil)
90 (new nil)
91 (cookies nil)
92 (cur-cookie nil)
93 (new-cookies nil)
94 )
95 (while val
96 (setq cur (car val)
97 val (cdr val)
98 new-cookies nil
99 cookies (cdr cur))
100 (while cookies
101 (setq cur-cookie (car cookies)
102 cookies (cdr cookies))
103 (if (or (not (url-cookie-p cur-cookie))
104 (url-cookie-expired-p cur-cookie)
105 (null (url-cookie-expires cur-cookie)))
106 nil
107 (setq new-cookies (cons cur-cookie new-cookies))))
108 (if (not new-cookies)
109 nil
110 (setcdr cur new-cookies)
111 (setq new (cons cur new))))
112 (set var new)))
113
114 (defun url-cookie-write-file (&optional fname)
115 (setq fname (or fname url-cookie-file))
116 (url-cookie-clean-up)
117 (url-cookie-clean-up t)
118 (save-excursion
119 (set-buffer (get-buffer-create " *cookies*"))
120 (erase-buffer)
121 (fundamental-mode)
122 (insert ";; Emacs-W3 HTTP cookies file\n"
123 ";; Automatically generated file!!! DO NOT EDIT!!!\n\n"
124 "(setq url-cookie-storage\n '")
125 (pp url-cookie-storage (current-buffer))
126 (insert ")\n(setq url-cookie-secure-storage\n '")
127 (pp url-cookie-secure-storage (current-buffer))
128 (insert ")\n")
129 (write-file fname)
130 (kill-buffer (current-buffer))))
131
132 (defun url-cookie-store (name value &optional expires domain path secure)
133 "Stores a netscape-style cookie"
134 (let* ((storage (if secure url-cookie-secure-storage url-cookie-storage))
135 (tmp storage)
136 (cur nil)
137 (found-domain nil))
138
139 ;; First, look for a matching domain
140 (setq found-domain (assoc domain storage))
141
142 (if found-domain
143 ;; Need to either stick the new cookie in existing domain storage
144 ;; or possibly replace an existing cookie if the names match.
145 (progn
146 (setq storage (cdr found-domain)
147 tmp nil)
148 (while storage
149 (setq cur (car storage)
150 storage (cdr storage))
151 (if (and (equal path (url-cookie-path cur))
152 (equal name (url-cookie-name cur)))
153 (progn
154 (url-cookie-set-expires cur expires)
155 (url-cookie-set-value cur value)
156 (setq tmp t))))
157 (if (not tmp)
158 ;; New cookie
159 (setcdr found-domain (cons
160 (url-cookie-create :name name
161 :value value
162 :expires expires
163 :domain domain
164 :path path
165 :secure secure)
166 (cdr found-domain)))))
167 ;; Need to add a new top-level domain
168 (setq tmp (url-cookie-create :name name
169 :value value
170 :expires expires
171 :domain domain
172 :path path
173 :secure secure))
174 (cond
175 (storage
176 (setcdr storage (cons (list domain tmp) (cdr storage))))
177 (secure
178 (setq url-cookie-secure-storage (list (list domain tmp))))
179 (t
180 (setq url-cookie-storage (list (list domain tmp))))))))
181
182 (defun url-cookie-expired-p (cookie)
183 (let* (
184 (exp (url-cookie-expires cookie))
185 (cur-date (and exp (timezone-parse-date (current-time-string))))
186 (exp-date (and exp (timezone-parse-date exp)))
187 (cur-greg (and cur-date (timezone-absolute-from-gregorian
188 (string-to-int (aref cur-date 1))
189 (string-to-int (aref cur-date 2))
190 (string-to-int (aref cur-date 0)))))
191 (exp-greg (and exp (timezone-absolute-from-gregorian
192 (string-to-int (aref exp-date 1))
193 (string-to-int (aref exp-date 2))
194 (string-to-int (aref exp-date 0)))))
195 (diff-in-days (and exp (- cur-greg exp-greg)))
196 )
197 (cond
198 ((not exp) nil) ; No expiry == expires at browser quit
199 ((< diff-in-days 0) nil) ; Expires sometime after today
200 ((> diff-in-days 0) t) ; Expired before today
201 (t ; Expires sometime today, check times
202 (let* ((cur-time (timezone-parse-time (aref cur-date 3)))
203 (exp-time (timezone-parse-time (aref exp-date 3)))
204 (cur-norm (+ (* 360 (string-to-int (aref cur-time 2)))
205 (* 60 (string-to-int (aref cur-time 1)))
206 (* 1 (string-to-int (aref cur-time 0)))))
207 (exp-norm (+ (* 360 (string-to-int (aref exp-time 2)))
208 (* 60 (string-to-int (aref exp-time 1)))
209 (* 1 (string-to-int (aref exp-time 0))))))
210 (> (- cur-norm exp-norm) 1))))))
211
212 (defun url-cookie-retrieve (host path &optional secure)
213 "Retrieves all the netscape-style cookies for a specified HOST and PATH"
214 (let ((storage (if secure
215 (append url-cookie-secure-storage url-cookie-storage)
216 url-cookie-storage))
217 (case-fold-search t)
218 (cookies nil)
219 (cur nil)
220 (retval nil)
221 (path-regexp nil))
222 (while storage
223 (setq cur (car storage)
224 storage (cdr storage)
225 cookies (cdr cur))
226 (if (and (car cur)
227 (string-match (concat "^.*" (regexp-quote (car cur)) "$") host))
228 ;; The domains match - a possible hit!
229 (while cookies
230 (setq cur (car cookies)
231 cookies (cdr cookies)
232 path-regexp (concat "^" (regexp-quote
233 (url-cookie-path cur))))
234 (if (and (string-match path-regexp path)
235 (not (url-cookie-expired-p cur)))
236 (setq retval (cons cur retval))))))
237 retval))
238
239 (defun url-cookie-generate-header-lines (host path secure)
240 (let* ((cookies (url-cookie-retrieve host path secure))
241 (retval nil)
242 (cur nil)
243 (chunk nil))
244 ;; Have to sort this for sending most specific cookies first
245 (setq cookies (and cookies
246 (sort cookies
247 (function
248 (lambda (x y)
249 (> (length (url-cookie-path x))
250 (length (url-cookie-path y))))))))
251 (while cookies
252 (setq cur (car cookies)
253 cookies (cdr cookies)
254 chunk (format "%s=%s" (url-cookie-name cur) (url-cookie-value cur))
255 retval (if (< 80 (+ (length retval) (length chunk) 4))
256 (concat retval "\r\nCookie: " chunk)
257 (if retval
258 (concat retval "; " chunk)
259 (concat "Cookie: " chunk)))))
260 (if retval
261 (concat retval "\r\n")
262 "")))
263
264 (defvar url-cookie-two-dot-domains
265 (concat "\\.\\("
266 (mapconcat 'identity (list "com" "edu" "net" "org" "gov" "mil" "int")
267 "\\|")
268 "\\)$")
269 "A regular expression of top-level domains that only require two matching
270 '.'s in the domain name in order to set a cookie.")
271
272 (defun url-cookie-host-can-set-p (host domain)
273 (let ((numdots 0)
274 (tmp domain)
275 (last nil)
276 (case-fold-search t)
277 (mindots 3))
278 (while (setq last (string-match "\\." host last))
279 (setq numdots (1+ numdots)
280 last (1+ last)))
281 (if (string-match url-cookie-two-dot-domains domain)
282 (setq mindots 2))
283 (if (< numdots mindots) ; Not enough dots in domain name!
284 nil
285 (string-match (concat (regexp-quote domain) "$") host))))
286
287 (defun url-header-comparison (x y)
288 (string= (downcase x) (downcase y)))
289
290 (defun url-cookie-handle-set-cookie (str)
291 (let* ((args (mm-parse-args str nil t)) ; Don't downcase names
292 (case-fold-search t)
293 (secure (and (assoc* "secure" args :test 'url-header-comparison) t))
294 (domain (or (cdr-safe (assoc* "domain" args :test
295 'url-header-comparison))
296 url-current-server))
297 (expires (cdr-safe (assoc* "expires" args :test
298 'url-header-comparison)))
299 (path (or (cdr-safe (assoc* "path" args :test
300 'url-header-comparison))
301 (file-name-directory url-current-file)))
302 (rest nil))
303 (while args
304 (if (not (member (downcase (car (car args)))
305 '("secure" "domain" "expires" "path")))
306 (setq rest (cons (car args) rest)))
307 (setq args (cdr args)))
308
309 ;; Sometimes we get dates that the timezone package cannot handle very
310 ;; gracefully - take care of this here, instead of in url-cookie-expired-p
311 ;; to speed things up.
312 (if (and expires
313 (string-match
314 (concat "^[^,]+, +\\(..\\)-\\(...\\)-\\(..\\) +"
315 "\\(..:..:..\\) +\\[*\\([^\]]+\\)\\]*$")
316 expires))
317 (setq expires (concat (url-match expires 1) " "
318 (url-match expires 2) " "
319 (url-match expires 3) " "
320 (url-match expires 4) " ["
321 (url-match expires 5) "]")))
322 (if (url-cookie-host-can-set-p url-current-server domain)
323 (while rest
324 (url-cookie-store (car (car rest)) (cdr (car rest))
325 expires domain path secure)
326 (setq rest (cdr rest)))
327 (url-warn 'url (format
328 (concat "%s tried to set a cookie for domain %s\n"
329 "Permission denied - cookie rejected.\n"
330 "Set-Cookie: %s")
331 url-current-server domain str)))))
332
333 (provide 'url-cookie)