Index: cookie.scm
==================================================================
--- cookie.scm
+++ cookie.scm
@@ -42,211 +42,216 @@
;; The parser also supports the old Netscape spec
;; <http://www.netscape.com/newsref/std/cookie_spec.html>
(declare (unit cookie))
(require-extension srfi-1 srfi-13 srfi-14 regex)
-(declare (export parse-cookie-string construct-cookie-string))
-
-#>
-#include <time.h>
-<#
-
-(define fmt-time
- (foreign-lambda* c-string ((long secs_since_epoch))
- "static char buf[256];"
- "time_t t = (time_t) secs_since_epoch;"
- "strftime(buf, sizeof(buf), \"%a, %d-%b-%Y %H:%M:%S GMT\", gmtime(&t));"
- "return(buf);"))
-
-;; utility fn. breaks ``attr=value;attr=value ... '' into alist.
-;; version is a cookie version. if version>0, we allow comma as the
-;; delimiter as well as semicolon.
-(define (parse-av-pairs input version)
- (define attr-regexp
- (if (= version 0)
- (regexp "\\s*([\\w$_-]+)\\s*([=\\;]\\s*)?")
- (regexp "\\s*([\\w$_-]+)\\s*([=\\;,]\\s*)?")))
- (define attr-delim
- (if (= version 0) #\; (char-set #\, #\\ #\;)))
-
- (define (read-attr input r)
- (cond ((string-null? input) (reverse! r))
- ((string-search attr-regexp input)
- => (lambda (m)
- (if (and-let* ((delimiter (third m))) ;;is an attr_value pai
- (string-prefix? "=" delimiter))
- (let ((attr (second m))
- (rest (string-search-after attr-regexp input)))
- (if (string-prefix? "\"" rest)
- (read-token-quoted attr (string-drop rest 1) r)
- (read-token attr rest r)))
- (read-attr (string-search-after attr-regexp input) ;; Skip ahead if broken input?
- (alist-cons (second m) #f r)))))
- (else
- ;; the input is broken; for now, we ignore the rest.
- (reverse! r))))
- (define (read-token attr input r)
- (cond ((string-index input attr-delim)
- => (lambda (i)
- (read-attr (string-drop input (+ i 1))
- (alist-cons attr
- (string-trim-right (string-take input i))
- r))))
- (else
- (reverse! (alist-cons attr (string-trim-right input) r)))))
- (define (read-token-quoted attr input r)
- (let loop ((input input)
- (partial '()))
- (cond ((string-index input (char-set #\\ #\"))
- => (lambda (i)
- (let ((c (string-ref input i)))
- (if (char=? c #\\)
- (if (< (string-length input) (+ i 1))
- (error-unterminated attr)
- (loop (string-drop input (+ i 2))
- (cons* (string (string-ref input (+ i 1)))
- (string-take input i)
- partial)))
- (read-attr (string-drop input (+ i 1))
- (alist-cons attr
- (string-concatenate-reverse
- (cons (string-take input i)
- partial))
- r))))))
- (else (error-unterminated attr)))))
- (define (error-unterminated attr)
- (error "Unterminated quoted value given for attribute" attr))
-
- (read-attr input '()))
-
-;; Parses the header value of "Cookie" request header.
-;; If cookie version is known by "Cookie2" request header, it should
-;; be passed to version (as integer). Otherwise, it figures out
-;; the cookie version from input.
-;;
-;; Returns the following format.
-;; ((<name> <value> [:path <path>] [:domain <domain>] [:port <port>])
-;; ...)
-
-(define (parse-cookie-string input #!optional version)
- (let ((ver (cond ((integer? version) version)
- ((string-search "^\\s*\\$Version\\s*=\\s*(\\d+)" input)
- => (lambda (m)
- (string->number (cadr m))))
- (else 0))))
- (let loop ((av-pairs (parse-av-pairs input ver))
- (r '())
- (current '()))
- (cond ((null? av-pairs)
- (if (null? current)
- (reverse r)
- (reverse (cons (reverse current) r))))
- ((string-ci=? "$path" (caar av-pairs))
- (loop (cdr av-pairs) r (cons* (cdar av-pairs) path: current)))
- ((string-ci=? "$domain" (caar av-pairs))
- (loop (cdr av-pairs) r (cons* (cdar av-pairs) domain: current)))
- ((string-ci=? "$port" (caar av-pairs))
- (loop (cdr av-pairs) r (cons* (cdar av-pairs) port: current)))
- (else
- (if (null? current)
- (loop (cdr av-pairs) r (list (cdar av-pairs) (caar av-pairs)))
- (loop (cdr av-pairs)
- (cons (reverse current) r)
- (list (cdar av-pairs) (caar av-pairs)))))))))
-
-;; Construct a cookie string suitable for Set-Cookie or Set-Cookie2 header.
-;; specs is the following format.
-;;
-;; ((<name> <value> [:comment <comment>] [:comment-url <comment-url>]
-;; [:discard <bool>] [:domain <domain>]
-;; [:max-age <age>] [:path <value>] [:port <port-list>]
-;; [:secure <bool>] [:version <version>] [:expires <date>]
-;; ) ...)
-;;
-;; Returns a list of cookie strings for each <name>=<value> pair. In the
-;; ``new cookie'' implementation, you can join them by comma and send it
-;; at once with Set-cookie2 header. For the old netscape protocol, you
-;; must send each of them by Set-cookie header.
-
-
-(define (construct-cookie-string specs #!optional (version 1))
- (map (lambda (spec) (construct-cookie-string-1 spec version))
- specs))
-
-(define (construct-cookie-string-1 spec ver)
- (when (< (length spec) 2)
- (error "bad cookie spec: at least <name> and <value> required" spec))
- (let ((name (car spec))
- (value (cadr spec)))
- (let loop ((attr (cddr spec))
- (r (list (if value
- (string-append name "="
- (quote-if-needed value))
- name))))
- (define (next s) (loop (cddr attr) (cons s r)))
- (define (ignore) (loop (cddr attr) r))
- (cond
- ((null? attr) (string-join (reverse r) ";"))
- ((null? (cdr attr))
- (error (conc "bad cookie spec: attribute " (car attr) " requires value" )))
- ((eqv? comment: (car attr))
- (if (> ver 0)
- (next (string-append "Comment=" (quote-if-needed (cadr attr))))
- (ignore)))
- ((eqv? comment-url: (car attr))
- (if (> ver 0)
- (next (string-append "CommentURL=" (quote-value (cadr attr))))
- (ignore)))
- ((eqv? discard: (car attr))
- (if (and (> ver 0) (cadr attr)) (next "Discard") (ignore)))
- ((eqv? domain: (car attr))
- (next (string-append "Domain=" (cadr attr))))
- ((eqv? max-age: (car attr))
- (if (> ver 0)
- (next (sprintf "Max-Age=~a" (cadr attr)))
- (ignore)))
- ((eqv? path: (car attr))
- (next (string-append "Path=" (quote-if-needed (cadr attr)))))
- ((eqv? port: (car attr))
- (if (> ver 0)
- (next (string-append "Port=" (quote-value (cadr attr))))
- (ignore)))
- ((eqv? secure: (car attr))
- (if (cadr attr) (next "Secure") (ignore)))
- ((eqv? version: (car attr))
- (if (> ver 0)
- (next (sprintf "Version=~a" (cadr attr)))
- (ignore)))
- ((eqv? expires: (car attr))
- (if (> ver 0)
- (ignore)
- (next (make-expires-attr (cadr attr)))))
- (else (error "Unknown cookie attribute" (car attr))))
- ))
- )
-
-
-;; (define (quote-value value)
-;; (string-append "\"" (regexp-replace-all #/\"|\\/ value "\\\\\\0") "\""))
-
-(define (quote-value value)
- (string-append "\"" (string-substitute* value '(("\\\"" . "\\\"") ("\\\\" . "\\\\"))) "\""))
-
-(define quote-if-needed
- (let ((rx (regexp "[\\\",;\\\\ \\t\\n]")))
- (lambda (value)
- (if (string-search rx value)
- (quote-value value)
- value))))
-
-(define (make-expires-attr time)
- (sprintf "Expires=~a"
- (if (number? time)
- (fmt-time time)
- time)))
-
-;;;; Added support functions from my utils, split this out
-
-(define (string-search-after r s #!optional (start 0))
- (and-let* ((match-indices (string-search-positions r s start))
- (right-match (second (first match-indices))))
- (substring s right-match)))
+;; (use srfi-1 srfi-13 srfi-14 regex)
+;; (declare (export parse-cookie-string construct-cookie-string))
+
+;; #>
+;; #include <time.h>
+;; <#
+;;
+;; (define fmt-time
+;; (foreign-lambda* c-string ((long secs_since_epoch))
+;; "static char buf[256];"
+;; "time_t t = (time_t) secs_since_epoch;"
+;; "strftime(buf, sizeof(buf), \"%a, %d-%b-%Y %H:%M:%S GMT\", gmtime(&t));"
+;; "return(buf);"))
+;;
+
+(define (fmt-time seconds)
+ (time->string (seconds->utc-time seconds) "%D"))
+
+ ;; utility fn. breaks ``attr=value;attr=value ... '' into alist.
+ ;; version is a cookie version. if version>0, we allow comma as the
+ ;; delimiter as well as semicolon.
+ (define (parse-av-pairs input version)
+ (define attr-regexp
+ (if (= version 0)
+ (regexp "\\s*([\\w$_-]+)\\s*([=\\;]\\s*)?")
+ (regexp "\\s*([\\w$_-]+)\\s*([=\\;,]\\s*)?")))
+ (define attr-delim
+ (if (= version 0) #\; (char-set #\, #\\ #\;)))
+
+ (define (read-attr input r)
+ (cond ((string-null? input) (reverse! r))
+ ((string-search attr-regexp input)
+ => (lambda (m)
+ (if (and-let* ((delimiter (third m))) ;;is an attr_value pai
+ (string-prefix? "=" delimiter))
+ (let ((attr (second m))
+ (rest (string-search-after attr-regexp input)))
+ (if (string-prefix? "\"" rest)
+ (read-token-quoted attr (string-drop rest 1) r)
+ (read-token attr rest r)))
+ (read-attr (string-search-after attr-regexp input) ;; Skip ahead if broken input?
+ (alist-cons (second m) #f r)))))
+ (else
+ ;; the input is broken; for now, we ignore the rest.
+ (reverse! r))))
+ (define (read-token attr input r)
+ (cond ((string-index input attr-delim)
+ => (lambda (i)
+ (read-attr (string-drop input (+ i 1))
+ (alist-cons attr
+ (string-trim-right (string-take input i))
+ r))))
+ (else
+ (reverse! (alist-cons attr (string-trim-right input) r)))))
+ (define (read-token-quoted attr input r)
+ (let loop ((input input)
+ (partial '()))
+ (cond ((string-index input (char-set #\\ #\"))
+ => (lambda (i)
+ (let ((c (string-ref input i)))
+ (if (char=? c #\\)
+ (if (< (string-length input) (+ i 1))
+ (error-unterminated attr)
+ (loop (string-drop input (+ i 2))
+ (cons* (string (string-ref input (+ i 1)))
+ (string-take input i)
+ partial)))
+ (read-attr (string-drop input (+ i 1))
+ (alist-cons attr
+ (string-concatenate-reverse
+ (cons (string-take input i)
+ partial))
+ r))))))
+ (else (error-unterminated attr)))))
+ (define (error-unterminated attr)
+ (error "Unterminated quoted value given for attribute" attr))
+
+ (read-attr input '()))
+
+ ;; Parses the header value of "Cookie" request header.
+ ;; If cookie version is known by "Cookie2" request header, it should
+ ;; be passed to version (as integer). Otherwise, it figures out
+ ;; the cookie version from input.
+ ;;
+ ;; Returns the following format.
+ ;; ((<name> <value> [:path <path>] [:domain <domain>] [:port <port>])
+ ;; ...)
+
+ (define (parse-cookie-string input #!optional version)
+ (let ((ver (cond ((integer? version) version)
+ ((string-search "^\\s*\\$Version\\s*=\\s*(\\d+)" input)
+ => (lambda (m)
+ (string->number (cadr m))))
+ (else 0))))
+ (let loop ((av-pairs (parse-av-pairs input ver))
+ (r '())
+ (current '()))
+ (cond ((null? av-pairs)
+ (if (null? current)
+ (reverse r)
+ (reverse (cons (reverse current) r))))
+ ((string-ci=? "$path" (caar av-pairs))
+ (loop (cdr av-pairs) r (cons* (cdar av-pairs) path: current)))
+ ((string-ci=? "$domain" (caar av-pairs))
+ (loop (cdr av-pairs) r (cons* (cdar av-pairs) domain: current)))
+ ((string-ci=? "$port" (caar av-pairs))
+ (loop (cdr av-pairs) r (cons* (cdar av-pairs) port: current)))
+ (else
+ (if (null? current)
+ (loop (cdr av-pairs) r (list (cdar av-pairs) (caar av-pairs)))
+ (loop (cdr av-pairs)
+ (cons (reverse current) r)
+ (list (cdar av-pairs) (caar av-pairs)))))))))
+
+ ;; Construct a cookie string suitable for Set-Cookie or Set-Cookie2 header.
+ ;; specs is the following format.
+ ;;
+ ;; ((<name> <value> [:comment <comment>] [:comment-url <comment-url>]
+ ;; [:discard <bool>] [:domain <domain>]
+ ;; [:max-age <age>] [:path <value>] [:port <port-list>]
+ ;; [:secure <bool>] [:version <version>] [:expires <date>]
+ ;; ) ...)
+ ;;
+ ;; Returns a list of cookie strings for each <name>=<value> pair. In the
+ ;; ``new cookie'' implementation, you can join them by comma and send it
+ ;; at once with Set-cookie2 header. For the old netscape protocol, you
+ ;; must send each of them by Set-cookie header.
+
+
+ (define (construct-cookie-string specs #!optional (version 1))
+ (map (lambda (spec) (construct-cookie-string-1 spec version))
+ specs))
+
+ (define (construct-cookie-string-1 spec ver)
+ (when (< (length spec) 2)
+ (error "bad cookie spec: at least <name> and <value> required" spec))
+ (let ((name (car spec))
+ (value (cadr spec)))
+ (let loop ((attr (cddr spec))
+ (r (list (if value
+ (string-append name "="
+ (quote-if-needed value))
+ name))))
+ (define (next s) (loop (cddr attr) (cons s r)))
+ (define (ignore) (loop (cddr attr) r))
+ (cond
+ ((null? attr) (string-join (reverse r) ";"))
+ ((null? (cdr attr))
+ (error (conc "bad cookie spec: attribute " (car attr) " requires value" )))
+ ((eqv? comment: (car attr))
+ (if (> ver 0)
+ (next (string-append "Comment=" (quote-if-needed (cadr attr))))
+ (ignore)))
+ ((eqv? comment-url: (car attr))
+ (if (> ver 0)
+ (next (string-append "CommentURL=" (quote-value (cadr attr))))
+ (ignore)))
+ ((eqv? discard: (car attr))
+ (if (and (> ver 0) (cadr attr)) (next "Discard") (ignore)))
+ ((eqv? domain: (car attr))
+ (next (string-append "Domain=" (cadr attr))))
+ ((eqv? max-age: (car attr))
+ (if (> ver 0)
+ (next (sprintf "Max-Age=~a" (cadr attr)))
+ (ignore)))
+ ((eqv? path: (car attr))
+ (next (string-append "Path=" (quote-if-needed (cadr attr)))))
+ ((eqv? port: (car attr))
+ (if (> ver 0)
+ (next (string-append "Port=" (quote-value (cadr attr))))
+ (ignore)))
+ ((eqv? secure: (car attr))
+ (if (cadr attr) (next "Secure") (ignore)))
+ ((eqv? version: (car attr))
+ (if (> ver 0)
+ (next (sprintf "Version=~a" (cadr attr)))
+ (ignore)))
+ ((eqv? expires: (car attr))
+ (if (> ver 0)
+ (ignore)
+ (next (make-expires-attr (cadr attr)))))
+ (else (error "Unknown cookie attribute" (car attr))))
+ ))
+ )
+
+
+ ;; (define (quote-value value)
+ ;; (string-append "\"" (regexp-replace-all #/\"|\\/ value "\\\\\\0") "\""))
+
+ (define (quote-value value)
+ (string-append "\"" (string-substitute* value '(("\\\"" . "\\\"") ("\\\\" . "\\\\"))) "\""))
+
+ (define quote-if-needed
+ (let ((rx (regexp "[\\\",;\\\\ \\t\\n]")))
+ (lambda (value)
+ (if (string-search rx value)
+ (quote-value value)
+ value))))
+
+ (define (make-expires-attr time)
+ (sprintf "Expires=~a"
+ (if (number? time)
+ (fmt-time time)
+ time)))
+
+ ;;;; Added support functions from my utils, split this out
+
+ (define (string-search-after r s #!optional (start 0))
+ (and-let* ((match-indices (string-search-positions r s start))
+ (right-match (second (first match-indices))))
+ (substring s right-match)))
Index: tests/test.scm
==================================================================
--- tests/test.scm
+++ tests/test.scm
@@ -15,11 +15,11 @@
(import (prefix sqlite3 sqlite3:))
(require-library dbi)
(load "./requirements.scm")
-(load "./cookie.so")
+(load "./cookie.scm")
(load "./misc-stml.scm")
(load "./formdat.scm")
(load "./stml.scm")
(load "./session.scm")
(load "./sqltbl.scm")