cgit.sxemacs.org Git - packages/blob - xemacs-packages/w3/lisp/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      (if (featurep 'xemacs)
  37          (locate-file "publicsuffix.txt" data-directory-list)
  38        (expand-file-name "publicsuffix.txt" data-directory)))
  39     (let ((domains nil)
  40           domain exception)
  41       (while (not (eobp))
  42         (when (not (looking-at "[/\n\t ]"))
  43           ;; !pref.aichi.jp means that it's allowed.
  44           (if (not (eq (following-char) ?!))
  45               (setq exception nil)
  46             (setq exception t)
  47             (forward-char 1))
  48           (setq domain (buffer-substring (point) (line-end-position)))
  49           (cond
  50            ((string-match "\\`\\*\\." domain)
  51             (setq domain (substring domain 2))
  52             (push (cons domain (1+ (length (split-string domain "[.]"))))
  53                   domains))
  54            (exception
  55             (push (cons domain t) domains))
  56            (t
  57             (push (cons domain nil) domains))))
  58         (forward-line 1))
  59       (setq url-domsuf-domains (nreverse domains)))))
  60
  61 (defun url-domsuf-cookie-allowed-p (domain)
  62   (unless url-domsuf-domains
  63     (url-domsuf-parse-file))
  64   (let* ((allowedp t)
  65          (domain-bits (split-string domain "[.]"))
  66          (length (length domain-bits))
  67          (upper-domain (mapconcat 'identity (cdr domain-bits) "."))
  68          entry modifier)
  69     (dolist (elem url-domsuf-domains)
  70       (setq entry (car elem)
  71             modifier (cdr elem))
  72       (cond
  73        ;; "com"
  74        ((and (null modifier)
  75              (string= domain entry))
  76         (setq allowedp nil))
  77        ;; "!pref.hokkaido.jp"
  78        ((and (eq modifier t)
  79              (string= domain entry))
  80         (setq allowedp t))
  81        ;; "*.ar"
  82        ((and (numberp modifier)
  83              (= length modifier)
  84              (string= entry upper-domain))
  85         (setq allowedp nil))))
  86     allowedp))
  87
  88 ;; Tests:
  89
  90 ;; (url-domsuf-cookie-allowed-p "com") => nil
  91 ;; (url-domsuf-cookie-allowed-p "foo.bar.ar") => t
  92 ;; (url-domsuf-cookie-allowed-p "bar.ar") => nil
  93 ;; (url-domsuf-cookie-allowed-p "co.uk") => nil
  94 ;; (url-domsuf-cookie-allowed-p "foo.bar.hokkaido.jo") => t
  95 ;; (url-domsuf-cookie-allowed-p "bar.hokkaido.jp") => nil
  96 ;; (url-domsuf-cookie-allowed-p "pref.hokkaido.jp") => t
  97
  98 (provide 'url-domsuf)
  99
 100 ;;; url-domsuf.el ends here