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