code.delx.au - gnu-emacs/blob - lisp/url/url-domsuf.el

   1 ;;; url-domsuf.el --- Say what domain names can have cookies set.
   2
   3 ;; Copyright (C) 2012-2015 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     (with-auto-compression-mode
  36       (insert-file-contents
  37        (let* ((suffixfile (expand-file-name "publicsuffix.txt" data-directory))
  38               (compressed-file (concat suffixfile ".gz")))
  39          (or (and (file-readable-p compressed-file) compressed-file)
  40              suffixfile))))
  41     (let ((domains nil)
  42           domain exception)
  43       (while (not (eobp))
  44         (when (not (looking-at "[/\n\t ]"))
  45           ;; !pref.aichi.jp means that it's allowed.
  46           (if (not (eq (following-char) ?!))
  47               (setq exception nil)
  48             (setq exception t)
  49             (forward-char 1))
  50           (setq domain (buffer-substring (point) (line-end-position)))
  51           (cond
  52            ((string-match "\\`\\*\\." domain)
  53             (setq domain (substring domain 2))
  54             (push (cons domain (1+ (length (split-string domain "[.]"))))
  55                   domains))
  56            (exception
  57             (push (cons domain t) domains))
  58            (t
  59             (push (cons domain nil) domains))))
  60         (forward-line 1))
  61       (setq url-domsuf-domains (nreverse domains)))))
  62
  63 (defun url-domsuf-cookie-allowed-p (domain)
  64   (unless url-domsuf-domains
  65     (url-domsuf-parse-file))
  66   (let* ((allowedp t)
  67          (domain-bits (split-string domain "[.]"))
  68          (length (length domain-bits))
  69          (upper-domain (mapconcat 'identity (cdr domain-bits) "."))
  70          entry modifier)
  71     (dolist (elem url-domsuf-domains)
  72       (setq entry (car elem)
  73             modifier (cdr elem))
  74       (cond
  75        ;; "com"
  76        ((and (null modifier)
  77              (string= domain entry))
  78         (setq allowedp nil))
  79        ;; "!city.yokohama.jp"
  80        ((and (eq modifier t)
  81              (string= domain entry))
  82         (setq allowedp t))
  83        ;; "*.bd"
  84        ((and (numberp modifier)
  85              (= length modifier)
  86              (string= entry upper-domain))
  87         (setq allowedp nil))))
  88     allowedp))
  89
  90 ;; Tests:
  91
  92 ;; TODO convert to a proper test/automated test.
  93 ;; (url-domsuf-cookie-allowed-p "com") => nil
  94 ;; (url-domsuf-cookie-allowed-p "foo.bar.bd") => t
  95 ;; (url-domsuf-cookie-allowed-p "bar.bd") => nil
  96 ;; (url-domsuf-cookie-allowed-p "co.uk") => nil
  97 ;; (url-domsuf-cookie-allowed-p "foo.bar.hokkaido.jo") => t
  98 ;; (url-domsuf-cookie-allowed-p "bar.yokohama.jp") => nil
  99 ;; (url-domsuf-cookie-allowed-p "city.yokohama.jp") => t
 100
 101 (provide 'url-domsuf)
 102
 103 ;;; url-domsuf.el ends here