(define-module(www server-utils cookies)#:export(rfc2109-set-cookie-string simple-parse-cookies rfc2965-set-cookie2-tree rfc2965-parse-cookie-header-value reach)#:use-module((srfi srfi-13)#:select((substring/shared . subs) string-tokenize string-trim-both string-index string-take string-drop))#:use-module((srfi srfi-14)#:select(char-set-complement char-set))#:use-module(ice-9 optargs))
(define (fs s . args)(apply simple-format #f s args))
(define*(rfc2109-set-cookie-string name value #:key(path #f)(domain #f)(expires #f)(secure #f))(fs "Set-Cookie: ~A=~A~A~A~A~A"(if(keyword? name)(keyword->symbol name)name)(if(keyword? value)(keyword->symbol value)value)(if path(fs "; path=~A" path)"")(if domain(fs "; domain=~A" domain)"")(if expires(fs "; expires=~A" expires)"")(if secure "; secure" "")))
(define sep-cs(let((cache `((#\, unquote(char-set-complement(char-set #\,))))))(lambda(sep)(or(assq-ref cache sep)(let((cs(char-set-complement(char-set sep))))(set! cache(acons sep cs cache))cs)))))
(define*(simple-parse-cookies string #:optional sep)(define(paired clean)(let((pos(string-index clean #\=)))(cons(string-take clean pos)(string-drop clean(#{1+}# pos)))))(map paired(map string-trim-both(string-tokenize string(sep-cs(or sep #\,))))))
(define *attribute-names*(map(lambda(kw)(cons kw(symbol->string(keyword->symbol kw)))) '(#:Comment #:CommentURL #:Discard #:Domain #:Max-Age #:Path #:Port #:Secure)))
(define (rfc2965-set-cookie2-tree M . cookie-specs)(define(csep q proc init)(if(pair? init)(let*((ls(map proc init))(rv(list(car ls)))(tp rv))(define(ok x)(set! tp(append!(last-pair tp)x)))(and q(set! rv(cons q rv)))(let loop((ls(cdr ls)))(cond((null? ls)(and q(ok(list q))))(else(ok(list ","(car ls)))(loop(cdr ls)))))rv)init))(define(pair<- x y)(list x "="(if(pair? y)y(fs "\"~A\"" y))))(define (tree<- name value . more)(let*((rv(pair<-(cond((keyword? name)(symbol->string(keyword->symbol name)))((string? name)name)((symbol? name)(symbol->string name))(else(error "bad name:" name)))value))(tp rv))(define(ok x)(set! tp(append!(last-pair tp)(cons ";" x))))(let loop((ls more))(or(null? ls)(let*((attr(car ls))(aname(or(assq-ref *attribute-names* attr)(error "invalid attribute:" attr))))(define(okv value)(ok(pair<- aname value)))(case attr((#:Discard #:Secure)(ok(list aname))(loop(cdr ls)))((#:Max-Age)(ok(list aname "="(number->string(cadr ls))))(loop(cddr ls)))((#:Port)(let*((ports(and(not(null?(cdr ls)))(cadr ls)))(none?(or(not ports)(keyword? ports))))(if none?(ok(list aname))(okv(csep "\"" number->string(if(pair? ports)ports(list ports)))))(loop((if none? cdr cddr)ls))))(else(okv(cadr ls))(loop(cddr ls)))))))(ok(list "Version=1"))rv))(let((hname #:Set-Cookie2)(hval(csep #f(lambda(c)(apply tree<- c))cookie-specs)))(if M(M #:add-header hname hval)(cons hname hval))))
(define (rfc2965-parse-cookie-header-value s . flags)(let*((as-is?(memq #:keep-attribute-dollarsign-prefix flags))(strict?(memq #:strict-comma-separator flags))(canon?(memq #:canonicalize-NAME-as-keyword flags))(len(string-length s))(rv(list 0))(tp rv)(context '())(pos 0))(define(context! x)(set! context(cons x context)))(define(context- v)(set! context(cdr context))v)(define(err! blurb)(error(fs "~A while ~A~%~A~%~A^" blurb(car context)s(make-string pos #\space))))(define(sw!)(and(char=? #\space(string-ref s pos))(begin(set! pos(#{1+}# pos))(sw!))))(define(fc!)(set! pos(#{1+}# pos))(or(< pos len)(err! "unexpected end")))(define(fc!/nocheck)(set! pos(#{1+}# pos)))(define(read-string)(context! "reading string")(fc!)(let((start pos))(let loop((c(string-ref s pos)))(if(char=? #\" c)(let((rv(subs s start pos)))(fc!/nocheck)(context- rv))(loop(string-ref s(begin(fc!)pos)))))))(define(->kw x)(symbol->keyword(string->symbol(let*((new(string-downcase x))(first-letter(if(char=? #\$(string-ref new 0))1 0)))(define(up! i)(string-set! new i(char-upcase(string-ref new i))))(up! first-letter)(let loop((i(#{1+}# first-letter)))(cond((string-index new #\- i)=>(lambda(hyphen)(up!(#{1+}# hyphen))(loop(+ 2 hyphen))))))new))))(define(read-token munge)(context! "reading token")(sw!)(let((return(or munge identity))(start pos)(last-pos(#{1-}# len)))(let loop((c(string-ref s pos)))(cond((= pos last-pos)(let((rv(subs s start len)))(fc!/nocheck)(context-(return rv))))((memq c '(#\= #\; #\, #\space #\tab))(let((rv(subs s start pos)))(context-(return rv))))(else(loop(string-ref s(begin(fc!)pos))))))))(define(read-pair one-munge)(context! "reading pair")(let((one(read-token one-munge))(expected-sep(if(begin(sw!)(char=? #\=(string-ref s pos)))(fc!)(err! "missing equal-sign")))(two(let((c(begin(sw!)(string-ref s pos))))(case c((#\")(read-string))(else(read-token #f))))))(context-(list one two))))(define(portlist s)(let loop((b 0)(acc '()))(let sw()(and(char=? #\space(string-ref s b))(begin(set! b(#{1+}# b))(sw))))(cond((string-index s #\, b)=>(lambda(e)(loop(#{1+}# e)(cons(string->number(subs s b e))acc))))(else(let((ls(reverse!(cons(string->number(subs s b))acc))))(if(= 1(length ls))(car ls)ls))))))(define(read-one-cookie)(context! "reading one cookie")(let*((first-pair(read-pair #f))(rv first-pair)(tp rv))(define(another!)(and(< pos len)(char=? #\;(string-ref s pos))(fc!)(let((opos pos)(p(read-pair ->kw)))(and(< pos len)(sw!))(cond((assq-ref '((#:$Path . #:Path) (#:$Domain . #:Domain) (#:$Port . #:Port))(car p))=>(lambda(recognized)(if as-is? p(cons recognized(let((rest(cdr p)))(if(eq? #:Port recognized)(list(portlist(car rest)))rest))))))(else(set! pos opos)(if strict?(err! "bad attribute")#f))))))(let loop((more(another!)))(cond(more(set! tp(append!(last-pair tp)more))(loop(another!)))))(context- rv)))(context! "parsing")(let((vers(let((start pos)(p(read-pair ->kw)))(cond((eq? #:$Version(car p))(string->number(cadr p)))(else(set! pos start)0)))))(define(more!)(and(< pos len)(begin(and(char=? #\,(string-ref s pos))(fc!))(read-one-cookie))))(sw!)(or(char=? #\;(string-ref s pos))(err! "missing semicolon"))(fc!)(let loop((cspec(more!)))(cond(cspec(set-car! rv(#{1+}#(car rv)))(and canon?(set-car! cspec(->kw(car cspec))))(set! tp(append!(last-pair tp)(list cspec)))(loop(more!)))))(context-(cons vers rv)))))
(define(reach h)(define(dot s)(string-index s #\.))(or(and=>(dot h)(lambda(pos)(and(not(dot(subs h 0 pos)))(let((b(subs h(#{1+}# pos))))(and(or(string=? "local" b)(dot b))(subs h pos))))))h))
