316 lines
14 KiB
Common Lisp
316 lines
14 KiB
Common Lisp
;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: DRAKMA; Base: 10 -*-
|
|
;;; $Header: /usr/local/cvsrep/drakma/cookies.lisp,v 1.15 2008/01/14 01:57:01 edi Exp $
|
|
|
|
;;; Copyright (c) 2006-2012, Dr. Edmund Weitz. All rights reserved.
|
|
|
|
;;; Redistribution and use in source and binary forms, with or without
|
|
;;; modification, are permitted provided that the following conditions
|
|
;;; are met:
|
|
|
|
;;; * Redistributions of source code must retain the above copyright
|
|
;;; notice, this list of conditions and the following disclaimer.
|
|
|
|
;;; * Redistributions in binary form must reproduce the above
|
|
;;; copyright notice, this list of conditions and the following
|
|
;;; disclaimer in the documentation and/or other materials
|
|
;;; provided with the distribution.
|
|
|
|
;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
|
|
;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
|
|
;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
|
|
;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
|
|
;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
|
|
;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
|
|
;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
|
|
;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
|
|
;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
|
|
;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
|
|
;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
|
|
|
|
(in-package :drakma)
|
|
|
|
(defclass cookie ()
|
|
((name :initarg :name
|
|
:initform (cookie-error nil "A cookie must have a name.")
|
|
:accessor cookie-name
|
|
:documentation "The name of the cookie.")
|
|
(value :initarg :value
|
|
:initform ""
|
|
:accessor cookie-value
|
|
:documentation "The cookie's value.")
|
|
(domain :initarg :domain
|
|
:initform (cookie-error nil "A cookie must have a domain.")
|
|
:accessor cookie-domain
|
|
:documentation "The domain the cookie is valid for.")
|
|
(path :initarg :path
|
|
:initform "/"
|
|
:accessor cookie-path
|
|
:documentation "The path prefix the cookie is valid for.")
|
|
(expires :initarg :expires
|
|
:initform nil
|
|
:accessor cookie-expires
|
|
:documentation "When the cookie expires. A Lisp
|
|
universal time or NIL.")
|
|
(securep :initarg :securep
|
|
:initform nil
|
|
:accessor cookie-securep
|
|
:documentation "Whether the cookie must only be
|
|
transmitted over secure connections.")
|
|
(http-only-p :initarg :http-only-p
|
|
:initform nil
|
|
:accessor cookie-http-only-p
|
|
:documentation "Whether the cookie should not be
|
|
accessible from Javascript.
|
|
|
|
This is a Microsoft extension that has been implemented in Firefox as
|
|
well. See <http://msdn2.microsoft.com/en-us/library/ms533046.aspx>."))
|
|
(:documentation "Elements of this class represent HTTP cookies."))
|
|
|
|
(defun render-cookie-date (time)
|
|
"Returns a string representation of the universal time TIME
|
|
which can be used for cookie headers."
|
|
(multiple-value-bind (second minute hour date month year weekday)
|
|
(decode-universal-time time 0)
|
|
(format nil "~A, ~2,'0d-~2,'0d-~4,'0d ~2,'0d:~2,'0d:~2,'0d GMT"
|
|
(aref #("Mon" "Tue" "Wed" "Thu" "Fri" "Sat" "Sun") weekday)
|
|
date month year hour minute second)))
|
|
|
|
(defmethod print-object ((cookie cookie) stream)
|
|
"Prints a representation of COOKIE similar to a `Set-Cookie' header."
|
|
(print-unreadable-object (cookie stream :type t)
|
|
(with-slots (name value expires path domain securep http-only-p)
|
|
cookie
|
|
(format stream "~A~@[=~A~]~@[; expires=~A~]~@[; path=~A~]~@[; domain=~A~]~@[; secure~]~@[; HttpOnly~]"
|
|
name (and (plusp (length value)) value)
|
|
(and expires (render-cookie-date expires))
|
|
path domain securep http-only-p))))
|
|
|
|
(defun normalize-cookie-domain (domain)
|
|
"Adds a dot at the beginning of the string DOMAIN unless there
|
|
is already one."
|
|
(cond ((starts-with-p domain ".") domain)
|
|
(t (format nil ".~A" domain))))
|
|
|
|
(defun valid-cookie-domain-p (domain)
|
|
"Checks if the string DOMAIN contains enough dots to be
|
|
acceptable. If *ALLOW-DOTLESS-COOKIE-DOMAINS-P* is non-NIL,
|
|
every domain name is considered acceptable."
|
|
(or *allow-dotless-cookie-domains-p*
|
|
(string-equal domain "localhost")
|
|
(> (count #\. (normalize-cookie-domain domain) :test #'char=) 1)))
|
|
|
|
(defun cookie-domain-matches (domain uri)
|
|
"Checks if the domain DOMAIN \(a string) matches the \(PURI) URI URI."
|
|
(ends-with-p (normalize-cookie-domain (uri-host uri))
|
|
(normalize-cookie-domain domain)))
|
|
|
|
(defun send-cookie-p (cookie uri force-ssl)
|
|
"Checks if the cookie COOKIE should be sent to the server
|
|
depending on the \(PURI) URI URI and the value of FORCE-SSL \(as
|
|
in HTTP-REQUEST)."
|
|
(and ;; check domain
|
|
(cookie-domain-matches (cookie-domain cookie) uri)
|
|
;; check path
|
|
(starts-with-p (or (uri-path uri) "/") (cookie-path cookie))
|
|
;; check expiry date
|
|
(let ((expires (cookie-expires cookie)))
|
|
(or (null expires)
|
|
(> expires (get-universal-time))))
|
|
;; check if connection must be secure
|
|
(or (null (cookie-securep cookie))
|
|
force-ssl
|
|
(eq (uri-scheme uri) :https))))
|
|
|
|
(defun check-cookie (cookie)
|
|
"Checks if the slots of the COOKIE object COOKIE have valid values
|
|
and raises a corresponding error of type COOKIE-ERROR otherwise."
|
|
(with-slots (name value domain path expires)
|
|
cookie
|
|
(unless (and (stringp name) (plusp (length name)))
|
|
(cookie-error cookie "Cookie name ~S must be a non-empty string." name))
|
|
(unless (stringp value)
|
|
(cookie-error cookie "Cookie value ~S must be a non-empty string." value))
|
|
(unless (valid-cookie-domain-p domain)
|
|
(cookie-error cookie "Invalid cookie domain ~S." domain))
|
|
(unless (and (stringp path) (plusp (length path)))
|
|
(cookie-error cookie "Cookie path ~S must be a non-empty string." path))
|
|
(unless (or (null expires)
|
|
(and (integerp expires)
|
|
(plusp expires)))
|
|
(cookie-error cookie "Cookie expiry ~S should have been NIL or a universal time." expires))))
|
|
|
|
(defmethod initialize-instance :after ((cookie cookie) &rest initargs)
|
|
"Check cookie validity after creation."
|
|
(declare (ignore initargs))
|
|
(check-cookie cookie))
|
|
|
|
(defmethod (setf cookie-name) :after (new-value (cookie cookie))
|
|
"Check cookie validity after name change."
|
|
(declare (ignore new-value))
|
|
(check-cookie cookie))
|
|
|
|
(defmethod (setf cookie-value) :after (new-value (cookie cookie))
|
|
"Check cookie validity after value change."
|
|
(declare (ignore new-value))
|
|
(check-cookie cookie))
|
|
|
|
(defmethod (setf cookie-domain) :after (new-value (cookie cookie))
|
|
"Check cookie validity after domain change."
|
|
(declare (ignore new-value))
|
|
(check-cookie cookie))
|
|
|
|
(defmethod (setf cookie-path) :after (new-value (cookie cookie))
|
|
"Check cookie validity after path change."
|
|
(declare (ignore new-value))
|
|
(check-cookie cookie))
|
|
|
|
(defmethod (setf cookie-expires) :after (new-value (cookie cookie))
|
|
"Check cookie validity after expiry change."
|
|
(declare (ignore new-value))
|
|
(check-cookie cookie))
|
|
|
|
(defun cookie= (cookie1 cookie2)
|
|
"Returns true if the cookies COOKIE1 and COOKIE2 are equal.
|
|
Two cookies are considered to be equal if name and path are
|
|
equal."
|
|
(and (string= (cookie-name cookie1) (cookie-name cookie2))
|
|
(string= (cookie-path cookie1) (cookie-path cookie2))))
|
|
|
|
(defclass cookie-jar ()
|
|
((cookies :initarg :cookies
|
|
:initform nil
|
|
:accessor cookie-jar-cookies
|
|
:documentation "A list of the cookies in this cookie jar."))
|
|
(:documentation "A COOKIE-JAR object is a collection of cookies."))
|
|
|
|
(defmethod print-object ((cookie-jar cookie-jar) stream)
|
|
"Print a cookie jar, showing the number of cookies it contains."
|
|
(print-unreadable-object (cookie-jar stream :type t :identity t)
|
|
(format stream "(with ~A cookie~:P)" (length (cookie-jar-cookies cookie-jar)))))
|
|
|
|
(defun parse-cookie-date (string)
|
|
"Parses a cookie expiry date and returns it as a Lisp universal
|
|
time. Currently understands the following formats:
|
|
|
|
\"Wed, 06-Feb-2008 21:01:38 GMT\"
|
|
\"Wed, 06-Feb-08 21:01:38 GMT\"
|
|
\"Tue Feb 13 08:00:00 2007 GMT\"
|
|
\"Wednesday, 07-February-2027 08:55:23 GMT\"
|
|
\"Wed, 07-02-2017 10:34:45 GMT\"
|
|
|
|
Instead of \"GMT\" time zone abbreviations like \"CEST\" and UTC
|
|
offsets like \"GMT-01:30\" are also allowed."
|
|
;; it seems like everybody and their sister invents their own format
|
|
;; for this, so (as there's no real standard for it) we'll have to
|
|
;; make this function more flexible once we come across something
|
|
;; new; as an alternative we could use net-telent-date, but it also
|
|
;; fails to parse some of the stuff you encounter in the wild; or we
|
|
;; could try to employ CL-PPCRE, but that'd add a new dependency
|
|
;; without making this code much cleaner
|
|
(handler-case
|
|
(let* ((last-space-pos
|
|
(or (position #\Space string :test #'char= :from-end t)
|
|
(cookie-date-parse-error "Can't parse cookie date ~S, no space found." string)))
|
|
(time-zone-string (subseq string (1+ last-space-pos)))
|
|
(time-zone (interpret-as-time-zone time-zone-string))
|
|
second minute hour day month year)
|
|
(dolist (part (rest (cl-ppcre:split "[ ,-]" (subseq string 0 last-space-pos))))
|
|
(when (and day month)
|
|
(cond ((every #'digit-char-p part)
|
|
(when year
|
|
(cookie-date-parse-error "Can't parse cookie date ~S, confused by ~S part."
|
|
string part))
|
|
(setq year (parse-integer part)))
|
|
((= (count #\: part :test #'char=) 2)
|
|
(let ((h-m-s (mapcar #'safe-parse-integer (cl-ppcre:split ":" part))))
|
|
(setq hour (first h-m-s)
|
|
minute (second h-m-s)
|
|
second (third h-m-s))))
|
|
(t (cookie-date-parse-error "Can't parse cookie date ~S, confused by ~S part."
|
|
string part))))
|
|
(cond ((null day)
|
|
(unless (setq day (safe-parse-integer part))
|
|
(setq month (interpret-as-month part))))
|
|
((null month)
|
|
(setq month (interpret-as-month part)))))
|
|
(unless (and second minute hour day month year)
|
|
(cookie-date-parse-error "Can't parse cookie date ~S, component missing." string))
|
|
(when (< year 100)
|
|
(setq year (+ year 2000)))
|
|
(encode-universal-time second minute hour day month year time-zone))
|
|
(cookie-date-parse-error (condition)
|
|
(cond (*ignore-unparseable-cookie-dates-p*
|
|
(drakma-warn "~A" condition)
|
|
nil)
|
|
(t (error condition))))))
|
|
|
|
(defun parse-set-cookie (string)
|
|
"Parses the `Set-Cookie' header line STRING and returns a list
|
|
of three-element lists where each one contains the name of the
|
|
cookie, the value of the cookie, and an attribute/value list for
|
|
the optional cookie parameters."
|
|
(let ((*current-error-message* (format nil "While parsing cookie header ~S:" string))
|
|
result)
|
|
(dolist (substring (split-set-cookie-string string))
|
|
(with-sequence-from-string (stream substring)
|
|
(let* ((name/value (read-name-value-pair stream :cookie-syntax t))
|
|
(parameters (read-name-value-pairs stream :value-required-p nil :cookie-syntax t)))
|
|
(push (list (car name/value) (cdr name/value) parameters) result))))
|
|
(nreverse result)))
|
|
|
|
(defun get-cookies (headers uri)
|
|
"Returns a list of COOKIE objects corresponding to the
|
|
`Set-Cookie' header as found in HEADERS \(an alist as returned by
|
|
HTTP-REQUEST). Collects only cookies which match the domain of
|
|
the \(PURI) URI URI."
|
|
(loop with set-cookie-header = (header-value :set-cookie headers)
|
|
with parsed-cookies = (and set-cookie-header (parse-set-cookie set-cookie-header))
|
|
for (name value parameters) in parsed-cookies
|
|
for expires = (parameter-value "expires" parameters)
|
|
for domain = (or (parameter-value "domain" parameters) (uri-host uri))
|
|
when (and (valid-cookie-domain-p domain)
|
|
(cookie-domain-matches domain uri))
|
|
collect (make-instance 'cookie
|
|
:name name
|
|
:value value
|
|
:path (or (parameter-value "path" parameters)
|
|
(uri-path uri)
|
|
"/")
|
|
:expires (and expires
|
|
(plusp (length expires))
|
|
(parse-cookie-date expires))
|
|
:domain domain
|
|
:securep (not (not (parameter-present-p "secure" parameters)))
|
|
:http-only-p (not (not (parameter-present-p "HttpOnly" parameters))))
|
|
into new-cookies
|
|
finally (return (ccase *remove-duplicate-cookies-p*
|
|
((nil) new-cookies)
|
|
((:keep-last t) (delete-duplicates new-cookies :test #'cookie=))
|
|
(:keep-first (delete-duplicates new-cookies :test #'cookie=
|
|
:from-end T))))))
|
|
|
|
(defun update-cookies (new-cookies cookie-jar)
|
|
"Updates the cookies in COOKIE-JAR by replacing those which are
|
|
equal to a cookie in \(the list) NEW-COOKIES with the corresponding
|
|
`new' cookie and adding those which are really new."
|
|
(setf (cookie-jar-cookies cookie-jar)
|
|
(let ((updated-cookies
|
|
(loop for old-cookie in (cookie-jar-cookies cookie-jar)
|
|
collect (or (find old-cookie new-cookies :test #'cookie=)
|
|
old-cookie))))
|
|
(union updated-cookies
|
|
(set-difference new-cookies updated-cookies :test #'cookie=)
|
|
:test #'cookie=)))
|
|
cookie-jar)
|
|
|
|
(defun delete-old-cookies (cookie-jar)
|
|
"Removes all cookies from COOKIE-JAR which have either expired
|
|
or which don't have an expiry date."
|
|
(setf (cookie-jar-cookies cookie-jar)
|
|
(loop with now = (get-universal-time)
|
|
for cookie in (cookie-jar-cookies cookie-jar)
|
|
for expires = (cookie-expires cookie)
|
|
unless (or (null expires) (< expires now))
|
|
collect cookie))
|
|
cookie-jar)
|