diff --git a/net-doc/net/scribblings/cookie.scrbl b/net-doc/net/scribblings/cookie.scrbl index 3355d37d60..0e4cf79ce3 100644 --- a/net-doc/net/scribblings/cookie.scrbl +++ b/net-doc/net/scribblings/cookie.scrbl @@ -8,9 +8,15 @@ @title[#:tag "cookie"]{Cookie: Legacy HTTP Client Storage} - @deprecated[@racketmodname[net/cookies/server]]{ - The new @secref["cookies" #:doc '(lib "net/scribblings/net.scrbl")] - library implements RFC 6265, which supersedes the obsolete RFC 2109.} + @deprecated[@hyperlink["http://pkgs.racket-lang.org/#[net-cookies]"]{the + net-cookies package}]{ + 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 utilities for using cookies as specified in RFC 2109 @cite["RFC2109"].} diff --git a/net-doc/net/scribblings/cookies.scrbl b/net-doc/net/scribblings/cookies.scrbl deleted file mode 100644 index d3727583d5..0000000000 --- a/net-doc/net/scribblings/cookies.scrbl +++ /dev/null @@ -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. diff --git a/net-doc/net/scribblings/net.scrbl b/net-doc/net/scribblings/net.scrbl index 9ae486c376..9dcb108dad 100644 --- a/net-doc/net/scribblings/net.scrbl +++ b/net-doc/net/scribblings/net.scrbl @@ -25,9 +25,8 @@ @include-section["tcp-redirect.scrbl"] @include-section["ssl-tcp-unit.scrbl"] @include-section["cgi.scrbl"] -@include-section["cookies.scrbl"] -@include-section["git-checkout.scrbl"] @include-section["cookie.scrbl"] +@include-section["git-checkout.scrbl"] @(bibliography @@ -49,20 +48,6 @@ #:url "http://www.ietf.org/rfc/rfc0977.txt" #: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" #:title "Uniform Resource Locators (URL)" #:author "T. Berners-Lee, L. Masinter, and M. McCahill" diff --git a/net-lib/net/cookies/common.rkt b/net-lib/net/cookies/common.rkt deleted file mode 100644 index 87ffc4782a..0000000000 --- a/net-lib/net/cookies/common.rkt +++ /dev/null @@ -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* -;; 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 = -;; ; 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 = -;; av-octet = -;; 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 #\;))) diff --git a/net-lib/net/cookies/server.rkt b/net-lib/net/cookies/server.rkt deleted file mode 100644 index 3d9d698265..0000000000 --- a/net-lib/net/cookies/server.rkt +++ /dev/null @@ -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") - diff --git a/net-lib/net/cookies/struct.rkt b/net-lib/net/cookies/struct.rkt deleted file mode 100644 index 2e1ee6752d..0000000000 --- a/net-lib/net/cookies/struct.rkt +++ /dev/null @@ -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 -|# diff --git a/net-lib/net/cookies/user-agent.rkt b/net-lib/net/cookies/user-agent.rkt deleted file mode 100644 index 15773bd001..0000000000 --- a/net-lib/net/cookies/user-agent.rkt +++ /dev/null @@ -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) #\/))))) - - diff --git a/net-test/tests/net/cookies/common.rkt b/net-test/tests/net/cookies/common.rkt deleted file mode 100644 index 87ddeb7539..0000000000 --- a/net-test/tests/net/cookies/common.rkt +++ /dev/null @@ -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\"" "" "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 diff --git a/net-test/tests/net/cookies/server.rkt b/net-test/tests/net/cookies/server.rkt deleted file mode 100644 index 6da4b6deee..0000000000 --- a/net-test/tests/net/cookies/server.rkt +++ /dev/null @@ -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"))) - diff --git a/net-test/tests/net/cookies/user-agent.rkt b/net-test/tests/net/cookies/user-agent.rkt deleted file mode 100644 index 81338adbf1..0000000000 --- a/net-test/tests/net/cookies/user-agent.rkt +++ /dev/null @@ -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"))))