Add a policy list of domains that url.el can set cookies for

* etc/publicsuffix.txt: New file.

* lisp/url/url-cookie.el (url-cookie-two-dot-domains): Remove.
(url-cookie-host-can-set-p): Use `url-domsuf-cookie-allowed-p'
instead of the variable above.

Fixes: debbugs:1401

3 files changed, 117 insertions, 32 deletions

diff --git a/lisp/url/ChangeLog b/lisp/url/ChangeLog
index d6e25188c69..4c9635f8ecf 100644
--- a/lisp/url/ChangeLog
+++ b/lisp/url/ChangeLog
@@ -1,3 +1,11 @@
+2012-04-10  Lars Magne Ingebrigtsen  <larsi@gnus.org>
+
+	* url-domsurf.el: New file (bug#1401).
+
+	* url-cookie.el (url-cookie-two-dot-domains): Remove.
+	(url-cookie-host-can-set-p): Use `url-domsuf-cookie-allowed-p'
+	instead of the variable above.
+
 2012-03-25  Lars Magne Ingebrigtsen  <larsi@gnus.org>
 
 	* url-queue.el (url-queue-kill-job): Check whether the buffer has
diff --git a/lisp/url/url-cookie.el b/lisp/url/url-cookie.el
index e6ff9bf7dea..aefe8fffd0a 100644
--- a/lisp/url/url-cookie.el
+++ b/lisp/url/url-cookie.el
@@ -25,6 +25,7 @@
 
 (require 'url-util)
 (require 'url-parse)
+(require 'url-domsuf)
 
 (eval-when-compile (require 'cl))	; defstruct
 
@@ -211,14 +212,6 @@ telling Microsoft that."
 	(concat retval "\r\n")
       "")))
 
-(defvar url-cookie-two-dot-domains
-  (concat "\\.\\("
-   (mapconcat 'identity (list "com" "edu" "net" "org" "gov" "mil" "int")
-	      "\\|")
-   "\\)$")
-  "A regexp of top level domains that only require two matching
-'.'s in the domain name in order to set a cookie.")
-
 (defcustom url-cookie-trusted-urls nil
   "A list of regular expressions matching URLs to always accept cookies from."
   :type '(repeat regexp)
@@ -230,30 +223,18 @@ telling Microsoft that."
   :group 'url-cookie)
 
 (defun url-cookie-host-can-set-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 url-cookie-two-dot-domains domain)
-	(setq mindots 2))
-    (cond
-     ((string= host domain)		; Apparently netscape lets you do this
-      t)
-     ((>= 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
-                             ;; Remove the dot from wildcard domains
-                             ;; before matching.
-                             (if (eq ?. (aref domain 0))
-                                 (substring domain 1)
-                               domain))
-                            "$") host))
-     (t
-      nil))))
+  (let ((last nil)
+	(case-fold-search t))
+    (if (string= host domain)	; Apparently netscape lets you do this
+	t
+      ;; Remove the dot from wildcard domains before matching.
+      (when (eq ?. (aref domain 0))
+	(setq domain (substring domain 1)))
+      (and (url-domsuf-cookie-allowed-p domain)
+	   ;; 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 url-cookie-handle-set-cookie (str)
   (setq url-cookies-changed-since-last-save t)
diff --git a/lisp/url/url-domsuf.el b/lisp/url/url-domsuf.el
new file mode 100644
index 00000000000..3785a1c2fb2
--- /dev/null
+++ b/lisp/url/url-domsuf.el
@@ -0,0 +1,96 @@
+;;; url-domsuf.el --- Say what domain names can have cookies set.
+
+;; Copyright (C) 2011  Free Software Foundation, Inc.
+
+;; Keywords: comm, data, processes, hypermedia
+
+;; This file is part of GNU Emacs.
+;;
+;; GNU Emacs 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 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; The rules for what domains can have cookies set is defined here:
+;; http://publicsuffix.org/list/
+
+;;; Code:
+
+(defvar url-domsuf-domains nil)
+
+(defun url-domsuf-parse-file ()
+  (with-temp-buffer
+    (insert-file-contents
+     (expand-file-name "publicsuffix.txt" data-directory))
+    (let ((domains nil)
+	  domain exception)
+      (while (not (eobp))
+	(when (not (looking-at "[/\n\t ]"))
+	  ;; !pref.aichi.jp means that it's allowed.
+	  (if (not (eq (following-char) ?!))
+	      (setq exception nil)
+	    (setq exception t)
+	    (forward-char 1))
+	  (setq domain (buffer-substring (point) (line-end-position)))
+	  (cond
+	   ((string-match "\\`\\*\\." domain)
+	    (setq domain (substring domain 2))
+	    (push (cons domain (1+ (length (split-string domain "[.]"))))
+		  domains))
+	   (exception
+	    (push (cons domain t) domains))
+	   (t
+	    (push (cons domain nil) domains))))
+	(forward-line 1))
+      (setq url-domsuf-domains (nreverse domains)))))
+
+(defun url-domsuf-cookie-allowed-p (domain)
+  (unless url-domsuf-domains
+    (url-domsuf-parse-file))
+  (let* ((allowedp t)
+	 (domain-bits (split-string domain "[.]"))
+	 (length (length domain-bits))
+	 (upper-domain (mapconcat 'identity (cdr domain-bits) "."))
+	 entry modifier)
+    (dolist (elem url-domsuf-domains)
+      (setq entry (car elem)
+	    modifier (cdr elem))
+      (cond
+       ;; "com"
+       ((and (null modifier)
+	     (string= domain entry))
+	(setq allowedp nil))
+       ;; "!pref.hokkaido.jp"
+       ((and (eq modifier t)
+	     (string= domain entry))
+	(setq allowedp t))
+       ;; "*.ar"
+       ((and (numberp modifier)
+	     (= length modifier)
+	     (string= entry upper-domain))
+	(setq allowedp nil))))
+    allowedp))
+
+;; Tests:
+
+;; (url-domsuf-cookie-allowed-p "com") => nil
+;; (url-domsuf-cookie-allowed-p "foo.bar.ar") => t
+;; (url-domsuf-cookie-allowed-p "bar.ar") => nil
+;; (url-domsuf-cookie-allowed-p "co.uk") => nil
+;; (url-domsuf-cookie-allowed-p "foo.bar.hokkaido.jo") => t
+;; (url-domsuf-cookie-allowed-p "bar.hokkaido.jp") => nil
+;; (url-domsuf-cookie-allowed-p "pref.hokkaido.jp") => t
+
+(provide 'url-domsuf)
+
+;;; url-domsuf.el ends here