summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
Diffstat
-rw-r--r--doc/cookiejar.n217
-rw-r--r--doc/http.n111
-rw-r--r--doc/idna.n88
-rw-r--r--library/http/cookiejar.tcl745
-rw-r--r--library/http/effective_tld_names.txt.gzbin0 -> 39188 bytes
-rw-r--r--library/http/http.tcl121
-rw-r--r--library/http/idna.tcl292
-rw-r--r--library/http/pkgIndex.tcl2
-rw-r--r--tests/http.test451
-rw-r--r--tests/httpcookie.test853
-rwxr-xr-x[-rw-r--r--]tests/tcltest.test0
11 files changed, 2876 insertions, 4 deletions
diff --git a/doc/cookiejar.n b/doc/cookiejar.n
new file mode 100644
index 0000000..ac71759
--- /dev/null
+++ b/doc/cookiejar.n
@@ -0,0 +1,217 @@
+'\"
+'\" Copyright (c) 2014-2018 Donal K. Fellows.
+'\"
+'\" See the file "license.terms" for information on usage and redistribution
+'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+'\"
+.TH "cookiejar" n 0.1 http "Tcl Bundled Packages"
+.so man.macros
+.BS
+'\" Note: do not modify the .SH NAME line immediately below!
+.SH NAME
+cookiejar \- Implementation of the Tcl http package cookie jar protocol
+.SH SYNOPSIS
+.nf
+\fBpackage require\fR \fBcookiejar\fR ?\fB0.1\fR?
+
+\fB::http::cookiejar configure\fR ?\fIoptionName\fR? ?\fIoptionValue\fR?
+\fB::http::cookiejar create\fR \fIname\fR ?\fIfilename\fR?
+\fB::http::cookiejar new\fR ?\fIfilename\fR?
+
+\fIcookiejar\fR \fBdestroy\fR
+\fIcookiejar\fR \fBforceLoadDomainData\fR
+\fIcookiejar\fR \fBgetCookies\fR \fIprotocol host path\fR
+\fIcookiejar\fR \fBstoreCookie\fR \fIoptions\fR
+\fIcookiejar\fR \fBlookup\fR ?\fIhost\fR? ?\fIkey\fR?
+.fi
+.SH DESCRIPTION
+.PP
+The cookiejar package provides an implementation of the http package's cookie
+jar protocol using an SQLite database. It provides one main command,
+\fB::http::cookiejar\fR, which is a TclOO class that should be instantiated to
+create a cookie jar that manages a particular HTTP session.
+.PP
+The database management policy can be controlled at the package level by the
+\fBconfigure\fR method on the \fB::http::cookiejar\fR class object:
+.TP
+\fB::http::cookiejar configure\fR ?\fIoptionName\fR? ?\fIoptionValue\fR?
+.
+If neither \fIoptionName\fR nor \fIoptionValue\fR are supplied, this returns a
+copy of the configuration as a Tcl dictionary. If just \fIoptionName\fR is
+supplied, just the value of the named option is returned. If both
+\fIoptionName\fR and \fIoptionValue\fR are given, the named option is changed
+to be the given value.
+.RS
+.PP
+Supported options are:
+.TP
+\fB\-domainfile \fIfilename\fR
+.
+A file (defaulting to within the cookiejar package) with a description of the
+list of top-level domains (e.g., \fB.com\fR or \fB.co.jp\fR). Such domains
+\fImust not\fR accept cookies set upon them. Note that the list of such
+domains is both security-sensitive and \fInot\fR constant and should be
+periodically refetched. Cookie jars maintain their own cache of the domain
+list.
+.TP
+\fB\-domainlist \fIurl\fR
+.
+A URL to fetch the list of top-level domains (e.g., \fB.com\fR or
+\fB.co.jp\fR) from. Such domains \fImust not\fR accept cookies set upon
+them. Note that the list of such domains is both security-sensitive and
+\fInot\fR constant and should be periodically refetched. Cookie jars maintain
+their own cache of the domain list.
+.TP
+\fB\-domainrefresh \fIintervalMilliseconds\fR
+.
+The number of milliseconds between checks of the \fI\-domainlist\fR for new
+domains.
+.TP
+\fB\-loglevel \fIlevel\fR
+.
+The logging level of this package. The logging level must be (in order of
+decreasing verbosity) one of \fBdebug\fR, \fBinfo\fR, \fBwarn\fR, or
+\fBerror\fR.
+.TP
+\fB\-offline \fIflag\fR
+.
+Allows the cookie managment engine to be placed into offline mode. In offline
+mode, the list of domains is read immediately from the file configured in the
+\fB\-domainfile\fR option, and the \fB\-domainlist\fR option is not used; it
+also makes the \fB\-domainrefresh\fR option be effectively ignored.
+.TP
+\fB\-purgeold \fIintervalMilliseconds\fR
+.
+The number of milliseconds between checks of the database for expired
+cookies; expired cookies are deleted.
+.TP
+\fB\-retain \fIcookieCount\fR
+.
+The maximum number of cookies to retain in the database.
+.TP
+\fB\-vacuumtrigger \fIdeletionCount\fR
+.
+A count of the number of persistent cookie deletions to go between vacuuming
+the database.
+.RE
+.PP
+Cookie jar instances may be made with any of the standard TclOO instance
+creation methods (\fBcreate\fR or \fRnew\fR).
+.TP
+\fB::http::cookiejar new\fR ?\fIfilename\fR?
+.
+If a \fIfilename\fR argument is provided, it is the name of a file containing
+an SQLite database that will contain the persistent cookies maintained by the
+cookie jar; the database will be created if the file does not already
+exist. If \fIfilename\fR is not supplied, the database will be held entirely within
+memory, which effectively forces all cookies within it to be session cookies.
+.SS "INSTANCE METHODS"
+.PP
+The following methods are supported on the instances:
+.TP
+\fIcookiejar\fR \fBdestroy\fR
+.
+This is the standard TclOO destruction method. It does \fInot\fR delete the
+SQLite database if it is written to disk. Callers are responsible for ensuring
+that the cookie jar is not in use by the http package at the time of
+destruction.
+.TP
+\fIcookiejar\fR \fBforceLoadDomainData\fR
+.
+This method causes the cookie jar to immediately load (and cache) the domain
+list data. The domain list will be loaded from the \fB\-domainlist\fR
+configured a the package level if that is enabled, and otherwise will be
+obtained from the \fB\-domainfile\fR configured at the package level.
+.TP
+\fIcookiejar\fR \fBgetCookies\fR \fIprotocol host path\fR
+.
+This method obtains the cookies for a particular HTTP request. \fIThis
+implements the http cookie jar protocol.\fR
+.TP
+\fIcookiejar\fR \fBpolicyAllow\fR \fIoperation domain path\fR
+.
+This method is called by the \fBstoreCookie\fR method to get a decision on
+whether to allow \fIoperation\fR to be performed for the \fIdomain\fR and
+\fIpath\fR. This is checked immediately before the database is updated but
+after the built-in security checks are done, and should return a boolean
+value; if the value is false, the operation is rejected and the database is
+not modified. The supported \fIoperation\fRs are:
+.RS
+.TP
+\fBdelete\fR
+.
+The \fIdomain\fR is seeking to delete a cookie.
+.TP
+\fBsession\fR
+.
+The \fIdomain\fR is seeking to create or update a session cookie.
+.TP
+\fBset\fR
+.
+The \fIdomain\fR is seeking to create or update a persistent cookie (with a
+defined lifetime).
+.PP
+The default implementation of this method just returns true, but subclasses of
+this class may impose their own rules.
+.RE
+.TP
+\fIcookiejar\fR \fBstoreCookie\fR \fIoptions\fR
+.
+This method stores a single cookie from a particular HTTP response. Cookies
+that fail security checks are ignored. \fIThis implements the http cookie jar
+protocol.\fR
+.TP
+\fIcookiejar\fR \fBlookup\fR ?\fIhost\fR? ?\fIkey\fR?
+.
+This method looks a cookie by exact host (or domain) matching. If neither
+\fIhost\fR nor \fIkey\fR are supplied, the list of hosts for which a cookie is
+stored is returned. If just \fIhost\fR (which may be a hostname or a domain
+name) is supplied, the list of cookie keys stored for that host is returned.
+If both \fIhost\fR and \fIkey\fR are supplied, the value for that key is
+returned; it is an error if no such host or key match exactly.
+.SH "EXAMPLES"
+.PP
+The simplest way of using a cookie jar is to just permanently configure it at
+the start of the application.
+.PP
+.CS
+package require http
+\fBpackage require cookiejar\fR
+
+set cookiedb ~/.tclcookies.db
+http::configure -cookiejar [\fBhttp::cookiejar new\fR $cookiedb]
+
+# No further explicit steps are required to use cookies
+set tok [http::geturl http://core.tcl.tk/]
+.CE
+.PP
+To only allow a particular domain to use cookies, perhaps because you only
+want to enable a particular host to create and manipulate sessions, create a
+subclass that imposes that policy.
+.PP
+.CS
+package require http
+\fBpackage require cookiejar\fR
+
+oo::class create MyCookieJar {
+ superclass \fBhttp::cookiejar\fR
+
+ method \fBpolicyAllow\fR {operation domain path} {
+ return [expr {$domain eq "my.example.com"}]
+ }
+}
+
+set cookiedb ~/.tclcookies.db
+http::configure -cookiejar [MyCookieJar new $cookiedb]
+
+# No further explicit steps are required to use cookies
+set tok [http::geturl http://core.tcl.tk/]
+.CE
+.SH "SEE ALSO"
+http(n), oo::class(n), sqlite3(n)
+.SH KEYWORDS
+cookie, internet, security policy, www
+'\" Local Variables:
+'\" mode: nroff
+'\" fill-column: 78
+'\" End:
diff --git a/doc/http.n b/doc/http.n
index a986704..7845e60 100644
--- a/doc/http.n
+++ b/doc/http.n
@@ -99,6 +99,15 @@ comma-separated list of mime type patterns that you are
willing to receive. For example,
.QW "image/gif, image/jpeg, text/*" .
.TP
+\fB\-cookiejar\fR \fIcommand\fR
+.VS TIP406
+The cookie store for the package to use to manage HTTP cookies.
+\fIcommand\fR is a command prefix list; if the empty list (the
+default value) is used, no cookies will be sent by requests or stored
+from responses. The command indicated by \fIcommand\fR, if supplied,
+must obey the \fBCOOKIE JAR PROTOCOL\fR described below.
+.VE TIP406
+.TP
\fB\-pipeline\fR \fIboolean\fR
.
Specifies whether HTTP/1.1 transactions on a persistent socket will be
@@ -770,6 +779,108 @@ Subsequent GET and HEAD requests in a failed pipeline will also be retried.
that the retry is appropriate\fR - specifically, the application must know
that if the failed POST successfully modified the state of the server, a repeat POST
would have no adverse effect.
+.VS TIP406
+.SH "COOKIE JAR PROTOCOL"
+.PP
+Cookies are short key-value pairs used to implement sessions within the
+otherwise-stateless HTTP protocol. (See RFC 6265 for details; Tcl does not
+implement the Cookie2 protocol as that is rarely seen in the wild.)
+.PP
+Cookie storage managment commands \(em
+.QW "cookie jars"
+\(em must support these subcommands which form the HTTP cookie storage
+management protocol. Note that \fIcookieJar\fR below does not have to be a
+command name; it is properly a command prefix (a Tcl list of words that will
+be expanded in place) and admits many possible implementations.
+.PP
+Though not formally part of the protocol, it is expected that particular
+values of \fIcookieJar\fR will correspond to sessions; it is up to the caller
+of \fB::http::config\fR to decide what session applies and to manage the
+deletion of said sessions when they are no longer desired (which should be
+when they not configured as the current cookie jar).
+.TP
+\fIcookieJar \fBgetCookies \fIprotocol host requestPath\fR
+.
+This command asks the cookie jar what cookies should be supplied for a
+particular request. It should take the \fIprotocol\fR (typically \fBhttp\fR or
+\fBhttps\fR), \fIhost\fR name and \fIrequestPath\fR (parsed from the \fIurl\fR
+argument to \fB::http::geturl\fR) and return a list of cookie keys and values
+that describe the cookies to supply to the remote host. The list must have an
+even number of elements.
+.RS
+.PP
+There should only ever be at most one cookie with a particular key for any
+request (typically the one with the most specific \fIhost\fR/domain match and
+most specific \fIrequestPath\fR/path match), but there may be many cookies
+with different names in any request.
+.RE
+.TP
+\fIcookieJar \fBstoreCookie \fIcookieDictionary\fR
+.
+This command asks the cookie jar to store a particular cookie that was
+returned by a request; the result of this command is ignored. The cookie
+(which will have been parsed by the http package) is described by a
+dictionary, \fIcookieDictionary\fR, that may have the following keys:
+.RS
+.TP
+\fBdomain\fR
+.
+This is always present. Its value describes the domain hostname \fIor
+prefix\fR that the cookie should be returned for. The checking of the domain
+against the origin (below) should be careful since sites that issue cookies
+should only do so for domains related to themselves. Cookies that do not obey
+a relevant origin matching rule should be ignored.
+.TP
+\fBexpires\fR
+.
+This is optional. If present, the cookie is intended to be a persistent cookie
+and the value of the option is the Tcl timestamp (in seconds from the same
+base as \fBclock seconds\fR) of when the cookie expires (which may be in the
+past, which should result in the cookie being deleted immediately). If absent,
+the cookie is intended to be a session cookie that should be not persisted
+beyond the lifetime of the cookie jar.
+.TP
+\fBhostonly\fR
+.
+This is always present. Its value is a boolean that describes whether the
+cookie is a single host cookie (true) or a domain-level cookie (false).
+.TP
+\fBhttponly\fR
+.
+This is always present. Its value is a boolean that is true when the site
+wishes the cookie to only ever be used with HTTP (or HTTPS) traffic.
+.TP
+\fBkey\fR
+.
+This is always present. Its value is the \fIkey\fR of the cookie, which is
+part of the information that must be return when sending this cookie back in a
+future request.
+.TP
+\fBorigin\fR
+.
+This is always present. Its value describes where the http package believes it
+received the cookie from, which may be useful for checking whether the
+cookie's domain is valid.
+.TP
+\fBpath\fR
+.
+This is always present. Its value describes the path prefix of requests to the
+cookie domain where the cookie should be returned.
+.TP
+\fBsecure\fR
+.
+This is always present. Its value is a boolean that is true when the cookie
+should only used on requests sent over secure channels (typically HTTPS).
+.TP
+\fBvalue\fR
+.
+This is always present. Its value is the value of the cookie, which is part of
+the information that must be return when sending this cookie back in a future
+request.
+.PP
+Other keys may always be ignored; they have no meaning in this protocol.
+.RE
+.VE TIP406
.SH EXAMPLE
.PP
This example creates a procedure to copy a URL to a file while printing a
diff --git a/doc/idna.n b/doc/idna.n
new file mode 100644
index 0000000..744bf67
--- /dev/null
+++ b/doc/idna.n
@@ -0,0 +1,88 @@
+'\"
+'\" Copyright (c) 2014-2018 Donal K. Fellows.
+'\"
+'\" See the file "license.terms" for information on usage and redistribution
+'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+'\"
+.TH "idna" n 0.1 http "Tcl Bundled Packages"
+.so man.macros
+.BS
+'\" Note: do not modify the .SH NAME line immediately below!
+.SH NAME
+tcl::idna \- Support for normalization of Internationalized Domain Names
+.SH SYNOPSIS
+.nf
+package require tcl::idna 1.0
+
+\fBtcl::idna decode\fR \fIhostname\fR
+\fBtcl::idna encode\fR \fIhostname\fR
+\fBtcl::idna puny decode\fR \fIstring\fR ?\fIcase\fR?
+\fBtcl::idna puny encode\fR \fIstring\fR ?\fIcase\fR?
+\fBtcl::idna version\fR
+.fi
+.SH DESCRIPTION
+This package provides an implementation of the punycode scheme used in
+Internationalised Domain Names, and some access commands. (See RFC 3492 for a
+description of punycode.)
+.TP
+\fBtcl::idna decode\fR \fIhostname\fR
+.
+This command takes the name of a host that potentially contains
+punycode-encoded character sequences, \fIhostname\fR, and returns the hostname
+as might be displayed to the user. Note that there are often UNICODE
+characters that have extremely similar glyphs, so care should be taken with
+displaying hostnames to users.
+.TP
+\fBtcl::idna encode\fR \fIhostname\fR
+.
+This command takes the name of a host as might be displayed to the user,
+\fIhostname\fR, and returns the version of the hostname with characters not
+permitted in basic hostnames encoded with punycode.
+.TP
+\fBtcl::idna puny\fR \fIsubcommand ...\fR
+.
+This command provides direct access to the basic punycode encoder and
+decoder. It supports two \fIsubcommand\fRs:
+.RS
+.TP
+\fBtcl::idna puny decode\fR \fIstring\fR ?\fIcase\fR?
+.
+This command decodes the punycode-encoded string, \fIstring\fR, and returns
+the result. If \fIcase\fR is provided, it is a boolean to make the case be
+folded to upper case (if \fIcase\fR is true) or lower case (if \fIcase\fR is
+false) during the decoding process; if omitted, no case transformation is
+applied.
+.TP
+\fBtcl::idna puny encode\fR \fIstring\fR ?\fIcase\fR?
+.
+This command encodes the string, \fIstring\fR, and returns the
+punycode-encoded version of the string. If \fIcase\fR is provided, it is a
+boolean to make the case be folded to upper case (if \fIcase\fR is true) or
+lower case (if \fIcase\fR is false) during the encoding process; if omitted,
+no case transformation is applied.
+.RE
+.TP
+\fBtcl::idna version\fR
+.
+This returns the version of the \fBtcl::idna\fR package.
+.SH "EXAMPLE"
+.PP
+This is an example of how punycoding of a string works:
+.PP
+.CS
+package require tcl::idna
+
+puts [\fBtcl::idna puny encode\fR "abc\(->def"]
+# prints: \fIabcdef-kn2c\fR
+puts [\fBtcl::idna puny decode\fR "abcdef-kn2c"]
+# prints: \fIabc\(->def\fR
+.CE
+'\" TODO: show how it handles a real domain name
+.SH "SEE ALSO"
+http(n), cookiejar(n)
+.SH KEYWORDS
+internet, www
+'\" Local Variables:
+'\" mode: nroff
+'\" fill-column: 78
+'\" End:
diff --git a/library/http/cookiejar.tcl b/library/http/cookiejar.tcl
new file mode 100644
index 0000000..309ca7a
--- /dev/null
+++ b/library/http/cookiejar.tcl
@@ -0,0 +1,745 @@
+# cookiejar.tcl --
+#
+# Implementation of an HTTP cookie storage engine using SQLite. The
+# implementation is done as a TclOO class, and includes a punycode
+# encoder and decoder (though only the encoder is currently used).
+#
+# See the file "license.terms" for information on usage and redistribution of
+# this file, and for a DISCLAIMER OF ALL WARRANTIES.
+
+# Dependencies
+package require Tcl 8.6
+package require http 2.8.4
+package require sqlite3
+package require tcl::idna 1.0
+
+#
+# Configuration for the cookiejar package, plus basic support procedures.
+#
+
+# This is the class that we are creating
+if {![llength [info commands ::http::cookiejar]]} {
+ ::oo::class create ::http::cookiejar
+}
+
+namespace eval [info object namespace ::http::cookiejar] {
+ proc setInt {*var val} {
+ upvar 1 ${*var} var
+ if {[catch {incr dummy $val} msg]} {
+ return -code error $msg
+ }
+ set var $val
+ }
+ proc setInterval {trigger *var val} {
+ upvar 1 ${*var} var
+ if {![string is integer -strict $val] || $val < 1} {
+ return -code error "expected positive integer but got \"$val\""
+ }
+ set var $val
+ {*}$trigger
+ }
+ proc setBool {*var val} {
+ upvar 1 ${*var} var
+ if {[catch {if {$val} {}} msg]} {
+ return -code error $msg
+ }
+ set var [expr {!!$val}]
+ }
+
+ proc setLog {*var val} {
+ upvar 1 ${*var} var
+ set var [::tcl::prefix match -message "log level" \
+ {debug info warn error} $val]
+ }
+
+ # Keep this in sync with pkgIndex.tcl and with the install directories in
+ # Makefiles
+ variable version 0.1
+
+ variable domainlist \
+ http://publicsuffix.org/list/effective_tld_names.dat
+ variable domainfile \
+ [file join [file dirname [info script]] effective_tld_names.txt.gz]
+ # The list is directed to from http://publicsuffix.org/list/
+ variable loglevel info
+ variable vacuumtrigger 200
+ variable retainlimit 100
+ variable offline false
+ variable purgeinterval 60000
+ variable refreshinterval 10000000
+ variable domaincache {}
+
+ # Some support procedures, none particularly useful in general
+ namespace eval support {
+ # Set up a logger if the http package isn't actually loaded yet.
+ if {![llength [info commands ::http::Log]]} {
+ proc ::http::Log args {
+ # Do nothing by default...
+ }
+ }
+
+ namespace export *
+ proc locn {secure domain path {key ""}} {
+ if {$key eq ""} {
+ format "%s://%s%s" [expr {$secure?"https":"http"}] \
+ [::tcl::idna encode $domain] $path
+ } else {
+ format "%s://%s%s?%s" \
+ [expr {$secure?"https":"http"}] [::tcl::idna encode $domain] \
+ $path $key
+ }
+ }
+ proc splitDomain domain {
+ set pieces [split $domain "."]
+ for {set i [llength $pieces]} {[incr i -1] >= 0} {} {
+ lappend result [join [lrange $pieces $i end] "."]
+ }
+ return $result
+ }
+ proc splitPath path {
+ set pieces [split [string trimleft $path "/"] "/"]
+ for {set j -1} {$j < [llength $pieces]} {incr j} {
+ lappend result /[join [lrange $pieces 0 $j] "/"]
+ }
+ return $result
+ }
+ proc isoNow {} {
+ set ms [clock milliseconds]
+ set ts [expr {$ms / 1000}]
+ set ms [format %03d [expr {$ms % 1000}]]
+ clock format $ts -format "%Y%m%dT%H%M%S.${ms}Z" -gmt 1
+ }
+ proc log {level msg args} {
+ namespace upvar [info object namespace ::http::cookiejar] \
+ loglevel loglevel
+ set who [uplevel 1 self class]
+ set mth [uplevel 1 self method]
+ set map {debug 0 info 1 warn 2 error 3}
+ if {[string map $map $level] >= [string map $map $loglevel]} {
+ set msg [format $msg {*}$args]
+ set LVL [string toupper $level]
+ ::http::Log "[isoNow] $LVL $who $mth - $msg"
+ }
+ }
+ }
+}
+
+# Now we have enough information to provide the package.
+package provide cookiejar \
+ [set [info object namespace ::http::cookiejar]::version]
+
+# The implementation of the cookiejar package
+::oo::define ::http::cookiejar {
+ self {
+ method configure {{optionName "\u0000\u0000"} {optionValue "\u0000\u0000"}} {
+ set tbl {
+ -domainfile {domainfile set}
+ -domainlist {domainlist set}
+ -domainrefresh {refreshinterval setInterval}
+ -loglevel {loglevel setLog}
+ -offline {offline setBool}
+ -purgeold {purgeinterval setInterval}
+ -retain {retainlimit setInt}
+ -vacuumtrigger {vacuumtrigger setInt}
+ }
+ dict lappend tbl -domainrefresh [namespace code {
+ my IntervalTrigger PostponeRefresh
+ }]
+ dict lappend tbl -purgeold [namespace code {
+ my IntervalTrigger PostponePurge
+ }]
+ if {$optionName eq "\u0000\u0000"} {
+ return [dict keys $tbl]
+ }
+ set opt [::tcl::prefix match -message "option" \
+ [dict keys $tbl] $optionName]
+ set setter [lassign [dict get $tbl $opt] varname]
+ namespace upvar [namespace current] $varname var
+ if {$optionValue ne "\u0000\u0000"} {
+ {*}$setter var $optionValue
+ }
+ return $var
+ }
+
+ method IntervalTrigger {method} {
+ # TODO: handle subclassing
+ foreach obj [info class instances [self]] {
+ [info object namespace $obj]::my $method
+ }
+ }
+ }
+
+ variable purgeTimer deletions refreshTimer
+ constructor {{path ""}} {
+ namespace import [info object namespace [self class]]::support::*
+
+ if {$path eq ""} {
+ sqlite3 [namespace current]::db :memory:
+ set storeorigin "constructed cookie store in memory"
+ } else {
+ sqlite3 [namespace current]::db $path
+ db timeout 500
+ set storeorigin "loaded cookie store from $path"
+ }
+
+ set deletions 0
+ db transaction {
+ db eval {
+ --;# Store the persistent cookies in this table.
+ --;# Deletion policy: once they expire, or if explicitly
+ --;# killed.
+ CREATE TABLE IF NOT EXISTS persistentCookies (
+ id INTEGER PRIMARY KEY,
+ secure INTEGER NOT NULL,
+ domain TEXT NOT NULL COLLATE NOCASE,
+ path TEXT NOT NULL,
+ key TEXT NOT NULL,
+ value TEXT NOT NULL,
+ originonly INTEGER NOT NULL,
+ expiry INTEGER NOT NULL,
+ lastuse INTEGER NOT NULL,
+ creation INTEGER NOT NULL);
+ CREATE UNIQUE INDEX IF NOT EXISTS persistentUnique
+ ON persistentCookies (domain, path, key);
+ CREATE INDEX IF NOT EXISTS persistentLookup
+ ON persistentCookies (domain, path);
+
+ --;# Store the session cookies in this table.
+ --;# Deletion policy: at cookiejar instance deletion, if
+ --;# explicitly killed, or if the number of session cookies is
+ --;# too large and the cookie has not been used recently.
+ CREATE TEMP TABLE sessionCookies (
+ id INTEGER PRIMARY KEY,
+ secure INTEGER NOT NULL,
+ domain TEXT NOT NULL COLLATE NOCASE,
+ path TEXT NOT NULL,
+ key TEXT NOT NULL,
+ originonly INTEGER NOT NULL,
+ value TEXT NOT NULL,
+ lastuse INTEGER NOT NULL,
+ creation INTEGER NOT NULL);
+ CREATE UNIQUE INDEX sessionUnique
+ ON sessionCookies (domain, path, key);
+ CREATE INDEX sessionLookup ON sessionCookies (domain, path);
+
+ --;# View to allow for simple looking up of a cookie.
+ --;# Deletion policy: NOT SUPPORTED via this view.
+ CREATE TEMP VIEW cookies AS
+ SELECT id, domain, (
+ CASE originonly WHEN 1 THEN path ELSE '.' || path END
+ ) AS path, key, value, secure, 1 AS persistent
+ FROM persistentCookies
+ UNION
+ SELECT id, domain, (
+ CASE originonly WHEN 1 THEN path ELSE '.' || path END
+ ) AS path, key, value, secure, 0 AS persistent
+ FROM sessionCookies;
+
+ --;# Encoded domain permission policy; if forbidden is 1, no
+ --;# cookie may be ever set for the domain, and if forbidden
+ --;# is 0, cookies *may* be created for the domain (overriding
+ --;# the forbiddenSuper table).
+ --;# Deletion policy: normally not modified.
+ CREATE TABLE IF NOT EXISTS domains (
+ domain TEXT PRIMARY KEY NOT NULL,
+ forbidden INTEGER NOT NULL);
+
+ --;# Domains that may not have a cookie defined for direct
+ --;# child domains of them.
+ --;# Deletion policy: normally not modified.
+ CREATE TABLE IF NOT EXISTS forbiddenSuper (
+ domain TEXT PRIMARY KEY);
+
+ --;# When we last retrieved the domain list.
+ CREATE TABLE IF NOT EXISTS domainCacheMetadata (
+ id INTEGER PRIMARY KEY,
+ retrievalDate INTEGER,
+ installDate INTEGER);
+ }
+
+ set cookieCount "no"
+ db eval {
+ SELECT COUNT(*) AS cookieCount FROM persistentCookies
+ }
+ log info "%s with %s entries" $storeorigin $cookieCount
+
+ my PostponePurge
+
+ if {$path ne ""} {
+ if {[db exists {SELECT 1 FROM domains}]} {
+ my RefreshDomains
+ } else {
+ my InitDomainList
+ my PostponeRefresh
+ }
+ } else {
+ set data [my GetDomainListOffline metadata]
+ my InstallDomainData $data $metadata
+ my PostponeRefresh
+ }
+ }
+ }
+
+ method PostponePurge {} {
+ namespace upvar [info object namespace [self class]] \
+ purgeinterval interval
+ catch {after cancel $purgeTimer}
+ set purgeTimer [after $interval [namespace code {my PurgeCookies}]]
+ }
+
+ method PostponeRefresh {} {
+ namespace upvar [info object namespace [self class]] \
+ refreshinterval interval
+ catch {after cancel $refreshTimer}
+ set refreshTimer [after $interval [namespace code {my RefreshDomains}]]
+ }
+
+ method RefreshDomains {} {
+ # TODO: domain list refresh policy
+ my PostponeRefresh
+ }
+
+ method HttpGet {url {timeout 0} {maxRedirects 5}} {
+ for {set r 0} {$r < $maxRedirects} {incr r} {
+ set tok [::http::geturl $url -timeout $timeout]
+ try {
+ if {[::http::status $tok] eq "timeout"} {
+ return -code error "connection timed out"
+ } elseif {[::http::ncode $tok] == 200} {
+ return [::http::data $tok]
+ } elseif {[::http::ncode $tok] >= 400} {
+ return -code error [::http::error $tok]
+ } elseif {[dict exists [::http::meta $tok] Location]} {
+ set url [dict get [::http::meta $tok] Location]
+ continue
+ }
+ return -code error \
+ "unexpected state: [::http::code $tok]"
+ } finally {
+ ::http::cleanup $tok
+ }
+ }
+ return -code error "too many redirects"
+ }
+ method GetDomainListOnline {metaVar} {
+ upvar 1 $metaVar meta
+ namespace upvar [info object namespace [self class]] \
+ domainlist url domaincache cache
+ lassign $cache when data
+ if {$when > [clock seconds] - 3600} {
+ log debug "using cached value created at %s" \
+ [clock format $when -format {%Y%m%dT%H%M%SZ} -gmt 1]
+ dict set meta retrievalDate $when
+ return $data
+ }
+ log debug "loading domain list from %s" $url
+ try {
+ set when [clock seconds]
+ set data [my HttpGet $url]
+ set cache [list $when $data]
+ # TODO: Should we use the Last-Modified header instead?
+ dict set meta retrievalDate $when
+ return $data
+ } on error msg {
+ log error "failed to fetch list of forbidden cookie domains from %s: %s" \
+ $url $msg
+ return {}
+ }
+ }
+ method GetDomainListOffline {metaVar} {
+ upvar 1 $metaVar meta
+ namespace upvar [info object namespace [self class]] \
+ domainfile filename
+ log debug "loading domain list from %s" $filename
+ try {
+ set f [open $filename]
+ try {
+ if {[string match *.gz $filename]} {
+ zlib push gunzip $f
+ }
+ fconfigure $f -encoding utf-8
+ dict set meta retrievalDate [file mtime $filename]
+ return [read $f]
+ } finally {
+ close $f
+ }
+ } on error {msg opt} {
+ log error "failed to read list of forbidden cookie domains from %s: %s" \
+ $filename $msg
+ return -options $opt $msg
+ }
+ }
+ method InitDomainList {} {
+ namespace upvar [info object namespace [self class]] \
+ offline offline
+ if {!$offline} {
+ try {
+ set data [my GetDomainListOnline metadata]
+ if {[string length $data]} {
+ my InstallDomainData $data $metadata
+ return
+ }
+ } on error {} {
+ log warn "attempting to fall back to built in version"
+ }
+ }
+ set data [my GetDomainListOffline metadata]
+ my InstallDomainData $data $metadata
+ }
+
+ method InstallDomainData {data meta} {
+ set n [db total_changes]
+ db transaction {
+ foreach line [split $data "\n"] {
+ if {[string trim $line] eq ""} {
+ continue
+ } elseif {[string match //* $line]} {
+ continue
+ } elseif {[string match !* $line]} {
+ set line [string range $line 1 end]
+ set idna [string tolower [::tcl::idna encode $line]]
+ set utf [::tcl::idna decode [string tolower $line]]
+ db eval {
+ INSERT OR REPLACE INTO domains (domain, forbidden)
+ VALUES ($utf, 0);
+ }
+ if {$idna ne $utf} {
+ db eval {
+ INSERT OR REPLACE INTO domains (domain, forbidden)
+ VALUES ($idna, 0);
+ }
+ }
+ } else {
+ if {[string match {\*.*} $line]} {
+ set line [string range $line 2 end]
+ set idna [string tolower [::tcl::idna encode $line]]
+ set utf [::tcl::idna decode [string tolower $line]]
+ db eval {
+ INSERT OR REPLACE INTO forbiddenSuper (domain)
+ VALUES ($utf);
+ }
+ if {$idna ne $utf} {
+ db eval {
+ INSERT OR REPLACE INTO forbiddenSuper (domain)
+ VALUES ($idna);
+ }
+ }
+ } else {
+ set idna [string tolower [::tcl::idna encode $line]]
+ set utf [::tcl::idna decode [string tolower $line]]
+ }
+ db eval {
+ INSERT OR REPLACE INTO domains (domain, forbidden)
+ VALUES ($utf, 1);
+ }
+ if {$idna ne $utf} {
+ db eval {
+ INSERT OR REPLACE INTO domains (domain, forbidden)
+ VALUES ($idna, 1);
+ }
+ }
+ }
+ if {$utf ne [::tcl::idna decode [string tolower $idna]]} {
+ log warn "mismatch in IDNA handling for %s (%d, %s, %s)" \
+ $idna $line $utf [::tcl::idna decode $idna]
+ }
+ }
+
+ dict with meta {
+ set installDate [clock seconds]
+ db eval {
+ INSERT OR REPLACE INTO domainCacheMetadata
+ (id, retrievalDate, installDate)
+ VALUES (1, $retrievalDate, $installDate);
+ }
+ }
+ }
+ set n [expr {[db total_changes] - $n}]
+ log info "constructed domain info with %d entries" $n
+ }
+
+ # This forces the rebuild of the domain data, loading it from
+ method forceLoadDomainData {} {
+ db transaction {
+ db eval {
+ DELETE FROM domains;
+ DELETE FROM forbiddenSuper;
+ INSERT OR REPLACE INTO domainCacheMetadata
+ (id, retrievalDate, installDate)
+ VALUES (1, -1, -1);
+ }
+ my InitDomainList
+ }
+ }
+
+ destructor {
+ catch {
+ after cancel $purgeTimer
+ }
+ catch {
+ after cancel $refreshTimer
+ }
+ catch {
+ db close
+ }
+ return
+ }
+
+ method GetCookiesForHostAndPath {listVar secure host path fullhost} {
+ upvar 1 $listVar result
+ log debug "check for cookies for %s" [locn $secure $host $path]
+ set exact [expr {$host eq $fullhost}]
+ db eval {
+ SELECT key, value FROM persistentCookies
+ WHERE domain = $host AND path = $path AND secure <= $secure
+ AND (NOT originonly OR domain = $fullhost)
+ AND originonly = $exact
+ } {
+ lappend result $key $value
+ db eval {
+ UPDATE persistentCookies SET lastuse = $now WHERE id = $id
+ }
+ }
+ set now [clock seconds]
+ db eval {
+ SELECT id, key, value FROM sessionCookies
+ WHERE domain = $host AND path = $path AND secure <= $secure
+ AND (NOT originonly OR domain = $fullhost)
+ AND originonly = $exact
+ } {
+ lappend result $key $value
+ db eval {
+ UPDATE sessionCookies SET lastuse = $now WHERE id = $id
+ }
+ }
+ }
+
+ method getCookies {proto host path} {
+ set result {}
+ set paths [splitPath $path]
+ if {[regexp {[^0-9.]} $host]} {
+ set domains [splitDomain [string tolower [::tcl::idna encode $host]]]
+ } else {
+ # Ugh, it's a numeric domain! Restrict it to just itself...
+ set domains [list $host]
+ }
+ set secure [string equal -nocase $proto "https"]
+ # Open question: how to move these manipulations into the database
+ # engine (if that's where they *should* be).
+ #
+ # Suggestion from kbk:
+ #LENGTH(theColumn) <= LENGTH($queryStr) AND
+ #SUBSTR(theColumn, LENGTH($queryStr) LENGTH(theColumn)+1) = $queryStr
+ #
+ # However, we instead do most of the work in Tcl because that lets us
+ # do the splitting exactly right, and it's far easier to work with
+ # strings in Tcl than in SQL.
+ db transaction {
+ foreach domain $domains {
+ foreach p $paths {
+ my GetCookiesForHostAndPath result $secure $domain $p $host
+ }
+ }
+ return $result
+ }
+ }
+
+ method BadDomain options {
+ if {![dict exists $options domain]} {
+ log error "no domain present in options"
+ return 0
+ }
+ dict with options {}
+ if {$domain ne $origin} {
+ log debug "cookie domain varies from origin (%s, %s)" \
+ $domain $origin
+ if {[string match .* $domain]} {
+ set dotd $domain
+ } else {
+ set dotd .$domain
+ }
+ if {![string equal -length [string length $dotd] \
+ [string reverse $dotd] [string reverse $origin]]} {
+ log warn "bad cookie: domain not suffix of origin"
+ return 1
+ }
+ }
+ if {![regexp {[^0-9.]} $domain]} {
+ if {$domain eq $origin} {
+ # May set for itself
+ return 0
+ }
+ log warn "bad cookie: for a numeric address"
+ return 1
+ }
+ db eval {
+ SELECT forbidden FROM domains WHERE domain = $domain
+ } {
+ if {$forbidden} {
+ log warn "bad cookie: for a forbidden address"
+ }
+ return $forbidden
+ }
+ if {[regexp {^[^.]+\.(.+)$} $domain -> super] && [db exists {
+ SELECT 1 FROM forbiddenSuper WHERE domain = $super
+ }]} then {
+ log warn "bad cookie: for a forbidden address"
+ return 1
+ }
+ return 0
+ }
+
+ # A defined extension point to allow users to easily impose extra policies
+ # on whether to accept cookies from a particular domain and path.
+ method policyAllow {operation domain path} {
+ return true
+ }
+
+ method storeCookie {options} {
+ db transaction {
+ if {[my BadDomain $options]} {
+ return
+ }
+ set now [clock seconds]
+ set persistent [dict exists $options expires]
+ dict with options {}
+ if {!$persistent} {
+ if {![my policyAllow session $domain $path]} {
+ log warn "bad cookie: $domain prohibited by user policy"
+ return
+ }
+ db eval {
+ INSERT OR REPLACE INTO sessionCookies (
+ secure, domain, path, key, value, originonly, creation,
+ lastuse)
+ VALUES ($secure, $domain, $path, $key, $value, $hostonly,
+ $now, $now);
+ DELETE FROM persistentCookies
+ WHERE domain = $domain AND path = $path AND key = $key
+ AND secure <= $secure AND originonly = $hostonly
+ }
+ incr deletions [db changes]
+ log debug "defined session cookie for %s" \
+ [locn $secure $domain $path $key]
+ } elseif {$expires < $now} {
+ if {![my policyAllow delete $domain $path]} {
+ log warn "bad cookie: $domain prohibited by user policy"
+ return
+ }
+ db eval {
+ DELETE FROM persistentCookies
+ WHERE domain = $domain AND path = $path AND key = $key
+ AND secure <= $secure AND originonly = $hostonly
+ }
+ set del [db changes]
+ db eval {
+ DELETE FROM sessionCookies
+ WHERE domain = $domain AND path = $path AND key = $key
+ AND secure <= $secure AND originonly = $hostonly
+ }
+ incr deletions [incr del [db changes]]
+ log debug "deleted %d cookies for %s" \
+ $del [locn $secure $domain $path $key]
+ } else {
+ if {![my policyAllow set $domain $path]} {
+ log warn "bad cookie: $domain prohibited by user policy"
+ return
+ }
+ db eval {
+ INSERT OR REPLACE INTO persistentCookies (
+ secure, domain, path, key, value, originonly, expiry,
+ creation, lastuse)
+ VALUES ($secure, $domain, $path, $key, $value, $hostonly,
+ $expires, $now, $now);
+ DELETE FROM sessionCookies
+ WHERE domain = $domain AND path = $path AND key = $key
+ AND secure <= $secure AND originonly = $hostonly
+ }
+ incr deletions [db changes]
+ log debug "defined persistent cookie for %s, expires at %s" \
+ [locn $secure $domain $path $key] \
+ [clock format $expires]
+ }
+ }
+ }
+
+ method PurgeCookies {} {
+ namespace upvar [info object namespace [self class]] \
+ vacuumtrigger trigger retainlimit retain
+ my PostponePurge
+ set now [clock seconds]
+ log debug "purging cookies that expired before %s" [clock format $now]
+ db transaction {
+ db eval {
+ DELETE FROM persistentCookies WHERE expiry < $now
+ }
+ incr deletions [db changes]
+ db eval {
+ DELETE FROM persistentCookies WHERE id IN (
+ SELECT id FROM persistentCookies ORDER BY lastuse ASC
+ LIMIT -1 OFFSET $retain)
+ }
+ incr deletions [db changes]
+ db eval {
+ DELETE FROM sessionCookies WHERE id IN (
+ SELECT id FROM sessionCookies ORDER BY lastuse
+ LIMIT -1 OFFSET $retain)
+ }
+ incr deletions [db changes]
+ }
+
+ # Once we've deleted a fair bit, vacuum the database. Must be done
+ # outside a transaction.
+ if {$deletions > $trigger} {
+ set deletions 0
+ log debug "vacuuming cookie database"
+ catch {
+ db eval {
+ VACUUM
+ }
+ }
+ }
+ }
+
+ forward Database db
+
+ method lookup {{host ""} {key ""}} {
+ set host [string tolower [::tcl::idna encode $host]]
+ db transaction {
+ if {$host eq ""} {
+ set result {}
+ db eval {
+ SELECT DISTINCT domain FROM cookies
+ ORDER BY domain
+ } {
+ lappend result [::tcl::idna decode [string tolower $domain]]
+ }
+ return $result
+ } elseif {$key eq ""} {
+ set result {}
+ db eval {
+ SELECT DISTINCT key FROM cookies
+ WHERE domain = $host
+ ORDER BY key
+ } {
+ lappend result $key
+ }
+ return $result
+ } else {
+ db eval {
+ SELECT value FROM cookies
+ WHERE domain = $host AND key = $key
+ LIMIT 1
+ } {
+ return $value
+ }
+ return -code error "no such key for that host"
+ }
+ }
+ }
+}
+
+# Local variables:
+# mode: tcl
+# fill-column: 78
+# End:
diff --git a/library/http/effective_tld_names.txt.gz b/library/http/effective_tld_names.txt.gz
new file mode 100644
index 0000000..9ce2b69
--- /dev/null
+++ b/library/http/effective_tld_names.txt.gz
Binary files differ
diff --git a/library/http/http.tcl b/library/http/http.tcl
index f82bced..7236bae 100644
--- a/library/http/http.tcl
+++ b/library/http/http.tcl
@@ -20,6 +20,7 @@ namespace eval http {
if {![info exists http]} {
array set http {
-accept */*
+ -cookiejar {}
-pipeline 1
-postfresh 0
-proxyhost {}
@@ -127,6 +128,18 @@ namespace eval http {
set defaultKeepalive 0
}
+ # Regular expression used to parse cookies
+ variable CookieRE {(?x) # EXPANDED SYNTAX
+ \s* # Ignore leading spaces
+ ([^][\u0000- ()<>@,;:\\""/?={}\u007f-\uffff]+) # Match the name
+ = # LITERAL: Equal sign
+ ([!\u0023-+\u002D-:<-\u005B\u005D-~]*) # Match the value
+ (?:
+ \s* ; \s* # LITERAL: semicolon
+ ([^\u0000]+) # Match the options
+ )?
+ }
+
namespace export geturl config reset wait formatQuery quoteString
namespace export register unregister registerError
# - Useful, but not exported: data, size, status, code, cleanup, error,
@@ -892,8 +905,12 @@ proc http::geturl {url args} {
}
return -code error "Illegal characters in URL path"
}
+ if {![regexp {^[^?#]+} $srvurl state(path)]} {
+ set state(path) /
+ }
} else {
set srvurl /
+ set state(path) /
}
if {$proto eq ""} {
set proto http
@@ -1354,12 +1371,16 @@ proc http::Connected {token proto phost srvurl} {
puts $sock "$how $srvurl HTTP/$state(-protocol)"
if {[dict exists $state(-headers) Host]} {
# Allow Host spoofing. [Bug 928154]
- puts $sock "Host: [dict get $state(-headers) Host]"
+ set hostHdr [dict get $state(-headers) Host]
+ regexp {^[^:]+} $hostHdr state(host)
+ puts $sock "Host: $hostHdr"
} elseif {$port == $defport} {
# Don't add port in this case, to handle broken servers. [Bug
# #504508]
+ set state(host) $host
puts $sock "Host: $host"
} else {
+ set state(host) $host
puts $sock "Host: $host:$port"
}
puts $sock "User-Agent: $http(-useragent)"
@@ -1421,6 +1442,22 @@ proc http::Connected {token proto phost srvurl} {
seek $state(-querychannel) $start
}
+ # Note that we don't do Cookie2; that's much nastier and not normally
+ # observed in practice either. It also doesn't fix the multitude of
+ # bugs in the basic cookie spec.
+ if {$http(-cookiejar) ne ""} {
+ set cookies ""
+ set separator ""
+ foreach {key value} [{*}$http(-cookiejar) \
+ getCookies $proto $host $state(path)] {
+ append cookies $separator $key = $value
+ set separator "; "
+ }
+ if {$cookies ne ""} {
+ puts $sock "Cookie: $cookies"
+ }
+ }
+
# Flush the request header and set up the fileevent that will either
# push the POST data or read the response.
#
@@ -2693,6 +2730,11 @@ proc http::Event {sock token} {
set state(connection) \
[string trim [string tolower $value]]
}
+ set-cookie {
+ if {$http(-cookiejar) ne ""} {
+ ParseCookie $token [string trim $value]
+ }
+ }
}
lappend state(meta) $key [string trim $value]
}
@@ -2990,6 +3032,83 @@ proc http::IsBinaryContentType {type} {
return true
}
+proc http::ParseCookie {token value} {
+ variable http
+ variable CookieRE
+ variable $token
+ upvar 0 $token state
+
+ if {![regexp $CookieRE $value -> cookiename cookieval opts]} {
+ # Bad cookie! No biscuit!
+ return
+ }
+
+ # Convert the options into a list before feeding into the cookie store;
+ # ugly, but quite easy.
+ set realopts {hostonly 1 path / secure 0 httponly 0}
+ dict set realopts origin $state(host)
+ dict set realopts domain $state(host)
+ foreach option [split [regsub -all {;\s+} $opts \u0000] \u0000] {
+ regexp {^(.*?)(?:=(.*))?$} $option -> optname optval
+ switch -exact -- [string tolower $optname] {
+ expires {
+ if {[catch {
+ #Sun, 06 Nov 1994 08:49:37 GMT
+ dict set realopts expires \
+ [clock scan $optval -format "%a, %d %b %Y %T %Z"]
+ }] && [catch {
+ # Google does this one
+ #Mon, 01-Jan-1990 00:00:00 GMT
+ dict set realopts expires \
+ [clock scan $optval -format "%a, %d-%b-%Y %T %Z"]
+ }] && [catch {
+ # This is in the RFC, but it is also in the original
+ # Netscape cookie spec, now online at:
+ # <URL:http://curl.haxx.se/rfc/cookie_spec.html>
+ #Sunday, 06-Nov-94 08:49:37 GMT
+ dict set realopts expires \
+ [clock scan $optval -format "%A, %d-%b-%y %T %Z"]
+ }]} {catch {
+ #Sun Nov 6 08:49:37 1994
+ dict set realopts expires \
+ [clock scan $optval -gmt 1 -format "%a %b %d %T %Y"]
+ }}
+ }
+ max-age {
+ # Normalize
+ if {[string is integer -strict $optval]} {
+ dict set realopts expires [expr {[clock seconds] + $optval}]
+ }
+ }
+ domain {
+ # From the domain-matches definition [RFC 2109, section 2]:
+ # Host A's name domain-matches host B's if [...]
+ # A is a FQDN string and has the form NB, where N is a
+ # non-empty name string, B has the form .B', and B' is a
+ # FQDN string. (So, x.y.com domain-matches .y.com but
+ # not y.com.)
+ if {$optval ne "" && ![string match *. $optval]} {
+ dict set realopts domain [string trimleft $optval "."]
+ dict set realopts hostonly [expr {
+ ! [string match .* $optval]
+ }]
+ }
+ }
+ path {
+ if {[string match /* $optval]} {
+ dict set realopts path $optval
+ }
+ }
+ secure - httponly {
+ dict set realopts [string tolower $optname] 1
+ }
+ }
+ }
+ dict set realopts key $cookiename
+ dict set realopts value $cookieval
+ {*}$http(-cookiejar) storeCookie $realopts
+}
+
# http::getTextLine --
#
# Get one line with the stream in crlf mode.
diff --git a/library/http/idna.tcl b/library/http/idna.tcl
new file mode 100644
index 0000000..2a7d289
--- /dev/null
+++ b/library/http/idna.tcl
@@ -0,0 +1,292 @@
+# cookiejar.tcl --
+#
+# Implementation of IDNA (Internationalized Domain Names for
+# Applications) encoding/decoding system, built on a punycode engine
+# developed directly from the code in RFC 3492, Appendix C (with
+# substantial modifications).
+#
+# This implementation includes code from that RFC, translated to Tcl; the
+# other parts are:
+# Copyright (c) 2014 Donal K. Fellows
+#
+# See the file "license.terms" for information on usage and redistribution of
+# this file, and for a DISCLAIMER OF ALL WARRANTIES.
+
+namespace eval ::tcl::idna {
+ namespace ensemble create -command puny -map {
+ encode punyencode
+ decode punydecode
+ }
+ namespace ensemble create -command ::tcl::idna -map {
+ encode IDNAencode
+ decode IDNAdecode
+ puny puny
+ version {::apply {{} {package present tcl::idna} ::}}
+ }
+
+ proc IDNAencode hostname {
+ set parts {}
+ # Split term from RFC 3490, Sec 3.1
+ foreach part [split $hostname "\u002E\u3002\uFF0E\uFF61"] {
+ if {[regexp {[^-A-Za-z0-9]} $part]} {
+ if {[regexp {[^-A-Za-z0-9\u00a1-\uffff]} $part ch]} {
+ scan $ch %c c
+ if {$ch < "!" || $ch > "~"} {
+ set ch [format "\\u%04x" $c]
+ }
+ throw [list IDNA INVALID_NAME_CHARACTER $ch] \
+ "bad character \"$ch\" in DNS name"
+ }
+ set part xn--[punyencode $part]
+ # Length restriction from RFC 5890, Sec 2.3.1
+ if {[string length $part] > 63} {
+ throw [list IDNA OVERLONG_PART $part] \
+ "hostname part too long"
+ }
+ }
+ lappend parts $part
+ }
+ return [join $parts .]
+ }
+ proc IDNAdecode hostname {
+ set parts {}
+ # Split term from RFC 3490, Sec 3.1
+ foreach part [split $hostname "\u002E\u3002\uFF0E\uFF61"] {
+ if {[string match -nocase "xn--*" $part]} {
+ set part [punydecode [string range $part 4 end]]
+ }
+ lappend parts $part
+ }
+ return [join $parts .]
+ }
+
+ variable digits [split "abcdefghijklmnopqrstuvwxyz0123456789" ""]
+ # Bootstring parameters for Punycode
+ variable base 36
+ variable tmin 1
+ variable tmax 26
+ variable skew 38
+ variable damp 700
+ variable initial_bias 72
+ variable initial_n 0x80
+
+ variable max_codepoint 0x10FFFF
+
+ proc adapt {delta first numchars} {
+ variable base
+ variable tmin
+ variable tmax
+ variable damp
+ variable skew
+
+ set delta [expr {$delta / ($first ? $damp : 2)}]
+ incr delta [expr {$delta / $numchars}]
+ set k 0
+ while {$delta > ($base - $tmin) * $tmax / 2} {
+ set delta [expr {$delta / ($base-$tmin)}]
+ incr k $base
+ }
+ return [expr {$k + ($base-$tmin+1) * $delta / ($delta+$skew)}]
+ }
+
+ # Main punycode encoding function
+ proc punyencode {string {case ""}} {
+ variable digits
+ variable tmin
+ variable tmax
+ variable base
+ variable initial_n
+ variable initial_bias
+
+ if {![string is boolean $case]} {
+ return -code error "\"$case\" must be boolean"
+ }
+
+ set in {}
+ foreach char [set string [split $string ""]] {
+ scan $char "%c" ch
+ lappend in $ch
+ }
+ set output {}
+
+ # Initialize the state:
+ set n $initial_n
+ set delta 0
+ set bias $initial_bias
+
+ # Handle the basic code points:
+ foreach ch $string {
+ if {$ch < "\u0080"} {
+ if {$case eq ""} {
+ append output $ch
+ } elseif {[string is true $case]} {
+ append output [string toupper $ch]
+ } elseif {[string is false $case]} {
+ append output [string tolower $ch]
+ }
+ }
+ }
+
+ set b [string length $output]
+
+ # h is the number of code points that have been handled, b is the
+ # number of basic code points.
+
+ if {$b > 0} {
+ append output "-"
+ }
+
+ # Main encoding loop:
+
+ for {set h $b} {$h < [llength $in]} {incr delta; incr n} {
+ # All non-basic code points < n have been handled already. Find
+ # the next larger one:
+
+ set m inf
+ foreach ch $in {
+ if {$ch >= $n && $ch < $m} {
+ set m $ch
+ }
+ }
+
+ # Increase delta enough to advance the decoder's <n,i> state to
+ # <m,0>, but guard against overflow:
+
+ if {$m-$n > (0xffffffff-$delta)/($h+1)} {
+ throw {PUNYCODE OVERFLOW} "overflow in delta computation"
+ }
+ incr delta [expr {($m-$n) * ($h+1)}]
+ set n $m
+
+ foreach ch $in {
+ if {$ch < $n && ([incr delta] & 0xffffffff) == 0} {
+ throw {PUNYCODE OVERFLOW} "overflow in delta computation"
+ }
+
+ if {$ch != $n} {
+ continue
+ }
+
+ # Represent delta as a generalized variable-length integer:
+
+ for {set q $delta; set k $base} true {incr k $base} {
+ set t [expr {min(max($k-$bias, $tmin), $tmax)}]
+ if {$q < $t} {
+ break
+ }
+ append output \
+ [lindex $digits [expr {$t + ($q-$t)%($base-$t)}]]
+ set q [expr {($q-$t) / ($base-$t)}]
+ }
+
+ append output [lindex $digits $q]
+ set bias [adapt $delta [expr {$h==$b}] [expr {$h+1}]]
+ set delta 0
+ incr h
+ }
+ }
+
+ return $output
+ }
+
+ # Main punycode decode function
+ proc punydecode {string {case ""}} {
+ variable tmin
+ variable tmax
+ variable base
+ variable initial_n
+ variable initial_bias
+ variable max_codepoint
+
+ if {![string is boolean $case]} {
+ return -code error "\"$case\" must be boolean"
+ }
+
+ # Initialize the state:
+
+ set n $initial_n
+ set i 0
+ set first 1
+ set bias $initial_bias
+
+ # Split the string into the "real" ASCII characters and the ones to
+ # feed into the main decoder. Note that we don't need to check the
+ # result of [regexp] because that RE will technically match any string
+ # at all.
+
+ regexp {^(?:(.*)-)?([^-]*)$} $string -> pre post
+ if {[string is true -strict $case]} {
+ set pre [string toupper $pre]
+ } elseif {[string is false -strict $case]} {
+ set pre [string tolower $pre]
+ }
+ set output [split $pre ""]
+ set out [llength $output]
+
+ # Main decoding loop:
+
+ for {set in 0} {$in < [string length $post]} {incr in} {
+ # Decode a generalized variable-length integer into delta, which
+ # gets added to i. The overflow checking is easier if we increase
+ # i as we go, then subtract off its starting value at the end to
+ # obtain delta.
+
+ for {set oldi $i; set w 1; set k $base} 1 {incr in} {
+ if {[set ch [string index $post $in]] eq ""} {
+ throw {PUNYCODE BAD_INPUT LENGTH} "exceeded input data"
+ }
+ if {[string match -nocase {[a-z]} $ch]} {
+ scan [string toupper $ch] %c digit
+ incr digit -65
+ } elseif {[string match {[0-9]} $ch]} {
+ set digit [expr {$ch + 26}]
+ } else {
+ throw {PUNYCODE BAD_INPUT CHAR} \
+ "bad decode character \"$ch\""
+ }
+ incr i [expr {$digit * $w}]
+ set t [expr {min(max($tmin, $k-$bias), $tmax)}]
+ if {$digit < $t} {
+ set bias [adapt [expr {$i-$oldi}] $first [incr out]]
+ set first 0
+ break
+ }
+ if {[set w [expr {$w * ($base - $t)}]] > 0x7fffffff} {
+ throw {PUNYCODE OVERFLOW} \
+ "excessively large integer computed in digit decode"
+ }
+ incr k $base
+ }
+
+ # i was supposed to wrap around from out+1 to 0, incrementing n
+ # each time, so we'll fix that now:
+
+ if {[incr n [expr {$i / $out}]] > 0x7fffffff} {
+ throw {PUNYCODE OVERFLOW} \
+ "excessively large integer computed in character choice"
+ } elseif {$n > $max_codepoint} {
+ if {$n >= 0x00d800 && $n < 0x00e000} {
+ # Bare surrogate?!
+ throw {PUNYCODE NON_BMP} \
+ [format "unsupported character U+%06x" $n]
+ }
+ throw {PUNYCODE NON_UNICODE} "bad codepoint $n"
+ }
+ set i [expr {$i % $out}]
+
+ # Insert n at position i of the output:
+
+ set output [linsert $output $i [format "%c" $n]]
+ incr i
+ }
+
+ return [join $output ""]
+ }
+}
+
+package provide tcl::idna 1.0
+
+# Local variables:
+# mode: tcl
+# fill-column: 78
+# End:
diff --git a/library/http/pkgIndex.tcl b/library/http/pkgIndex.tcl
index 4f74635..3bc111f 100644
--- a/library/http/pkgIndex.tcl
+++ b/library/http/pkgIndex.tcl
@@ -1,2 +1,4 @@
if {![package vsatisfies [package provide Tcl] 8.6-]} {return}
package ifneeded http 2.9.0 [list tclPkgSetup $dir http 2.9.0 {{http.tcl source {::http::config ::http::formatQuery ::http::geturl ::http::reset ::http::wait ::http::register ::http::unregister ::http::mapReply}}}]
+package ifneeded cookiejar 0.1 [list source [file join $dir cookiejar.tcl]]
+package ifneeded tcl::idna 1.0 [list source [file join $dir idna.tcl]]
diff --git a/tests/http.test b/tests/http.test
index b6a7251..cf30348 100644
--- a/tests/http.test
+++ b/tests/http.test
@@ -82,7 +82,7 @@ if {[catch {package present Thread}] == 0 && [file exists $httpdFile]} {
test http-1.1 {http::config} {
http::config -useragent UserAgent
http::config
-} [list -accept */* -pipeline 1 -postfresh 0 -proxyfilter http::ProxyRequired -proxyhost {} -proxyport {} -repost 0 -urlencoding utf-8 -useragent UserAgent -zip 1]
+} [list -accept */* -cookiejar {} -pipeline 1 -postfresh 0 -proxyfilter http::ProxyRequired -proxyhost {} -proxyport {} -repost 0 -urlencoding utf-8 -useragent UserAgent -zip 1]
test http-1.2 {http::config} {
http::config -proxyfilter
} http::ProxyRequired
@@ -97,10 +97,10 @@ test http-1.4 {http::config} {
set x [http::config]
http::config {*}$savedconf
set x
-} {-accept */* -pipeline 1 -postfresh 0 -proxyfilter myFilter -proxyhost nowhere.come -proxyport 8080 -repost 0 -urlencoding iso8859-1 -useragent {Tcl Test Suite} -zip 1}
+} {-accept */* -cookiejar {} -pipeline 1 -postfresh 0 -proxyfilter myFilter -proxyhost nowhere.come -proxyport 8080 -repost 0 -urlencoding iso8859-1 -useragent {Tcl Test Suite} -zip 1}
test http-1.5 {http::config} -returnCodes error -body {
http::config -proxyhost {} -junk 8080
-} -result {Unknown option -junk, must be: -accept, -pipeline, -postfresh, -proxyfilter, -proxyhost, -proxyport, -repost, -urlencoding, -useragent, -zip}
+} -result {Unknown option -junk, must be: -accept, -cookiejar, -pipeline, -postfresh, -proxyfilter, -proxyhost, -proxyport, -repost, -urlencoding, -useragent, -zip}
test http-1.6 {http::config} -setup {
set oldenc [http::config -urlencoding]
} -body {
@@ -670,6 +670,451 @@ test http-7.4 {http::formatQuery} -setup {
http::config -urlencoding $enc
} -result {%3F}
+package require -exact tcl::idna 1.0
+
+test http-idna-1.1 {IDNA package: basics} -returnCodes error -body {
+ ::tcl::idna
+} -result {wrong # args: should be "::tcl::idna subcommand ?arg ...?"}
+test http-idna-1.2 {IDNA package: basics} -returnCodes error -body {
+ ::tcl::idna ?
+} -result {unknown or ambiguous subcommand "?": must be decode, encode, puny, or version}
+test http-idna-1.3 {IDNA package: basics} -body {
+ ::tcl::idna version
+} -result 1.0
+test http-idna-1.4 {IDNA package: basics} -returnCodes error -body {
+ ::tcl::idna version what
+} -result {wrong # args: should be "::tcl::idna version"}
+test http-idna-1.5 {IDNA package: basics} -returnCodes error -body {
+ ::tcl::idna puny
+} -result {wrong # args: should be "::tcl::idna puny subcommand ?arg ...?"}
+test http-idna-1.6 {IDNA package: basics} -returnCodes error -body {
+ ::tcl::idna puny ?
+} -result {unknown or ambiguous subcommand "?": must be decode, or encode}
+test http-idna-1.7 {IDNA package: basics} -returnCodes error -body {
+ ::tcl::idna puny encode
+} -result {wrong # args: should be "::tcl::idna puny encode string ?case?"}
+test http-idna-1.8 {IDNA package: basics} -returnCodes error -body {
+ ::tcl::idna puny encode a b c
+} -result {wrong # args: should be "::tcl::idna puny encode string ?case?"}
+test http-idna-1.9 {IDNA package: basics} -returnCodes error -body {
+ ::tcl::idna puny decode
+} -result {wrong # args: should be "::tcl::idna puny decode string ?case?"}
+test http-idna-1.10 {IDNA package: basics} -returnCodes error -body {
+ ::tcl::idna puny decode a b c
+} -result {wrong # args: should be "::tcl::idna puny decode string ?case?"}
+test http-idna-1.11 {IDNA package: basics} -returnCodes error -body {
+ ::tcl::idna decode
+} -result {wrong # args: should be "::tcl::idna decode hostname"}
+test http-idna-1.12 {IDNA package: basics} -returnCodes error -body {
+ ::tcl::idna encode
+} -result {wrong # args: should be "::tcl::idna encode hostname"}
+
+test http-idna-2.1 {puny encode: functional test} {
+ ::tcl::idna puny encode abc
+} abc-
+test http-idna-2.2 {puny encode: functional test} {
+ ::tcl::idna puny encode a\u20acb\u20acc
+} abc-k50ab
+test http-idna-2.3 {puny encode: functional test} {
+ ::tcl::idna puny encode ABC
+} ABC-
+test http-idna-2.4 {puny encode: functional test} {
+ ::tcl::idna puny encode A\u20ACB\u20ACC
+} ABC-k50ab
+test http-idna-2.5 {puny encode: functional test} {
+ ::tcl::idna puny encode ABC 0
+} abc-
+test http-idna-2.6 {puny encode: functional test} {
+ ::tcl::idna puny encode A\u20ACB\u20ACC 0
+} abc-k50ab
+test http-idna-2.7 {puny encode: functional test} {
+ ::tcl::idna puny encode ABC 1
+} ABC-
+test http-idna-2.8 {puny encode: functional test} {
+ ::tcl::idna puny encode A\u20ACB\u20ACC 1
+} ABC-k50ab
+test http-idna-2.9 {puny encode: functional test} {
+ ::tcl::idna puny encode abc 0
+} abc-
+test http-idna-2.10 {puny encode: functional test} {
+ ::tcl::idna puny encode a\u20ACb\u20ACc 0
+} abc-k50ab
+test http-idna-2.11 {puny encode: functional test} {
+ ::tcl::idna puny encode abc 1
+} ABC-
+test http-idna-2.12 {puny encode: functional test} {
+ ::tcl::idna puny encode a\u20ACb\u20ACc 1
+} ABC-k50ab
+test http-idna-2.13 {puny encode: edge cases} {
+ ::tcl::idna puny encode ""
+} ""
+test http-idna-2.14-A {puny encode: examples from RFC 3492} {
+ ::tcl::idna puny encode [join [subst [string map {u+ \\u} {
+ u+0644 u+064A u+0647 u+0645 u+0627 u+0628 u+062A u+0643 u+0644
+ u+0645 u+0648 u+0634 u+0639 u+0631 u+0628 u+064A u+061F
+ }]] ""]
+} egbpdaj6bu4bxfgehfvwxn
+test http-idna-2.14-B {puny encode: examples from RFC 3492} {
+ ::tcl::idna puny encode [join [subst [string map {u+ \\u} {
+ u+4ED6 u+4EEC u+4E3A u+4EC0 u+4E48 u+4E0D u+8BF4 u+4E2D u+6587
+ }]] ""]
+} ihqwcrb4cv8a8dqg056pqjye
+test http-idna-2.14-C {puny encode: examples from RFC 3492} {
+ ::tcl::idna puny encode [join [subst [string map {u+ \\u} {
+ u+4ED6 u+5011 u+7232 u+4EC0 u+9EBD u+4E0D u+8AAA u+4E2D u+6587
+ }]] ""]
+} ihqwctvzc91f659drss3x8bo0yb
+test http-idna-2.14-D {puny encode: examples from RFC 3492} {
+ ::tcl::idna puny encode [join [subst [string map {u+ \\u} {
+ u+0050 u+0072 u+006F u+010D u+0070 u+0072 u+006F u+0073 u+0074
+ u+011B u+006E u+0065 u+006D u+006C u+0075 u+0076 u+00ED u+010D
+ u+0065 u+0073 u+006B u+0079
+ }]] ""]
+} Proprostnemluvesky-uyb24dma41a
+test http-idna-2.14-E {puny encode: examples from RFC 3492} {
+ ::tcl::idna puny encode [join [subst [string map {u+ \\u} {
+ u+05DC u+05DE u+05D4 u+05D4 u+05DD u+05E4 u+05E9 u+05D5 u+05D8
+ u+05DC u+05D0 u+05DE u+05D3 u+05D1 u+05E8 u+05D9 u+05DD u+05E2
+ u+05D1 u+05E8 u+05D9 u+05EA
+ }]] ""]
+} 4dbcagdahymbxekheh6e0a7fei0b
+test http-idna-2.14-F {puny encode: examples from RFC 3492} {
+ ::tcl::idna puny encode [join [subst [string map {u+ \\u} {
+ u+092F u+0939 u+0932 u+094B u+0917 u+0939 u+093F u+0928 u+094D
+ u+0926 u+0940 u+0915 u+094D u+092F u+094B u+0902 u+0928 u+0939
+ u+0940 u+0902 u+092C u+094B u+0932 u+0938 u+0915 u+0924 u+0947
+ u+0939 u+0948 u+0902
+ }]] ""]
+} i1baa7eci9glrd9b2ae1bj0hfcgg6iyaf8o0a1dig0cd
+test http-idna-2.14-G {puny encode: examples from RFC 3492} {
+ ::tcl::idna puny encode [join [subst [string map {u+ \\u} {
+ u+306A u+305C u+307F u+3093 u+306A u+65E5 u+672C u+8A9E u+3092
+ u+8A71 u+3057 u+3066 u+304F u+308C u+306A u+3044 u+306E u+304B
+ }]] ""]
+} n8jok5ay5dzabd5bym9f0cm5685rrjetr6pdxa
+test http-idna-2.14-H {puny encode: examples from RFC 3492} {
+ ::tcl::idna puny encode [join [subst [string map {u+ \\u} {
+ u+C138 u+ACC4 u+C758 u+BAA8 u+B4E0 u+C0AC u+B78C u+B4E4 u+C774
+ u+D55C u+AD6D u+C5B4 u+B97C u+C774 u+D574 u+D55C u+B2E4 u+BA74
+ u+C5BC u+B9C8 u+B098 u+C88B u+C744 u+AE4C
+ }]] ""]
+} 989aomsvi5e83db1d2a355cv1e0vak1dwrv93d5xbh15a0dt30a5jpsd879ccm6fea98c
+test http-idna-2.14-I {puny encode: examples from RFC 3492} {
+ ::tcl::idna puny encode [join [subst [string map {u+ \\u} {
+ u+043F u+043E u+0447 u+0435 u+043C u+0443 u+0436 u+0435 u+043E
+ u+043D u+0438 u+043D u+0435 u+0433 u+043E u+0432 u+043E u+0440
+ u+044F u+0442 u+043F u+043E u+0440 u+0443 u+0441 u+0441 u+043A
+ u+0438
+ }]] ""]
+} b1abfaaepdrnnbgefbadotcwatmq2g4l
+test http-idna-2.14-J {puny encode: examples from RFC 3492} {
+ ::tcl::idna puny encode [join [subst [string map {u+ \\u} {
+ u+0050 u+006F u+0072 u+0071 u+0075 u+00E9 u+006E u+006F u+0070
+ u+0075 u+0065 u+0064 u+0065 u+006E u+0073 u+0069 u+006D u+0070
+ u+006C u+0065 u+006D u+0065 u+006E u+0074 u+0065 u+0068 u+0061
+ u+0062 u+006C u+0061 u+0072 u+0065 u+006E u+0045 u+0073 u+0070
+ u+0061 u+00F1 u+006F u+006C
+ }]] ""]
+} PorqunopuedensimplementehablarenEspaol-fmd56a
+test http-idna-2.14-K {puny encode: examples from RFC 3492} {
+ ::tcl::idna puny encode [join [subst [string map {u+ \\u} {
+ u+0054 u+1EA1 u+0069 u+0073 u+0061 u+006F u+0068 u+1ECD u+006B
+ u+0068 u+00F4 u+006E u+0067 u+0074 u+0068 u+1EC3 u+0063 u+0068
+ u+1EC9 u+006E u+00F3 u+0069 u+0074 u+0069 u+1EBF u+006E u+0067
+ u+0056 u+0069 u+1EC7 u+0074
+ }]] ""]
+} TisaohkhngthchnitingVit-kjcr8268qyxafd2f1b9g
+test http-idna-2.14-L {puny encode: examples from RFC 3492} {
+ ::tcl::idna puny encode [join [subst [string map {u+ \\u} {
+ u+0033 u+5E74 u+0042 u+7D44 u+91D1 u+516B u+5148 u+751F
+ }]] ""]
+} 3B-ww4c5e180e575a65lsy2b
+test http-idna-2.14-M {puny encode: examples from RFC 3492} {
+ ::tcl::idna puny encode [join [subst [string map {u+ \\u} {
+ u+5B89 u+5BA4 u+5948 u+7F8E u+6075 u+002D u+0077 u+0069 u+0074
+ u+0068 u+002D u+0053 u+0055 u+0050 u+0045 u+0052 u+002D u+004D
+ u+004F u+004E u+004B u+0045 u+0059 u+0053
+ }]] ""]
+} -with-SUPER-MONKEYS-pc58ag80a8qai00g7n9n
+test http-idna-2.14-N {puny encode: examples from RFC 3492} {
+ ::tcl::idna puny encode [join [subst [string map {u+ \\u} {
+ u+0048 u+0065 u+006C u+006C u+006F u+002D u+0041 u+006E u+006F
+ u+0074 u+0068 u+0065 u+0072 u+002D u+0057 u+0061 u+0079 u+002D
+ u+305D u+308C u+305E u+308C u+306E u+5834 u+6240
+ }]] ""]
+} Hello-Another-Way--fc4qua05auwb3674vfr0b
+test http-idna-2.14-O {puny encode: examples from RFC 3492} {
+ ::tcl::idna puny encode [join [subst [string map {u+ \\u} {
+ u+3072 u+3068 u+3064 u+5C4B u+6839 u+306E u+4E0B u+0032
+ }]] ""]
+} 2-u9tlzr9756bt3uc0v
+test http-idna-2.14-P {puny encode: examples from RFC 3492} {
+ ::tcl::idna puny encode [join [subst [string map {u+ \\u} {
+ u+004D u+0061 u+006A u+0069 u+3067 u+004B u+006F u+0069 u+3059
+ u+308B u+0035 u+79D2 u+524D
+ }]] ""]
+} MajiKoi5-783gue6qz075azm5e
+test http-idna-2.14-Q {puny encode: examples from RFC 3492} {
+ ::tcl::idna puny encode [join [subst [string map {u+ \\u} {
+ u+30D1 u+30D5 u+30A3 u+30FC u+0064 u+0065 u+30EB u+30F3 u+30D0
+ }]] ""]
+} de-jg4avhby1noc0d
+test http-idna-2.14-R {puny encode: examples from RFC 3492} {
+ ::tcl::idna puny encode [join [subst [string map {u+ \\u} {
+ u+305D u+306E u+30B9 u+30D4 u+30FC u+30C9 u+3067
+ }]] ""]
+} d9juau41awczczp
+test http-idna-2.14-S {puny encode: examples from RFC 3492} {
+ ::tcl::idna puny encode {-> $1.00 <-}
+} {-> $1.00 <--}
+
+test http-idna-3.1 {puny decode: functional test} {
+ ::tcl::idna puny decode abc-
+} abc
+test http-idna-3.2 {puny decode: functional test} {
+ ::tcl::idna puny decode abc-k50ab
+} a\u20acb\u20acc
+test http-idna-3.3 {puny decode: functional test} {
+ ::tcl::idna puny decode ABC-
+} ABC
+test http-idna-3.4 {puny decode: functional test} {
+ ::tcl::idna puny decode ABC-k50ab
+} A\u20ACB\u20ACC
+test http-idna-3.5 {puny decode: functional test} {
+ ::tcl::idna puny decode ABC-K50AB
+} A\u20ACB\u20ACC
+test http-idna-3.6 {puny decode: functional test} {
+ ::tcl::idna puny decode abc-K50AB
+} a\u20ACb\u20ACc
+test http-idna-3.7 {puny decode: functional test} {
+ ::tcl::idna puny decode ABC- 0
+} abc
+test http-idna-3.8 {puny decode: functional test} {
+ ::tcl::idna puny decode ABC-K50AB 0
+} a\u20ACb\u20ACc
+test http-idna-3.9 {puny decode: functional test} {
+ ::tcl::idna puny decode ABC- 1
+} ABC
+test http-idna-3.10 {puny decode: functional test} {
+ ::tcl::idna puny decode ABC-K50AB 1
+} A\u20ACB\u20ACC
+test http-idna-3.11 {puny decode: functional test} {
+ ::tcl::idna puny decode abc- 0
+} abc
+test http-idna-3.12 {puny decode: functional test} {
+ ::tcl::idna puny decode abc-k50ab 0
+} a\u20ACb\u20ACc
+test http-idna-3.13 {puny decode: functional test} {
+ ::tcl::idna puny decode abc- 1
+} ABC
+test http-idna-3.14 {puny decode: functional test} {
+ ::tcl::idna puny decode abc-k50ab 1
+} A\u20ACB\u20ACC
+test http-idna-3.15 {puny decode: edge cases and errors} {
+ # Is this case actually correct?
+ binary encode hex [encoding convertto utf-8 [::tcl::idna puny decode abc]]
+} c282c281c280
+test http-idna-3.16 {puny decode: edge cases and errors} -returnCodes error -body {
+ ::tcl::idna puny decode abc!
+} -result {bad decode character "!"}
+test http-idna-3.17 {puny decode: edge cases and errors} {
+ catch {::tcl::idna puny decode abc!} -> opt
+ dict get $opt -errorcode
+} {PUNYCODE BAD_INPUT CHAR}
+test http-idna-3.18 {puny decode: edge cases and errors} {
+ ::tcl::idna puny decode ""
+} {}
+# A helper so we don't get lots of crap in failures
+proc hexify s {lmap c [split $s ""] {format u+%04X [scan $c %c]}}
+test http-idna-3.19-A {puny decode: examples from RFC 3492} {
+ hexify [::tcl::idna puny decode egbpdaj6bu4bxfgehfvwxn]
+} [list {*}{
+ u+0644 u+064A u+0647 u+0645 u+0627 u+0628 u+062A u+0643 u+0644
+ u+0645 u+0648 u+0634 u+0639 u+0631 u+0628 u+064A u+061F
+}]
+test http-idna-3.19-B {puny decode: examples from RFC 3492} {
+ hexify [::tcl::idna puny decode ihqwcrb4cv8a8dqg056pqjye]
+} {u+4ED6 u+4EEC u+4E3A u+4EC0 u+4E48 u+4E0D u+8BF4 u+4E2D u+6587}
+test http-idna-3.19-C {puny decode: examples from RFC 3492} {
+ hexify [::tcl::idna puny decode ihqwctvzc91f659drss3x8bo0yb]
+} {u+4ED6 u+5011 u+7232 u+4EC0 u+9EBD u+4E0D u+8AAA u+4E2D u+6587}
+test http-idna-3.19-D {puny decode: examples from RFC 3492} {
+ hexify [::tcl::idna puny decode Proprostnemluvesky-uyb24dma41a]
+} [list {*}{
+ u+0050 u+0072 u+006F u+010D u+0070 u+0072 u+006F u+0073 u+0074
+ u+011B u+006E u+0065 u+006D u+006C u+0075 u+0076 u+00ED u+010D
+ u+0065 u+0073 u+006B u+0079
+}]
+test http-idna-3.19-E {puny decode: examples from RFC 3492} {
+ hexify [::tcl::idna puny decode 4dbcagdahymbxekheh6e0a7fei0b]
+} [list {*}{
+ u+05DC u+05DE u+05D4 u+05D4 u+05DD u+05E4 u+05E9 u+05D5 u+05D8
+ u+05DC u+05D0 u+05DE u+05D3 u+05D1 u+05E8 u+05D9 u+05DD u+05E2
+ u+05D1 u+05E8 u+05D9 u+05EA
+}]
+test http-idna-3.19-F {puny decode: examples from RFC 3492} {
+ hexify [::tcl::idna puny decode \
+ i1baa7eci9glrd9b2ae1bj0hfcgg6iyaf8o0a1dig0cd]
+} [list {*}{
+ u+092F u+0939 u+0932 u+094B u+0917 u+0939 u+093F u+0928 u+094D
+ u+0926 u+0940 u+0915 u+094D u+092F u+094B u+0902 u+0928 u+0939
+ u+0940 u+0902 u+092C u+094B u+0932 u+0938 u+0915 u+0924 u+0947
+ u+0939 u+0948 u+0902
+}]
+test http-idna-3.19-G {puny decode: examples from RFC 3492} {
+ hexify [::tcl::idna puny decode n8jok5ay5dzabd5bym9f0cm5685rrjetr6pdxa]
+} [list {*}{
+ u+306A u+305C u+307F u+3093 u+306A u+65E5 u+672C u+8A9E u+3092
+ u+8A71 u+3057 u+3066 u+304F u+308C u+306A u+3044 u+306E u+304B
+}]
+test http-idna-3.19-H {puny decode: examples from RFC 3492} {
+ hexify [::tcl::idna puny decode \
+ 989aomsvi5e83db1d2a355cv1e0vak1dwrv93d5xbh15a0dt30a5jpsd879ccm6fea98c]
+} [list {*}{
+ u+C138 u+ACC4 u+C758 u+BAA8 u+B4E0 u+C0AC u+B78C u+B4E4 u+C774
+ u+D55C u+AD6D u+C5B4 u+B97C u+C774 u+D574 u+D55C u+B2E4 u+BA74
+ u+C5BC u+B9C8 u+B098 u+C88B u+C744 u+AE4C
+}]
+test http-idna-3.19-I {puny decode: examples from RFC 3492} {
+ hexify [::tcl::idna puny decode b1abfaaepdrnnbgefbadotcwatmq2g4l]
+} [list {*}{
+ u+043F u+043E u+0447 u+0435 u+043C u+0443 u+0436 u+0435 u+043E
+ u+043D u+0438 u+043D u+0435 u+0433 u+043E u+0432 u+043E u+0440
+ u+044F u+0442 u+043F u+043E u+0440 u+0443 u+0441 u+0441 u+043A
+ u+0438
+}]
+test http-idna-3.19-J {puny decode: examples from RFC 3492} {
+ hexify [::tcl::idna puny decode \
+ PorqunopuedensimplementehablarenEspaol-fmd56a]
+} [list {*}{
+ u+0050 u+006F u+0072 u+0071 u+0075 u+00E9 u+006E u+006F u+0070
+ u+0075 u+0065 u+0064 u+0065 u+006E u+0073 u+0069 u+006D u+0070
+ u+006C u+0065 u+006D u+0065 u+006E u+0074 u+0065 u+0068 u+0061
+ u+0062 u+006C u+0061 u+0072 u+0065 u+006E u+0045 u+0073 u+0070
+ u+0061 u+00F1 u+006F u+006C
+}]
+test http-idna-3.19-K {puny decode: examples from RFC 3492} {
+ hexify [::tcl::idna puny decode \
+ TisaohkhngthchnitingVit-kjcr8268qyxafd2f1b9g]
+} [list {*}{
+ u+0054 u+1EA1 u+0069 u+0073 u+0061 u+006F u+0068 u+1ECD u+006B
+ u+0068 u+00F4 u+006E u+0067 u+0074 u+0068 u+1EC3 u+0063 u+0068
+ u+1EC9 u+006E u+00F3 u+0069 u+0074 u+0069 u+1EBF u+006E u+0067
+ u+0056 u+0069 u+1EC7 u+0074
+}]
+test http-idna-3.19-L {puny decode: examples from RFC 3492} {
+ hexify [::tcl::idna puny decode 3B-ww4c5e180e575a65lsy2b]
+} {u+0033 u+5E74 u+0042 u+7D44 u+91D1 u+516B u+5148 u+751F}
+test http-idna-3.19-M {puny decode: examples from RFC 3492} {
+ hexify [::tcl::idna puny decode -with-SUPER-MONKEYS-pc58ag80a8qai00g7n9n]
+} [list {*}{
+ u+5B89 u+5BA4 u+5948 u+7F8E u+6075 u+002D u+0077 u+0069 u+0074
+ u+0068 u+002D u+0053 u+0055 u+0050 u+0045 u+0052 u+002D u+004D
+ u+004F u+004E u+004B u+0045 u+0059 u+0053
+}]
+test http-idna-3.19-N {puny decode: examples from RFC 3492} {
+ hexify [::tcl::idna puny decode Hello-Another-Way--fc4qua05auwb3674vfr0b]
+} [list {*}{
+ u+0048 u+0065 u+006C u+006C u+006F u+002D u+0041 u+006E u+006F
+ u+0074 u+0068 u+0065 u+0072 u+002D u+0057 u+0061 u+0079 u+002D
+ u+305D u+308C u+305E u+308C u+306E u+5834 u+6240
+}]
+test http-idna-3.19-O {puny decode: examples from RFC 3492} {
+ hexify [::tcl::idna puny decode 2-u9tlzr9756bt3uc0v]
+} {u+3072 u+3068 u+3064 u+5C4B u+6839 u+306E u+4E0B u+0032}
+test http-idna-3.19-P {puny decode: examples from RFC 3492} {
+ hexify [::tcl::idna puny decode MajiKoi5-783gue6qz075azm5e]
+} [list {*}{
+ u+004D u+0061 u+006A u+0069 u+3067 u+004B u+006F u+0069 u+3059
+ u+308B u+0035 u+79D2 u+524D
+}]
+test http-idna-3.19-Q {puny decode: examples from RFC 3492} {
+ hexify [::tcl::idna puny decode de-jg4avhby1noc0d]
+} {u+30D1 u+30D5 u+30A3 u+30FC u+0064 u+0065 u+30EB u+30F3 u+30D0}
+test http-idna-3.19-R {puny decode: examples from RFC 3492} {
+ hexify [::tcl::idna puny decode d9juau41awczczp]
+} {u+305D u+306E u+30B9 u+30D4 u+30FC u+30C9 u+3067}
+test http-idna-3.19-S {puny decode: examples from RFC 3492} {
+ ::tcl::idna puny decode {-> $1.00 <--}
+} {-> $1.00 <-}
+rename hexify ""
+
+test http-idna-4.1 {IDNA encoding} {
+ ::tcl::idna encode abc.def
+} abc.def
+test http-idna-4.2 {IDNA encoding} {
+ ::tcl::idna encode a\u20acb\u20acc.def
+} xn--abc-k50ab.def
+test http-idna-4.3 {IDNA encoding} {
+ ::tcl::idna encode def.a\u20acb\u20acc
+} def.xn--abc-k50ab
+test http-idna-4.4 {IDNA encoding} {
+ ::tcl::idna encode ABC.DEF
+} ABC.DEF
+test http-idna-4.5 {IDNA encoding} {
+ ::tcl::idna encode A\u20acB\u20acC.def
+} xn--ABC-k50ab.def
+test http-idna-4.6 {IDNA encoding: invalid edge case} {
+ # Should this be an error?
+ ::tcl::idna encode abc..def
+} abc..def
+test http-idna-4.7 {IDNA encoding: invalid char} -returnCodes error -body {
+ ::tcl::idna encode abc.$.def
+} -result {bad character "$" in DNS name}
+test http-idna-4.7.1 {IDNA encoding: invalid char} {
+ catch {::tcl::idna encode abc.$.def} -> opt
+ dict get $opt -errorcode
+} {IDNA INVALID_NAME_CHARACTER {$}}
+test http-idna-4.8 {IDNA encoding: empty} {
+ ::tcl::idna encode ""
+} {}
+set overlong www.[join [subst [string map {u+ \\u} {
+ u+C138 u+ACC4 u+C758 u+BAA8 u+B4E0 u+C0AC u+B78C u+B4E4 u+C774
+ u+D55C u+AD6D u+C5B4 u+B97C u+C774 u+D574 u+D55C u+B2E4 u+BA74
+ u+C5BC u+B9C8 u+B098 u+C88B u+C744 u+AE4C
+}]] ""].com
+test http-idna-4.9 {IDNA encoding: max lengths from RFC 5890} -body {
+ ::tcl::idna encode $overlong
+} -returnCodes error -result "hostname part too long"
+test http-idna-4.9.1 {IDNA encoding: max lengths from RFC 5890} {
+ catch {::tcl::idna encode $overlong} -> opt
+ dict get $opt -errorcode
+} {IDNA OVERLONG_PART xn--989aomsvi5e83db1d2a355cv1e0vak1dwrv93d5xbh15a0dt30a5jpsd879ccm6fea98c}
+unset overlong
+test http-idna-4.10 {IDNA encoding: edge cases} {
+ ::tcl::idna encode pass\u00e9.example.com
+} xn--pass-epa.example.com
+
+test http-idna-5.1 {IDNA decoding} {
+ ::tcl::idna decode abc.def
+} abc.def
+test http-idna-5.2 {IDNA decoding} {
+ # Invalid entry that's just a wrapper
+ ::tcl::idna decode xn--abc-.def
+} abc.def
+test http-idna-5.3 {IDNA decoding} {
+ # Invalid entry that's just a wrapper
+ ::tcl::idna decode xn--abc-.xn--def-
+} abc.def
+test http-idna-5.4 {IDNA decoding} {
+ # Invalid entry that's just a wrapper
+ ::tcl::idna decode XN--abc-.XN--def-
+} abc.def
+test http-idna-5.5 {IDNA decoding: error cases} -returnCodes error -body {
+ ::tcl::idna decode xn--$$$.example.com
+} -result {bad decode character "$"}
+test http-idna-5.5.1 {IDNA decoding: error cases} {
+ catch {::tcl::idna decode xn--$$$.example.com} -> opt
+ dict get $opt -errorcode
+} {PUNYCODE BAD_INPUT CHAR}
+test http-idna-5.6 {IDNA decoding: error cases} -returnCodes error -body {
+ ::tcl::idna decode xn--a-zzzzzzzzzzzzzzzzzzzzzzzzzzzzzz.def
+} -result {exceeded input data}
+test http-idna-5.6.1 {IDNA decoding: error cases} {
+ catch {::tcl::idna decode xn--a-zzzzzzzzzzzzzzzzzzzzzzzzzzzzzz.def} -> opt
+ dict get $opt -errorcode
+} {PUNYCODE BAD_INPUT LENGTH}
+
# cleanup
catch {unset url}
catch {unset badurl}
diff --git a/tests/httpcookie.test b/tests/httpcookie.test
new file mode 100644
index 0000000..204c263
--- /dev/null
+++ b/tests/httpcookie.test
@@ -0,0 +1,853 @@
+# Commands covered: http::cookiejar
+#
+# This file contains a collection of tests for the cookiejar package.
+# Sourcing this file into Tcl runs the tests and generates output for errors.
+# No output means no errors were found.
+#
+# Copyright (c) 2014 Donal K. Fellows.
+#
+# See the file "license.terms" for information on usage and redistribution of
+# this file, and for a DISCLAIMER OF ALL WARRANTIES.
+
+package require tcltest 2
+namespace import -force ::tcltest::*
+
+testConstraint cookiejar [expr {![catch {
+ package require cookiejar
+}]}]
+
+test http-cookiejar-1.1 {cookie storage: packaging} cookiejar {
+ package require cookiejar
+} 0.1
+test http-cookiejar-1.2 {cookie storage: packaging} cookiejar {
+ package require cookiejar
+ package require cookiejar
+} 0.1
+
+test http-cookiejar-2.1 {cookie storage: basics} -constraints cookiejar -body {
+ http::cookiejar
+} -returnCodes error -result {wrong # args: should be "http::cookiejar method ?arg ...?"}
+test http-cookiejar-2.2 {cookie storage: basics} -constraints cookiejar -body {
+ http::cookiejar ?
+} -returnCodes error -result {unknown method "?": must be configure, create, destroy or new}
+test http-cookiejar-2.3 {cookie storage: basics} cookiejar {
+ http::cookiejar configure
+} {-domainfile -domainlist -domainrefresh -loglevel -offline -purgeold -retain -vacuumtrigger}
+test http-cookiejar-2.4 {cookie storage: basics} -constraints cookiejar -body {
+ http::cookiejar configure a b c d e
+} -returnCodes error -result {wrong # args: should be "http::cookiejar configure ?optionName? ?optionValue?"}
+test http-cookiejar-2.5 {cookie storage: basics} -constraints cookiejar -body {
+ http::cookiejar configure a
+} -returnCodes error -result {bad option "a": must be -domainfile, -domainlist, -domainrefresh, -loglevel, -offline, -purgeold, -retain, or -vacuumtrigger}
+test http-cookiejar-2.6 {cookie storage: basics} -constraints cookiejar -body {
+ http::cookiejar configure -d
+} -returnCodes error -result {ambiguous option "-d": must be -domainfile, -domainlist, -domainrefresh, -loglevel, -offline, -purgeold, -retain, or -vacuumtrigger}
+test http-cookiejar-2.7 {cookie storage: basics} -setup {
+ set old [http::cookiejar configure -loglevel]
+} -constraints cookiejar -body {
+ list [http::cookiejar configure -loglevel] \
+ [http::cookiejar configure -loglevel debug] \
+ [http::cookiejar configure -loglevel] \
+ [http::cookiejar configure -loglevel error] \
+ [http::cookiejar configure -loglevel]
+} -cleanup {
+ http::cookiejar configure -loglevel $old
+} -result {info debug debug error error}
+test http-cookiejar-2.8 {cookie storage: basics} -setup {
+ set old [http::cookiejar configure -loglevel]
+} -constraints cookiejar -body {
+ list [http::cookiejar configure -loglevel] \
+ [http::cookiejar configure -loglevel d] \
+ [http::cookiejar configure -loglevel i] \
+ [http::cookiejar configure -loglevel w] \
+ [http::cookiejar configure -loglevel e]
+} -cleanup {
+ http::cookiejar configure -loglevel $old
+} -result {info debug info warn error}
+test http-cookiejar-2.9 {cookie storage: basics} -constraints cookiejar -body {
+ http::cookiejar configure -off
+} -match glob -result *
+test http-cookiejar-2.10 {cookie storage: basics} -setup {
+ set oldval [http::cookiejar configure -offline]
+} -constraints cookiejar -body {
+ http::cookiejar configure -offline true
+} -cleanup {
+ catch {http::cookiejar configure -offline $oldval}
+} -result 1
+test http-cookiejar-2.11 {cookie storage: basics} -setup {
+ set oldval [http::cookiejar configure -offline]
+} -constraints cookiejar -body {
+ http::cookiejar configure -offline nonbool
+} -cleanup {
+ catch {http::cookiejar configure -offline $oldval}
+} -returnCodes error -result {expected boolean value but got "nonbool"}
+test http-cookiejar-2.12 {cookie storage: basics} -setup {
+ set oldval [http::cookiejar configure -purgeold]
+} -constraints cookiejar -body {
+ http::cookiejar configure -purge nonint
+} -cleanup {
+ catch {http::cookiejar configure -purgeold $oldval}
+} -returnCodes error -result {expected positive integer but got "nonint"}
+test http-cookiejar-2.13 {cookie storage: basics} -setup {
+ set oldval [http::cookiejar configure -domainrefresh]
+} -constraints cookiejar -body {
+ http::cookiejar configure -domainref nonint
+} -cleanup {
+ catch {http::cookiejar configure -domainrefresh $oldval}
+} -returnCodes error -result {expected positive integer but got "nonint"}
+test http-cookiejar-2.14 {cookie storage: basics} -setup {
+ set oldval [http::cookiejar configure -domainrefresh]
+} -constraints cookiejar -body {
+ http::cookiejar configure -domainref -42
+} -cleanup {
+ catch {http::cookiejar configure -domainrefresh $oldval}
+} -returnCodes error -result {expected positive integer but got "-42"}
+test http-cookiejar-2.15 {cookie storage: basics} -setup {
+ set oldval [http::cookiejar configure -domainrefresh]
+ set result unset
+ set tracer [http::cookiejar create tracer]
+} -constraints cookiejar -body {
+ oo::objdefine $tracer method PostponeRefresh {} {
+ set ::result set
+ next
+ }
+ http::cookiejar configure -domainref 12345
+ return $result
+} -cleanup {
+ $tracer destroy
+ catch {http::cookiejar configure -domainrefresh $oldval}
+} -result set
+
+test http-cookiejar-3.1 {cookie storage: class} cookiejar {
+ info object isa object http::cookiejar
+} 1
+test http-cookiejar-3.2 {cookie storage: class} cookiejar {
+ info object isa class http::cookiejar
+} 1
+test http-cookiejar-3.3 {cookie storage: class} cookiejar {
+ lsort [info object methods http::cookiejar]
+} {configure}
+test http-cookiejar-3.4 {cookie storage: class} cookiejar {
+ lsort [info object methods http::cookiejar -all]
+} {configure create destroy new}
+test http-cookiejar-3.5 {cookie storage: class} -setup {
+ catch {rename ::cookiejar ""}
+} -constraints cookiejar -body {
+ namespace eval :: {http::cookiejar create cookiejar}
+} -cleanup {
+ catch {rename ::cookiejar ""}
+} -result ::cookiejar
+test http-cookiejar-3.6 {cookie storage: class} -setup {
+ catch {rename ::cookiejar ""}
+} -constraints cookiejar -body {
+ list [http::cookiejar create ::cookiejar] [info commands ::cookiejar] \
+ [::cookiejar destroy] [info commands ::cookiejar]
+} -cleanup {
+ catch {rename ::cookiejar ""}
+} -result {::cookiejar ::cookiejar {} {}}
+test http-cookiejar-3.7 {cookie storage: class} -setup {
+ catch {rename ::cookiejar ""}
+} -constraints cookiejar -body {
+ http::cookiejar create ::cookiejar foo bar
+} -returnCodes error -cleanup {
+ catch {rename ::cookiejar ""}
+} -result {wrong # args: should be "http::cookiejar create ::cookiejar ?path?"}
+test http-cookiejar-3.8 {cookie storage: class} -setup {
+ catch {rename ::cookiejar ""}
+ set f [makeFile "" cookiejar]
+ file delete $f
+} -constraints cookiejar -body {
+ http::cookiejar create ::cookiejar $f
+} -cleanup {
+ catch {rename ::cookiejar ""}
+ removeFile $f
+} -result ::cookiejar
+test http-cookiejar-3.9 {cookie storage: class} -setup {
+ catch {rename ::cookiejar ""}
+ set f [makeFile "bogus content for a database" cookiejar]
+} -constraints cookiejar -body {
+ http::cookiejar create ::cookiejar $f
+} -returnCodes error -cleanup {
+ catch {rename ::cookiejar ""}
+ removeFile $f
+} -result {file is encrypted or is not a database}
+test http-cookiejar-3.10 {cookie storage: class} -setup {
+ catch {rename ::cookiejar ""}
+ set dir [makeDirectory cookiejar]
+} -constraints cookiejar -body {
+ http::cookiejar create ::cookiejar $dir
+} -returnCodes error -cleanup {
+ catch {rename ::cookiejar ""}
+ removeDirectory $dir
+} -result {unable to open database file}
+
+test http-cookiejar-4.1 {cookie storage: instance} -setup {
+ http::cookiejar create ::cookiejar
+} -constraints cookiejar -body {
+ cookiejar
+} -returnCodes error -cleanup {
+ ::cookiejar destroy
+} -result {wrong # args: should be "cookiejar method ?arg ...?"}
+test http-cookiejar-4.2 {cookie storage: instance} -setup {
+ http::cookiejar create ::cookiejar
+} -constraints cookiejar -body {
+ cookiejar ?
+} -returnCodes error -cleanup {
+ ::cookiejar destroy
+} -result {unknown method "?": must be destroy, forceLoadDomainData, getCookies, lookup or storeCookie}
+test http-cookiejar-4.3 {cookie storage: instance} -setup {
+ http::cookiejar create ::cookiejar
+} -constraints cookiejar -body {
+ lsort [info object methods cookiejar -all]
+} -cleanup {
+ ::cookiejar destroy
+} -result {destroy forceLoadDomainData getCookies lookup storeCookie}
+test http-cookiejar-4.4 {cookie storage: instance} -setup {
+ http::cookiejar create ::cookiejar
+} -constraints cookiejar -body {
+ cookiejar getCookies
+} -returnCodes error -cleanup {
+ ::cookiejar destroy
+} -result {wrong # args: should be "cookiejar getCookies proto host path"}
+test http-cookiejar-4.5 {cookie storage} -setup {
+ http::cookiejar create ::cookiejar
+} -constraints cookiejar -body {
+ cookiejar getCookies http www.example.com /
+} -cleanup {
+ ::cookiejar destroy
+} -result {}
+test http-cookiejar-4.6 {cookie storage: instance} -setup {
+ http::cookiejar create ::cookiejar
+} -constraints cookiejar -body {
+ cookiejar storeCookie
+} -returnCodes error -cleanup {
+ ::cookiejar destroy
+} -result {wrong # args: should be "cookiejar storeCookie options"}
+test http-cookiejar-4.7 {cookie storage: instance} -setup {
+ http::cookiejar create ::cookiejar
+} -constraints cookiejar -body {
+ cookiejar storeCookie {
+ key foo
+ value bar
+ secure 0
+ domain www.example.com
+ origin www.example.com
+ path /
+ hostonly 1
+ }
+} -cleanup {
+ ::cookiejar destroy
+} -result {}
+test http-cookiejar-4.8 {cookie storage: instance} -setup {
+ http::cookiejar create ::cookiejar
+ oo::objdefine ::cookiejar export Database
+} -constraints cookiejar -body {
+ cookiejar storeCookie {
+ key foo
+ value bar
+ secure 0
+ domain www.example.com
+ origin www.example.com
+ path /
+ hostonly 1
+ }
+ # Poke inside implementation!
+ cookiejar Database eval {SELECT count(*) FROM sessionCookies}
+} -cleanup {
+ ::cookiejar destroy
+} -result 1
+test http-cookiejar-4.9 {cookie storage: instance} -setup {
+ http::cookiejar create ::cookiejar
+ oo::objdefine ::cookiejar export Database
+} -constraints cookiejar -body {
+ cookiejar storeCookie {
+ key foo
+ value bar
+ secure 0
+ domain www.example.com
+ origin www.example.com
+ path /
+ hostonly 1
+ }
+ # Poke inside implementation!
+ cookiejar Database eval {SELECT count(*) FROM persistentCookies}
+} -cleanup {
+ ::cookiejar destroy
+} -result 0
+test http-cookiejar-4.10 {cookie storage: instance} -setup {
+ http::cookiejar create ::cookiejar
+} -constraints cookiejar -body {
+ cookiejar storeCookie [dict replace {
+ key foo
+ value bar
+ secure 0
+ domain www.example.com
+ origin www.example.com
+ path /
+ hostonly 1
+ } expires [expr {[clock seconds]+5}]]
+} -cleanup {
+ ::cookiejar destroy
+} -result {}
+test http-cookiejar-4.11 {cookie storage: instance} -setup {
+ http::cookiejar create ::cookiejar
+ oo::objdefine ::cookiejar export Database
+} -constraints cookiejar -body {
+ cookiejar storeCookie [dict replace {
+ key foo
+ value bar
+ secure 0
+ domain www.example.com
+ origin www.example.com
+ path /
+ hostonly 1
+ } expires [expr {[clock seconds]+5}]]
+ # Poke inside implementation!
+ cookiejar Database eval {SELECT count(*) FROM sessionCookies}
+} -cleanup {
+ ::cookiejar destroy
+} -result 0
+test http-cookiejar-4.12 {cookie storage: instance} -setup {
+ http::cookiejar create ::cookiejar
+ oo::objdefine ::cookiejar export Database
+} -constraints cookiejar -body {
+ cookiejar storeCookie [dict replace {
+ key foo
+ value bar
+ secure 0
+ domain www.example.com
+ origin www.example.com
+ path /
+ hostonly 1
+ } expires [expr {[clock seconds]+5}]]
+ # Poke inside implementation!
+ cookiejar Database eval {SELECT count(*) FROM persistentCookies}
+} -cleanup {
+ ::cookiejar destroy
+} -result 1
+test http-cookiejar-4.13 {cookie storage: instance} -setup {
+ http::cookiejar create ::cookiejar
+ set result {}
+} -constraints cookiejar -body {
+ lappend result [cookiejar getCookies http www.example.com /]
+ cookiejar storeCookie {
+ key foo
+ value bar
+ secure 0
+ domain www.example.com
+ origin www.example.com
+ path /
+ hostonly 1
+ }
+ lappend result [cookiejar getCookies http www.example.com /]
+} -cleanup {
+ ::cookiejar destroy
+} -result {{} {foo bar}}
+test http-cookiejar-4.14 {cookie storage: instance} -setup {
+ http::cookiejar create ::cookiejar
+ set result {}
+} -constraints cookiejar -body {
+ lappend result [cookiejar getCookies http www.example.com /]
+ cookiejar storeCookie [dict replace {
+ key foo
+ value bar
+ secure 0
+ domain www.example.com
+ origin www.example.com
+ path /
+ hostonly 1
+ } expires [expr {[clock seconds]+5}]]
+ lappend result [cookiejar getCookies http www.example.com /]
+} -cleanup {
+ ::cookiejar destroy
+} -result {{} {foo bar}}
+test http-cookiejar-4.15 {cookie storage: instance} -setup {
+ http::cookiejar create ::cookiejar
+ set result {}
+} -constraints cookiejar -body {
+ lappend result [cookiejar getCookies http www.example.com /]
+ cookiejar storeCookie {
+ key foo
+ value bar
+ secure 0
+ domain www.example.com
+ origin www.example.com
+ path /
+ hostonly 1
+ }
+ cookiejar storeCookie [dict replace {
+ key foo
+ value bar
+ secure 0
+ domain www.example.com
+ origin www.example.com
+ path /
+ hostonly 1
+ } expires [expr {[clock seconds]+5}]]
+ lappend result [cookiejar getCookies http www.example.com /]
+} -cleanup {
+ ::cookiejar destroy
+} -result {{} {foo bar}}
+test http-cookiejar-4.16 {cookie storage: instance} -setup {
+ http::cookiejar create ::cookiejar
+ set result {}
+} -constraints cookiejar -body {
+ lappend result [cookiejar getCookies http www.example.com /]
+ cookiejar storeCookie {
+ key foo1
+ value bar
+ secure 0
+ domain www.example.com
+ origin www.example.com
+ path /
+ hostonly 1
+ }
+ cookiejar storeCookie [dict replace {
+ key foo2
+ value bar
+ secure 0
+ domain www.example.com
+ origin www.example.com
+ path /
+ hostonly 1
+ } expires [expr {[clock seconds]+5}]]
+ lappend result [lsort -stride 2 [cookiejar getCookies http www.example.com /]]
+} -cleanup {
+ ::cookiejar destroy
+} -result {{} {foo1 bar foo2 bar}}
+test http-cookiejar-4.17 {cookie storage: instance} -setup {
+ http::cookiejar create ::cookiejar
+} -constraints cookiejar -body {
+ cookiejar lookup a b c d
+} -returnCodes error -cleanup {
+ ::cookiejar destroy
+} -result {wrong # args: should be "cookiejar lookup ?host? ?key?"}
+test http-cookiejar-4.18 {cookie storage: instance} -setup {
+ http::cookiejar create ::cookiejar
+ set result {}
+} -constraints cookiejar -body {
+ lappend result [cookiejar lookup]
+ lappend result [cookiejar lookup www.example.com]
+ lappend result [catch {cookiejar lookup www.example.com foo} value] $value
+ cookiejar storeCookie {
+ key foo
+ value bar
+ secure 0
+ domain www.example.com
+ origin www.example.com
+ path /
+ hostonly 1
+ }
+ lappend result [cookiejar lookup]
+ lappend result [cookiejar lookup www.example.com]
+ lappend result [cookiejar lookup www.example.com foo]
+} -cleanup {
+ ::cookiejar destroy
+} -result {{} {} 1 {no such key for that host} www.example.com foo bar}
+test http-cookiejar-4.19 {cookie storage: instance} -setup {
+ http::cookiejar create ::cookiejar
+ set result {}
+} -constraints cookiejar -body {
+ cookiejar storeCookie {
+ key foo
+ value bar
+ secure 0
+ domain www.example.com
+ origin www.example.com
+ path /
+ hostonly 1
+ }
+ cookiejar storeCookie {
+ key bar
+ value foo
+ secure 0
+ domain www.example.org
+ origin www.example.org
+ path /
+ hostonly 1
+ }
+ lappend result [lsort [cookiejar lookup]]
+ lappend result [cookiejar lookup www.example.com]
+ lappend result [cookiejar lookup www.example.com foo]
+ lappend result [cookiejar lookup www.example.org]
+ lappend result [cookiejar lookup www.example.org bar]
+} -cleanup {
+ ::cookiejar destroy
+} -result {{www.example.com www.example.org} foo bar bar foo}
+test http-cookiejar-4.20 {cookie storage: instance} -setup {
+ http::cookiejar create ::cookiejar
+ set result {}
+} -constraints cookiejar -body {
+ cookiejar storeCookie {
+ key foo1
+ value bar1
+ secure 0
+ domain www.example.com
+ origin www.example.com
+ path /
+ hostonly 1
+ }
+ cookiejar storeCookie [dict replace {
+ key foo2
+ value bar2
+ secure 0
+ domain www.example.com
+ origin www.example.com
+ path /
+ hostonly 1
+ } expires [expr {[clock seconds]+5}]]
+ lappend result [cookiejar lookup]
+ lappend result [lsort [cookiejar lookup www.example.com]]
+ lappend result [cookiejar lookup www.example.com foo1]
+ lappend result [cookiejar lookup www.example.com foo2]
+} -cleanup {
+ ::cookiejar destroy
+} -result {www.example.com {foo1 foo2} bar1 bar2}
+test http-cookiejar-4.21 {cookie storage: instance} -setup {
+ http::cookiejar create ::cookiejar
+ set result {}
+} -constraints cookiejar -body {
+ cookiejar storeCookie {
+ key foo1
+ value bar1
+ secure 0
+ domain www.example.com
+ origin www.example.com
+ path /
+ hostonly 1
+ }
+ cookiejar storeCookie {
+ key foo2
+ value bar2
+ secure 0
+ domain www.example.com
+ origin www.example.com
+ path /
+ hostonly 1
+ }
+ lappend result [cookiejar lookup]
+ lappend result [lsort [cookiejar lookup www.example.com]]
+ lappend result [cookiejar lookup www.example.com foo1]
+ lappend result [cookiejar lookup www.example.com foo2]
+} -cleanup {
+ ::cookiejar destroy
+} -result {www.example.com {foo1 foo2} bar1 bar2}
+test http-cookiejar-4.22 {cookie storage: instance} -setup {
+ http::cookiejar create ::cookiejar
+ set result {}
+} -constraints cookiejar -body {
+ cookiejar forceLoadDomainData x y z
+} -returnCodes error -cleanup {
+ ::cookiejar destroy
+} -result {wrong # args: should be "cookiejar forceLoadDomainData"}
+test http-cookiejar-4.23 {cookie storage: instance} -setup {
+ http::cookiejar create ::cookiejar
+ set result {}
+} -constraints cookiejar -body {
+ cookiejar forceLoadDomainData
+} -cleanup {
+ ::cookiejar destroy
+} -result {}
+test http-cookiejar-4.23.a {cookie storage: instance} -setup {
+ set off [http::cookiejar configure -offline]
+} -constraints cookiejar -body {
+ http::cookiejar configure -offline 1
+ [http::cookiejar create ::cookiejar] destroy
+} -cleanup {
+ catch {::cookiejar destroy}
+ http::cookiejar configure -offline $off
+} -result {}
+test http-cookiejar-4.23.b {cookie storage: instance} -setup {
+ set off [http::cookiejar configure -offline]
+} -constraints cookiejar -body {
+ http::cookiejar configure -offline 0
+ [http::cookiejar create ::cookiejar] destroy
+} -cleanup {
+ catch {::cookiejar destroy}
+ http::cookiejar configure -offline $off
+} -result {}
+
+test http-cookiejar-5.1 {cookie storage: constraints} -setup {
+ http::cookiejar create ::cookiejar
+ cookiejar forceLoadDomainData
+} -constraints cookiejar -body {
+ cookiejar storeCookie {
+ key foo
+ value bar
+ secure 0
+ domain com
+ origin com
+ path /
+ hostonly 1
+ }
+ cookiejar lookup
+} -cleanup {
+ ::cookiejar destroy
+} -result {}
+test http-cookiejar-5.2 {cookie storage: constraints} -setup {
+ http::cookiejar create ::cookiejar
+ cookiejar forceLoadDomainData
+} -constraints cookiejar -body {
+ cookiejar storeCookie {
+ key foo
+ value bar
+ secure 0
+ domain foo.example.com
+ origin bar.example.org
+ path /
+ hostonly 1
+ }
+ cookiejar lookup
+} -cleanup {
+ ::cookiejar destroy
+} -result {}
+test http-cookiejar-5.3 {cookie storage: constraints} -setup {
+ http::cookiejar create ::cookiejar
+ cookiejar forceLoadDomainData
+} -constraints cookiejar -body {
+ cookiejar storeCookie {
+ key foo1
+ value bar
+ secure 0
+ domain com
+ origin www.example.com
+ path /
+ hostonly 1
+ }
+ cookiejar storeCookie {
+ key foo2
+ value bar
+ secure 0
+ domain example.com
+ origin www.example.com
+ path /
+ hostonly 1
+ }
+ cookiejar lookup
+} -cleanup {
+ ::cookiejar destroy
+} -result {example.com}
+test http-cookiejar-5.4 {cookie storage: constraints} -setup {
+ http::cookiejar create ::cookiejar
+ cookiejar forceLoadDomainData
+} -constraints cookiejar -body {
+ cookiejar storeCookie {
+ key foo
+ value bar1
+ secure 0
+ domain www.example.com
+ origin www.example.com
+ path /
+ hostonly 1
+ }
+ cookiejar storeCookie {
+ key foo
+ value bar2
+ secure 0
+ domain example.com
+ origin www.example.com
+ path /
+ hostonly 1
+ }
+ lsort [cookiejar lookup]
+} -cleanup {
+ ::cookiejar destroy
+} -result {example.com www.example.com}
+test http-cookiejar-5.5 {cookie storage: constraints} -setup {
+ http::cookiejar create ::cookiejar
+ cookiejar forceLoadDomainData
+} -constraints cookiejar -body {
+ cookiejar storeCookie {
+ key foo1
+ value 1
+ secure 0
+ domain com
+ origin www.example.com
+ path /
+ hostonly 0
+ }
+ cookiejar storeCookie {
+ key foo2
+ value 2
+ secure 0
+ domain com
+ origin www.example.com
+ path /
+ hostonly 1
+ }
+ cookiejar storeCookie {
+ key foo3
+ value 3
+ secure 0
+ domain example.com
+ origin www.example.com
+ path /
+ hostonly 0
+ }
+ cookiejar storeCookie {
+ key foo4
+ value 4
+ secure 0
+ domain example.com
+ origin www.example.com
+ path /
+ hostonly 1
+ }
+ cookiejar storeCookie {
+ key foo5
+ value 5
+ secure 0
+ domain www.example.com
+ origin www.example.com
+ path /
+ hostonly 0
+ }
+ cookiejar storeCookie {
+ key foo6
+ value 6
+ secure 0
+ domain www.example.com
+ origin www.example.com
+ path /
+ hostonly 1
+ }
+ cookiejar storeCookie {
+ key foo7
+ value 7
+ secure 1
+ domain www.example.com
+ origin www.example.com
+ path /
+ hostonly 0
+ }
+ cookiejar storeCookie {
+ key foo8
+ value 8
+ secure 1
+ domain www.example.com
+ origin www.example.com
+ path /
+ hostonly 1
+ }
+ cookiejar storeCookie {
+ key foo9
+ value 9
+ secure 0
+ domain sub.www.example.com
+ origin www.example.com
+ path /
+ hostonly 1
+ }
+ list [cookiejar getCookies http www.example.com /] \
+ [cookiejar getCookies http www2.example.com /] \
+ [cookiejar getCookies https www.example.com /] \
+ [cookiejar getCookies http sub.www.example.com /]
+} -cleanup {
+ ::cookiejar destroy
+} -result {{foo3 3 foo6 6} {foo3 3} {foo3 3 foo6 6 foo8 8} {foo3 3 foo5 5}}
+
+test http-cookiejar-6.1 {cookie storage: expiry and lookup} -setup {
+ http::cookiejar create ::cookiejar
+ oo::objdefine cookiejar export PurgeCookies
+ set result {}
+ proc values cookies {
+ global result
+ lappend result [lsort [lmap {k v} $cookies {set v}]]
+ }
+} -constraints cookiejar -body {
+ values [cookiejar getCookies http www.example.com /]
+ cookiejar storeCookie {
+ key foo
+ value session
+ secure 0
+ domain www.example.com
+ origin www.example.com
+ path /
+ hostonly 1
+ }
+ values [cookiejar getCookies http www.example.com /]
+ cookiejar storeCookie [dict replace {
+ key foo
+ value cookie
+ secure 0
+ domain www.example.com
+ origin www.example.com
+ path /
+ hostonly 1
+ } expires [expr {[clock seconds]+1}]]
+ values [cookiejar getCookies http www.example.com /]
+ cookiejar storeCookie {
+ key foo
+ value session-global
+ secure 0
+ domain example.com
+ origin www.example.com
+ path /
+ hostonly 0
+ }
+ values [cookiejar getCookies http www.example.com /]
+ after 2500
+ update
+ values [cookiejar getCookies http www.example.com /]
+ cookiejar PurgeCookies
+ values [cookiejar getCookies http www.example.com /]
+ cookiejar storeCookie {
+ key foo
+ value go-away
+ secure 0
+ domain example.com
+ origin www.example.com
+ path /
+ hostonly 0
+ expires 0
+ }
+ values [cookiejar getCookies http www.example.com /]
+} -cleanup {
+ ::cookiejar destroy
+} -result {{} session cookie {cookie session-global} {cookie session-global} session-global {}}
+
+test http-cookiejar-7.1 {cookie storage: persistence of persistent cookies} -setup {
+ catch {rename ::cookiejar ""}
+ set f [makeFile "" cookiejar]
+ file delete $f
+} -constraints cookiejar -body {
+ http::cookiejar create ::cookiejar $f
+ ::cookiejar destroy
+ http::cookiejar create ::cookiejar $f
+} -cleanup {
+ catch {rename ::cookiejar ""}
+ removeFile $f
+} -result ::cookiejar
+test http-cookiejar-7.2 {cookie storage: persistence of persistent cookies} -setup {
+ catch {rename ::cookiejar ""}
+ set f [makeFile "" cookiejar]
+ file delete $f
+ set result {}
+} -constraints cookiejar -body {
+ http::cookiejar create ::cookiejar $f
+ cookiejar storeCookie [dict replace {
+ key foo
+ value cookie
+ secure 0
+ domain www.example.com
+ origin www.example.com
+ path /
+ hostonly 1
+ } expires [expr {[clock seconds]+1}]]
+ lappend result [::cookiejar getCookies http www.example.com /]
+ ::cookiejar destroy
+ http::cookiejar create ::cookiejar
+ lappend result [::cookiejar getCookies http www.example.com /]
+ ::cookiejar destroy
+ http::cookiejar create ::cookiejar $f
+ lappend result [::cookiejar getCookies http www.example.com /]
+} -cleanup {
+ catch {rename ::cookiejar ""}
+ removeFile $f
+} -result {{foo cookie} {} {foo cookie}}
+
+::tcltest::cleanupTests
+
+# Local variables:
+# mode: tcl
+# End:
diff --git a/tests/tcltest.test b/tests/tcltest.test
index ca720ee..ca720ee 100644..100755
--- a/tests/tcltest.test
+++ b/tests/tcltest.test
generated by cgit v0.12 at 2024-11-16 16:21:55 (GMT)