Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Fetching contributors…

Cannot retrieve contributors at this time

316 lines (284 sloc) 14.645 kB
;;; -*- 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)
Jump to Line
Something went wrong with that request. Please try again.