lisp/url/url-cookie.el

   1 ;;; url-cookie.el --- Netscape Cookie support
   2
   3 ;; Copyright (C) 1996, 1997, 1998, 1999, 2004, 2005, 2006, 2007, 2008,
   4 ;;   2009, 2010, 2011, 2012  Free Software Foundation, Inc.
   5
   6 ;; Keywords: comm, data, processes, hypermedia
   7
   8 ;; This file is part of GNU Emacs.
   9 ;;
  10 ;; GNU Emacs is free software: you can redistribute it and/or modify
  11 ;; it under the terms of the GNU General Public License as published by
  12 ;; the Free Software Foundation, either version 3 of the License, or
  13 ;; (at your option) any later version.
  14
  15 ;; GNU Emacs is distributed in the hope that it will be useful,
  16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18 ;; GNU General Public License for more details.
  19
  20 ;; You should have received a copy of the GNU General Public License
  21 ;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
  22
  23 ;;; Commentary:
  24
  25 ;;; Code:
  26
  27 (require 'url-util)
  28 (require 'url-parse)
  29 (eval-when-compile (require 'cl))
  30
  31 ;; See http://home.netscape.com/newsref/std/cookie_spec.html for the
  32 ;; 'open standard' defining this crap.
  33
  34 (defgroup url-cookie nil
  35   "URL cookies."
  36   :prefix "url-"
  37   :prefix "url-cookie-"
  38   :group 'url)
  39
  40 ;; A cookie is stored internally as a vector of 7 slots
  41 ;; [ cookie NAME VALUE EXPIRES LOCALPART DOMAIN SECURE ]
  42
  43 (defstruct (url-cookie
  44             (:constructor url-cookie-create)
  45             (:copier nil)
  46             ;; For compatibility with a previous version which did not use
  47             ;; defstruct, and also in order to make sure that the printed
  48             ;; representation does not depend on CL internals, we use an
  49             ;; explicitly managed tag.
  50             (:type vector))
  51   (tag 'cookie :read-only t)
  52   name value expires localpart domain secure)
  53
  54 (defvar url-cookie-storage nil         "Where cookies are stored.")
  55 (defvar url-cookie-secure-storage nil  "Where secure cookies are stored.")
  56 (defcustom url-cookie-file nil
  57   "File where cookies are stored on disk."
  58   :type '(choice (const :tag "Default" :value nil) file)
  59   :group 'url-file
  60   :group 'url-cookie)
  61
  62 (defcustom url-cookie-confirmation nil
  63   "If non-nil, confirmation by the user is required to accept HTTP cookies."
  64   :type 'boolean
  65   :group 'url-cookie)
  66
  67 (defcustom url-cookie-multiple-line nil
  68   "If nil, HTTP requests put all cookies for the server on one line.
  69 Some web servers, such as http://www.hotmail.com/, only accept cookies
  70 when they are on one line.  This is broken behavior, but just try
  71 telling Microsoft that."
  72   :type 'boolean
  73   :group 'url-cookie)
  74
  75 (defvar url-cookies-changed-since-last-save nil
  76   "Whether the cookies list has changed since the last save operation.")
  77
  78 (defun url-cookie-parse-file (&optional fname)
  79   (setq fname (or fname url-cookie-file))
  80   (condition-case ()
  81       (load fname nil t)
  82     (error
  83      ;; It's completely normal for the cookies file not to exist yet.
  84      ;; (message "Could not load cookie file %s" fname)
  85      )))
  86
  87 (declare-function url-cookie-p "url-cookie" t t) ; defstruct
  88
  89 (defun url-cookie-clean-up (&optional secure)
  90   (let* (
  91          (var (if secure 'url-cookie-secure-storage 'url-cookie-storage))
  92          (val (symbol-value var))
  93          (cur nil)
  94          (new nil)
  95          (cookies nil)
  96          (cur-cookie nil)
  97          (new-cookies nil)
  98          )
  99     (while val
 100       (setq cur (car val)
 101             val (cdr val)
 102             new-cookies nil
 103             cookies (cdr cur))
 104       (while cookies
 105         (setq cur-cookie (car cookies)
 106               cookies (cdr cookies))
 107         (if (or (not (url-cookie-p cur-cookie))
 108                 (url-cookie-expired-p cur-cookie)
 109                 (null (url-cookie-expires cur-cookie)))
 110             nil
 111           (setq new-cookies (cons cur-cookie new-cookies))))
 112       (if (not new-cookies)
 113           nil
 114         (setcdr cur new-cookies)
 115         (setq new (cons cur new))))
 116     (set var new)))
 117
 118 (defun url-cookie-write-file (&optional fname)
 119   (when url-cookies-changed-since-last-save
 120     (or fname (setq fname (expand-file-name url-cookie-file)))
 121     (if (condition-case nil
 122             (progn
 123               (url-make-private-file fname)
 124               nil)
 125           (error t))
 126         (message "Error accessing cookie file `%s'" fname)
 127     (url-cookie-clean-up)
 128     (url-cookie-clean-up t)
 129     (with-temp-buffer
 130       (insert ";; Emacs-W3 HTTP cookies file\n"
 131               ";; Automatically generated file!!! DO NOT EDIT!!!\n\n"
 132               "(setq url-cookie-storage\n '")
 133       (pp url-cookie-storage (current-buffer))
 134       (insert ")\n(setq url-cookie-secure-storage\n '")
 135       (pp url-cookie-secure-storage (current-buffer))
 136       (insert ")\n")
 137       (insert "\f\n;; Local Variables:\n"
 138               ";; version-control: never\n"
 139               ";; no-byte-compile: t\n"
 140               ";; End:\n")
 141       (set (make-local-variable 'version-control) 'never)
 142       (write-file fname))
 143     (setq url-cookies-changed-since-last-save nil))))
 144
 145 (defun url-cookie-store (name value &optional expires domain localpart secure)
 146   "Store a netscape-style cookie."
 147   (let* ((storage (if secure url-cookie-secure-storage url-cookie-storage))
 148          (tmp storage)
 149          (cur nil)
 150          (found-domain nil))
 151
 152     ;; First, look for a matching domain
 153     (setq found-domain (assoc domain storage))
 154
 155     (if found-domain
 156         ;; Need to either stick the new cookie in existing domain storage
 157         ;; or possibly replace an existing cookie if the names match.
 158         (progn
 159           (setq storage (cdr found-domain)
 160                 tmp nil)
 161           (while storage
 162             (setq cur (car storage)
 163                   storage (cdr storage))
 164             (if (and (equal localpart (url-cookie-localpart cur))
 165                      (equal name (url-cookie-name cur)))
 166                 (progn
 167                   (setf (url-cookie-expires cur) expires)
 168                   (setf (url-cookie-value cur) value)
 169                   (setq tmp t))))
 170           (if (not tmp)
 171               ;; New cookie
 172               (setcdr found-domain (cons
 173                                     (url-cookie-create :name name
 174                                                        :value value
 175                                                        :expires expires
 176                                                        :domain domain
 177                                                        :localpart localpart
 178                                                        :secure secure)
 179                                     (cdr found-domain)))))
 180       ;; Need to add a new top-level domain
 181       (setq tmp (url-cookie-create :name name
 182                                    :value value
 183                                    :expires expires
 184                                    :domain domain
 185                                    :localpart localpart
 186                                    :secure secure))
 187       (cond
 188        (storage
 189         (setcdr storage (cons (list domain tmp) (cdr storage))))
 190        (secure
 191         (setq url-cookie-secure-storage (list (list domain tmp))))
 192        (t
 193         (setq url-cookie-storage (list (list domain tmp))))))))
 194
 195 (defun url-cookie-expired-p (cookie)
 196   "Return non-nil if COOKIE is expired."
 197   (let ((exp (url-cookie-expires cookie)))
 198     (and exp (> (float-time) (float-time (date-to-time exp))))))
 199
 200 (defun url-cookie-retrieve (host &optional localpart secure)
 201   "Retrieve all cookies for a specified HOST and LOCALPART."
 202   (let ((storage (if secure
 203                      (append url-cookie-secure-storage url-cookie-storage)
 204                    url-cookie-storage))
 205         (case-fold-search t)
 206         (cookies nil)
 207         (cur nil)
 208         (retval nil)
 209         (localpart-match nil))
 210     (while storage
 211       (setq cur (car storage)
 212             storage (cdr storage)
 213             cookies (cdr cur))
 214       (if (and (car cur)
 215                (string-match
 216                 (concat "^.*"
 217                         (regexp-quote
 218                          ;; Remove the dot from wildcard domains
 219                          ;; before matching.
 220                          (if (eq ?. (aref (car cur) 0))
 221                              (substring (car cur) 1)
 222                            (car cur)))
 223                         "$") host))
 224           ;; The domains match - a possible hit!
 225           (while cookies
 226             (setq cur (car cookies)
 227                   cookies (cdr cookies)
 228                   localpart-match (url-cookie-localpart cur))
 229             (if (and (if (and (stringp localpart-match)
 230                               (stringp localpart))
 231                          (string-match (concat "^" (regexp-quote
 232                                                     localpart-match))
 233                                        localpart)
 234                        (equal localpart localpart-match))
 235                      (not (url-cookie-expired-p cur)))
 236                 (setq retval (cons cur retval))))))
 237     retval))
 238
 239 (defun url-cookie-generate-header-lines (host localpart secure)
 240   (let* ((cookies (url-cookie-retrieve host localpart secure))
 241          (retval nil)
 242          (cur nil)
 243          (chunk nil))
 244     ;; Have to sort this for sending most specific cookies first
 245     (setq cookies (and cookies
 246                        (sort cookies
 247                              (function
 248                               (lambda (x y)
 249                                 (> (length (url-cookie-localpart x))
 250                                    (length (url-cookie-localpart y))))))))
 251     (while cookies
 252       (setq cur (car cookies)
 253             cookies (cdr cookies)
 254             chunk (format "%s=%s" (url-cookie-name cur) (url-cookie-value cur))
 255             retval (if (and url-cookie-multiple-line
 256                             (< 80 (+ (length retval) (length chunk) 4)))
 257                        (concat retval "\r\nCookie: " chunk)
 258                      (if retval
 259                          (concat retval "; " chunk)
 260                        (concat "Cookie: " chunk)))))
 261     (if retval
 262         (concat retval "\r\n")
 263       "")))
 264
 265 (defvar url-cookie-two-dot-domains
 266   (concat "\\.\\("
 267    (mapconcat 'identity (list "com" "edu" "net" "org" "gov" "mil" "int")
 268               "\\|")
 269    "\\)$")
 270   "A regexp of top level domains that only require two matching
 271 '.'s in the domain name in order to set a cookie.")
 272
 273 (defcustom url-cookie-trusted-urls nil
 274   "A list of regular expressions matching URLs to always accept cookies from."
 275   :type '(repeat regexp)
 276   :group 'url-cookie)
 277
 278 (defcustom url-cookie-untrusted-urls nil
 279   "A list of regular expressions matching URLs to never accept cookies from."
 280   :type '(repeat regexp)
 281   :group 'url-cookie)
 282
 283 (defun url-cookie-host-can-set-p (host domain)
 284   (let ((numdots 0)
 285         (last nil)
 286         (case-fold-search t)
 287         (mindots 3))
 288     (while (setq last (string-match "\\." domain last))
 289       (setq numdots (1+ numdots)
 290             last (1+ last)))
 291     (if (string-match url-cookie-two-dot-domains domain)
 292         (setq mindots 2))
 293     (cond
 294      ((string= host domain)             ; Apparently netscape lets you do this
 295       t)
 296      ((>= numdots mindots)              ; We have enough dots in domain name
 297       ;; Need to check and make sure the host is actually _in_ the
 298       ;; domain it wants to set a cookie for though.
 299       (string-match (concat (regexp-quote
 300                              ;; Remove the dot from wildcard domains
 301                              ;; before matching.
 302                              (if (eq ?. (aref domain 0))
 303                                  (substring domain 1)
 304                                domain))
 305                             "$") host))
 306      (t
 307       nil))))
 308
 309 (defun url-cookie-handle-set-cookie (str)
 310   (setq url-cookies-changed-since-last-save t)
 311   (let* ((args (url-parse-args str t))
 312          (case-fold-search t)
 313          (secure (and (assoc-string "secure" args t) t))
 314          (domain (or (cdr-safe (assoc-string "domain" args t))
 315                      (url-host url-current-object)))
 316          (current-url (url-view-url t))
 317          (trusted url-cookie-trusted-urls)
 318          (untrusted url-cookie-untrusted-urls)
 319          (expires (cdr-safe (assoc-string "expires" args t)))
 320          (localpart (or (cdr-safe (assoc-string "path" args t))
 321                         (file-name-directory
 322                          (url-filename url-current-object))))
 323          (rest nil))
 324     (while args
 325       (if (not (member (downcase (car (car args)))
 326                        '("secure" "domain" "expires" "path")))
 327           (setq rest (cons (car args) rest)))
 328       (setq args (cdr args)))
 329
 330     ;; Sometimes we get dates that the timezone package cannot handle very
 331     ;; gracefully - take care of this here, instead of in url-cookie-expired-p
 332     ;; to speed things up.
 333     (if (and expires
 334              (string-match
 335               (concat "^[^,]+, +\\(..\\)-\\(...\\)-\\(..\\) +"
 336                       "\\(..:..:..\\) +\\[*\\([^\]]+\\)\\]*$")
 337               expires))
 338         (setq expires (concat (match-string 1 expires) " "
 339                               (match-string 2 expires) " "
 340                               (match-string 3 expires) " "
 341                               (match-string 4 expires) " ["
 342                               (match-string 5 expires) "]")))
 343
 344     ;; This one is for older Emacs/XEmacs variants that don't
 345     ;; understand this format without tenths of a second in it.
 346     ;; Wednesday, 30-Dec-2037 16:00:00 GMT
 347     ;;       - vs -
 348     ;; Wednesday, 30-Dec-2037 16:00:00.00 GMT
 349     (if (and expires
 350              (string-match
 351               "\\([0-9]+\\)-\\([A-Za-z]+\\)-\\([0-9]+\\)[ \t]+\\([0-9]+:[0-9]+:[0-9]+\\)\\(\\.[0-9]+\\)*[ \t]+\\([-+a-zA-Z0-9]+\\)"
 352               expires))
 353         (setq expires (concat (match-string 1 expires) "-"      ; day
 354                               (match-string 2 expires) "-"      ; month
 355                               (match-string 3 expires) " "      ; year
 356                               (match-string 4 expires) ".00 " ; hour:minutes:seconds
 357                               (match-string 6 expires)))) ":" ; timezone
 358
 359     (while (consp trusted)
 360       (if (string-match (car trusted) current-url)
 361           (setq trusted (- (match-end 0) (match-beginning 0)))
 362         (pop trusted)))
 363     (while (consp untrusted)
 364       (if (string-match (car untrusted) current-url)
 365           (setq untrusted (- (match-end 0) (match-beginning 0)))
 366         (pop untrusted)))
 367     (if (and trusted untrusted)
 368         ;; Choose the more specific match
 369         (if (> trusted untrusted)
 370             (setq untrusted nil)
 371           (setq trusted nil)))
 372     (cond
 373      (untrusted
 374       ;; The site was explicity marked as untrusted by the user
 375       nil)
 376      ((or (eq url-privacy-level 'paranoid)
 377           (and (listp url-privacy-level) (memq 'cookies url-privacy-level)))
 378       ;; user never wants cookies
 379       nil)
 380      ((and url-cookie-confirmation
 381            (not trusted)
 382            (save-window-excursion
 383              (with-output-to-temp-buffer "*Cookie Warning*"
 384                (mapcar
 385                 (function
 386                  (lambda (x)
 387                    (princ (format "%s - %s" (car x) (cdr x))))) rest))
 388              (prog1
 389                  (not (funcall url-confirmation-func
 390                                (format "Allow %s to set these cookies? "
 391                                        (url-host url-current-object))))
 392                (if (get-buffer "*Cookie Warning*")
 393                    (kill-buffer "*Cookie Warning*")))))
 394       ;; user wants to be asked, and declined.
 395       nil)
 396      ((url-cookie-host-can-set-p (url-host url-current-object) domain)
 397       ;; Cookie is accepted by the user, and passes our security checks
 398       (let ((cur nil))
 399         (while rest
 400           (setq cur (pop rest))
 401           (url-cookie-store (car cur) (cdr cur)
 402                             expires domain localpart secure))))
 403      (t
 404       (message "%s tried to set a cookie for domain %s - rejected."
 405                (url-host url-current-object) domain)))))
 406
 407 (defvar url-cookie-timer nil)
 408
 409 (defcustom url-cookie-save-interval 3600
 410   "The number of seconds between automatic saves of cookies.
 411 Default is 1 hour.  Note that if you change this variable outside of
 412 the `customize' interface after `url-do-setup' has been run, you need
 413 to run the `url-cookie-setup-save-timer' function manually."
 414   :set #'(lambda (var val)
 415            (set-default var val)
 416            (if (bound-and-true-p url-setup-done)
 417                (url-cookie-setup-save-timer)))
 418   :type 'integer
 419   :group 'url-cookie)
 420
 421 (defun url-cookie-setup-save-timer ()
 422   "Reset the cookie saver timer."
 423   (interactive)
 424   (ignore-errors (cancel-timer url-cookie-timer))
 425   (setq url-cookie-timer nil)
 426   (if url-cookie-save-interval
 427       (setq url-cookie-timer (run-at-time url-cookie-save-interval
 428                                           url-cookie-save-interval
 429                                           #'url-cookie-write-file))))
 430
 431 (provide 'url-cookie)
 432
 433 ;; arch-tag: 2568751b-6452-4398-aa2d-303edadb54d7
 434 ;;; url-cookie.el ends here