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  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 the netscape-style 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 (stringp localpart-match)
 230                          (string-match (concat "^" (regexp-quote
 231                                                     localpart-match))
 232                                        localpart)
 233                        (equal localpart localpart-match))
 234                      (not (url-cookie-expired-p cur)))
 235                 (setq retval (cons cur retval))))))
 236     retval))
 237
 238 (defun url-cookie-generate-header-lines (host localpart secure)
 239   (let* ((cookies (url-cookie-retrieve host localpart secure))
 240          (retval nil)
 241          (cur nil)
 242          (chunk nil))
 243     ;; Have to sort this for sending most specific cookies first
 244     (setq cookies (and cookies
 245                        (sort cookies
 246                              (function
 247                               (lambda (x y)
 248                                 (> (length (url-cookie-localpart x))
 249                                    (length (url-cookie-localpart y))))))))
 250     (while cookies
 251       (setq cur (car cookies)
 252             cookies (cdr cookies)
 253             chunk (format "%s=%s" (url-cookie-name cur) (url-cookie-value cur))
 254             retval (if (and url-cookie-multiple-line
 255                             (< 80 (+ (length retval) (length chunk) 4)))
 256                        (concat retval "\r\nCookie: " chunk)
 257                      (if retval
 258                          (concat retval "; " chunk)
 259                        (concat "Cookie: " chunk)))))
 260     (if retval
 261         (concat retval "\r\n")
 262       "")))
 263
 264 (defvar url-cookie-two-dot-domains
 265   (concat "\\.\\("
 266    (mapconcat 'identity (list "com" "edu" "net" "org" "gov" "mil" "int")
 267               "\\|")
 268    "\\)$")
 269   "A regexp of top level domains that only require two matching
 270 '.'s in the domain name in order to set a cookie.")
 271
 272 (defcustom url-cookie-trusted-urls nil
 273   "A list of regular expressions matching URLs to always accept cookies from."
 274   :type '(repeat regexp)
 275   :group 'url-cookie)
 276
 277 (defcustom url-cookie-untrusted-urls nil
 278   "A list of regular expressions matching URLs to never accept cookies from."
 279   :type '(repeat regexp)
 280   :group 'url-cookie)
 281
 282 (defun url-cookie-host-can-set-p (host domain)
 283   (let ((numdots 0)
 284         (last nil)
 285         (case-fold-search t)
 286         (mindots 3))
 287     (while (setq last (string-match "\\." domain last))
 288       (setq numdots (1+ numdots)
 289             last (1+ last)))
 290     (if (string-match url-cookie-two-dot-domains domain)
 291         (setq mindots 2))
 292     (cond
 293      ((string= host domain)             ; Apparently netscape lets you do this
 294       t)
 295      ((>= numdots mindots)              ; We have enough dots in domain name
 296       ;; Need to check and make sure the host is actually _in_ the
 297       ;; domain it wants to set a cookie for though.
 298       (string-match (concat (regexp-quote
 299                              ;; Remove the dot from wildcard domains
 300                              ;; before matching.
 301                              (if (eq ?. (aref domain 0))
 302                                  (substring domain 1)
 303                                domain))
 304                             "$") host))
 305      (t
 306       nil))))
 307
 308 (defun url-cookie-handle-set-cookie (str)
 309   (setq url-cookies-changed-since-last-save t)
 310   (let* ((args (url-parse-args str t))
 311          (case-fold-search t)
 312          (secure (and (assoc-string "secure" args t) t))
 313          (domain (or (cdr-safe (assoc-string "domain" args t))
 314                      (url-host url-current-object)))
 315          (current-url (url-view-url t))
 316          (trusted url-cookie-trusted-urls)
 317          (untrusted url-cookie-untrusted-urls)
 318          (expires (cdr-safe (assoc-string "expires" args t)))
 319          (localpart (or (cdr-safe (assoc-string "path" args t))
 320                         (file-name-directory
 321                          (url-filename url-current-object))))
 322          (rest nil))
 323     (while args
 324       (if (not (member (downcase (car (car args)))
 325                        '("secure" "domain" "expires" "path")))
 326           (setq rest (cons (car args) rest)))
 327       (setq args (cdr args)))
 328
 329     ;; Sometimes we get dates that the timezone package cannot handle very
 330     ;; gracefully - take care of this here, instead of in url-cookie-expired-p
 331     ;; to speed things up.
 332     (if (and expires
 333              (string-match
 334               (concat "^[^,]+, +\\(..\\)-\\(...\\)-\\(..\\) +"
 335                       "\\(..:..:..\\) +\\[*\\([^\]]+\\)\\]*$")
 336               expires))
 337         (setq expires (concat (match-string 1 expires) " "
 338                               (match-string 2 expires) " "
 339                               (match-string 3 expires) " "
 340                               (match-string 4 expires) " ["
 341                               (match-string 5 expires) "]")))
 342
 343     ;; This one is for older Emacs/XEmacs variants that don't
 344     ;; understand this format without tenths of a second in it.
 345     ;; Wednesday, 30-Dec-2037 16:00:00 GMT
 346     ;;       - vs -
 347     ;; Wednesday, 30-Dec-2037 16:00:00.00 GMT
 348     (if (and expires
 349              (string-match
 350               "\\([0-9]+\\)-\\([A-Za-z]+\\)-\\([0-9]+\\)[ \t]+\\([0-9]+:[0-9]+:[0-9]+\\)\\(\\.[0-9]+\\)*[ \t]+\\([-+a-zA-Z0-9]+\\)"
 351               expires))
 352         (setq expires (concat (match-string 1 expires) "-"      ; day
 353                               (match-string 2 expires) "-"      ; month
 354                               (match-string 3 expires) " "      ; year
 355                               (match-string 4 expires) ".00 " ; hour:minutes:seconds
 356                               (match-string 6 expires)))) ":" ; timezone
 357
 358     (while (consp trusted)
 359       (if (string-match (car trusted) current-url)
 360           (setq trusted (- (match-end 0) (match-beginning 0)))
 361         (pop trusted)))
 362     (while (consp untrusted)
 363       (if (string-match (car untrusted) current-url)
 364           (setq untrusted (- (match-end 0) (match-beginning 0)))
 365         (pop untrusted)))
 366     (if (and trusted untrusted)
 367         ;; Choose the more specific match
 368         (if (> trusted untrusted)
 369             (setq untrusted nil)
 370           (setq trusted nil)))
 371     (cond
 372      (untrusted
 373       ;; The site was explicity marked as untrusted by the user
 374       nil)
 375      ((or (eq url-privacy-level 'paranoid)
 376           (and (listp url-privacy-level) (memq 'cookies url-privacy-level)))
 377       ;; user never wants cookies
 378       nil)
 379      ((and url-cookie-confirmation
 380            (not trusted)
 381            (save-window-excursion
 382              (with-output-to-temp-buffer "*Cookie Warning*"
 383                (mapcar
 384                 (function
 385                  (lambda (x)
 386                    (princ (format "%s - %s" (car x) (cdr x))))) rest))
 387              (prog1
 388                  (not (funcall url-confirmation-func
 389                                (format "Allow %s to set these cookies? "
 390                                        (url-host url-current-object))))
 391                (if (get-buffer "*Cookie Warning*")
 392                    (kill-buffer "*Cookie Warning*")))))
 393       ;; user wants to be asked, and declined.
 394       nil)
 395      ((url-cookie-host-can-set-p (url-host url-current-object) domain)
 396       ;; Cookie is accepted by the user, and passes our security checks
 397       (let ((cur nil))
 398         (while rest
 399           (setq cur (pop rest))
 400           (url-cookie-store (car cur) (cdr cur)
 401                             expires domain localpart secure))))
 402      (t
 403       (url-lazy-message "%s tried to set a cookie for domain %s - rejected."
 404                         (url-host url-current-object) domain)))))
 405
 406 (defvar url-cookie-timer nil)
 407
 408 (defcustom url-cookie-save-interval 3600
 409   "The number of seconds between automatic saves of cookies.
 410 Default is 1 hour.  Note that if you change this variable outside of
 411 the `customize' interface after `url-do-setup' has been run, you need
 412 to run the `url-cookie-setup-save-timer' function manually."
 413   :set #'(lambda (var val)
 414            (set-default var val)
 415            (if (bound-and-true-p url-setup-done)
 416                (url-cookie-setup-save-timer)))
 417   :type 'integer
 418   :group 'url-cookie)
 419
 420 (defun url-cookie-setup-save-timer ()
 421   "Reset the cookie saver timer."
 422   (interactive)
 423   (ignore-errors (cancel-timer url-cookie-timer))
 424   (setq url-cookie-timer nil)
 425   (if url-cookie-save-interval
 426       (setq url-cookie-timer (run-at-time url-cookie-save-interval
 427                                           url-cookie-save-interval
 428                                           #'url-cookie-write-file))))
 429
 430 (provide 'url-cookie)
 431
 432 ;; arch-tag: 2568751b-6452-4398-aa2d-303edadb54d7
 433 ;;; url-cookie.el ends here