# Cookies - a package to provide parsing and formatting of HTTP cookies
# according to rfc2109 (with a nod to Netscape)
#
# TODO: effective filtering of cookies for a given URL
#
# URL: http://wiki.tcl.tk/Cookies.tcl
#
# Modification:
# Wed, 31st Jan, 2007 Initial Release Colin McCormack (colin at chinix dot com)
####
package provide Cookies 1.0
namespace eval Cookies {
# filter all expired cookies from a cookie dict
proc expire {cookies {now ""}} {
# get a time value as a base for expiry calculations
if {$now eq ""} {
set now [clock seconds]
}
# expire old cookies
dict for {name cdict} $cookies {
# ensure the cookie expires when it's supposed to
set name [dict get $cdict -name]
if {[dict exists $cdict -when] && ([dict exists $cdict -when] < $now)} {
dict unset cookies $name ;# delete expired cookie
continue
}
}
return $cookies
}
# return an http date
proc DateInSeconds {date} {
if {[string is integer -strict $date]} {
return $date
} elseif {[catch {clock scan $date \
-format {%a, %d %b %Y %T GMT} \
-gmt true} result eo]} {
error "DateInSeconds '$date', ($result)"
} else {
return $result
}
}
# filter all expired cookies from a cookie dict stored in a record
proc expire_record {rec} {
if {[dict exists $rec -cookies]} {
# get a time value as a base for expiry calculations
if {[dict exists $rec date]} {
set now [DateInSeconds [dict get $rec date]]
} else {
set now [clock seconds]
}
dict set rec -cookies [expire [dict get $rec -cookies] $now]
}
return $rec
}
# filter a cookie dict according to the url dict given
# TODO: filter by domain and path
proc filter {cookie_dict args} {
if {[llength $args] eq 1} {
set url_dict [lindex $args 0]
} else {
set url_dict $args
}
# decide which cookies are in and out according to rfc2109
return $cookie_dict
}
# format a cookie dict into a list of 'cookie:' values
# ready to be sent by Http/1.1 client
proc format4client {cookie_dict {secure 0}} {
Debug.cookies {format4client save $cookie_dict}
set cookies {} ;# list of cookies in rfc2109 format
dict for {name cdict} $cookie_dict {
if {[string match "-*" $name]} {
continue
}
# secure cookies should not be sent over insecure connection
if {[dict exists $cdict -secure] && !$secure} {
continue
}
# cdict is a cookie record, comprising:
# rfc-specified attributes:
# -path, -comment, -domain, -max-age, -expires -secure, etc.
#
# and internal attributes:
# -name (the original name of the cookie)
# -when (the absolute seconds when the cookie expires)
# first send the $Version
if {![dict exists $cdict -version]} {
dict set cdict -version 0
}
set cookie "\$Version=[dict get $cdict -version]"
# then the named value
set name [dict get $cdict -name]
set val [dict get $cdict -value]
if {[string is alnum -strict $val]} {
lappend cookie "$name=[dict get $cdict -value]"
} else {
lappend cookie "$name=\"[dict get $cdict -value]\""
}
# then other cookie fields with values
foreach k {domain path} {
if {[dict exists $cdict -$k]} {
set v [dict get $cdict -$k]
set k [string totitle $k]
if {![string is alnum -strict $v]} {
lappend cookie "\$$k=\"$v\""
} else {
lappend cookie "\$$k=$v"
}
}
}
lappend cookies [join $cookie ";"]
}
return $cookies
}
# decode a cookie header received from a server into a dict
proc parse4client {cookies {now ""}} {
# get a time value as a base for expiry calculations
if {$now eq ""} {
set now [clock seconds]
}
set cdict [dict create]
Debug.cookies {PREEXPIRES: $cookies} 9
# hide and strip quoted strings
catch {unset quoted}
set re \[\"\](\[^\"\]*)\[\"\] ;# quoted string
set cnt 0
while {[regexp $re $cookies -> quoted(\x84$cnt\x85)]} {
regsub $re $cookies "\x84$cnt\x85" cookies
incr cnt
}
# clean up the absolutely awful "expires" field.
# we look for these naked time-values (which contain commas) and remove them
# prior to splitting on ',', then resubstitute them - awful hack - blame netscape.
catch {unset expires}
set re {((Mon|Tue|Wed|Thu|Fri|Sat|Sun)[^,]*, +[0-9]+-(Jan|Feb|Mar|Apr|May|Jun|Jul|Aug|Sep|Oct|Nov|Dec)-[0-9]+ [0-9]+:[0-9]+:[0-9]+ GMT)}
set cnt 0
while {[regexp $re $cookies expires(\x81$cnt\x82)]} {
regsub $re $cookies "\x81$cnt\x82" cookies
incr cnt
}
# distinguish the real delimiters in the set-cookie field
# split on delimeter, substitute back hidden values
set cookies [string map {, \x83 ; \x86} $cookies]
set cookies [string map [array get expires] [split $cookies "\x83"]]
Debug.cookies {PROCESSING: [array get expires] - $cookies} 9
# construct an attribute dict for each cookie
set attrs [dict create]
foreach cookie $cookies {
set cookie [string map [array get quoted] [split $cookie "\x86"]]
Debug.cookies {Client Parsing: $cookie}
set cval [string trim [join [lassign [split [lindex $cookie 0] =] name] =]]
# process each cookie's attributes
foreach term [lrange $cookie 1 end] {
set val [string trim [join [lassign [split $term =] attr] =]]
set attr [string trim $attr]
Debug.cookies {ATTR '$attr' $val}
dict set attrs -$attr [string trim $val \"]
}
# check cookie values, ensure -domain is in .form, etc.
# TODO
# store attribute dict into cookie dict by unique name
dict set attrs -value $cval
dict set attrs -name $name
set cname [unique $attrs] ;# get full name of cookie
dict set cdict $cname $attrs
# set expiry time
if {[dict exists $cdict $cname -expires]} {
dict set cdict $cname -when [clock scan [dict get $cdict $cname -expires]]
} elseif {[dict exists $cdict $cname -max-age]} {
dict set cdict $cname -when [expr {$now + [dict get $cdict $cname -expires]}]
}
}
return $cdict
}
# load cookies from a server's response into a cookie dict
proc load_server_cookies {rsp} {
Debug.cookies {load $rsp}
if {[dict exists $rsp set-cookie]} {
# get a time value as a base for expiry calculations
if {[dict exists $rsp date]} {
set now [DateInSeconds [dict get $rsp date]]
} else {
set now [clock seconds]
}
Debug.cookies {Cookies to parse: [dict get $rsp set-cookie]}
dict set rsp -cookies [parse4client [dict get $rsp set-cookie] $now]
} else {
Debug.cookies {load NO cookie}
}
return $rsp
}
# Save the -cookie sub-dict into fields ready to be sent by HTTP/1.1 server
proc format4server {cookie_dict {secure 0}} {
set cookies {} ;# collection of cookies in cookie1 format
dict for {name cdict} $cookie_dict {
if {[string match "-*" $name]} {
continue
}
if {[dict exists $cdict -secure] && !$secure} {
continue ;# secure cookies shouldn't be sent over insecure connection
}
# cdict is a cookie record, comprising:
# rfc-specified attributes:
# -path, -comment, -domain, -max-age, -expires -secure, etc.
#
# and internal attributes:
# -name (the original name of the cookie)
# -when (the absolute seconds when the cookie expires)
set name [dict get $cdict -name]
set val [dict get $cdict -value]
if {[string is alnum -strict $val]} {
set cookie "$name=[dict get $cdict -value]"
} else {
set cookie "$name=\"[dict get $cdict -value]\""
}
# cookie fields with values
foreach k {comment domain max-age path expires} {
if {[dict exists $cdict -$k]} {
set v [dict get $cdict -$k]
if {![string is alnum -strict $v]} {
lappend cookie "$k=\"$v\""
} else {
lappend cookie "$k=$v"
}
}
}
# assemble cookie
if {$cookie != {}} {
lappend cookie "version=1"
}
lappend cookies [join $cookie ";"]
}
Debug.cookies {format4server value: ($cookies)}
return $cookies
#set rsp [Http Vary $rsp set-cookie] ;# cookies are significant to caching
}
# decode a cookie header received from a client.
proc parse4server {cookies} {
set cdict [dict create] ;# empty cookie dict
# hide and strip quoted strings
catch {unset quoted}
set re \[\"\](\[^\"\]*)\[\"\] ;# quoted string
set cnt 0
while {[regexp $re $cookies -> quoted(\x84$cnt\x85)]} {
regsub $re $cookies "\x84$cnt\x85" cookies
incr cnt
}
set cookies [string map {, ;} $cookies] ;# comma and ; are identical
set cookies [split $cookies ";"]
# process each cookie from client
set cname ""
set attrs [dict create]
set version 0
foreach cookie $cookies {
set cookie [string trim [string map [array get quoted] $cookie]]
Debug.cookies {TRYING '$cookie'} 10
set val [string trim [join [lassign [split $cookie =] name] =]]
set name [string trim [string tolower $name]]
if {[string match {$*} $name]} {
# it's a reserved name which applies to the previous cookie
set name [string range $name 1 end]
dict set attrs -$name $val
if {$name eq "version"} {
set version $val
dict unset attrs -version
}
} else {
if {[dict size $attrs] != 0} {
# we have the full dict for previous cookie,
# save it uniquely in cdict
dict set attrs -version $version
set cname [unique $attrs]
dict set cdict $cname $attrs
set attrs [dict create]
}
# it's a value name, but we can't store it
# until we have -path, -domain
dict set attrs -value $val
dict set attrs -name $name
}
}
# store final cookie's values
if {[dict size $attrs] != 0} {
dict set attrs -version $version
set cname [unique $attrs]
dict set cdict $cname $attrs
}
return $cdict
}
# load cookies from a client's request
proc load_client_cookies {req} {
if {[dict exists $rsp cookie]} {
dict set req -cookies [parse4server [dict get $req cookie]]
}
return $req
}
# construct a unique name for cookie storage
# cookies are distinguished by -name, -domain and -path qualifiers
proc unique {cookie} {
Debug.cookies {unique: $cookie} 10
if {![dict exists $cookie -domain]} {
dict set cookie -domain ""
}
if {![dict exists $cookie -path]} {
dict set cookie -path ""
}
return [list [dict get $cookie -domain] [dict get $cookie -path] [dict get $cookie -name]]
}
# return a list of unique cookie names within cookies dict
# which match the template given in $args
proc match {cookies args} {
if {[llength $args] eq 1} {
set args [lindex $args 0]
}
foreach v {name path domain} {
if {[dict exists $args -$v]} {
set $v [dict get $args -$v]
} else {
set $v "*"
}
}
set matches [dict keys $cookies [list $domain $path $name]]
Debug.cookies {match ($cookies) $args -> $matches}
return $matches
}
# clear all cookies in cookie dict which match the template in args
# note: the cookies are modified to a state intended to cause a client
# to drop the cookie from their local cookie jar. YMMV.
proc clear {cookies args} {
Debug.cookies {Cookie clear ($cookies) $args}
if {[llength $args] eq 1} {
set args [lindex $args 0]
}
dict for n [match $cookies $args] {
Debug.cookies {Cookie clear $n}
dict set cookies $n -value ""
dict set cookies $n -max-age 0
dict set cookies $n -changed 1
}
return $cookies
}
# add a cookie to the cookie dict.
# Cookie must be unique (by -name, -domain, -path)
proc add {cookies args} {
Debug.cookies {Cookie add ($cookies) $args}
if {[llength $args] eq 1} {
set args [lindex $args 0]
}
set cn [unique $args]
if {[dict exists $cookies $cn]} {
error "Duplicate cookie $args"
}
if {0 && ![string is alnum -strict [dict get $args -name]]} {
# not strictly true - can include _
error "name must be alphanumeric, '[dict get $args -name]'"
}
foreach {attr val} $args {
dict set cookies $cn [string tolower $attr] $val
}
dict set cookies $cn -changed 1
return $cookies
}
# remove cookies from the cookie dict.
proc remove {cookies args} {
Debug.cookies {Cookie remove ($cookies) $args}
if {[llength $args] eq 1} {
set args [lindex $args 0]
}
foreach n [match $cookies $args] {
dict unset cookies $n
}
return $cookies
}
# modify matching cookies in the cookie dict.
proc modify {cookies args} {
Debug.cookies {Cookie modify $cookies $args}
if {[llength $args] eq 1} {
set args [lindex $args 0]
}
# construct a modifier dict, as distinct from a selector dict
# because modify can't change the name elements of a cookie
set mods $args
catch {dict unset mods -name}
catch {dict unset mods -path}
catch {dict unset mods -domain}
foreach cookie [match $cookies $args] {
foreach {attr val} $mods {
dict set cookies $cookie $attr $val
}
dict cookies $cookie -changed 1
}
return $cookies
}
# fetch a single matching cookie's value from the cookie dict.
proc fetch {cookies args} {
Debug.cookies {Cookie fetch $cookies $args}
if {[llength $args] eq 1} {
set args [lindex $args 0]
}
set matches [match $cookies $args]
if {[llength $matches] != 1} {
error "Multiple matches: $matches"
}
return [dict get $cookies [lindex $matches 0]]
}
# fetch all matching cookie's values from the cookie dict.
proc fetchAll {cookies args} {
Debug.cookies {Cookie fetch $cookies $args}
if {[llength $args] eq 1} {
set args [lindex $args 0]
}
set matches
set result {}
foreach n [match $cookies $args] {
lappend result $n [dict get $cookies $n]
}
return $result
}
namespace export -clear *
namespace ensemble create -subcommands {}
}
if {[info exists argv0] && ($argv0 eq [info script])} {
lappend auto_path [file dirname [info script]]
if {[catch {package require Debug}]} {
proc Debug.cookies {args} {
}
} else {
Debug off cookies 10
}
# parsing cookies from a client
foreach sc {
{$Version="1"; Customer="WILE_E_COYOTE"; $Path="/acme"}
{$Version="1"; Customer="WILE_E_COYOTE"; $Path="/acme"; Part_Number="Rocket_Launcher_0001"; $Path="/acme"}
{$Version="1"; Customer="WILE_E_COYOTE"; $Path="/acme"; Part_Number="Rocket_Launcher_0001"; $Path="/acme"; Shipping="FedEx"; $Path="/acme"}
{$Version="1"; Part_Number="Riding_Rocket_0023"; $Path="/acme/ammo"; Part_Number="Rocket_Launcher_0001"; $Path="/acme"}} {
set cd [Cookies parse4server $sc]
puts "$sc -> ($cd) -> [Cookies format4server $cd] + [Cookies format4client $cd]"
}
# parsing cookies from a server
foreach sc {
{Customer="WILE_E_COYOTE"; Version="1"; Path="/acme"}
{Part_Number="Rocket_Launcher_0001"; Version="1"; Path="/acme"}
{Shipping="FedEx"; Version="1"; Path="/acme"}
{Part_Number="Rocket_Launcher_0001"; Version="1"; Path="/acme"}
{Part_Number="Riding_Rocket_0023"; Version="1"; Path="/acme/ammo"}
} {
set cd [Cookies parse4client $sc]
puts "$sc -> ($cd) -> [Cookies format4server $cd] + [Cookies format4client $cd]"
}
# direct access tests - there should be more of these :)
set x [dict create]
foreach sc {
{Customer WILE_E_COYOTE -path /acme}
{Part_Number Rocket_Launcher_0001 -path /acme}
{Shipping FedEx -path /acme}
} {
set attrs [lassign $sc name val]
set x [Cookies add $x -name $name -value $val {*}$attrs]
}
}
# Here's the relevant syntax from rfc2109
# Set-Cookie: has the following syntax
#
# av-pairs = av-pair *(";" av-pair)
# av-pair = attr ["=" value] ; optional value
# attr = token
# value = token | quoted-string
#
# set-cookie = "Set-Cookie:" cookies
# cookies = 1#cookie
# cookie = NAME "=" VALUE *(";" cookie-av)
# NAME = attr
# VALUE = value
# cookie-av = "Comment" "=" value
# | "Domain" "=" value
# | "Max-Age" "=" value
# | "Path" "=" value
# | "Secure"
# | "Version" "=" 1*DIGIT
# Cookie: has the following syntax:
#
# cookie = "Cookie:" cookie-version 1*((";" | ",") cookie-value)
# cookie-value = NAME "=" VALUE [";" path] [";" domain] [";" port]
# cookie-version = "$Version" "=" value
# NAME = attr
# VALUE = value
# path = "$Path" "=" value
# domain = "$Domain" "=" value