emacs/external/ljupdate/http-cookies.el

   1 ;;; http-cookies.el --- simple HTTP cookies implementation
   2
   3 ;; Copyright (C) 2004, David Hansen
   4
   5 ;; Author: David Hansen <david.hansen@physik.fu-berlin.de>
   6 ;; Maintainer: David Hansen <david.hansen@physik.fu-berlin.de>
   7 ;; Version: 1.0.0
   8 ;; Keywords: hypermedia
   9
  10 ;; This file is not part of GNU Emacs.
  11
  12 ;; This is free software; you can redistribute it and/or modify
  13 ;; it under the terms of the GNU General Public License as published by
  14 ;; the Free Software Foundation; either version 2, or (at your option)
  15 ;; any later version.
  16
  17 ;; This is distributed in the hope that it will be useful,
  18 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  19 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  20 ;; GNU General Public License for more details.
  21
  22 ;; You should have received a copy of the GNU General Public License
  23 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  24 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  25 ;; Boston, MA 02111-1307, USA.
  26
  27
  28 ;;; Commentary:
  29
  30 ;; Implementation of old netscape cookies (used by maybe all servers) and
  31 ;; version 1 cookies.
  32 ;;
  33 ;; See http://www.faqs.org/rfcs/rfc2109.html and
  34 ;; http://wp.netscape.com/newsref/std/cookie_spec.html
  35
  36 ;;; Change log:
  37
  38 ;;; TODO:
  39
  40 ;;    - whitelist
  41 ;;    - blacklist
  42 ;;    - reading from file, saving to file
  43 ;;    - expire
  44
  45 ;;; Code:
  46
  47 (require 'time-date)
  48
  49 (defconst http-cookies-version "1.0.0")
  50
  51 (defgroup http-emacs ()
  52   "Simple HTTP client implementation in elisp.")
  53
  54 (defcustom http-emacs-use-cookies nil
  55   "Use cookies in the http-emacs package. *EXPERIMENTAL*"
  56   :type 'boolean
  57   :group 'http-emacs)
  58
  59 (defcustom http-emacs-cookie-file "~/.emacs-cookies"
  60   "*File where to store the cookies."
  61   :type 'file
  62   :group 'http-emacs)
  63
  64 (defconst http-token-value-regexp
  65   "^[ \t]*\\(.*?\\)[ \t]*=[ \t]*\"?\\(.*?\\)\"?[ \t]*;?[ \t]*$"
  66   "Regexp to match a token=\"value\"; in a cookie.")
  67
  68 (defvar http-cookies-accept-functions
  69   '(http-cookie-check-path
  70     http-cookie-check-domain
  71     http-cookie-check-hostname)
  72   "*List of functions used to determine if we accept a cookie or not.
  73 If one of these function returns nil the cookie will be rejected.  Each
  74 function can access the free variables `cookie', `host' (from the url)
  75 `path' (from the URL) and `url' to make its decision.")
  76
  77 (defvar http-cookies-host-hash
  78   (make-hash-table :test 'equal)
  79   "Hash to look up cookies by host name.")
  80
  81 (defvar http-cookies-domain-hash
  82   (make-hash-table :test 'equal)
  83   "Hash to look up cookies by domain.")
  84
  85
  86
  87 ;; functions for parsing the header
  88
  89 (defun http-cookies-ns-to-rfc (line)
  90   "Make the header value LINE a bit more RFC compatible.
  91 Make old netscape cookies a bit more RFC 2109 compatible by quoting
  92 the \"expires\" value.  We need this to be able to properly split
  93 the header value if there is more than one cookie."
  94   (let ((start 0))
  95     (while (string-match "expires[ \t]*=[ \t]*\\([^\";]+?\\)\\(;\\|$\\)"
  96                          line start)
  97       (setq start (match-end 0))
  98       (setq line (replace-match "\"\\1\"" t nil line 1)))
  99     line))
 100
 101 (defun http-cookies-find-char-in-string (char string &optional start)
 102   "Return the first position of CHAR in STRING.
 103 If START is non-nil start at position START."
 104   (unless start
 105     (setq start 0))
 106   (let ((i start) (len (length string)) pos)
 107     (while (and (not pos) (< i len))
 108       (when (= (aref string i) char)
 109         (setq pos i))
 110       (setq i (1+ i)))
 111     pos))
 112
 113 (defun http-cookies-find-quoted-strings (header-value)
 114   "Return list of positions of quoted strings in HEADER_VALUE.
 115 Return a list of pairs with the beginning and end of quoted strings
 116 in a \"Set-cookie: \" header value."
 117   (let ((start 0) qstring-pos)
 118     (while (string-match "=[ \t]*\\(\".*?[^\\]\"\\)" header-value start)
 119       (add-to-list 'qstring-pos (cons (match-beginning 1) (1- (match-end 1))))
 120       (setq start (match-end 1)))
 121     qstring-pos))
 122
 123 (defun http-cookies-split-string (header-value sep-char)
 124   "Split the HEADER-VALUE at the character SEP-CHAR.
 125 Ignores SEP-CHAR if it is in a quoted string.  Return a list of the
 126 substrings."
 127   (let ((qstrings (http-cookies-find-quoted-strings header-value))
 128         (start 0) (beg 0) pos in-qstring strings)
 129     (while (setq pos (http-cookies-find-char-in-string
 130                       sep-char header-value start))
 131       (unless (= pos start)           ; ignore empty strings
 132         ;; check if pos is in a quoted string
 133         (dolist (qstring-pos qstrings)
 134           (unless in-qstring
 135             (when (and (> pos (car qstring-pos)) (< pos (cdr qstring-pos)))
 136               (setq in-qstring t))))
 137         (if in-qstring
 138             (setq in-qstring nil)
 139           (add-to-list 'strings (substring header-value beg pos))
 140           (setq beg (1+ pos))))
 141       (setq start (1+ pos)))
 142     ;; add the last token
 143     (add-to-list 'strings (substring header-value beg))
 144     strings))
 145
 146 (defun http-cookies-parse-cookie (string)
 147   "Parse one cookie.
 148 Return an alist ((NAME . VALUE) (attr1 . value1) (attr2 . value2) ...)
 149 or nil on error."
 150   (let (attrs error)
 151     (dolist (attr (http-cookies-split-string string ?\;))
 152       (if (string-match http-token-value-regexp attr)
 153           (add-to-list 'attrs (cons (match-string 1 attr)
 154                                     (match-string 2 attr)))
 155         ;; match the secure attribute
 156         (if (string-match "[ \t]*\\([a-zA-Z]+\\)[ \t]*"  attr)
 157             (add-to-list 'attrs (cons (match-string 1 attr) t))
 158           (setq error t)
 159           (message "Cannot parse cookie %s" string))))
 160     (unless error
 161       attrs)))
 162
 163 (defun http-cookies-set (url headers)
 164   "Set the cookies from the response to a request of URL.
 165 Set HEADERS to the headers of the response."
 166   (let ((host (http-cookies-url-host url)) (path (http-cookies-url-path url))
 167         header-value cookie)
 168     ;; The server may send several "Set-Cookie:" headers.
 169     (dolist (line headers)
 170       (when (equal (car line) "set-cookie")
 171         (setq header-value (http-cookies-ns-to-rfc (cdr line)))
 172         ;; there may be several cookies separated by ","
 173         (dolist (raw-cookie (http-cookies-split-string header-value ?\,))
 174           (setq cookie (http-cookies-parse-cookie raw-cookie))
 175           ;; (message "%s" raw-cookie)
 176           (when (http-cookies-accept)
 177             ;; (message "accepted")
 178             (http-cookies-store host cookie)))))))
 179
 180
 181
 182 ;; storing cookies
 183
 184 (defun http-cookies-name (cookie)
 185   "Return the name of the COOKIE."
 186   (car (car cookie)))
 187
 188 (defun http-cookies-path (cookie)
 189   "Return the value of the path attribute of the COOKIE."
 190   (let ((attr (or (assoc "path" cookie) (assoc "Path" cookie))))
 191     (when attr
 192       (cdr attr))))
 193
 194 (defun http-cookies-domain (cookie)
 195   "Return the value of the domain attribute of the COOKIE."
 196   (let ((attr (or (assoc "domain" cookie) (assoc "Domain" cookie))))
 197     (when attr
 198       (cdr attr))))
 199
 200 (defun http-cookies-expires (cookie)
 201   "Return the value of the expires attribute of the COOKIE."
 202   (let ((attr (assoc "expires" cookie)))
 203     (when attr
 204       (cdr attr))))
 205
 206 (defun http-cookies-max-age (cookie)
 207   "Return the value of the Max-Age attribute of the COOKIE."
 208   (let ((attr (assoc "Max-Age" cookie)))
 209     (when attr
 210       (cdr attr))))
 211
 212 (defun http-cookies-version (cookie)
 213   "Return the value of the version attribute of the COOKIE."
 214   (let ((version (assoc "Version" cookie)))
 215     (when version
 216       (if (equal version "1")
 217           t
 218         (message "Cookie version %s not supported." version)
 219         nil))))
 220
 221 (defun http-cookies-equal (c1 c2)
 222   "Return non nil if the given cookies are equal.
 223 Old netscape cookies are equal if the name and path attributes are equal.
 224 Version 1 cookies are equal if name path and domain are equal."
 225   (if (and (http-cookies-version c1) (http-cookies-version c2))
 226       ;; version 1 cookies
 227       (and (equal (http-cookies-name c1) (http-cookies-name c2))
 228            (equal (http-cookies-path c1) (http-cookies-path c2))
 229            (equal (http-cookies-domain c1) (http-cookies-domain c2)))
 230     ;; netscape cookies
 231     (and (equal (http-cookies-name c1) (http-cookies-name c2))
 232          (equal (http-cookies-path c1) (http-cookies-path c2)))))
 233
 234 (defun http-cookies-expired (expire-string)
 235   "Return non nil if EXPIRE-STRING is in the past."
 236   (> (time-to-seconds (time-since expire-string)) 0.0))
 237
 238 (defun http-cookies-remove (cookie key table)
 239   "Remove cookies \"equal\" to COOKIE from the list stored with KEY in TABLE."
 240   (let ((cookie-list (gethash key table)) new-list)
 241     (dolist (entry cookie-list)
 242       (unless (http-cookies-equal entry cookie)
 243         (add-to-list 'new-list entry)))
 244     (when cookie-list
 245       (remhash key table)
 246       (puthash key new-list table))))
 247
 248 (defun http-cookies-store (host cookie)
 249   "Store the given COOKIE from HOST in the hash tables.
 250 Remove cookie from the tables if the given COOKIE expires in the past or
 251 has an \"Max-Age\" of 0."
 252   (let ((domain (http-cookies-domain cookie))
 253         (max-age (http-cookies-max-age cookie))
 254         (expires (http-cookies-expires cookie))
 255         (cookie-list))
 256     ;; remove an possible "equal" old cookie
 257     (http-cookies-remove cookie host http-cookies-host-hash)
 258     (when domain
 259       (http-cookies-remove cookie domain http-cookies-domain-hash))
 260     ;; check if expires is in the past or Max-Age is zero
 261     (unless (or (and max-age (= (string-to-number max-age) 0))
 262                 (and expires (http-cookies-expired expires)))
 263       ;; convert "Max-Age" to "expire"
 264       (when max-age
 265         ;; this value does not have to be in the "right" format
 266         ;; it's enough if `parse-time-string' can parse it
 267         (setq expires (format-time-string
 268                        "%Y-%m-%d %T %z"
 269                        (time-add (current-time) (seconds-to-time max-age))
 270                        t))
 271         (setcdr (assoc "Max-Age" cookie) expires)
 272         (setcar (assoc "Max-Age" cookie) "expires"))
 273       (setq cookie-list (gethash host http-cookies-host-hash))
 274       (add-to-list 'cookie-list cookie)
 275       (puthash host cookie-list http-cookies-host-hash)
 276       (when domain
 277         (setq cookie-list (gethash domain http-cookies-domain-hash))
 278         (add-to-list 'cookie-list cookie)
 279         (puthash domain cookie-list http-cookies-domain-hash)))))
 280
 281
 282
 283 ;; building the header to send back the cookie
 284
 285 (defun http-cookies-cookie-to-string (cookie)
 286   "Return the cookie as a string to be used as a header value."
 287   (let* ((name (http-cookies-name cookie))
 288          (value (cdr (assoc name cookie)))
 289          (path (http-cookies-path cookie))
 290          (domain (http-cookies-domain cookie))
 291          (string))
 292     (if (http-cookies-version cookie)
 293         ;; version 1 cookie
 294         (progn
 295           (setq string (concat "$Version = \"1\"; " name " = \"" value "\""))
 296           (when path
 297             (setq string (concat string "; $Path = \"" path "\"")))
 298           (when domain
 299             (setq string (concat string "; $Domain = \"" domain "\""))))
 300       ;; netscape cookies
 301       (setq string (concat name "=" value)))))
 302
 303 (defun http-cookies-cookie-in-list (cookie list)
 304   "Return non-nil if a cookie \"equal\" to the given COOKIE is in LIST."
 305   (let ((in-list))
 306     (dolist (element list)
 307       (unless in-list
 308         (setq in-list (http-cookies-equal cookie element))))
 309     in-list))
 310
 311 (defun http-cookies-path-depth (cookie)
 312   "Return the number of dashes in the path attribute of the cookie."
 313   (let ((patch http-cookies-path cookie) (n 0) (start 0))
 314     (while (setq start (http-cookies-find-char-in-string ?\/ path start))
 315       (setq n (1+ n)))
 316     n))
 317
 318 (defun http-cookie-path-depth-less (c1 c2)
 319   "Return non nil if the path depth of cookie C1 is less than C2."
 320   (< (http-cookies-path-depth c1) (http-cookies-path-depth c2)))
 321
 322 (defun http-cookies-build-header (url)
 323   "Return a pair (\"Cookie\" . <header value>).
 324 Use this to send back cookies to the given URL."
 325   (let ((host (http-cookies-url-host url)) (domain) (cookie-list) (string))
 326     (when (string-match "^[^.]+\\(\\..+\\)" host)
 327       (setq domain (match-string 1 host))
 328       (dolist (cookie (gethash host http-cookies-host-hash))
 329         (unless (http-cookies-expired (http-cookies-expires cookie))
 330           (add-to-list 'cookie-list cookie)))
 331       (dolist (cookie (gethash domain http-cookies-domain-hash))
 332         (unless (or (http-cookies-cookie-in-list cookie cookie-list)
 333                     (http-cookies-expired (http-cookies-expires cookie)))
 334           (add-to-list 'cookie-list cookie)))
 335       (setq cookie-list (sort cookie-list 'http-cookies-path-depth-less))
 336       (dolist (cookie cookie-list)
 337         (if string
 338             (setq string (concat string "; "
 339                                  (http-cookies-cookie-to-string cookie)))
 340           (setq string (http-cookies-cookie-to-string cookie)))))
 341     (cons "Cookie" string)))
 342
 343
 344
 345 ;; extract parts of the url
 346
 347 (defun http-cookies-url-host (url)
 348   "Return the hostname of URL"
 349   (unless (string-match
 350            "http://\\([^/:]+\\)\\(:\\([0-9]+\\)\\)?/\\(.*/\\)?\\([^:]*\\)"
 351            url)
 352     (error "Cannot parse URL %s." url))
 353   (match-string 1 url))
 354
 355 (defun http-cookies-url-path (url)
 356   "Return the path of the URL."
 357   (unless (string-match
 358            "http://\\([^/:]+\\)\\(:\\([0-9]+\\)\\)?/\\(.*/\\)?\\([^:]*\\)"
 359            url)
 360     (error "Cannot parse URL %s." url))
 361   (concat "/" (or (match-string 4 url) "")))
 362
 363
 364
 365 ;; functions to check the cookie (implementation of 4.3.2 of RFC 2109)
 366
 367 (defun http-cookies-accept ()
 368   "Return non nil if the cookie should be accepted.
 369 The tests are based on the functions in `http-cookies-accept-functions'."
 370   (let ((accept t))
 371     (dolist (fun http-cookies-accept-functions)
 372       (when accept
 373         (setq accept (funcall fun))))
 374     accept))
 375
 376 (defun http-cookie-check-path ()
 377   "Return nil if the \"path\" attribute is not a prefix of th URL."
 378   (let ((cookie-path (cdr (assoc "path" cookie))))
 379     (if cookie-path
 380         (if (string-match (concat "^" cookie-path) path)
 381             t
 382           (message "Rejecting cookie: path attribute \"%s\" is not a prefix\
 383  of the URL %s." cookie-path url)
 384           nil)
 385       t)))
 386
 387 (defun http-cookie-check-domain ()
 388   "Return nil if the domain is bogus.
 389 Return nil if the domain does not start with a \".\" or does not contain
 390 an embedded dot."
 391   (let ((domain (cdr (assoc "domain" cookie))))
 392     (if domain
 393         (if (string-match "^\\.[^.]+\\.[^.]+" domain)
 394             t
 395           (message "Rejection cookie: domain \"%s\" does not start with a dot\
 396  or does not contain an embedded dot." domain)
 397           nil)
 398       t)))
 399
 400 (defun http-cookie-check-hostname ()
 401   "Return nil if the domain doesn't match the host.
 402 Return nil if the domain attribute does not match the host name or the
 403 host name without the domain attribute still contains one or more dots."
 404   ;; FIXME: hostname might be an IP address
 405   (let ((domain (cdr (assoc "domain" cookie))))
 406     (if (not domain)
 407         t
 408       (when (string-match (concat domain "$") host)
 409         (not (http-cookies-find-char-in-string
 410               ?\. (substring host 0 (match-beginning 0))))))))
 411
 412
 413
 414 (provide 'http-cookies)
 415
 416 ;;; http-cookies.el ends here