1 ;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: HUNCHENTOOT; Base: 10 -*-
  2 
  3 ;;; Copyright (c) 2004-2010, Dr. Edmund Weitz.  All rights reserved.
  4 
  5 ;;; Redistribution and use in source and binary forms, with or without
  6 ;;; modification, are permitted provided that the following conditions
  7 ;;; are met:
  8 
  9 ;;;   * Redistributions of source code must retain the above copyright
 10 ;;;     notice, this list of conditions and the following disclaimer.
 11 
 12 ;;;   * Redistributions in binary form must reproduce the above
 13 ;;;     copyright notice, this list of conditions and the following
 14 ;;;     disclaimer in the documentation and/or other materials
 15 ;;;     provided with the distribution.
 16 
 17 ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
 18 ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
 19 ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
 20 ;;; ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
 21 ;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
 22 ;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
 23 ;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
 24 ;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
 25 ;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
 26 ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
 27 ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
 28 
 29 (in-package :hunchentoot)
 30 
 31 (defclass cookie ()
 32   ((name :initarg :name
 33          :reader cookie-name
 34          :type string
 35          :documentation "The name of the cookie - a string.")
 36    (value :initarg :value
 37           :accessor cookie-value
 38           :initform ""
 39           :documentation "The value of the cookie. Will be URL-encoded
 40 when sent to the browser.")
 41    (expires :initarg :expires
 42             :initform nil
 43             :accessor cookie-expires
 44             :documentation "The time \(a universal time) when the
 45 cookie expires \(or NIL).")
 46    (max-age :initarg :max-age
 47             :initform nil
 48             :accessor cookie-max-age
 49             :documentation "The time delta \(in seconds) after which the
 50 cookie expires \(or NIL).")
 51    (path :initarg :path
 52          :initform nil
 53          :accessor cookie-path
 54          :documentation "The path this cookie is valid for \(or NIL).")
 55    (domain :initarg :domain
 56            :initform nil
 57            :accessor cookie-domain
 58            :documentation "The domain this cookie is valid for \(or NIL).")
 59    (secure :initarg :secure
 60            :initform nil
 61            :accessor cookie-secure
 62            :documentation "A generalized boolean denoting whether this
 63 cookie is a secure cookie.")
 64    (http-only :initarg :http-only
 65               :initform nil
 66               :accessor cookie-http-only
 67               :documentation "A generalized boolean denoting whether
 68 this cookie is a `HttpOnly' cookie.
 69 
 70 This is a Microsoft extension that has been implemented in Firefox as
 71 well. See <http://msdn2.microsoft.com/en-us/library/ms533046.aspx>."))
 72   (:documentation "Each COOKIE objects describes one outgoing cookie."))
 73 
 74 (defmethod initialize-instance :around ((cookie cookie) &rest init-args)
 75   "Ensure COOKIE has a correct slot-value for NAME."
 76   (let ((name (getf init-args :name)))
 77     (unless (http-token-p name)
 78       (parameter-error "~S is not a legal name for a cookie." name)))
 79   (call-next-method))
 80 
 81 (defun set-cookie* (cookie &optional (reply *reply*))
 82   "Adds the COOKIE object COOKIE to the outgoing cookies of the
 83 REPLY object REPLY. If a cookie with the same name
 84 \(case-sensitive) already exists, it is replaced."
 85   (let* ((name (cookie-name cookie))
 86          (place (assoc name (cookies-out reply) :test #'string=)))
 87     (cond
 88       (place
 89         (setf (cdr place) cookie))
 90       (t
 91         (push (cons name cookie) (cookies-out reply))
 92         cookie))))
 93 
 94 (defun set-cookie (name &key (value "") expires max-age path domain secure http-only (reply *reply*))
 95   "Creates a cookie object from the parameters provided and adds
 96 it to the outgoing cookies of the REPLY object REPLY. If a cookie
 97 with the name NAME \(case-sensitive) already exists, it is
 98 replaced."
 99   (set-cookie* (make-instance 'cookie
100                               :name name
101                               :value value
102                               :expires expires
103                               :max-age max-age
104                               :path path
105                               :domain domain
106                               :secure secure
107                               :http-only http-only)
108                reply))
109 
110 (defun cookie-date (universal-time)
111   "Converts UNIVERSAL-TIME to cookie date format."
112   (and universal-time
113        (rfc-1123-date universal-time)))
114 
115 (defmethod stringify-cookie ((cookie cookie))
116   "Converts the COOKIE object COOKIE to a string suitable for a
117 'Set-Cookie' header to be sent to the client."
118   (format nil
119           "~A=~A~@[; Expires=~A~]~@[; Max-Age=~A~]~@[; Domain=~A~]~@[; Path=~A~]~:[~;; Secure~]~:[~;; HttpOnly~]"
120           (cookie-name cookie)
121           (cookie-value cookie)
122           (cookie-date (cookie-expires cookie))
123           (cookie-max-age cookie)
124           (cookie-domain cookie)
125           (cookie-path cookie)
126           (cookie-secure cookie)
127           (cookie-http-only cookie)))