cookie.lisp

   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    (same-site :initarg :same-site
  60            :initform nil
  61            :accessor cookie-same-site
  62            :documentation "The SameSite attribute for the cookie, needs
  63 to be one of \"None\", \"Lax\" or \"Strict\". Defaults to \"None\". See
  64 <https://datatracker.ietf.org/doc/html/draft-ietf-httpbis-rfc6265bis-02#section-5.3.7>.")
  65    (secure :initarg :secure
  66            :initform nil
  67            :accessor cookie-secure
  68            :documentation "A generalized boolean denoting whether this
  69 cookie is a secure cookie.")
  70    (http-only :initarg :http-only
  71               :initform nil
  72               :accessor cookie-http-only
  73               :documentation "A generalized boolean denoting whether
  74 this cookie is a `HttpOnly' cookie.
  75
  76 This is a Microsoft extension that has been implemented in Firefox as
  77 well. See <http://msdn2.microsoft.com/en-us/library/ms533046.aspx>."))
  78   (:documentation "Each COOKIE objects describes one outgoing cookie."))
  79
  80 (defmethod initialize-instance :around ((cookie cookie) &rest init-args)
  81   "Ensure COOKIE has a correct slot-value for NAME."
  82   (let ((name (getf init-args :name)))
  83     (unless (http-token-p name)
  84       (parameter-error "~S is not a legal name for a cookie." name)))
  85   (call-next-method))
  86
  87 (defun set-cookie* (cookie &optional (reply *reply*))
  88   "Adds the COOKIE object COOKIE to the outgoing cookies of the
  89 REPLY object REPLY. If a cookie with the same name
  90 \(case-sensitive) already exists, it is replaced."
  91   (let* ((name (cookie-name cookie))
  92          (place (assoc name (cookies-out reply) :test #'string=)))
  93     (cond
  94       (place
  95         (setf (cdr place) cookie))
  96       (t
  97         (push (cons name cookie) (cookies-out reply))
  98         cookie))))
  99
 100 (defun set-cookie (name &key (value "") expires max-age path domain same-site secure http-only (reply *reply*))
 101   "Creates a cookie object from the parameters provided and adds
 102 it to the outgoing cookies of the REPLY object REPLY. If a cookie
 103 with the name NAME \(case-sensitive) already exists, it is
 104 replaced."
 105   (set-cookie* (make-instance 'cookie
 106                               :name name
 107                               :value value
 108                               :expires expires
 109                               :max-age max-age
 110                               :path path
 111                               :domain domain
 112                               :same-site same-site
 113                               :secure secure
 114                               :http-only http-only)
 115                reply))
 116
 117 (defun cookie-date (universal-time)
 118   "Converts UNIVERSAL-TIME to cookie date format."
 119   (and universal-time
 120        (rfc-1123-date universal-time)))
 121
 122 (defmethod stringify-cookie ((cookie cookie))
 123   "Converts the COOKIE object COOKIE to a string suitable for a
 124 'Set-Cookie' header to be sent to the client."
 125   (format nil
 126           "~A=~A~@[; Expires=~A~]~@[; Max-Age=~A~]~@[; Domain=~A~]~@[; Path=~A~]~@[; SameSite=~A~]~:[~;; Secure~]~:[~;; HttpOnly~]"
 127           (cookie-name cookie)
 128           (cookie-value cookie)
 129           (cookie-date (cookie-expires cookie))
 130           (cookie-max-age cookie)
 131           (cookie-domain cookie)
 132           (cookie-path cookie)
 133           (cookie-same-site cookie)
 134           (cookie-secure cookie)
 135           (cookie-http-only cookie)))