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