lisp/url/url-domsuf.el

   1 ;;; url-domsuf.el --- Say what domain names can have cookies set.
   2
   3 ;; Copyright (C) 2012 Free Software Foundation, Inc.
   4
   5 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
   6
   7 ;; Keywords: comm, data, processes, hypermedia
   8
   9 ;; This file is part of GNU Emacs.
  10 ;;
  11 ;; GNU Emacs is free software: you can redistribute it and/or modify
  12 ;; it under the terms of the GNU General Public License as published by
  13 ;; the Free Software Foundation, either version 3 of the License, or
  14 ;; (at your option) any later version.
  15
  16 ;; GNU Emacs is distributed in the hope that it will be useful,
  17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  19 ;; GNU General Public License for more details.
  20
  21 ;; You should have received a copy of the GNU General Public License
  22 ;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
  23
  24 ;;; Commentary:
  25
  26 ;; The rules for what domains can have cookies set is defined here:
  27 ;; http://publicsuffix.org/list/
  28
  29 ;;; Code:
  30
  31 (defvar url-domsuf-domains nil)
  32
  33 (defun url-domsuf-parse-file ()
  34   (with-temp-buffer
  35     (insert-file-contents
  36      (expand-file-name "publicsuffix.txt" data-directory))
  37     (let ((domains nil)
  38           domain exception)
  39       (while (not (eobp))
  40         (when (not (looking-at "[/\n\t ]"))
  41           ;; !pref.aichi.jp means that it's allowed.
  42           (if (not (eq (following-char) ?!))
  43               (setq exception nil)
  44             (setq exception t)
  45             (forward-char 1))
  46           (setq domain (buffer-substring (point) (line-end-position)))
  47           (cond
  48            ((string-match "\\`\\*\\." domain)
  49             (setq domain (substring domain 2))
  50             (push (cons domain (1+ (length (split-string domain "[.]"))))
  51                   domains))
  52            (exception
  53             (push (cons domain t) domains))
  54            (t
  55             (push (cons domain nil) domains))))
  56         (forward-line 1))
  57       (setq url-domsuf-domains (nreverse domains)))))
  58
  59 (defun url-domsuf-cookie-allowed-p (domain)
  60   (unless url-domsuf-domains
  61     (url-domsuf-parse-file))
  62   (let* ((allowedp t)
  63          (domain-bits (split-string domain "[.]"))
  64          (length (length domain-bits))
  65          (upper-domain (mapconcat 'identity (cdr domain-bits) "."))
  66          entry modifier)
  67     (dolist (elem url-domsuf-domains)
  68       (setq entry (car elem)
  69             modifier (cdr elem))
  70       (cond
  71        ;; "com"
  72        ((and (null modifier)
  73              (string= domain entry))
  74         (setq allowedp nil))
  75        ;; "!pref.hokkaido.jp"
  76        ((and (eq modifier t)
  77              (string= domain entry))
  78         (setq allowedp t))
  79        ;; "*.ar"
  80        ((and (numberp modifier)
  81              (= length modifier)
  82              (string= entry upper-domain))
  83         (setq allowedp nil))))
  84     allowedp))
  85
  86 ;; Tests:
  87
  88 ;; (url-domsuf-cookie-allowed-p "com") => nil
  89 ;; (url-domsuf-cookie-allowed-p "foo.bar.ar") => t
  90 ;; (url-domsuf-cookie-allowed-p "bar.ar") => nil
  91 ;; (url-domsuf-cookie-allowed-p "co.uk") => nil
  92 ;; (url-domsuf-cookie-allowed-p "foo.bar.hokkaido.jo") => t
  93 ;; (url-domsuf-cookie-allowed-p "bar.hokkaido.jp") => nil
  94 ;; (url-domsuf-cookie-allowed-p "pref.hokkaido.jp") => t
  95
  96 (provide 'url-domsuf)
  97
  98 ;;; url-domsuf.el ends here