Fixing typo: surce => sure
[hunchentoot.git] / cookie.lisp
blob931531649472eac739dc47b518e3dcefa5a7c0f5
1 ;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: HUNCHENTOOT; Base: 10 -*-
3 ;;; Copyright (c) 2004-2010, Dr. Edmund Weitz. All rights reserved.
5 ;;; Redistribution and use in source and binary forms, with or without
6 ;;; modification, are permitted provided that the following conditions
7 ;;; are met:
9 ;;; * Redistributions of source code must retain the above copyright
10 ;;; notice, this list of conditions and the following disclaimer.
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.
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.
29 (in-package :hunchentoot)
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.
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."))
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))
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))
91 (push (cons name cookie) (cookies-out reply))
92 cookie))))
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))
110 (defun cookie-date (universal-time)
111 "Converts UNIVERSAL-TIME to cookie date format."
112 (and universal-time
113 (rfc-1123-date universal-time)))
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)))