suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Move 6265 code to separate pkg

Browse Source 
* Move all the new cookie code to the net-cookies package
 * Update deprecation notice on net/cookie to point to that package
This commit is contained in:
Jordan Johnson 2015-04-04 14:02:23 -07:00
parent c3ce72e229
commit b23108c4d4
10 changed files with 10 additions and 2221 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

12
net-doc/net/scribblings/cookie.scrbl
View File

@ -8,9 +8,15 @@
@title[#:tag "cookie"]{Cookie: Legacy HTTP Client Storage} @title[#:tag "cookie"]{Cookie: Legacy HTTP Client Storage}
@deprecated[@racketmodname[net/cookies/server]]{ @deprecated[@hyperlink["http://pkgs.racket-lang.org/#[net-cookies]"]{the
The new @secref["cookies" #:doc '(lib "net/scribblings/net.scrbl")] net-cookies package}]{
library implements RFC 6265, which supersedes the obsolete RFC 2109.} That package
(@hyperlink["https://github.com/RenaissanceBug/racket-cookies"]{source on
GitHub})
implements RFC 6265 @cite["RFC6265"] (which
supersedes RFC 2109) and supports creating cookies on the server
in an idiom more typical of Racket.
}
@defmodule[net/cookie]{The @racketmodname[net/cookie] library provides @defmodule[net/cookie]{The @racketmodname[net/cookie] library provides
utilities for using cookies as specified in RFC 2109 @cite["RFC2109"].} utilities for using cookies as specified in RFC 2109 @cite["RFC2109"].}

458
net-doc/net/scribblings/cookies.scrbl
View File

@ -1,458 +0,0 @@
#lang scribble/doc
@(require "common.rkt" scribble/manual scribble/eval
(for-label racket/class
net/cookies/server
net/cookies/user-agent
net/url
net/head
web-server/http/request-structs
))
@(define cookies-server-eval (make-base-eval))
@interaction-eval[#:eval cookies-server-eval
(require net/cookies/server)]
@title[#:tag "cookies"]{Cookies: HTTP State Management}
@author[(author+email "Jordan Johnson" "jmj@fellowhuman.com")]
This library provides utilities for handling cookies as specified
in RFC 6265 @cite["RFC6265"].
@; ------------------------------------------
@section[#:tag "cookies-common-procs"]{Cookies: Common Functionality}
@defmodule[net/cookies/common]{The @racketmodname[net/cookies/common] library
contains cookie-related code common to servers and user agents.
}
@defproc[(cookie-name? [v any/c]) boolean?]{
Returns @racket[#t] if @racket[v] is a valid cookie name (represented as
a string or a byte string), @racket[#f] otherwise.
Cookie names must consist of ASCII characters. They may not contain
control characters (ASCII codes 0-31 or 127) or the following ``separators'':
@itemlist[@item{double quotes}
@item{whitespace characters}
@item{@racket[#\@] or @racket[#\?]}
@item{parentheses, brackets, or curly braces}
@item{commas, colons, or semicolons}
@item{equals, greater-than, or less-than signs}
@item{slashes or backslashes}]
}
@defproc[(cookie-value? [v any/c]) boolean?]{
Returns @racket[#t] if @racket[v] is a valid cookie value (represented as
a string or byte string), @racket[#f] otherwise.
Cookie values must consist of ASCII characters. They may not contain:
@itemlist[@item{control characters}
@item{whitespace characters}
@item{double-quotes, except at the beginning and end if the entire
value is double-quoted}
@item{commas}
@item{semicolons}
@item{backslashes}]
}
@defproc[(path/extension-value? [v any/c])
boolean?]{
Returns @racket[#t] iff @racket[v] is a string that can be used as the value
of a ``Path='' attribute, or as an additional attribute (or attribute/value
pair) whose meaning is not specified by RFC6265.
}
@defproc[(domain-value? [v any/c])
boolean?]{
Returns @racket[#t] iff @racket[v] is a string that contains a (sub)domain
name, as defined by RFCs 1034 (Section 3.5) @cite["RFC1034"] and 1123
(Section 2.1) @cite["RFC1123"].
}
@; ------------------------------------------
@section[#:tag "cookies-server-procs"]{Cookies and HTTP Servers}
@defmodule[net/cookies/server]{The @racketmodname[net/cookies/server] library
is for handling cookies on the server end; it includes:
@itemlist[@item{a serializable @racket[cookie] structure definition}
@item{functions to convert a cookie structure to a string, or
a value for the HTTP ``Set-Cookie'' response header}
@item{functions that allow reading an HTTP ``Cookie'' header
generated by a user agent}]
}
@defstruct[cookie ([name (and/c string? cookie-name?)]
[value (and/c string? cookie-value?)]
[expires (or/c date? #f)]
[max-age (or/c (and/c integer? positive?) #f)]
[domain (or/c domain-value? #f)]
[path (or/c path/extension-value? #f)]
[secure? boolean?]
[http-only? boolean?]
[extension (or/c path/extension-value? #f)])
#:omit-constructor]{
A structure type for cookies the server will send to the user agent. For
client-side cookies, see @racketmodname[net/cookies/user-agent].
}
@defproc[(make-cookie [name cookie-name?]
[value cookie-value?]
[#:expires exp-date (or/c date? #f) #f]
[#:max-age max-age (or/c (and/c integer? positive?) #f)
#f]
[#:domain domain (or/c domain-value? #f) #f]
[#:path path (or/c path/extension-value? #f) #f]
[#:secure? secure? boolean? #f]
[#:http-only? http-only? boolean? #f]
[#:extension extension (or/c path/extension-value? #f)
#f])
cookie?]{
Constructs a cookie for sending to a user agent.
Both @racket[exp-date] and @racket[max-age] are for specifying a time at which
the user agent should remove the cookie from its cookie store.
@racket[exp-date] is for specifying this expiration time as a date;
@racket[max-age] is for specifying it as a number of seconds in the future.
If both @racket[exp-date] and @racket[max-age] are given, an RFC6265-compliant
user agent will disregard the @racket[exp-date] and use the @racket[max-age].
@racket[domain] indicates that the recipient should send the cookie back to
the server only if the hostname in the request URI is either @racket[domain]
itself, or a host within @racket[domain].
@racket[path] indicates that the recipient should send the cookie back to the
server only if @racket[path] is a prefix of the request URI's path.
@racket[secure], when @racket[#t], sets a flag telling the recipient that the
cookie may only be sent if the request URI's scheme specifies a ``secure''
protocol (presumably HTTPS).
@racket[http-only?], when @racket[#t], sets a flag telling the recipient that
the cookie may be communicated only to a server and only via HTTP or HTTPS.
@bold{This flag is important for security reasons:} Browsers provide JavaScript
access to cookies (for example, via @tt{document.cookie}), and consequently,
when cookies contain sensitive data such as user session info, malicious
JavaScript can compromise that data. The @tt{HttpOnly} cookie flag, set by
this keyword argument, instructs the browser not to make this cookie available
to JavaScript code.
@bold{If a cookie is intended to be confidential, both @racket[http-only?]
and @racket[secure?] should be @racket[#t], and all connections should
use HTTPS.}
(Some older browsers do not support this flag; see
@hyperlink["https://www.owasp.org/index.php/HttpOnly"]{the OWASP page on
HttpOnly} for more info.)
}
@defproc[(cookie->set-cookie-header [c cookie?]) bytes?]{
Produces a byte string containing the value portion of a ``Set-Cookie:'' HTTP
response header suitable for sending @racket[c] to a user agent.
@examples[
#:eval cookies-server-eval
(cookie->set-cookie-header
(make-cookie "rememberUser" "bob" #:path "/main"))
]
This procedure uses @racket[string->bytes/utf-8] to convert the cookie to
bytes; for an application that needs a different encoding function, use
@racket[cookie->string] and perform the bytes conversion with that function.
}
@defproc[(clear-cookie-header [name cookie-name?]
[#:domain domain (or/c domain-value? #f) #f]
[#:path path (or/c path/extension-value? #f) #f])
bytes?]{
Produces a byte string containing a ``Set-Cookie:'' header
suitable for telling a user agent to clear the cookie with
the given @racket[name]. (This is done, as per RFC6265, by
sending a cookie with an expiration date in the past.)
@examples[
#:eval cookies-server-eval
(clear-cookie-header "rememberUser" #:path "/main")
]
}
@defproc*[([(cookie-header->alist [header bytes?])
(listof (cons/c bytes? bytes?))]
[(cookie-header->alist [header bytes?]
[decode (-> bytes? X)])
(listof (cons/c X X))])]{
Given the value part of a ``Cookie:'' header, produces an
alist of all cookie name/value mappings in the header. If a
@racket[decode] function is given, applies @racket[decode]
to each key and each value before inserting the new
key-value pair into the alist. Invalid cookies will not
be present in the alist.
If a key in the header has no value, then @racket[#""], or
@racket[(decode #"")] if @racket[decode] is present, is
used as the value.
@examples[
#:eval cookies-server-eval
(cookie-header->alist #"SID=31d4d96e407aad42; lang=en-US")
(cookie-header->alist #"SID=31d4d96e407aad42; lang=en-US"
bytes->string/utf-8)
(cookie-header->alist #"seenIntro=; logins=3"
(compose (lambda (s) (or (string->number s) s))
bytes->string/utf-8))]
}
@defproc[(cookie->string [c cookie?])
string?]{
Produces a string containing the given cookie as text.
@examples[#:eval cookies-server-eval
(cookie->string
(make-cookie "usesRacket" "true"))
(cookie->string
(make-cookie "favColor" "teal"
#:max-age 86400
#:domain "example.com"
#:secure? #t))]
}
@; ------------------------------------------
@section[#:tag "cookies-client-procs"]{Cookies and HTTP User Agents}
@(define cookies-ua-eval (make-base-eval))
@interaction-eval[#:eval cookies-ua-eval
(require net/cookies/user-agent)]
@defmodule[net/cookies/user-agent]{The
@racketmodname[net/cookies/user-agent] library provides facilities
specific to user agents' handling of cookies.
Many user agents will need only two of this library's functions:
@itemlist[@item{@racket[extract-and-save-cookies!], for storing cookies}
@item{@racket[cookie-header], for retrieving them and
generating a ``Cookie:'' header}]
}
@defstruct[ua-cookie ([name cookie-name?]
[value cookie-value?]
[domain domain-value?]
[path path/extension-value?]
[expiration-time (and/c integer? positive?)]
[creation-time (and/c integer? positive?)]
[access-time (and/c integer? positive?)]
[persistent? boolean?]
[host-only? boolean?]
[secure-only? boolean?]
[http-only? boolean?])
#:omit-constructor]{
A structure representing a cookie from a user agent's
point of view.
All times are represented as the number of seconds since
midnight UTC, January 1, 1970, like the values produced by
@racket[current-seconds].
It's unlikely a client will need to construct a @racket[ua-cookie]
instance directly (except perhaps for testing); @racket[extract-cookies]
produces struct instances for all the cookies received in a server's response.
}
@defproc[(cookie-expired? [cookie ua-cookie?]
[current-time integer? (current-seconds)])
boolean?]{
True iff the given cookie's expiration time precedes @racket[current-time].
}
@;----------------------------------------
@subsection[#:tag "cookies-client-jar"]{Cookie jars: Client storage}
@defproc[(extract-and-save-cookies!
[headers (listof (or/c header? (cons/c bytes? bytes?)))]
[url url?]
[decode (-> bytes? string?) bytes->string/utf-8])
void?]{
Reads all cookies from any ``Set-Cookie'' headers present in
@racket[headers] received in an HTTP response from @racket[url],
converts them to strings using @racket[decode], and stores them
in the @racket[current-cookie-jar].
@examples[#:eval cookies-ua-eval
(require net/url)
(define site-url
(string->url "http://test.example.com/apps/main"))
(extract-and-save-cookies!
'((#"X-Test-Header" . #"isThisACookie=no")
(#"Set-Cookie" . #"a=b; Max-Age=2000; Path=/")
(#"Set-Cookie" . #"user=bob; Max-Age=86400; Path=/apps"))
site-url)
(cookie-header site-url)]
}
@defproc[(save-cookie! [c ua-cookie?] [via-http? boolean? #t]) void?]{
Attempts to save a single cookie @racket[c], received via an HTTP API iff
@racket[via-http?], to the @racket[current-cookie-jar]. Per Section 5.3
of RFC 6265, the cookie will be ignored if its @racket[http-only?] flag
(or that of the cookie it would replace) is set and it wasn't received via
an HTTP API.
}
@defproc[(cookie-header [url url?]
[encode (-> string? bytes?) string->bytes/utf-8]
[#:filter-with ok? (-> ua-cookie? boolean?)
(lambda (x) #t)])
(or/c bytes? #f)]{
Finds any unexpired cookies matching @racket[url] in the
@racket[current-cookie-jar], removes any for which @racket[ok?] produces
@racket[#f], and produces the value portion of a ``Cookie:'' HTTP request
header. Produces @racket[#f] if no cookies match.
Cookies with the ``Secure'' flag will be included in this header iff
@racket[(url-scheme url)] is @racket["https"], unless you remove them
manually using the @racket[ok?] parameter.
@examples[#:eval cookies-ua-eval
(cookie-header
(string->url "http://test.example.com/home"))]
}
@definterface[cookie-jar<%> ()]{
An interface for storing cookies received from servers. Implemented by
@racket[list-cookie-jar%]. Provides for saving cookies (imperatively)
and extracting all cookies that match a given URL.
Most clients will not need to deal with this interface, and none should
need to call its methods directly. (Use @racket[cookie-header] and
@racket[extract-and-save-cookies!], instead.) It is provided for situations
in which the default @racket[list-cookie-jar%] class will not suffice. For
example, if the user agent will be storing thousands of cookies, the linear
insertion time of @racket[list-cookie-jar%] could mean that writing a
@racket[cookie-jar<%>] implementation based on hash tables, trees, or a DBMS
might be a better alternative.
Programs requiring such a class should install an instance
of it using the @racket[current-cookie-jar] parameter.
@defmethod[(save-cookie! [c ua-cookie?] [via-http? boolean? #t]) void?]{
Saves @racket[c] to the jar, and removes any expired cookies from
the jar as well.
@racket[via-http?] should be @racket[#t] if the cookie
was received via an HTTP API; it is for properly ignoring the cookie if
the cookie's @racket[http-only?] flag is set, or if the cookie is
attempting to replace an ``HTTP only'' cookie already present in the jar.
}
@defmethod[(save-cookies! [cs (listof ua-cookie?)] [via-http? boolean? #t])
void?]{
Saves each cookie in @racket[cs] to the jar, and removes any expired
cookies from the jar. See the note immediately above, for explanation of the
@racket[via-http?] flag.
}
@defmethod[(cookies-matching [url url?]
[secure? boolean?
(equal? (url-scheme url) "https")])
(listof ua-cookie?)]{
Produces all cookies in the jar that should be sent in the
``Cookie'' header for a request made to @racket[url]. @racket[secure?]
specifies whether the cookies will be sent via a secure protocol.
(If not, cookies with the ``Secure'' flag set should not be returned by
this method.)
This method should produce its cookies in the order expected according to
RFC6265:
@itemlist[
@item{Cookies with longer paths are listed before cookies with shorter
paths.}
@item{Among cookies that have equal-length path fields, cookies with
earlier creation-times are listed before cookies with later
creation-times.}]
If there are multiple cookies in the jar with the same name and different
domains or paths, the RFC does not specify which to send. The default
@racket[list-cookie-jar%] class's implementation of this method produces
@bold{all} cookies that match the domain and path of the given URL, in the
order specified above.
}
}
@defclass[list-cookie-jar% object% (cookie-jar<%>)]{
Stores cookies in a list, internally maintaining a sorted order that
mirrors the sort order specified by the RFC for the ``Cookie'' header.
}
@defparam[current-cookie-jar jar (is-a?/c cookie-jar<%>)
#:value (new list-cookie-jar%)]{
A parameter that specifies the cookie jar to use for storing and
retrieving cookies.
}
@; ----------------------------------------
@subsection[#:tag "cookies-client-parsing"]{Reading the Set-Cookie header}
@defproc[(extract-cookies [headers (listof (or/c header? (cons/c bytes? bytes?)))]
[url url?]
[decode (-> bytes? string?)
bytes->string/utf-8])
(listof ua-cookie?)]{
Given a list of all the headers received in the response to
a request from the given @racket[url], produces a list of
cookies corresponding to all the ``Set-Cookie'' headers
present. The @racket[decode] function is used to convert the cookie's
textual fields to strings.
This function is suitable for use with the @racket[headers/raw]
field of a @racket[request] structure (from
@racketmodname[web-server/http/request-structs]), or with the output of
@racket[(extract-all-fields h)], where @racket[h] is a byte string.
}
@defproc[(parse-cookie [set-cookie-bytes bytes?]
[url url?]
[decode (-> bytes? string?) bytes->string/utf-8])
ua-cookie?]{
Given a single ``Set-Cookie'' header's value
@racket[set-cookie-bytes] received in response to a request
from the given @racket[url], produces a @racket[ua-cookie]
representing the cookie received.
The @racket[decode] function is used to convert the cookie's
textual fields (@racket[name], @racket[value], @racket[domain],
and @racket[path]) to strings.
}
@defproc[(default-path [url url?]) string?]{
Given a URL, produces the path that should be used for a
cookie that has no ``Path'' attribute, as specified in
Section 5.1.4 of the RFC.
}
@deftogether[(@defthing[max-cookie-seconds (and/c integer? positive?)]
@defthing[min-cookie-seconds (and/c integer? negative?)])]{
The largest and smallest integers that this user agent library will
use, or be guaranteed to accept, as time measurements in seconds since
midnight UTC on January 1, 1970.
}
@defproc[(parse-date [s string?]) (or/c string? #f)]{
Parses the given string for a date, producing @racket[#f] if
it is not possible to extract a date from the string using
the algorithm specified in Section 5.1.1 of the RFC.
}
@; ------------------------------------------
@section[#:tag "cookies-acknowledgments"]{Acknowledgements}
The server-side library is based on the original
@racketmodname[net/cookie] library by
@author+email["Francisco Solsona" "solsona@acm.org"]. Many of the
cookie-construction tests for this library are adapted from the
@racketmodname[net/cookie] tests.
@author+email["Roman Klochkov" "kalimehtar@mail.ru"] wrote the first
client-side cookie library on which this user-agent library is based.
In particular, this library relies on his code for parsing dates and
other cookie components.

17
net-doc/net/scribblings/net.scrbl
View File

@ -25,9 +25,8 @@
@include-section["tcp-redirect.scrbl"] @include-section["tcp-redirect.scrbl"]
@include-section["ssl-tcp-unit.scrbl"] @include-section["ssl-tcp-unit.scrbl"]
@include-section["cgi.scrbl"] @include-section["cgi.scrbl"]
@include-section["cookies.scrbl"]
@include-section["git-checkout.scrbl"]
@include-section["cookie.scrbl"] @include-section["cookie.scrbl"]
@include-section["git-checkout.scrbl"]
@(bibliography @(bibliography
@ -49,20 +48,6 @@
#:url "http://www.ietf.org/rfc/rfc0977.txt" #:url "http://www.ietf.org/rfc/rfc0977.txt"
#:date "1986") #:date "1986")
(bib-entry #:key "RFC1034"
#:title "Domain Names - Concepts and Facilities"
#:author "P. Mockapetris"
#:location "RFC"
#:url "http://tools.ietf.org/html/rfc1034.html"
#:date "1987")
(bib-entry #:key "RFC1123"
#:title "Requirements for Internet Hosts - Application and Support"
#:author "R. Braden (editor)"
#:location "RFC"
#:url "http://tools.ietf.org/html/rfc1123.html"
#:date "1989")
(bib-entry #:key "RFC1738" (bib-entry #:key "RFC1738"
#:title "Uniform Resource Locators (URL)" #:title "Uniform Resource Locators (URL)"
#:author "T. Berners-Lee, L. Masinter, and M. McCahill" #:author "T. Berners-Lee, L. Masinter, and M. McCahill"

129
net-lib/net/cookies/common.rkt
View File

@ -1,129 +0,0 @@
#lang racket
(provide (contract-out
[cookie-name? (-> any/c boolean?)]
[cookie-value? (-> any/c boolean?)]
[path/extension-value? (-> any/c boolean?)]
[domain-value? (-> any/c boolean?)]
))
(require racket/match)
;;;;;;;;; Cookie names ;;;;;;;;;
(require srfi/13 srfi/14) ; for charsets, and testing strings against them
;; cookie-name? : Any -> Bool
;; true iff s is a token, per RFC6265; see below
(define (cookie-name? s)
(or (and (bytes? s)
(not (zero? (bytes-length s)))
(for/and ([b (in-bytes s)]) (token-byte? b)))
(and (string? s)
(not (zero? (string-length s)))
(string-every char-set:token s))))
;; token = 1*<any CHAR except CTLs or separators>
;; separator = "(" | ")" | "<" | ">" | "@"
;; | "," | ";" | ":" | "\" | <">
;; | "/" | "[" | "]" | "?" | "="
;; | "{" | "}" | SP | HT
;; see also RFC2616 Sec 2.2
(define (token-byte? b)
(and (< 31 b 127) (not (separator-byte? b)))) ; exclude CTLs and seps
(define (separator-byte? b)
(member b (bytes->list #"()<>@,;:\\\"/[]?={} \t")))
(define char-set:separators
(char-set-union (string->char-set "()<>@,;:\\\"/[]?={}")
char-set:whitespace
(char-set #\tab)))
(define char-set:control
(char-set-union char-set:iso-control (char-set (integer->char 127))));; DEL
(define char-set:token
(char-set-difference char-set:ascii char-set:separators char-set:control))
;;;;;;;;; Cookie values ;;;;;;;;;
;; cookie-value? : Any -> Boolean
;; true iff x is a valid cookie value, per RFC6265. From the RFC:
;; cookie-value = *cookie-octet
;; / ( DQUOTE *cookie-octet DQUOTE )
;; where cookie-octet is defined below
(define (cookie-value? x)
(or (and (bytes? x)
(let ([len (bytes-length x)])
(or (and (>= len 2)
(= (bytes-ref x 0) DQUOTE)
(= (bytes-ref x (- len 1)) DQUOTE)
(all-cookie-octets? (subbytes x 1 (- len 1))))
(all-cookie-octets? x))))
(and (string? x)
(or (string-every char-set:cookie-octets x)
(let ([m (regexp-match #rx"^\"(.*)\"$" x)])
(match m
[(list _ quoted-text)
(string-every char-set:cookie-octets quoted-text)]
[_ #f]))))))
(define (all-cookie-octets? x)
(for/and ([b (in-bytes x)]) (cookie-octet-byte? b)))
(define DQUOTE #x22)
;; From the RFC:
;; path-value = *av-octet
;; extension-av = *av-octet
;; where av-octet is defined below.
(define (path/extension-value? x) ; : Any -> Boolean
(and (string? x) (string-every char-set:av-octets x)))
;; Per RFC1034.3.5 (with the RFC1123 revision to allow domain name
;; components to start with a digit):
;; subdomain = label *("." label)
;; label = ( ALPHA / DIGIT ) [ *ldh (ALPHA / DIGIT) ]
;; ldh = ALPHA / DIGIT / "-"
(define domain-label-rx
;; Regexp matching one component of a domain name:
#px"^[[:alnum:]][[:alnum:]-]*[[:alnum:]]$")
;; Test if dom is a valid domain name. From the RFC:
;; domain-value = <subdomain>
;; ; as def'd in RFC1034 Sec 3.5
;; ; and enhanced by RFC1123 Sec 2.1
(define (domain-value? dom) ; Any -> Boolean
(or (and (string? dom)
(let ([parts (string-split dom "." #:trim? #f)])
(and (not (null? parts))
(for/and ([part parts])
(regexp-match domain-label-rx part))))
#t)))
;;;; Underlying charsets
;; From the RFC:
;; cookie-octet = <US-ASCII chars excluding CTLs, whitespace, DQUOTE,
;; comma, semicolon, and backslash>
;; av-octet = <any CHAR except CTLs or #\;>
;; CTL = ASCII octets 0-31 and 127
;; Charset used in cookie values includes the following chars:
;; ( ) ! # $ % & ' * + - . / 0 1 2 3 4 5 6 7 8 9 : < = > ? @ [ ] ^ _ `
;; { | } ~ A-Z a-z
(define (cookie-octet-byte? x)
(and (< 31 x 127) (not (memv x non-cookie-octet-bytes))))
(define non-cookie-octet-bytes (map char->integer (string->list " \t\",;\\")))
(define char-set:cookie-octets
(char-set-difference char-set:ascii
char-set:control char-set:whitespace
(string->char-set "\",;\\")))
;; Chars used in path-av and extension-av values:
#;
(define (cookie-av-octet-byte? x)
(and (< 31 x 127) (not (= x #x3B)))) ; #x3B is #\;
(define char-set:av-octets
(char-set-difference char-set:ascii char-set:control (char-set #\;)))

160
net-lib/net/cookies/server.rkt
View File

@ -1,160 +0,0 @@
#lang racket/base
(require racket/contract
(only-in racket/bytes bytes-join)
"common.rkt")
(provide (contract-out (struct cookie
([name (and/c string? cookie-name?)]
[value (and/c string? cookie-value?)]
[expires (or/c date? #f)]
[max-age (or/c (and/c integer? positive?) #f)]
[domain (or/c domain-value? #f)]
[path (or/c path/extension-value? #f)]
[secure? boolean?]
[http-only? boolean?]
[extension (or/c path/extension-value? #f)])
#:omit-constructor)
[make-cookie
(->* (cookie-name? cookie-value?)
(#:expires (or/c date? #f)
#:max-age (or/c (and/c integer? positive?) #f)
#:domain (or/c domain-value? #f)
#:path (or/c path/extension-value? #f)
#:secure? boolean?
#:http-only? boolean?
#:extension (or/c path/extension-value? #f))
cookie?)]
[cookie->set-cookie-header (-> cookie? bytes?)]
[clear-cookie-header
(->* (cookie-name?)
(#:domain (or/c domain-value? #f)
#:path (or/c path/extension-value? #f))
bytes?)]
[cookie->string (-> cookie? string?)]
#:forall X
[cookie-header->alist
(case-> (-> bytes? (listof (cons/c bytes? bytes?)))
(-> bytes? (-> bytes? X)
(listof (cons/c X X))))]
))
(require racket/serialize ; for serializable cookie structs
srfi/19 ; for date handling
(only-in racket/string
string-join string-split)
racket/match
)
(serializable-struct cookie
[name value expires max-age domain path secure? http-only? extension]
#:transparent)
(define (make-cookie name value
#:expires [expires #f]
#:max-age [max-age #f]
#:domain [domain #f]
#:path [path #f]
#:secure? [secure? #f]
#:http-only? [http-only? #f]
#:extension [extension #f])
(cookie name value expires max-age domain path secure? http-only? extension))
;; cookie -> String
;; produce a Set-Cookie header suitable for sending to a client
(define (cookie->set-cookie-header c)
(string->bytes/utf-8 (cookie->string c)))
;; produce a Set-Cookie header suitable for telling the client to
;; clear a cookie
(define clear-cookie-expiration-seconds 1420070400) ; midnight UTC on 1/1/15
(define (clear-cookie-header name #:path [path #f] #:domain [domain #f])
(cookie->set-cookie-header
(make-cookie name ""
#:expires (seconds->date clear-cookie-expiration-seconds #f)
#:path path
#:domain domain)))
;; bytes? [(bytes? -> A)] -> (AList A A)
;; Given the value from a Cookie: header, produces an alist of name/value
;; mappings. If there is no value, the empty byte-string (or whatever
;; decode produces for #"") is used as the value.
;; XXX Would it be worthwhile to give the option to pass separate decoders
;; for keys and values?
(define (cookie-header->alist header [decode (lambda (x) x)])
(define header-pairs (regexp-split #"; " header))
(reverse
(for/fold ([cookies '()]) ([bs header-pairs]
#:unless (or (bytes=? bs #"")
(= (bytes-ref bs 0) #x3d)))
(match (regexp-split #"=" bs)
[(list) cookies]
[(list (? cookie-name? key) (? cookie-value? val))
(cons (cons (decode key) (decode val)) cookies)]
[(list-rest (? cookie-name? key) val-parts)
#:when (andmap cookie-value? val-parts)
(cons (cons (decode key) (decode (bytes-join val-parts #"=")))
cookies)]
[_ cookies]))))
(define (cookie->string c)
(define (maybe-format fmt val) (and val (format fmt val)))
(match c
[(cookie name value expires max-age domain path secure? http-only? extension)
(string-join
(filter values
(list (format "~a=~a" name value)
(and expires
(format "Expires=~a"
(date->string expires
rfc1123:date-template)))
(maybe-format "Max-Age=~a" max-age)
(maybe-format "Domain=~a" domain)
(maybe-format "Path=~a" path)
(and secure? "Secure")
(and http-only? "HttpOnly")
extension))
"; ")]
[_ (error 'cookie->string "expected a cookie; received: ~a" c)]))
#|
From RFC6265:
HTTP applications have historically allowed three different formats
for the representation of date/time stamps:
Sun, 06 Nov 1994 08:49:37 GMT ; RFC 822, updated by RFC 1123
Sunday, 06-Nov-94 08:49:37 GMT ; RFC 850, obsoleted by RFC 1036
Sun Nov 6 08:49:37 1994 ; ANSI C's asctime() format
The first format is preferred as an Internet standard and represents
a fixed-length subset of that defined by RFC 1123 [8] (an update to
RFC 822 [9]). The second format is in common use, but is based on the
obsolete RFC 850 [12] date format and lacks a four-digit year.
HTTP/1.1 clients and servers that parse the date value MUST accept
all three formats (for compatibility with HTTP/1.0), though they MUST
only generate the RFC 1123 format for representing HTTP-date values
in header fields...
Note: Recipients of date values are encouraged to be robust in
accepting date values that may have been sent by non-HTTP
applications, as is sometimes the case when retrieving or posting
messages via proxies/gateways to SMTP or NNTP.
All HTTP date/time stamps MUST be represented in Greenwich Mean Time
(GMT), without exception. For the purposes of HTTP, GMT is exactly
equal to UTC (Coordinated Universal Time). This is indicated in the
first two formats by the inclusion of "GMT" as the three-letter
abbreviation for time zone, and MUST be assumed when reading the
asctime format. HTTP-date is case sensitive and MUST NOT include
additional LWS beyond that specifically included as SP in the
grammar.
|#
(define rfc1123:date-template "~a, ~d ~b ~Y ~H:~M:~S GMT")
(define rfc850:date-template "~A, ~d-~b-~y ~H:~M:~S GMT")
(define asctime:date-template "~a ~b ~e ~H:~M:~S ~Y")

14
net-lib/net/cookies/struct.rkt
View File

@ -1,14 +0,0 @@
#lang racket/base
#|
net/cookies/server : RFC6265-compliant server cookie handling
- read the Cookie header
- make a cookie struct
- write the Set-Cookie header
net/cookies/user-agent : RFC6265-compliant user agent cookie handling
- read the Set-Cookie header
- make a cookie struct
- write the Cookie header
net/cookies/common : Any code that winds up being common to UA & server
|#

451
net-lib/net/cookies/user-agent.rkt
View File

@ -1,451 +0,0 @@
#lang racket/base
(require racket/contract
racket/class ; for cookie-jar interface & class
racket/list
racket/match
(only-in racket/bytes bytes-join) ; for building the Cookie: header
srfi/19
"common.rkt"
;web-server/http/request-structs
; The above is commented out because, although it'd be clean to reuse
; header structs, I don't want to create a dependency on the
; web-server-lib package. I'm leaving it in as comments, in case
; net/head acquires a similar facility at some point.
net/url ; used in path matching
(only-in racket/date date->seconds)
(only-in racket/string string-join string-trim string-split)
(only-in srfi/13 string-index-right)
)
(struct ua-cookie [name value domain path
expiration-time creation-time [access-time #:mutable]
persistent? host-only? secure-only? http-only?]
#:transparent)
(provide (contract-out
(struct ua-cookie ([name cookie-name?]
[value cookie-value?]
[domain domain-value?]
[path path/extension-value?]
[expiration-time integer?]
[creation-time (and/c integer? positive?)]
[access-time (and/c integer? positive?)]
[persistent? boolean?]
[host-only? boolean?]
[secure-only? boolean?]
[http-only? boolean?]))
[extract-and-save-cookies!
(->* ((listof (cons/c bytes? bytes?))
url?)
((-> bytes? string?))
void?)]
[save-cookie! (->* (ua-cookie?) (boolean?) void?)]
[cookie-header (->* (url?)
((-> string? bytes?)
#:filter-with (-> ua-cookie? boolean?))
(or/c bytes? #f))]
[current-cookie-jar (parameter/c (is-a?/c cookie-jar<%>))]
[list-cookie-jar%
(class/c [save-cookies! (->*m ((listof ua-cookie?)) (boolean?) void?)]
[save-cookie! (->*m (ua-cookie?) (boolean?) void?)]
[cookies-matching
(->*m (url?) (boolean?) (listof ua-cookie?))])]
[extract-cookies
(->* ((listof (cons/c bytes? bytes?))
;(listof (or/c header? (cons/c bytes? bytes?)))
url?)
((-> bytes? string?))
(listof ua-cookie?))]
[parse-cookie (-> bytes? url? (or/c ua-cookie? #f))]
[default-path (-> url? string?)]
[min-cookie-seconds (and/c integer? negative?)]
[max-cookie-seconds (and/c integer? positive?)]
[parse-date (-> string? (or/c date? #f))]
)
cookie-jar<%>
)
;;;;;;;;;;;;;;;;;;;;; Storing Cookies ;;;;;;;;;;;;;;;;;;;;;
;; for saving all cookies from a Set-Cookie header
(define (extract-and-save-cookies! headers url [decode bytes->string/utf-8])
(send (current-cookie-jar)
save-cookies! (extract-cookies headers url decode)
(and (member (url-scheme url) '("http" "https")) #t)))
;; ua-cookie? [boolean?] -> void?
;; for saving a single cookie (already parsed), received via an HTTP API
;; iff via-http? is #t.
(define (save-cookie! c [via-http? #t])
(send (current-cookie-jar) save-cookie! c via-http?))
;; url? (-> string? bytes?) #:filter-with [ua-cookie? -> boolean?] -> bytes?
;; for producing a header from the cookie jar, for requests to given url.
;; NOTE: this produces only the VALUE portion of the header, not the ``Cookie:''
;; part; I'm not sure if users will prefer to use web-server/http/request-structs
;; or net/head to construct their headers, or manually construct them to feed
;; to http-sendrecv and friends.
(define (cookie-header url
[encode string->bytes/utf-8]
#:filter-with [ok? (lambda (x) #t)])
(define (make-cookie-pair c)
(bytes-append (encode (ua-cookie-name c))
#"=" (encode (ua-cookie-value c))))
(define cookie-pairs
(for/list ([c (in-list
(filter ok?
(send (current-cookie-jar) cookies-matching url)))])
(make-cookie-pair c)))
(and (not (null? cookie-pairs)) (bytes-join cookie-pairs #"; ")))
;;;; The cookie jar:
(define cookie-jar<%>
(interface ()
; TODO: Modify the below to take optional URL
[save-cookie! (->*m (ua-cookie?) (boolean?) void?)]
[save-cookies! (->*m ((listof ua-cookie?)) (boolean?) void?)]
[cookies-matching (->m url? (listof ua-cookie?))]))
;; ua-cookie [Int+] -> Boolean
(define (cookie-expired? cookie [current-time (current-seconds)])
(> current-time (ua-cookie-expiration-time cookie)))
;; Represents the cookie jar as a list of cookies, sorted in ascending order
;; by length of path, with ties broken by later-ctime-first.
(define list-cookie-jar%
(class* object% (cookie-jar<%>)
(super-new)
(field [cookies '()])
(define/public (save-cookie! c [via-http? #t])
(set! cookies (insert c cookies via-http?)))
(define/public (save-cookies! cs [via-http? #t])
(for ([c cs]) (save-cookie! c via-http?)))
;; insert : ua-cookie? (listof ua-cookie?) [boolean?] -> (listof ua-cookie?)
;; Inserts new-cookie into the given list, maintaining sort order, unless
;; it was received via a non-HTTP API (as indicated by via-http?) and should
;; be ignored per section 5.3 of RFC6265.
(define (insert new-cookie jar via-http?)
(match-define (ua-cookie name _ dom path _ ctime _ _ _ _ http-only?)
new-cookie)
(if (and http-only? (not via-http?)) ; ignore -- see Sec 5.3.10
jar
(let insert-into ([jar jar]) ; != Binks
(cond
[(null? jar) (if (cookie-ok? new-cookie) (list new-cookie) '())]
[else
(match-define (ua-cookie name2 _ dom2 path2 _ ctime2 _ _ _ _ ho2?)
(car jar))
(cond
[(and (string=? name name2) (string=? dom dom2)
(string=? path path2)) ; Replace this cookie.
(filter cookie-ok?
(if (and ho2? (not via-http?))
jar ; ignore new cookie -- see Sec 5.3.11.2.
(cons (struct-copy ua-cookie new-cookie
[creation-time ctime2])
(cdr jar))))]
[(let ([plen (string-length path)]
[plen2 (string-length path2)])
(or (< plen plen2) (and (= plen plen2) (> ctime ctime2))))
;; Shorter path, or eq path and later ctime, comes first.
(filter cookie-ok? (cons new-cookie jar))]
[(cookie-ok? (car jar))
(cons (car jar) (insert-into (cdr jar)))]
[else (insert-into (cdr jar))])]))))
(define (cookie-ok? c) (not (cookie-expired? c)))
(define/public (cookies-matching url
[secure? (equal? (url-scheme url) "https")])
(define host (url-host url))
(define (match? cookie)
(and (domain-match? (ua-cookie-domain cookie) host)
(path-match? (ua-cookie-path cookie) url)
(or secure? (not (ua-cookie-secure-only? cookie)))))
;; Produce the cookies in reverse order (ie, desc by path length):
(for/fold ([cs '()]) ([c (in-list cookies)])
(if (match? c) (cons c cs) cs)))
))
;; The cookie jar that will be used for saving new cookies, and for choosing
;; cookies to send to the server.
(define current-cookie-jar (make-parameter (new list-cookie-jar%)))
;;;;;;;;;;;;;;;;;;;;; Reading the Set-Cookie header ;;;;;;;;;;;;;;;;;;;;;
;; given a list of all the headers received in a response,
;; produce a list of cookies corresponding to all the Set-Cookie headers
;; present. TODO: tests
(define (extract-cookies headers url [decode bytes->string/utf-8])
(define (set-cookie? x) (string-ci=? (decode x) "set-cookie"))
(define (header->maybe-cookie hdr)
(match hdr
[(cons (? set-cookie?) value) value]
;[(header (? set-cookie?) value) value]
[_ #f]))
(filter (lambda (x) x)
(for/list ([header-value (filter-map header->maybe-cookie headers)])
(parse-cookie header-value url decode))))
;; parse-cookie : bytes? url? [(bytes? -> string?)] -> (Option ua-cookie?)
;; Given the value from a Set-Cookie: header, produce a ua-cookie, or #f
;; if the byte-string doesn't contain an adequately well-formed cookie.
(define (parse-cookie set-cookie-bytes url [decode bytes->string/utf-8])
(let/ec esc
(define (ignore-this-Set-Cookie) (esc #f))
(define now (current-seconds))
(match-define (list-rest nvpair unparsed-attributes)
(string-split (decode set-cookie-bytes) ";"))
(define-values (name value)
(match (regexp-match nvpair-regexp nvpair)
[(list all "" v) (ignore-this-Set-Cookie)]
[(list all n v) (values n v)]
[#f (ignore-this-Set-Cookie)]))
;;; parsing the unparsed-attributes
(define-values (domain-attribute path expires max-age secure? http-only?)
(parse-cookie-attributes unparsed-attributes url))
(define-values (host-only? domain)
(let ([request-host (url-host url)])
(cond
[domain-attribute
(when (or (string=? domain-attribute "")
(not (domain-match? domain-attribute request-host)))
(ignore-this-Set-Cookie))
(values #f domain-attribute)]
[else
(values #t request-host)])))
(define-values (persistent? expiry-time)
(cond [max-age (values #t (if (positive? max-age)
(+ now max-age)
min-cookie-seconds))]
[expires (values #t (max min-cookie-seconds
(min max-cookie-seconds
(date->seconds expires))))]
[else (values #f max-cookie-seconds)]))
(ua-cookie name value
;; TODO: allow UA to "reject public suffixes", sec 5.3
domain
(or path (default-path url))
expiry-time now now
persistent? host-only? secure? http-only?)))
;; parse-cookie-attributes :
;; bytes? url? -> (values (Option string?) (Option string?)
;; (Option Nat) (Option Nat)
;; Bool Bool)
(define (parse-cookie-attributes unparsed-attributes url)
(for/fold ([domain #f] [path #f] [expires #f] [max-age #f]
[secure? #f] [http-only? #f])
([cookie-av unparsed-attributes])
(cond
[(equal? cookie-av "") ; skip blank a/v pairs
(values domain path expires max-age secure? http-only?)]
[else
(define-values (name value)
(match (regexp-match nvpair-regexp cookie-av)
[(list all n v) (values n v)]
[#f (values (string-trim cookie-av) "")]))
(case (string-downcase name)
[("expires")
(values domain path (parse-date value) max-age secure? http-only?)]
[("max-age")
(values domain path expires
(if (regexp-match #px"^-?\\d+$" value)
(string->number value)
max-age)
secure? http-only?)]
[("domain")
(values (cond
[(string=? value "") domain] ; don't set domain now
[(char=? (string-ref value 0) #\.)
(string-downcase (substring value 1))]
[else (string-downcase value)])
path expires max-age secure? http-only?)]
[("path")
(values domain
(if (or (string=? value "")
(not (char=? (string-ref value 0) #\/)))
path ; skip setting path this iteration
value)
expires max-age secure? http-only?)]
[("secure")
(values domain path expires max-age #t http-only?)]
[("httponly")
(values domain path expires max-age secure? #t)]
[else
(values domain path expires max-age secure? http-only?)])])))
;; Regexp for matching an equals-sign-delimited name-value pair,
;; and trimming it of whitespace:
(define nvpair-regexp #px"^\\s*(.*?)\\s*=\\s*(.*)\\s*$")
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; Dates ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; Constant defs for date parsing ;;;;
;; Greatest and least dates this cookie library accepts:
(define max-cookie-seconds (- (expt 2 32) 1))
(define min-cookie-seconds (- max-cookie-seconds))
;; Characters used as delimiters between parts of a date string
;; used in the "Expires" attribute.
(define (range+ a b) (cons b (range a b)))
(define delimiter `(#x09 ,@(range+ #x20 #x2F)
,@(range+ #x3B #x40)
,@(range+ #x5B #x60)
,@(range+ #x7B #x7E)))
(define month-names
`("jan" "feb" "mar" "apr" "may" "jun" "jul" "aug" "sep" "oct" "nov" "dec"))
;; string? -> date?
;; As specified in section 5.1.1 of RFC6265.
(define (parse-date str)
(let/ec escape
(define (fail) (escape #f))
(define tokens
(let ()
(define-values (acc current)
(for/fold ([acc null] [current null])
([ch (in-string str)])
(if (memv (char->integer ch) delimiter)
(values (cons (list->string (reverse current)) acc) null)
(values acc (cons ch current)))))
(reverse (if (null? current)
acc
(cons (list->string (reverse current)) acc)))))
;; String -> (Option (List Int[0,23] Int[0,59] Int[0,59]))
(define (parse-time str)
(match (regexp-match #px"^(\\d\\d?):(\\d\\d?):(\\d\\d?)\\D*$" str)
[(list _ hs ms ss)
(define-values (h m s)
(apply values (map string->number (list hs ms ss))))
(if (and (<= h 23) (<= m 59) (<= s 59))
(list h m s)
(fail))] ; malformed time
[_ #f]))
(define (parse-day str) ; String -> (Option Int[1,31])
(match (regexp-match #px"^(\\d\\d?)\\D*$" str)
[(list _ day) (string->number day)]
[_ #f]))
(define (parse-year str) ; String -> (Option Int[>= 1601])
(match (regexp-match #px"^(\\d\\d\\d?\\d?)\\D*$" str)
[(list _ year/s)
(define year (string->number year/s))
(cond [(<= 70 year 99) (+ year 1900)]
[(<= 0 year 69) (+ year 2000)]
[(< year 1601) (fail)]
[else year])]
[_ #f]))
(define (parse-month str) ; String -> Int[1,12]
(cond
[(>= (string-length str) 3)
(define prefix (string-downcase (substring str 0 3)))
(for/or ([m (in-list month-names)]
[n (in-naturals)])
(if (string=? m prefix) (add1 n) #f))]
[else #f]))
(define-values (time day month year)
(for/fold ([time #f] [day #f] [month #f] [year #f])
([token (in-list tokens)])
(cond
[(and (not time) (parse-time token))
=> (λ (time) (values time day month year))]
[(and (not day) (parse-day token))
=> (λ (day) (values time day month year))]
[(and (not month) (parse-month token))
=> (λ (month) (values time day month year))]
[(and (not year) (parse-year token))
=> (λ (year) (values time day month year))]
[else (values time day month year)])))
(if time
(let-values ([(hour minute second) (apply values time)])
;; Last check: fail if day is not OK for given month:
(and day month year
(<= day (case month
[(1 3 5 7 8 10 12) 31]
[(2) 29]
[(4 6 9 11) 30]
[else (fail)]))
(date second minute hour day month
year
0 0 #f 0)))
#f)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; Domains ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; String String -> Boolean
;; As specified in section 5.1.3: "A string domain-matches a given
;; domain string if at least one of the following conditions hold..."
;; domain is the "domain string", and host is the string being tested.
(define (domain-match? domain host)
(define diff (- (string-length host) (string-length domain)))
(and (diff . >= . 0)
(string=? domain (substring host diff))
(or (= diff 0) (char=? (string-ref host (sub1 diff)) #\.))
(not (regexp-match #px"\\.\\d\\d?\\d?$" host))))
;;;; As spec'd in section 5.1.4:
;; url? -> string?
;; compute the default-path of a cookie, for use in creating the ua-cookie struct
;; when parsing a Set-Cookie header.
(define (default-path url)
(define uri-path
(string-append "/" (string-join (map path/param-path (url-path url)) "/")))
(if (or (= (string-length uri-path) 0)
(not (char=? (string-ref uri-path 0) #\/)))
"/"
(let ([last-slash-pos (string-index-right uri-path #\/)])
(if (= last-slash-pos 0) ; uri-path contains only one slash
"/"
(substring uri-path 0 last-slash-pos)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; Paths ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; path-match? : String (U URL String) -> Boolean
;; Does the URL's (typically the one to which the UA is sending the request)
;; request-path path-match the given cookie-path?
(define (path-match? cookie-path url)
(define (url-full-path url)
(cond
[(url? url)
(string-append "/"
(string-join (map path/param-path (url-path url)) "/"))]
[else (url-full-path (string->url url))]))
(define request-path
(cond
[(string? url) url]
[(url? url) (url-full-path url)]))
(define cookie-len (string-length cookie-path))
(define request-path-len (string-length request-path))
(and (<= cookie-len request-path-len)
(string=? (substring request-path 0 cookie-len) cookie-path)
(or (char=? (string-ref cookie-path (sub1 cookie-len)) #\/)
(and (< cookie-len request-path-len)
(char=? (string-ref request-path cookie-len) #\/)))))

48
net-test/tests/net/cookies/common.rkt
View File

@ -1,48 +0,0 @@
#lang racket
(require rackunit net/cookies/common)
(module+ main
(require rackunit/text-ui)
(run-tests cookie-name-tests)
(run-tests cookie-value-tests)
(run-tests p/e-value-tests))
(define-syntax test-cookie-pred
(syntax-rules (valid invalid)
[(_ label ok? bytes-too? (valid v ...) (invalid inv ...))
(test-begin
(test-case (string-append "Valid " label)
(check-true (ok? v) v)
...
(when bytes-too?
(check-true (ok? (string->bytes/utf-8 v)) v)
...))
(test-case (string-append "Invalid " label)
(check-false (ok? inv) inv)
...
(when bytes-too?
(check-false (ok? (string->bytes/utf-8 inv)) inv)
...)))]))
(define-test-suite cookie-name-tests
(test-cookie-pred "cookie names" cookie-name? #t
(valid "HI" "hi" "Hi" "modestlyLongCookieName"
"somewhatTremendouslyOverlongCookieNameThatTakesAWhileToType")
(invalid "(ugh)" "\"" "\"argh\"" "<tags>" "foo@bar"
",,,,,chameleon" "this;that" "this:that" "[bracketed]" "{braced}"
"slashed/" "back\\slashed" "what?" "x=y" "spaced out" "\ttabbed")))
(define-test-suite cookie-value-tests
(test-cookie-pred "cookie values" cookie-value? #t
(valid "value" "(" "!" ")" ")!" "(!" "(!)" "!)" "\"hey!\"" "a=b=c")
(invalid "a;b" "a,b" "a b" "a\tb" "a=\"foo\"")))
(define-test-suite p/e-value-tests
(test-cookie-pred "path/extension values" path/extension-value? #f
(valid "abc=123"
"def=(define (forever x) (forever x))"
"You're so \"cool\"")
(invalid "x;y" "\000" (string #\rubout))))
(module+ test (require (submod ".." main))) ; for raco test & drdr

185
net-test/tests/net/cookies/server.rkt
View File

@ -1,185 +0,0 @@
#lang racket
(require net/cookies/server
net/cookies/common
rackunit
)
;; Based on tests from original net/cookie (JBM, 2006-12-01)
;; with additional from JMJ & porting to rackunit, 2015-02-01 - 2015-03-27.
(define rfc1123:date-template "~a, ~d ~b ~Y ~H:~M:~S GMT")
(define rfc850:date-template "~A, ~d-~b-~y ~H:~M:~S GMT")
(define asctime:date-template "~a ~b ~e ~H:~M:~S ~Y")
; Date/time used by server.rkt for expiring cookies:
(define clear-cookie-expiration-seconds 1420070400)
(define clear-cookie-expdate-string "Thu, 01 Jan 2015 00:00:00 GMT")
(module+ main
(require rackunit/text-ui)
(run-tests cookie-making-tests)
(run-tests set-cookie-header-tests)
(run-tests cookie-header-parsing-tests)
(run-tests contract-tests))
(module+ test (require (submod ".." main))) ; for raco test & drdr
;; ctest : string cookie string -> test
(define (ctest message c expected)
(test-equal? message (cookie->string c) expected))
;; date for testing "Expires=" attribute:
(define exp-date (seconds->date 1424050886 #f))
(define exp-date-str "Mon, 16 Feb 2015 01:41:26 GMT")
(define-test-suite cookie-making-tests
(ctest "simple cookie, no A/V pairs" (make-cookie "a" "b") "a=b")
(ctest "test each modifier individually: expires"
(make-cookie "a" "b" #:expires exp-date)
(format "a=b; Expires=~a" exp-date-str))
(ctest "test each modifier individually: domain"
(make-cookie "x" "y" #:domain "example.net")
"x=y; Domain=example.net")
(ctest "test each modifier individually: long domain"
(make-cookie "x" "y"
#:domain
(string-append "r" (make-string 250 #\e)
"allylong.hostname.example.net"))
(string-append "x=y; Domain=r" (make-string 250 #\e)
"allylong.hostname.example.net"))
(ctest "test each modifier individually: max-age"
(make-cookie "x" "y" #:max-age 100)
"x=y; Max-Age=100")
(ctest "test each modifier individually: path"
(make-cookie "x" "y" #:path "/") "x=y; Path=/")
(ctest "test each modifier individually: longer path"
(make-cookie "x" "y" #:path "/whatever/wherever/")
"x=y; Path=/whatever/wherever/")
(ctest "test each modifier individually: path with a plus"
(make-cookie "x" "y" #:path "a+path")
"x=y; Path=a+path")
(ctest "test each modifier individually: path with quotes"
(make-cookie "x" "y" #:path "\"/already/quoted/\"")
"x=y; Path=\"/already/quoted/\"")
(ctest "test each modifier individually: secure?"
(make-cookie "x" "y" #:secure? #t)
"x=y; Secure")
(ctest "test each modifier individually: secure? = #f"
(make-cookie "x" "y" #:secure? #f)
"x=y")
(ctest "test each modifier individually: http-only? = #t"
(make-cookie "x" "y" #:http-only? #t)
"x=y; HttpOnly")
(ctest "test each modifier individually: http-only? = #f"
(make-cookie "x" "y" #:http-only? #f)
"x=y")
(ctest "test each modifier individually: extension"
(make-cookie "a" "b" #:extension "Comment=set+a+to+b")
"a=b; Comment=set+a+to+b")
(ctest "test each modifier individually: extension with spaces"
(make-cookie "a" "b" #:extension "Comment=a comment with spaces")
"a=b; Comment=a comment with spaces")
(ctest "test each modifier individually: extension with escaped dquotes"
(make-cookie "a" "b"
#:extension
"Comment=the \"risks\" involved in waking")
"a=b; Comment=the \"risks\" involved in waking")
(ctest "test each modifier individually: extension"
(make-cookie "x" "y" #:extension "Version=12")
"x=y; Version=12")
(ctest "test each modifier individually: extension"
(make-cookie "x" "y" #:extension "Omega=Lx.(x x) Lx.(x x)")
"x=y; Omega=Lx.(x x) Lx.(x x)")
(ctest "test combinations: ext/domain"
(make-cookie "m" "n"
#:extension "Comment=set+a+to+b"
#:domain "example.net")
"m=n; Domain=example.net; Comment=set+a+to+b")
(ctest "test combinations: max-age/secure"
(make-cookie "m" "n"
#:max-age 300
#:secure? #t)
"m=n; Max-Age=300; Secure")
(ctest "test combinations: expires/max-age"
(make-cookie "a" "b" #:expires exp-date #:max-age 86400)
(format "a=b; Expires=~a; Max-Age=86400" exp-date-str))
(ctest "test combinations: path/ext/max-age"
(make-cookie "m" "n"
#:path "/whatever/wherever/"
#:extension "Version=10"
#:max-age 20)
"m=n; Max-Age=20; Path=/whatever/wherever/; Version=10"))
(define-test-suite set-cookie-header-tests
;; There aren't a lot of tests to do here, since currently all
;; that cookie->set-cookie-header does is apply string->bytes/utf-8
;; to the output of cookie->string, which is tested in cookie-making-tests.
(test-equal? "header for setting a cookie"
(cookie->set-cookie-header
(make-cookie "rememberUser" "bob" #:path "/main"))
#"rememberUser=bob; Path=/main")
(test-equal? "header for clearing a cookie"
(clear-cookie-header "foo")
(string->bytes/utf-8
(string-append "foo=; Expires=" clear-cookie-expdate-string))))
;; Cookie header parsing, starting w/examples from RFC6265:
(define-test-suite cookie-header-parsing-tests
(test-equal? "parse to alist: 2 cookies"
(cookie-header->alist #"SID=31d4d96e407aad42; lang=en-US")
'((#"SID" . #"31d4d96e407aad42")
(#"lang" . #"en-US")))
(test-equal? "parse to alist: 2 cookies"
(cookie-header->alist #"SID=31d4d96e407aad42; lang=en-US"
bytes->string/utf-8)
'(("SID" . "31d4d96e407aad42")
("lang" . "en-US")))
(test-equal? "parse to alist: many empty cookies"
(cookie-header->alist #"a=; b=; c=; d="
bytes->string/utf-8)
'(("a" . "") ("b" . "") ("c" . "") ("d" . "")))
(test-equal? "parse to alist: fancy cookies"
(cookie-header->alist
#"a=fn(x); b=foo[2]; c=foo=fn(x){x+3}"
bytes->string/utf-8)
'(("a" . "fn(x)")
("b" . "foo[2]")
("c" . "foo=fn(x){x+3}")))
(test-equal? "parse to alist: 3 cookies, 1 empty, 1 w/escaped dquotes"
(cookie-header->alist #"seenIntro=; uname=bob; nick=\"FuzzyDucky\"")
'((#"seenIntro" . #"")
(#"uname" . #"bob")
(#"nick" . #"\"FuzzyDucky\"")))
;; No valid cookies:
(test-equal? "no valid cookies" (cookie-header->alist #"; ; ; ") '())
(test-equal? "no valid cookies" (cookie-header->alist #"=; ;a=b ; =5; x=y z; ")
'())
(test-equal? "no valid cookies"
(cookie-header->alist #"=55; a=x\\y; b=x,y; c=x\"y; d=x y z;")
'())
;; Some valid cookies:
(test-case "some valid cookies"
(check-equal? (cookie-header->alist #"x=y; =23") '((#"x" . #"y")))
(check-equal? (cookie-header->alist #"x=y; a=b=c; p=q=r=s=t")
'((#"x" . #"y") (#"a" . #"b=c") (#"p" . #"q=r=s=t")))
(check-equal? (cookie-header->alist #"; ;x=y ; a=b; =; c=d")
'((#"a" . #"b") (#"c" . #"d")))))
;; test error cases
(define-syntax contract-test
(syntax-rules ()
[(_ e) (check-exn exn:fail:contract? (lambda () e))]))
(define-test-suite contract-tests
(contract-test (make-cookie "a" "b" #:extension "Comment=contains;semicolon"))
(contract-test (make-cookie "x" "y" #:extension "IllegalCharacter=#\000"))
(contract-test (make-cookie "x" "y" #:max-age 0))
(contract-test (make-cookie "x" "y" #:max-age -10))
(contract-test (make-cookie "x" "y" #:domain ""))
(contract-test (make-cookie "x" "y" #:domain ".com"))
(contract-test (make-cookie "x" "y" #:domain ".example.net"))
(contract-test (make-cookie "x" "y" #:domain "emptypart..example.com"))
(contract-test (make-cookie "x" "y" #:domain "bad domain.com"))
(contract-test (make-cookie "x" "y" #:domain ".bad-domain;com")))

757
net-test/tests/net/cookies/user-agent.rkt
View File

@ -1,757 +0,0 @@
#lang racket/base
(require rackunit
racket/match
racket/class
net/cookies/user-agent
(only-in net/url string->url)
;web-server/http/request-structs
(only-in racket/date date->seconds))
;;;; Date-related constants ;;;;
(define exp-date:rfc1123 "Mon, 16 Feb 2015 01:41:26 GMT")
(define exp-date:rfc850 "Monday, 16-Feb-15 01:41:26 GMT")
(define exp-date:asctime "Mon Feb 16 01:41:26 2015")
(define exp-seconds 1424079686)
;;;; Processing the Set-Cookie header ;;;;
;; Helpers: Cookie times will vary depending on when the test is run,
;; so the following two fns allow for that variation.
(define ((ua-cookie-matches expected-uac) uac)
(and (ua-cookie? uac)
(match (list uac expected-uac)
[(list (ua-cookie name value dom path exp _ _ p? h? s? http-only?)
(ua-cookie name value dom path exp _ _ p? h? s? http-only?))
#t]
[_ #f])))
(define ((test-ua-cookies-match expected-ls) ls)
(for/and ([expected expected-ls]
[cookie ls])
(and (ua-cookie? cookie)
((ua-cookie-matches expected) cookie))))
;; URLs for testing:
(define example-url (string->url "http://example.com/"))
(define https://example.com/ (string->url "https://example.com/"))
(define example.com/abc/d (string->url "http://example.com/abc/d"))
(define example.com/x/y (string->url "http://example.com/x/y"))
(define example.com/x/y/z (string->url "http://example.com/x/y/z"))
(define test-example-url (string->url "http://test.example.com/"))
(define test.example.com/abc/e (string->url "http://test.example.com/abc/e"))
(define test.example.com/x/y (string->url "http://test.example.com/x/y"))
(define test.example.com/x/y/z (string->url "http://test.example.com/x/y/z"))
(define racket-lang-url (string->url "http://racket-lang.org/"))
(module+ main
(require rackunit/text-ui)
(run-tests extract-cookies-tests)
(run-tests cookie-jar-tests)
(run-tests cookie-saving-tests)
(run-tests default-path-tests)
(run-tests date-parsing-tests1)
(run-tests date-parsing-tests2))
(module+ test (require (submod ".." main)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Testing extract-cookies
(define (test-header message headers url cookie [maxage #f])
(define now (current-seconds))
(test-equal? message
(extract-cookies headers url)
(list
(struct-copy ua-cookie cookie
[expiration-time
(if maxage (+ now maxage) max-cookie-seconds)]
[creation-time now]
[access-time now]))))
(define-test-suite extract-cookies-tests
(test-header "extract cookie with no exp-time or options"
'((#"Set-Cookie"
. #"foo=bar"))
example-url
(ua-cookie "foo" "bar" "example.com" "/" 1 1 1
#f #t #f #f))
(test-header "extract cookie with max-age only"
'((#"Set-Cookie"
. #"foo=bar; Max-Age=51"))
example-url
(ua-cookie "foo" "bar" "example.com" "/" 1 1 1
#t #t #f #f)
51)
(test-header "extract cookie with max-age and domain"
'((#"Set-Cookie"
. #"foo=bar; Max-Age=52; Domain=example.com"))
example-url
(ua-cookie "foo" "bar" "example.com" "/" 1 1 1
#t #f #f #f)
52)
(test-header "extract cookie with max-age, secure, domain"
'((#"Set-Cookie"
. #"foo=bar; Max-Age=53; Secure; Domain=example.com"))
example-url
(ua-cookie "foo" "bar" "example.com" "/" 1 1 1
#t #f #t #f)
53)
(test-header "extract cookie with httponly, domain"
'((#"Set-Cookie"
. #"foo=bar; httpOnly; Domain=example.com"))
example-url
(ua-cookie "foo" "bar" "example.com" "/" 1 1 1
#f #f #f #t))
(test-header "extract cookie with path"
'((#"Set-Cookie"
. #"foo=bar; Path=/abc/def"))
example-url
(ua-cookie "foo" "bar" "example.com" "/abc/def" 1 1 1
#f #t #f #f))
(test-header "extract cookie with domain, path"
'((#"Set-Cookie"
. #"foo=bar; Domain=test.example.com; Path=/abc/de/f"))
test-example-url
(ua-cookie "foo" "bar" "test.example.com" "/abc/de/f" 1 1 1
#f #f #f #f))
(test-header "extract cookie -- use last domain given (1)"
'((#"Set-Cookie"
. #"foo=bar; Domain=test.example.com; Domain=example.com"))
test-example-url
(ua-cookie "foo" "bar" "example.com" "/" 1 1 1 #f #f #f #f))
(test-header "extract cookie -- use last domain given (2)"
'((#"Set-Cookie"
. #"foo=bar; Domain=example.com; Domain=test.example.com;"))
test-example-url
(ua-cookie "foo" "bar" "test.example.com" "/" 1 1 1 #f #f #f #f))
(test-equal? "cookies that should be ignored"
(extract-cookies
'((#"Set-Cookie" . #"foo=bar; Domain=foo.com") ; wrong dom
(#"Set-Cookie" . #"foo=bar; Domain=test.example.com") ;subdom
(#"Set-Cookie"
. #"foo=bar; Domain=test.example.com; Path=/abc/de/f")) ;subdom
example-url)
'()))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Cookie jars: Storing & Retrieving, Generating Headers
(define-test-suite cookie-jar-tests
(parameterize ([current-cookie-jar (new list-cookie-jar%)])
(define now (current-seconds))
(test-false "cookie-header: empty jar" (cookie-header test-example-url))
(extract-and-save-cookies!
'((#"X-Test-Header" . #"ignore this header")
(#"Set-Cookie" . #"a=b; Max-Age=2000; Path=/")
(#"Another-Dummy" . #"another value to ignore")
; This next one won't get saved:
(#"Set-Cookie" . #"c=d; Max-Age=3; Domain=example.com; Path=/x/y")
(#"Set-Cookie" . #"user=bob; Max-Age=4; Path=/x")
)
test.example.com/x/y)
(test-equal? "cookie-header: one match"
(cookie-header test-example-url) ; sic, NOT -url3
#"a=b")
(test-equal? "cookie-header: one match (via domain & path)"
(cookie-header example.com/x/y/z)
#"c=d")
(test-equal? "cookie-header: multiple matches"
(cookie-header test.example.com/x/y/z)
#"c=d; user=bob; a=b")
(sleep 1) ; so next cookie's ctime is later than a's.
(extract-and-save-cookies!
'((#"Dummy-Header" . #"something to ignore")
; This cookie, being inserted later, should follow #"a=b" in the header:
(#"Set-Cookie" . #"x=y; Domain=test.example.com; Path=/"))
test.example.com/x/y)
(test-false "cookie-header: no matches" (cookie-header racket-lang-url))
(test-equal? "cookie-header: multiple matches, order w/ties broken by ctime"
(cookie-header test.example.com/x/y)
#"user=bob; a=b; x=y")
(extract-and-save-cookies!
'((#"Set-Cookie" . #"user=; Max-Age=6; Path=/x"))
test.example.com/x/y)
(test-equal? "cookie-header: after replacing a cookie"
(cookie-header test.example.com/x/y)
#"user=; a=b; x=y")
(test-equal? "cookie-header: 4 cookies, after replacing a cookie"
(cookie-header test.example.com/x/y/z)
#"c=d; user=; a=b; x=y")
(sleep 4) ; move past c's expiration
(extract-and-save-cookies! ; This should expire the "c" cookie but not "user"
'((#"Set-Cookie" . #"timeToExpire=now; Domain=test.example.com; Path=/x"))
test.example.com/x/y)
(test-equal? "cookie-header: after expiring a cookie"
(cookie-header test.example.com/x/y/z)
#"user=; timeToExpire=now; a=b; x=y") ; x is later by ctime
(sleep 3) ; move past user's expiration
(extract-and-save-cookies! ; This should expire the "user" cookie.
'((#"Set-Cookie" . #"timeToExpire=NOW; Domain=test.example.com; Path=/x"))
test.example.com/x/y)
(test-equal? "cookie-header: after expiring another cookie"
(cookie-header test.example.com/x/y/z)
#"timeToExpire=NOW; a=b; x=y")
(sleep 1) ; so next timeToExpire cookie's ctime is later
(extract-and-save-cookies!
'((#"Set-Cookie" . #"timeToExpire=SOON; Domain=example.com; Path=/x"))
test.example.com/x/y)
(test-equal? "cookie-header: same cookie on 2 domains: earlier ctime first"
(cookie-header test.example.com/x/y/z)
#"timeToExpire=NOW; timeToExpire=SOON; a=b; x=y")
(extract-and-save-cookies! ; Clear both timeToExpire cookies:
'((#"Set-Cookie" . #"timeToExpire=; Max-Age=-1; Domain=example.com; Path=/x")
(#"Set-Cookie"
. #"timeToExpire=; Max-Age=-1; Domain=test.example.com; Path=/x"))
test.example.com/x/y)
(test-equal? "cookie-header: clearing cookies"
(cookie-header test.example.com/x/y/z)
#"a=b; x=y")
(extract-and-save-cookies!
'((#"Set-Cookie" . #"supersecret=yeah; Secure"))
https://example.com/)
(test-false "cookie-header: don't send a secure cookie over insecure HTTP"
(cookie-header example-url))
(test-equal? "cookie-header: do send a secure cookie over HTTPS"
(cookie-header https://example.com/)
#"supersecret=yeah"))
(parameterize ([current-cookie-jar (new list-cookie-jar%)])
(extract-and-save-cookies!
'((#"Set-Cookie" . #"okToReplace=NO; Path=/; Domain=example.com; HttpOnly"))
example-url)
(test-equal? "cookie-header: an HTTPOnly cookie" (cookie-header example-url)
#"okToReplace=NO")
(save-cookie! (parse-cookie #"okToReplace=please?; Path=/; Domain=example.com"
example-url)
#f)
(test-equal? "save-cookie!: non-HTTP cookie can't replace an HTTPOnly one"
(cookie-header example-url)
#"okToReplace=NO")))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Cookies used in subsequent tests:
(define test-cookie1
(ua-cookie "foo" "bar" "example.com" "/" max-cookie-seconds 1 1 #f #t #f #f))
(define test-cookie2
(ua-cookie "baz" "" "example.com" "/abc" (- max-cookie-seconds 1)
1 1 #f #f #f #f))
(define test-cookie3
(ua-cookie "ugh" "" "test.example.com" "/x" max-cookie-seconds 1 1 #f #f #f #f))
(define test-cookie4 ; replaces test-cookie2
(ua-cookie "baz" "42" "example.com" "/abc" max-cookie-seconds 1 1 #f #f #f #f))
(define test-cookie5
(ua-cookie "qux" "" "racket-lang.org" "/" max-cookie-seconds 1 1 #f #f #f #f))
(define test-cookie-expired ; removes test-cookie2
(ua-cookie "baz" "" "example.com" "/abc" 100 1 1 #f #f #f #f))
(define-test-suite cookie-saving-tests
;; Inserting via save-cookie! procedure:
(parameterize ([current-cookie-jar (new list-cookie-jar%)])
(test-begin
(define the-jar (current-cookie-jar))
(check-equal? (send the-jar cookies-matching example-url) '()
"cookies-matching on an empty jar")
(save-cookie! test-cookie1)
(check-equal? (send the-jar cookies-matching example-url)
(list test-cookie1)
"cookies-matching, 1 in the jar")
(check-equal? (send the-jar cookies-matching test-example-url)
(list test-cookie1)
"cookies-matching, 1 cookie in the jar, subdomain matches")
(save-cookie! test-cookie2)
(check-equal? (send the-jar cookies-matching example-url)
(list test-cookie1)
"cookies-matching, 2 in the jar; path only matches 1")
(check-equal? (send the-jar cookies-matching example.com/abc/d)
(list test-cookie2 test-cookie1)
"cookies-matching, 2 in the jar; longer path s.b. first")
(check-equal? (send the-jar cookies-matching test-example-url)
(list test-cookie1)
"cookies-matching with 2 in the jar; subdomain; match 1")
(check-equal? (send the-jar cookies-matching test.example.com/abc/e)
(list test-cookie2 test-cookie1)
"cookies-matching with 2 in the jar; subdomain; match 2")
(save-cookie! test-cookie3)
(check-equal? (send the-jar cookies-matching example.com/abc/d)
(list test-cookie2 test-cookie1)
"cookies-matching, 3 in the jar, exclude subdomain cookie")
(check-equal? (send the-jar cookies-matching test.example.com/abc/e)
(list test-cookie2 test-cookie1)
"cookies-matching, 3 in the jar; subdomain; path excludes 1")
(check-equal? (send the-jar cookies-matching test.example.com/x/y)
(list test-cookie3 test-cookie1)
"cookies-matching, 3 in the jar; subdomain; path excludes 1")
(save-cookie! test-cookie4)
(check-equal? (send the-jar cookies-matching test.example.com/abc/e)
(list test-cookie4 test-cookie1)
"cookies-matching, 3 in jar, after replacing a cookie")
(check-equal? (send the-jar cookies-matching racket-lang-url) '()
"totally different URL")
(save-cookie! test-cookie5)
(check-equal? (send the-jar cookies-matching example-url)
(list test-cookie1)
"cookies-matching, 4 in the jar, diff domains")
(check-equal? (send the-jar cookies-matching racket-lang-url)
(list test-cookie5)
"cookies-matching, 4 in the jar, diff domains")
(save-cookie! test-cookie-expired)
(check-equal? (send the-jar cookies-matching test.example.com/abc/e)
(list test-cookie1)
"cookies-matching, check that cookies are expired")
))
;; Inserting via save-cookie! method. (Same sequence of insertions and
;; checks as above for the procedure.)
(parameterize ([current-cookie-jar (new list-cookie-jar%)])
(test-begin
(define the-jar (current-cookie-jar))
(check-equal? (send the-jar cookies-matching example-url) '()
"cookies-matching on an empty jar")
(send the-jar save-cookie! test-cookie1)
(check-equal? (send the-jar cookies-matching example-url)
(list test-cookie1)
"cookies-matching, 1 in the jar")
(check-equal? (send the-jar cookies-matching test-example-url)
(list test-cookie1)
"cookies-matching, 1 cookie in the jar, subdomain matches")
(send the-jar save-cookie! test-cookie2)
(check-equal? (send the-jar cookies-matching example-url)
(list test-cookie1)
"cookies-matching, 2 in the jar; path only matches 1")
(check-equal? (send the-jar cookies-matching example.com/abc/d)
(list test-cookie2 test-cookie1)
"cookies-matching, 2 in the jar; longer path s.b. first")
(check-equal? (send the-jar cookies-matching test-example-url)
(list test-cookie1)
"cookies-matching with 2 in the jar; subdomain; match 1")
(check-equal? (send the-jar cookies-matching test.example.com/abc/e)
(list test-cookie2 test-cookie1)
"cookies-matching with 2 in the jar; subdomain; match 2")
(send the-jar save-cookie! test-cookie3)
(check-equal? (send the-jar cookies-matching example.com/abc/d)
(list test-cookie2 test-cookie1)
"cookies-matching, 3 in the jar, exclude subdomain cookie")
(check-equal? (send the-jar cookies-matching test.example.com/abc/e)
(list test-cookie2 test-cookie1)
"cookies-matching, 3 in the jar; subdomain; path excludes 1")
(check-equal? (send the-jar cookies-matching test.example.com/x/y)
(list test-cookie3 test-cookie1)
"cookies-matching, 3 in the jar; subdomain; path excludes 1")
(send the-jar save-cookie! test-cookie4)
(check-equal? (send the-jar cookies-matching test.example.com/abc/e)
(list test-cookie4 test-cookie1)
"cookies-matching, 3 in jar, after replacing a cookie")
(check-equal? (send the-jar cookies-matching racket-lang-url) '()
"totally different URL")
(send the-jar save-cookie! test-cookie5)
(check-equal? (send the-jar cookies-matching example-url)
(list test-cookie1)
"cookies-matching, 4 in the jar, diff domains")
(check-equal? (send the-jar cookies-matching racket-lang-url)
(list test-cookie5)
"cookies-matching, 4 in the jar, diff domains")
(send the-jar save-cookie! test-cookie-expired)
(check-equal? (send the-jar cookies-matching test.example.com/abc/e)
(list test-cookie1)
"cookies-matching, check that cookies are expired")
))
;; Inserting via save-cookies! method:
(parameterize ([current-cookie-jar (new list-cookie-jar%)])
(test-begin
(define the-jar (current-cookie-jar))
(send the-jar save-cookies! (list test-cookie1 test-cookie2 test-cookie5))
(check-equal? (send the-jar cookies-matching test.example.com/abc/e)
(list test-cookie2 test-cookie1)
"inserted cookies with save-cookies! method: domain 1")
(check-equal? (send the-jar cookies-matching racket-lang-url)
(list test-cookie5)
"inserted cookies with save-cookies! method: domain 2")
))
(parameterize ([current-cookie-jar (new list-cookie-jar%)])
(test-begin
(send (current-cookie-jar) save-cookie!
(ua-cookie "x" "y" "example.com" "/" max-cookie-seconds 1 1
#f #t #f #t)
#f)
(check-equal? (send (current-cookie-jar) cookies-matching example-url)
'()
"don't save an HTTPOnly cookie that didn't come in on HTTP")
)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Parsing cookies and extracting them from headers
(define-test-suite cookie-parsing-tests
(test-pred "extracting from HTTP Response headers"
(test-ua-cookies-match
(list (ua-cookie "foo" "bar" "example.com" "/"
max-cookie-seconds
1 1 #f #t #f #f)
(ua-cookie "baz" "qux" "example.com" "/"
max-cookie-seconds
1 1 #f #t #f #t)))
(extract-cookies
'((#"X-Test-Padding" . #"notacookie")
(#"Set-Cookie" . #"foo=bar")
(#"set-Cookie" . #"baz=qux; HttpOnly"))
example-url))
(test-pred "extracting cookies from byte alist"
(test-ua-cookies-match
(list (ua-cookie "qux" "" "example.com" "/"
max-cookie-seconds 1 1 #f #f #f #f)
(ua-cookie "mum" "" "example.com" "/"
max-cookie-seconds 1 1 #f #f #f #f)))
(extract-cookies '((#"foo" . #"bar")
(#"Set-Cookie" . #"qux; ")
(#"set-Cookie" . #"mum"))
example-url))
(test-pred "parse-cookie: simple"
(ua-cookie-matches
(ua-cookie "foo" "bar" "example.com" "/" max-cookie-seconds
1 1 #f #t #f #f))
(parse-cookie #"foo=bar" example-url))
(test-pred "parse-cookie: simple, no value"
(ua-cookie-matches
(ua-cookie "foo" "" "example.com" "/" max-cookie-seconds
1 1 #f #t #f #f))
(parse-cookie #"foo=" example-url))
(test-pred "parse-cookie: multiple semicolons in a row"
(ua-cookie-matches
(ua-cookie "foo" "bar" "example.com" "/" max-cookie-seconds
1 1 #f #t #f #f))
(parse-cookie #"foo=bar;;;" example-url))
(test-pred "parse-cookie: ignore av-pair without name"
(ua-cookie-matches
(ua-cookie "foo" "bar" "example.com" "/" max-cookie-seconds
1 1 #f #t #f #f))
(parse-cookie #"foo=bar;=xyz" example-url))
(test-pred "parse-cookie: ignore empty av-pair"
(ua-cookie-matches
(ua-cookie "foo" "bar" "example.com" "/" max-cookie-seconds
1 1 #f #t #f #f))
(parse-cookie #"foo=bar;=;" example-url))
(test-pred "parse-cookie: domain"
(ua-cookie-matches
(ua-cookie "foo" "bar" "example.com" "/" max-cookie-seconds
1 1 #f #f #f #f))
(parse-cookie #"foo=bar; Domain=example.com" example-url))
(test-pred "parse-cookie: ignore empty domain"
(ua-cookie-matches
(ua-cookie "foo" "bar" "test.example.com" "/" max-cookie-seconds
1 1 #f #t #f #f))
(parse-cookie #"foo=bar; Domain=" test-example-url))
(test-pred "parse-cookie: domain - uppercase & space don't matter"
(ua-cookie-matches
(ua-cookie "foo" "bar" "example.com" "/" max-cookie-seconds
1 1 #f #f #f #f))
(parse-cookie #"foo=bar; DOMAIN = example.com" example-url))
(test-pred "parse-cookie: subdomain"
(ua-cookie-matches
(ua-cookie "foo" "bar" "example.com" "/" max-cookie-seconds
1 1 #f #f #f #f))
(parse-cookie #"foo=bar; Domain=example.com" test-example-url))
(test-pred "parse-cookie: subdomain with leading dot (which must be removed)"
(ua-cookie-matches
(ua-cookie "foo" "bar" "example.com" "/" max-cookie-seconds
1 1 #f #f #f #f))
(parse-cookie #"foo=bar; Domain=.example.com" test-example-url))
(test-pred "parse-cookie: subdomain that must be lowercased"
(ua-cookie-matches
(ua-cookie "foo" "bar" "example.com" "/" max-cookie-seconds
1 1 #f #f #f #f))
(parse-cookie #"foo=bar; Domain=Example.Com" test-example-url))
(test-pred "parse-cookie: multiple domains: use the final domain"
(ua-cookie-matches
(ua-cookie "foo" "bar" "example.com" "/" max-cookie-seconds
1 1 #f #f #f #f))
(parse-cookie #"foo=bar; Domain=test.example.com; Domain=example.com"
test-example-url))
(test-pred "parse-cookie: ignore empty path"
(ua-cookie-matches
(ua-cookie "foo" "bar" "example.com" "/" max-cookie-seconds
1 1 #f #t #f #f))
(parse-cookie #"foo=bar; Path=" example-url))
(test-pred "parse-cookie: ignore non-absolute path"
(ua-cookie-matches
(ua-cookie "foo" "bar" "example.com" "/" max-cookie-seconds
1 1 #f #t #f #f))
(parse-cookie #"foo=bar; Path=some/place/" example-url))
(test-pred "parse-cookie: non-empty path"
(ua-cookie-matches
(ua-cookie "foo" "bar" "example.com" "/some/place"
max-cookie-seconds 1 1 #f #t #f #f))
(parse-cookie #"foo=bar; Path=/some/place" example-url))
(let ([current-time (current-seconds)])
(test-pred "parse-cookie: max-age"
(ua-cookie-matches
(ua-cookie "foo" "bar" "example.com" "/" (+ current-time 56)
1 1 #t #t #f #f))
(parse-cookie #"foo=bar; Max-age=56" example-url)))
(test-pred "parse-cookie: negative max-age"
(ua-cookie-matches
(ua-cookie "foo" "bar" "example.com" "/" min-cookie-seconds
1 1 #t #t #f #f))
(parse-cookie #"foo=bar; Max-age=-1" example-url))
(test-pred "parse-cookie: invalid max-age (non-initial dash)"
(ua-cookie-matches
(ua-cookie "foo" "bar" "example.com" "/" max-cookie-seconds
1 1 #f #t #f #f))
(parse-cookie #"foo=bar; Max-age=123-456" example-url))
(test-pred "parse-cookie: invalid max-age (invalid starting char)"
(ua-cookie-matches
(ua-cookie "foo" "bar" "example.com" "/" max-cookie-seconds
1 1 #f #t #f #f))
(parse-cookie #"foo=bar; Max-age=/123456" example-url))
(test-pred "parse-cookie: invalid max-age (other non-digit chars)"
(ua-cookie-matches
(ua-cookie "foo" "bar" "example.com" "/" max-cookie-seconds
1 1 #f #t #f #f))
(parse-cookie #"foo=bar; Max-age=123*456" example-url))
(test-pred "parse-cookie: Expires (RFC1123)"
(ua-cookie-matches
(ua-cookie "foo" "bar" "example.com" "/" exp-seconds
1 1 #t #t #f #f))
(parse-cookie (bytes-append #"foo=bar; Expires="
(string->bytes/utf-8
exp-date:rfc1123))
example-url))
(test-pred "parse-cookie: Expires (RFC850)"
(ua-cookie-matches
(ua-cookie "foo" "bar" "example.com" "/" exp-seconds
1 1 #t #t #f #f))
(parse-cookie (bytes-append #"foo=bar; Expires="
(string->bytes/utf-8
exp-date:rfc850))
example-url))
(test-pred "parse-cookie: Expires (ANSI ctime)"
(ua-cookie-matches
(ua-cookie "foo" "bar" "example.com" "/" exp-seconds
1 1 #t #t #f #f))
(parse-cookie (bytes-append #"foo=bar; Expires="
(string->bytes/utf-8
exp-date:asctime))
example-url))
(let ([now (current-seconds)])
(test-pred "parse-cookie: Max-Age overrides Expires"
(ua-cookie-matches
(ua-cookie "foo" "bar" "example.com" "/" (+ now 86400)
1 1 #t #t #f #f))
(parse-cookie (bytes-append #"foo=bar; "
#"Max-age=86400; "
#"Expires="
(string->bytes/utf-8
exp-date:rfc1123))
example-url)))
(let ([now (current-seconds)])
(test-pred "parse-cookie: Max-Age overrides Expires that comes first"
(ua-cookie-matches
(ua-cookie "foo" "bar" "example.com" "/" (+ now 86400)
1 1 #t #t #f #f))
(parse-cookie (bytes-append #"foo=bar; "
#"Expires="
(string->bytes/utf-8
exp-date:rfc1123)
#"; Max-age=86400")
example-url)))
(test-pred "parse-cookie: secure flag"
(ua-cookie-matches
(ua-cookie "foo" "bar" "example.com" "/" max-cookie-seconds 1 1
#f #t #t #f))
(parse-cookie #"foo=bar; Secure;" example-url))
(test-pred "parse-cookie: HttpOnly flag"
(ua-cookie-matches
(ua-cookie "foo" "bar" "example.com" "/" max-cookie-seconds 1 1
#f #t #f #t))
(parse-cookie #"foo=bar; HttpOnly;" example-url))
(test-pred "parse-cookie: httponly flag, case doesn't matter"
(ua-cookie-matches
(ua-cookie "foo" "bar" "example.com" "/" max-cookie-seconds 1 1
#f #t #f #t))
(parse-cookie #"foo=bar; httponly;" example-url))
(test-pred "parse-cookie: both Secure and HttpOnly"
(ua-cookie-matches
(ua-cookie "foo" "bar" "example.com" "/" max-cookie-seconds 1 1
#f #t #t #t))
(parse-cookie #"foo=bar; Secure ; HttpOnly;" example-url))
(let ([current-time (current-seconds)])
(test-pred "parse-cookie: secure and max-age"
(ua-cookie-matches
(ua-cookie "foo" "bar" "example.com" "/"
(+ current-time 20000) 1 1
#t #t #t #f))
(parse-cookie
#"foo=bar; Secure; Max-Age=20000"
example-url)))
(let ([now (current-seconds)])
(test-pred "parse-cookie: all but domain"
(ua-cookie-matches
(ua-cookie "x" "y" "test.example.com" "/apps/special"
(+ now 20000) 1 1
#t #t #t #t))
(parse-cookie
(bytes-append #"x=y; Secure; Max-Age=20000; Expires="
(string->bytes/utf-8 exp-date:rfc1123)
#"; HttPOnly; SECURE; "
#"Path=/apps/special")
test-example-url)))
(let ([now (current-seconds)])
(test-pred "parse-cookie: kitchen sink"
(ua-cookie-matches
(ua-cookie "x" "y" "example.com" "/apps/special"
(+ now 20000) 1 1
#t #f #t #t))
(parse-cookie
(bytes-append #"x=y; Secure; Max-Age=20000; Expires="
(string->bytes/utf-8 exp-date:rfc1123)
#"; HttPOnly; SECURE; Domain=.example.com; "
#"Path=/apps/special")
test-example-url)))
;; Cookie parsing failures:
(test-false "no equals in nvpair" (parse-cookie #"foo" example-url))
(test-false "no equals in nvpair" (parse-cookie #"foo;" example-url))
(test-false "no cookie name" (parse-cookie #"=foo" example-url))
(test-false "domain doesn't match"
(parse-cookie #"foo=bar; Domain=yahoo.com" example-url)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define-test-suite default-path-tests
(test-equal? "default path with no slashes"
(default-path (string->url "http://example.com"))
"/")
(test-equal? "default path with one slash"
(default-path example-url)
"/")
(test-equal? "default path with multiple slashes"
(default-path (string->url "http://example.com/foo/bar"))
"/foo")
(test-equal? "default path with empty string URL"
(default-path (string->url ""))
"/")
(test-equal? "default path with no host and no slash"
(default-path (string->url "foo"))
"/")
(test-equal? "default path with no host and one slash"
(default-path (string->url "/foo"))
"/")
(test-equal? "default path with no host and several parts"
(default-path (string->url "/foo/bar/baz"))
"/foo/bar"))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Date-parsing tests
(define-test-suite date-parsing-tests1
(test-equal? "parse RFC1123 date"
(date->seconds (parse-date exp-date:rfc1123))
exp-seconds)
(test-equal? "parse RFC1123 date (4-digit yr >= 2000)"
(parse-date "Thu, 19 Feb 2015 09:23:26 GMT")
(date 26 23 9 19 2 2015 0 0 #f 0))
(test-equal? "parse RFC1123 date (2-digit yr >= 2000)"
(parse-date "Thu, 19 Feb 15 09:23:26 GMT")
(date 26 23 9 19 2 2015 0 0 #f 0))
(test-equal? "parse RFC1123 date (max 2-digit yr >= 2000)"
(parse-date "Thu, 19 Feb 69 09:23:26 GMT")
(date 26 23 9 19 2 2069 0 0 #f 0))
(test-equal? "parse RFC1123 date (2-digit yr < 2000)"
(parse-date "Thu, 19 Feb 78 09:23:26 GMT")
(date 26 23 9 19 2 1978 0 0 #f 0))
(test-equal? "parse bare-minimum date"
(parse-date "19 Feb 15 09:23:26")
(date 26 23 9 19 2 2015 0 0 #f 0)))
(define months
(map symbol->string
'(jan feb mar apr may jun jul aug sep oct nov dec)))
(define (randtest n)
(if (zero? n)
(void)
(let ([day (+ 1 (random 28))]
[mon (list-ref months (random 12))]
[y (+ 2000 (random 100))]
[h (random 24)]
[m (random 60)]
[s (random 60)])
(define d1
(parse-date
(format "~a ~a, ~a ~a:~a:~a GMT" mon day y h m s)))
(define d2
(parse-date
(format "~a:~a:~a GMT on ~a ~a, ~a" h m s mon day y)))
(define d3
(parse-date
(format "~a:~a:~a GMT on ~a ~a ~a" h m s day mon y)))
(define d4
(parse-date
(format "~a ~a ~a ~a:~a:~a" y mon day h m s)))
(check-equal? d1 d2)
(check-equal? d1 d3)
(check-equal? d1 d4)
(randtest (sub1 n)))))
;(randtest 100)
(define-test-suite date-parsing-tests2
(test-case
"parsing other date formats"
(test-equal? "parse RFC850 date"
(date->seconds (parse-date exp-date:rfc850))
exp-seconds)
(test-equal? "parse asctime() date"
(date->seconds (parse-date exp-date:asctime))
exp-seconds))
(test-case
"invalid date component tests"
(test-false "invalid day"
(parse-date "Mon, 30 Feb 2015 01:41:26 GMT"))
(test-false "invalid day"
(parse-date "Mon, 32 Jan 2015 01:41:26 GMT"))
(test-false "invalid day"
(parse-date "Mon, 31 Apr 2015 01:41:26 GMT"))
(test-false "missing day"
(parse-date "Mon, Dec 2015 01:41:26 GMT"))
(test-false "invalid month"
(parse-date "Mon, 31 Erb 2015 01:41:26 GMT"))
(test-false "missing month"
(parse-date "Mon, 31 2015 01:41:26 GMT"))
(test-false "invalid year"
(parse-date "Mon, 31 Jan 1515 01:41:26 GMT"))
(test-false "invalid year"
(parse-date "Mon, 31 Jan 19999 01:41:26 GMT"))
(test-false "invalid year"
(parse-date "Mon, 31 Jan -5 01:41:26 GMT"))
(test-false "invalid year"
(parse-date "Mon, 31 Jan 0 01:41:26 GMT"))
(test-false "missing year"
(parse-date "Mon, 31 Jan 01:41:26 GMT"))
(test-false "invalid hours"
(parse-date "Mon, 31 Jan 2015 24:41:26 GMT"))
(test-false "invalid minutes"
(parse-date "Mon, 31 Jan 2015 10:60:26 GMT"))
(test-false "invalid seconds"
(parse-date "Mon, 31 Jan 2015 22:41:60 GMT"))))