cookie.lisp

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