|
70
|
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)
|
