Skip to content
Fetching contributors…
Cannot retrieve contributors at this time
579 lines (522 sloc) 18.1 KB
;;; w3m-cookie.el --- Functions for cookie processing
;; Copyright (C) 2002, 2003, 2005, 2006, 2008, 2009, 2010
;; TSUCHIYA Masatoshi <>
;; Authors: Teranishi Yuuichi <>
;; Keywords: w3m, WWW, hypermedia
;; This file is a part of emacs-w3m.
;; This program is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with this program; see the file COPYING. If not, write to
;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301, USA.
;;; Commentary:
;; This file contains the functions for cookies. For more detail
;; about emacs-w3m, see:
;; Reference for version 0 cookie:
;; Reference for version 1 cookie:
;;; Code:
(require 'cl))
(require 'w3m-util)
(require 'w3m)
(defvar w3m-cookies nil
"A list of cookie elements.
Currently only browser local cookies are stored.")
(defconst w3m-cookie-two-dot-domains-regexp
(concat "\\.\\(?:"
(mapconcat 'identity (list "com" "edu" "net" "org" "gov" "mil" "int")
"A regular expression of top-level domains that only require two matching
'.'s in the domain name in order to set a cookie.")
(defcustom w3m-cookie-accept-domains nil
"A list of trusted domain name string."
:group 'w3m
:type '(repeat (string :format "Domain name: %v\n" :size 0)))
(defcustom w3m-cookie-reject-domains nil
"A list of untrusted domain name string."
:group 'w3m
:type '(repeat (string :format "Domain name: %v\n" :size 0)))
(defcustom w3m-cookie-accept-bad-cookies nil
"If nil, don't accept bad cookies.
If t, accept bad cookies.
If ask, ask user whether accept bad cookies or not."
:group 'w3m
:type '(radio
(const :tag "Don't accept bad cookies" nil)
(const :tag "Ask accepting bad cookies" ask)
(const :tag "Always accept bad cookies" t)))
(defcustom w3m-cookie-save-cookies t
"*Non-nil means save cookies when emacs-w3m cookie system shutdown."
:group 'w3m
:type 'boolean)
(defcustom w3m-cookie-file
(expand-file-name ".cookie" w3m-profile-directory)
"File in which cookies are kept."
:group 'w3m
:type '(file :size 0))
;;; Cookie accessor.
(defmacro w3m-cookie-url (cookie)
`(aref ,cookie 0))
(defmacro w3m-cookie-domain (cookie)
`(aref ,cookie 1))
(defmacro w3m-cookie-secure (cookie)
`(aref ,cookie 2))
(defmacro w3m-cookie-name (cookie)
`(aref ,cookie 3))
(defmacro w3m-cookie-value (cookie)
`(aref ,cookie 4))
(defmacro w3m-cookie-path (cookie)
`(aref ,cookie 5))
(defmacro w3m-cookie-version (cookie)
`(aref ,cookie 6))
(defmacro w3m-cookie-expires (cookie)
`(aref ,cookie 7))
(defmacro w3m-cookie-ignore (cookie)
`(aref ,cookie 8))
(defun w3m-cookie-create (&rest args)
(let ((cookie (make-vector 9 nil)))
(setf (w3m-cookie-url cookie) (plist-get args :url))
(setf (w3m-cookie-domain cookie) (plist-get args :domain))
(setf (w3m-cookie-secure cookie) (plist-get args :secure))
(setf (w3m-cookie-name cookie) (plist-get args :name))
(setf (w3m-cookie-value cookie) (plist-get args :value))
(setf (w3m-cookie-path cookie) (plist-get args :path))
(setf (w3m-cookie-version cookie) (or (plist-get args :version) 0))
(setf (w3m-cookie-expires cookie) (plist-get args :expires))
(setf (w3m-cookie-ignore cookie) (plist-get args :ignore))
(defun w3m-cookie-store (cookie)
"Store COOKIE."
(let (ignored)
(catch 'found
(dolist (c w3m-cookies)
(when (and (string= (w3m-cookie-domain c)
(w3m-cookie-domain cookie))
(string= (w3m-cookie-path c)
(w3m-cookie-path cookie))
(string= (w3m-cookie-name c)
(w3m-cookie-name cookie)))
(if (w3m-cookie-ignore c)
(setq ignored t)
(setq w3m-cookies (delq c w3m-cookies)))
(throw 'found t))))
(unless ignored
(push cookie w3m-cookies))))
(defun w3m-cookie-remove (domain path name)
"Remove COOKIE if stored."
(dolist (c w3m-cookies)
(when (and (string= (w3m-cookie-domain c)
(string= (w3m-cookie-path c)
(string= (w3m-cookie-name c)
(setq w3m-cookies (delq c w3m-cookies)))))
(defun w3m-cookie-retrieve (host path &optional secure)
"Retrieve cookies for DOMAIN and PATH."
(let ((case-fold-search t)
expires cookies)
(dolist (c w3m-cookies)
(if (and (w3m-cookie-expires c)
(w3m-time-newer-p (current-time)
(w3m-cookie-expires c))))
(push c expires)
(when (and (not (w3m-cookie-ignore c))
;; A special case that domain name is ".hostname".
(string= (concat "." host) (w3m-cookie-domain c))
(string-match (concat
(regexp-quote (w3m-cookie-domain c)) "$")
(string-match (concat
"^" (regexp-quote (w3m-cookie-path c)))
(if (w3m-cookie-secure c)
(if secure
(push c cookies))
(push c cookies)))))
;; Delete expired cookies.
(dolist (expire expires)
(setq w3m-cookies (delq expire w3m-cookies)))
;; HTTP URL parser.
(defun w3m-parse-http-url (url)
"Parse an absolute HTTP URL."
(let (secure split)
(w3m-string-match-url-components url)
(when (and (match-beginning 4)
(or (equal (match-string 2 url) "http")
(setq secure (equal (match-string 2 url) "https"))))
(setq split (save-match-data
(split-string (match-string 4 url) ":")))
(vector secure
(nth 0 split)
(string-to-number (or (nth 1 split) "80"))
(if (eq (length (match-string 5 url)) 0)
(match-string 5 url))))))
(defsubst w3m-http-url-secure (http-url)
"Secure flag of the HTTP-URL."
(aref http-url 0))
(defsubst w3m-http-url-host (http-url)
"Host name of the HTTP-URL."
(aref http-url 1))
(defsubst w3m-http-url-port (http-url)
"Port number of the HTTP-URL."
(aref http-url 2))
(defsubst w3m-http-url-path (http-url)
"Path of the HTTP-URL."
(aref http-url 3))
;;; Cookie parser.
(defvar w3m-cookie-parse-args-syntax-table
(copy-syntax-table emacs-lisp-mode-syntax-table)
"A syntax table for parsing sgml attributes.")
(modify-syntax-entry ?' "\"" w3m-cookie-parse-args-syntax-table)
(modify-syntax-entry ?` "\"" w3m-cookie-parse-args-syntax-table)
(modify-syntax-entry ?{ "(" w3m-cookie-parse-args-syntax-table)
(modify-syntax-entry ?} ")" w3m-cookie-parse-args-syntax-table)
(defun w3m-cookie-parse-args (str &optional nodowncase)
(let (name value results name-pos val-pos)
(with-current-buffer (get-buffer-create " *w3m-cookie-parse-temp*")
(set-syntax-table w3m-cookie-parse-args-syntax-table)
(insert str)
(goto-char (point-min))
(while (not (eobp))
(skip-chars-forward "; \n\t")
(setq name-pos (point))
(skip-chars-forward "^ \n\t=;")
(unless nodowncase
(downcase-region name-pos (point)))
(setq name (buffer-substring name-pos (point)))
(skip-chars-forward " \t\n")
(if (/= (or (char-after (point)) 0) ?=) ; There is no value
(setq value nil)
(skip-chars-forward " \t\n=")
(setq val-pos (point)
((or (= (or (char-after val-pos) 0) ?\")
(= (or (char-after val-pos) 0) ?'))
(buffer-substring (1+ val-pos)
(condition-case ()
(forward-sexp 1)
(1- (point))
(skip-chars-forward "\""))
(skip-chars-forward "^ \t\n")
(buffer-substring val-pos
(skip-chars-forward "^;")
(skip-chars-backward " \t")
(push (cons name value) results)
(skip-chars-forward "; \n\t"))
(defun w3m-cookie-trusted-host-p (host)
"Returns non-nil when the HOST is specified as trusted by user."
(let ((accept w3m-cookie-accept-domains)
(reject w3m-cookie-reject-domains)
(trusted t)
regexp tlen rlen)
(while accept
((string= (car accept) ".")
(setq regexp ".*"))
((string= (car accept) ".local")
(setq regexp "^[^\\.]+$"))
((eq (string-to-char (car accept)) ?.)
(setq regexp (concat (regexp-quote (car accept)) "$")))
(t (setq regexp (concat "^" (regexp-quote (car accept)) "$"))))
(when (string-match regexp host)
(setq tlen (length (car accept))
accept nil))
(pop accept))
(while reject
((string= (car reject) ".")
(setq regexp ".*"))
((string= (car reject) ".local")
(setq regexp "^[^\\.]+$"))
((eq (string-to-char (car reject)) ?.)
(setq regexp (concat (regexp-quote (car reject)) "$")))
(t (setq regexp (concat "^" (regexp-quote (car reject)) "$"))))
(when (string-match regexp host)
(setq rlen (length (car reject))
reject nil))
(pop reject))
(if tlen
(if rlen
(if (<= tlen rlen)
(setq trusted nil)))
(if rlen
(setq trusted nil)))
;;; Version 0 cookie.
(defun w3m-cookie-1-acceptable-p (host domain)
(let ((numdots 0)
(last nil)
(case-fold-search t)
(mindots 3))
(while (setq last (string-match "\\." domain last))
(setq numdots (1+ numdots)
last (1+ last)))
(if (string-match w3m-cookie-two-dot-domains-regexp domain)
(setq mindots 2))
((string= host domain) ; Apparently netscape lets you do this
;; A special case that domain name is ".hostname".
((string= (concat "." host) domain)
((>= numdots mindots) ; We have enough dots in domain name
;; Need to check and make sure the host is actually _in_ the
;; domain it wants to set a cookie for though.
(string-match (concat (regexp-quote domain) "$") host))
(defun w3m-cookie-1-set (url &rest args)
;; Set-Cookie:, version 0 cookie.
(let ((http-url (w3m-parse-http-url url))
(case-fold-search t)
secure domain expires path rest)
(when http-url
(setq secure (and (w3m-assoc-ignore-case "secure" args) t)
domain (or (cdr-safe (w3m-assoc-ignore-case "domain" args))
(w3m-http-url-host http-url))
expires (cdr-safe (w3m-assoc-ignore-case "expires" args))
path (or (cdr-safe (w3m-assoc-ignore-case "path" args))
(w3m-http-url-path http-url))))
(while args
(if (not (member (downcase (car (car args)))
'("secure" "domain" "expires" "path")))
(setq rest (cons (car args) rest)))
(setq args (cdr args)))
((not (w3m-cookie-trusted-host-p (w3m-http-url-host http-url)))
;; The site was explicity marked as untrusted by the user
((or (w3m-cookie-1-acceptable-p (w3m-http-url-host http-url) domain)
(eq w3m-cookie-accept-bad-cookies t)
(and (eq w3m-cookie-accept-bad-cookies 'ask)
(y-or-n-p (format "Accept bad cookie from %s for %s? "
(w3m-http-url-host http-url) domain))))
;; Cookie is accepted by the user, and passes our security checks
(dolist (elem rest)
;; If a CGI script wishes to delete a cookie, it can do so by
;; returning a cookie with the same name, and an expires time
;; which is in the past.
(when (and expires
(w3m-time-newer-p (current-time)
(w3m-time-parse-string expires)))
(w3m-cookie-remove domain path (car elem)))
(w3m-cookie-create :url url
:domain domain
:name (car elem)
:value (cdr elem)
:path path
:expires expires
:secure secure))))
(message "%s tried to set a cookie for domain %s - rejected."
(w3m-http-url-host http-url) domain))))))
;;; Version 1 cookie.
(defun w3m-cookie-2-acceptable-p (http-url domain)
;; A user agent rejects (SHALL NOT store its information) if the Version
;; attribute is missing. Moreover, a user agent rejects (SHALL NOT
;; store its information) if any of the following is true of the
;; attributes explicitly present in the Set-Cookie2 response header:
;; * The value for the Path attribute is not a prefix of the
;; request-URI.
;; * The value for the Domain attribute contains no embedded dots,
;; and the value is not .local.
;; * The effective host name that derives from the request-host does
;; not domain-match the Domain attribute.
;; * The request-host is a HDN (not IP address) and has the form HD,
;; where D is the value of the Domain attribute, and H is a string
;; that contains one or more dots.
;; * The Port attribute has a "port-list", and the request-port was
;; not in the list.
(defun w3m-cookie-2-set (url &rest args)
;; Set-Cookie2:, version 1 cookie.
;; Not implemented yet.
;;; Save & Load
(defvar w3m-cookie-init nil)
(defun w3m-cookie-clear ()
"Clear cookie list."
(setq w3m-cookies nil))
(defun w3m-cookie-save (&optional domain)
"Save cookies.
When DOMAIN is non-nil, only save cookies whose domains match it."
(let (cookies)
(dolist (cookie w3m-cookies)
(when (and (or (not domain)
(string= (w3m-cookie-domain cookie) domain))
(w3m-cookie-expires cookie)
(w3m-time-newer-p (w3m-time-parse-string
(w3m-cookie-expires cookie))
(push cookie cookies)))
(w3m-save-list w3m-cookie-file cookies)))
(defun w3m-cookie-save-current-site-cookies ()
"Save cookies for the current site."
(when (and w3m-current-url
(not (w3m-url-local-p w3m-current-url)))
(w3m-string-match-url-components w3m-current-url)
(w3m-cookie-save (match-string 4 w3m-current-url))))
(defun w3m-cookie-load ()
"Load cookies."
(when (null w3m-cookies)
(setq w3m-cookies
(w3m-load-list w3m-cookie-file))))
(defun w3m-cookie-setup ()
"Setup cookies. Returns immediataly if already initialized."
(unless w3m-cookie-init
(setq w3m-cookie-init t)))
(defun w3m-cookie-shutdown ()
"Save cookies, and reset cookies' data."
(when w3m-cookie-save-cookies
(setq w3m-cookie-init nil)
(if (get-buffer " *w3m-cookie-parse-temp*")
(kill-buffer (get-buffer " *w3m-cookie-parse-temp*"))))
(defun w3m-cookie-set (url beg end)
"Register cookies which correspond to URL.
BEG and END should be an HTTP response header region on current buffer."
(when (and url beg end)
(let ((case-fold-search t)
(version 0)
(goto-char beg)
(while (re-search-forward
"^\\(?:Set-Cookie\\(2\\)?:\\) *\\(.*\\(?:\n[ \t].*\\)*\\)\n"
end t)
(setq data (match-string 2))
(if (match-beginning 1)
(setq version 1))
(case version
(0 'w3m-cookie-1-set)
(1 'w3m-cookie-2-set))
url (w3m-cookie-parse-args data 'nodowncase)))))))
(defun w3m-cookie-get (url)
"Get a cookie field string which corresponds to the URL."
(let* ((http-url (w3m-parse-http-url url))
(cookies (and http-url
(w3m-cookie-retrieve (w3m-http-url-host http-url)
(w3m-http-url-path http-url)
(w3m-http-url-secure http-url)))))
;; When sending cookies to a server, all cookies with a more specific path
;; mapping should be sent before cookies with less specific path mappings.
(setq cookies (sort cookies
(lambda (x y)
(< (length (w3m-cookie-path x))
(length (w3m-cookie-path y))))))
(when cookies
(mapconcat (lambda (cookie)
(concat (w3m-cookie-name cookie)
"=" (w3m-cookie-value cookie)))
"; "))))
(defun w3m-cookie (&optional no-cache)
"Display cookies and enable you to manage them."
(interactive "P")
(w3m-goto-url "about://cookie/" no-cache))
(defun w3m-about-cookie (url &optional no-decode no-cache post-data &rest args)
"Make the html contents to display and to enable you to manage cookies."
(unless w3m-use-cookies (error "You must enable emacs-w3m to use cookies."))
(let ((pos 0))
(when post-data
(dolist (pair (split-string post-data "&"))
(setq pair (split-string pair "="))
(setf (w3m-cookie-ignore
(nth (string-to-number (car pair)) w3m-cookies))
(eq (string-to-number (cadr pair)) 0))))
<p><form method=\"post\" action=\"about://cookie/\">
(dolist (cookie w3m-cookies)
"<li><h1><a href=\""
(w3m-cookie-url cookie)
(w3m-cookie-url cookie)
"<table cellpadding=0>"
"<tr><td width=\"80\"><b>Cookie:</b></td><td>"
(w3m-cookie-name cookie) "=" (w3m-cookie-value cookie)
(when (w3m-cookie-expires cookie)
"<tr><td width=\"80\"><b>Expires:</b></td><td>"
(w3m-cookie-expires cookie)
"<tr><td width=\"80\"><b>Version:</b></td><td>"
(number-to-string (w3m-cookie-version cookie))
(when (w3m-cookie-domain cookie)
"<tr><td width=\"80\"><b>Domain:</b></td><td>"
(w3m-cookie-domain cookie)
(when (w3m-cookie-path cookie)
"<tr><td width=\"80\"><b>Path:</b></td><td>"
(w3m-cookie-path cookie)
"<tr><td width=\"80\"><b>Secure:</b></td><td>"
(if (w3m-cookie-secure cookie) "Yes" "No")
"<tr><td width=\"80\"><b>Use:</b></td><td>"
(format "<input type=radio name=\"%d\" value=1%s>Yes"
pos (if (w3m-cookie-ignore cookie) "" " checked"))
(format "<input type=radio name=\"%d\" value=0%s>No"
pos (if (w3m-cookie-ignore cookie) " checked" ""))
"</td></tr><tr><td><input type=submit value=\"OK\"></table><p>"))
(setq pos (1+ pos)))
(insert "</ol></form></body></html>")
(provide 'w3m-cookie)
;;; w3m-cookie.el ends here
Something went wrong with that request. Please try again.