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