1;;;
2;;; cookie.scm - parse and construct http state information
3;;;
4;;;   Copyright (c) 2000-2020  Shiro Kawai  <shiro@acm.org>
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;;;   1. Redistributions of source code must retain the above copyright
11;;;      notice, this list of conditions and the following disclaimer.
12;;;
13;;;   2. Redistributions in binary form must reproduce the above copyright
14;;;      notice, this list of conditions and the following disclaimer in the
15;;;      documentation and/or other materials provided with the distribution.
16;;;
17;;;   3. Neither the name of the authors nor the names of its contributors
18;;;      may be used to endorse or promote products derived from this
19;;;      software without specific prior written permission.
20;;;
21;;;   THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
22;;;   "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
23;;;   LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
24;;;   A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
25;;;   OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
26;;;   SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED
27;;;   TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
28;;;   PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
29;;;   LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
30;;;   NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
31;;;   SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
32;;;
33
34;; Parser and constructor of http "Cookies" defined in
35;; RFC 6265 HTTP state managemnet mechanism
36;;   http://tools.ietf.org/html/rfc6265
37;; See also
38;; RFC 2964 Use of HTTP state management
39;;   <ftp://ftp.isi.edu/in-notes/rfc2964.txt>
40;; The parser also supports the old Netscape spec
41;;   <http://www.netscape.com/newsref/std/cookie_spec.html>
42
43(define-module rfc.cookie
44  (use srfi-1)
45  (use srfi-13)
46  (use srfi-19)
47  (export parse-cookie-string
48          construct-cookie-string
49          )
50  )
51(select-module rfc.cookie)
52
53;;==============================================================
54;; Cookie header parser and constructor
55;; These are mainly used by the server side.
56;;
57
58;; utility fn.  breaks  ``attr=value;attr=value ... '' into alist.
59;; version is a cookie version.  if version>0, we allow comma as the
60;; delimiter as well as semicolon.
61(define (parse-av-pairs input version)
62  (define attr-regexp
63    (if (= version 0)
64      #/\s*([\w$_.-]+)\s*([=\;]\s*)?/
65      #/\s*([\w$_.-]+)\s*([=\;,]\s*)?/))
66  (define attr-delim
67    (if (= version 0) #\; #[,\;]))
68
69  (define (read-attr input r)
70    (cond [(string-null? input) (reverse! r)]
71          [(rxmatch attr-regexp input)
72           => (^m (if (and-let* ([delimiter (rxmatch-substring m 2)])
73                        (string-prefix? "=" delimiter))
74                    (let ([attr (rxmatch-substring m 1)]
75                          [rest (rxmatch-after m)])
76                      (if (string-prefix? "\"" rest)
77                        (read-token-quoted attr (string-drop rest 1) r)
78                        (read-token attr rest r)))
79                    (read-attr (rxmatch-after m)
80                               (acons (rxmatch-substring m 1) #f r))))]
81          [else
82           ;; the input is broken; for now, we ignore the rest.
83           (reverse! r)]))
84  (define (read-token attr input r)
85    (cond [(string-index input attr-delim)
86           => (^i (read-attr (string-drop input (+ i 1))
87                             (acons attr
88                                    (string-trim-right (string-take input i))
89                                    r)))]
90          [else
91           (reverse! (acons attr (string-trim-right input) r))]))
92  (define (read-token-quoted attr input r)
93    (let loop ([input input]
94               [partial '()])
95      (cond ([string-index input #[\\\"]]
96             => (^i (let1 c (string-ref input i)
97                      (if (char=? c #\\)
98                        (if (< (string-length input) (+ i 1))
99                          (error-unterminated attr)
100                          (loop (string-drop input (+ i 2))
101                                (list* (string (string-ref input (+ i 1)))
102                                       (string-take input i)
103                                       partial)))
104                        (read-attr (string-drop input (+ i 1))
105                                   (acons attr
106                                          (string-concatenate-reverse
107                                           (cons (string-take input i)
108                                                 partial))
109                                          r))))))
110            [else (error-unterminated attr)])))
111  (define (error-unterminated attr)
112    (error "Unterminated quoted value given for attribute" attr))
113
114  (read-attr input '()))
115
116;; Parses the header value of "Cookie" request header.
117;; If cookie version is known by "Cookie2" request header, it should
118;; be passed to version (as integer).  Otherwise, it figures out
119;; the cookie version from input.
120;;
121;; Returns the following format.
122;;   ((<name> <value> [:path <path>] [:domain <domain>] [:port <port>])
123;;    ...)
124
125(define (parse-cookie-string input . version)
126  (let1 ver (cond [(and (pair? version) (integer? (car version)))
127                   (car version)]
128                  [(rxmatch #/^\s*$Version\s*=\s*(\d+)/ input)
129                   => (^m (string->number (rxmatch-substring m 1)))]
130                  [else 0])
131    (let loop ([av-pairs (parse-av-pairs input ver)]
132               [r '()]
133               [current '()])
134      (cond [(null? av-pairs)
135             (if (null? current)
136               (reverse r)
137               (reverse (cons (reverse current) r)))]
138            [(string-ci=? "$path" (caar av-pairs))
139             (loop (cdr av-pairs) r (list* (cdar av-pairs) :path current))]
140            [(string-ci=? "$domain" (caar av-pairs))
141             (loop (cdr av-pairs) r (list* (cdar av-pairs) :domain current))]
142            [(string-ci=? "$port" (caar av-pairs))
143             (loop (cdr av-pairs) r (list* (cdar av-pairs) :port current))]
144            [else
145             (if (null? current)
146               (loop (cdr av-pairs) r (list (cdar av-pairs) (caar av-pairs)))
147               (loop (cdr av-pairs)
148                     (cons (reverse current) r)
149                     (list (cdar av-pairs) (caar av-pairs))))]))
150    ))
151
152;; Construct a cookie string suitable for Set-Cookie or Set-Cookie2 header.
153;; specs is the following format.
154;;
155;;   ((<name> <value> [:comment <comment>] [:comment-url <comment-url>]
156;;                    [:discard <bool>] [:domain <domain>] [:http-only <bool>]
157;;                    [:max-age <age>] [:path <value>] [:port <port-list>]
158;;                    [:secure <bool>] [:version <version>] [:expires <date>]
159;;    ) ...)
160;;
161;; Returns a list of cookie strings for each <name>=<value> pair.  In the
162;; ``new cookie'' implementation, you can join them by comma and send it
163;; at once with Set-cookie2 header.  For the old netscape protocol, you
164;; must send each of them by Set-cookie header.
165
166(define (construct-cookie-string specs . version)
167  (let1 ver (if (and (pair? version) (integer? (car version)))
168              (car version)
169              1)
170    (map (^[spec] (construct-cookie-string-1 spec ver)) specs)))
171
172(define (construct-cookie-string-1 spec ver)
173  (when (< (length spec) 2)
174    (error "bad cookie spec: at least <name> and <value> required" spec))
175  (let ([name (car spec)]
176        [value (cadr spec)])
177    (let loop ([attr (cddr spec)]
178               [r    (list (if value
179                             (string-append name "="
180                                            (quote-if-needed value))
181                             name))])
182      (define (next s) (loop (cddr attr) (cons s r)))
183      (define (ignore) (loop (cddr attr) r))
184      (cond
185       [(null? attr) (string-join (reverse r) ";")]
186       [(null? (cdr attr))
187        (errorf "bad cookie spec: attribute ~s requires value" (car attr))]
188       [(eqv? :comment (car attr))
189        (if (> ver 0)
190          (next (string-append "Comment=" (quote-if-needed (cadr attr))))
191          (ignore))]
192       [(eqv? :comment-url (car attr))
193        (if (> ver 0)
194          (next (string-append "CommentURL=" (quote-value (cadr attr))))
195          (ignore))]
196       [(eqv? :discard (car attr))
197        (if (and (> ver 0) (cadr attr)) (next "Discard") (ignore))]
198       [(eqv? :domain (car attr))
199        (next (string-append "Domain=" (cadr attr)))]
200       [(eqv? :max-age (car attr))
201        (if (> ver 0)
202          (next (format #f "Max-Age=~a" (cadr attr)))
203          (ignore))]
204       [(eqv? :path (car attr))
205        (next (string-append "Path=" (quote-if-needed (cadr attr))))]
206       [(eqv? :port (car attr))
207        (if (> ver 0)
208          (next (string-append "Port=" (quote-value (cadr attr))))
209          (ignore))]
210       [(eqv? :secure (car attr))
211        (if (cadr attr) (next "Secure") (ignore))]
212       [(eqv? :http-only (car attr))
213        (if (cadr attr) (next "HttpOnly") (ignore))]
214       [(eqv? :version (car attr))
215        (if (> ver 0)
216          (next (format #f "Version=~a" (cadr attr)))
217          (ignore))]
218       [(eqv? :expires (car attr))
219        (if (> ver 0)
220          (ignore)
221          (next (make-expires-attr (cadr attr))))]
222       [else (error "Unknown cookie attribute" (car attr))])
223      ))
224  )
225
226;; aux. function to quote value
227(define (quote-value value)
228  (string-append "\"" (regexp-replace-all #/\"|\\/ value "\\\\\\0") "\""))
229
230(define (quote-if-needed value)
231  (if (rxmatch #/[\",\;\\ \t\n]/ value)
232    (quote-value value)
233    value))
234
235(define (make-expires-attr time)
236  (define (ensure-time-string time)
237    (cond
238     [(number? time)
239      (sys-strftime "%a, %d-%b-%Y %H:%M:%S GMT" (sys-gmtime time))]
240     [(is-a? time <date>)
241      (date->string time "~a, ~d-~@b-~Y ~H:~M:~S GMT")]
242     [(is-a? time <time>)
243      (case (time-type time)
244        [(time-utc) (ensure-time-string (time-utc->date time 0))]
245        [(time-tai) (ensure-time-string (time-tai->date time 0))]
246        [(time-monotonic) (ensure-time-string (time-monotonic->date time 0))]
247        [else (errorf "Don't know how to convert a time object ~s to string."
248                      time)])]
249     [else time]))
250
251    (format #f "Expires=~a" (ensure-time-string time)))
252
253;;==============================================================
254;; Cookie-bin, a client-side storage of cookies used by <http-connection>
255;;
256
257
258;; Client-side cookie representation.
259;; Max-Age is converted to the absolute time when the cookie shall be
260;; discarded.
261; (define-class <http-cookie> ()
262;   ((name    :init-keyword :name)
263;    (value   :init-keyword :value)
264;    (domain  :init-keyword :domain)
265;    (path    :init-keyword :path)
266;    (lifetime :init-keyword :lifetime :init-value #f) ; #f or <time>
267;    (port    :init-keyword :port :init-value '())  ; list of port numbers
268;    (secure  :init-keyword :secure :init-value #f)
269;    (version :init-keyword :version :init-value 1)
270;    (comment :init-keyword :comment :init-value #f)
271;    (comment-url :init-keyword :comment-url :init-value #f)
272;    ))
273
274