From 8f01cae77772fba79527bfe03afb0f3ae91a9a6c Mon Sep 17 00:00:00 2001 From: Christoffer Kugg Jerkeby Date: Tue, 13 Nov 2018 14:33:16 +0100 Subject: [PATCH 1/3] Added rudimentary cookie support to HTTP::. --- src/irulehttp.tcl | 144 +++++++++++++++++++++++++++++++++++++++++++--- 1 file changed, 137 insertions(+), 7 deletions(-) diff --git a/src/irulehttp.tcl b/src/irulehttp.tcl index f926357..2abb5a9 100644 --- a/src/irulehttp.tcl +++ b/src/irulehttp.tcl @@ -1,4 +1,4 @@ -package provide testcl 1.0.13 +package provide testcl 1.0.12 package require log package require base64 @@ -45,7 +45,7 @@ namespace eval ::testcl::HTTP { } -# testcl::HTTP::cookie -- !!! TODO !!! +# testcl::HTTP::cookie -- # # stub for the iRule HTTP::cookie - Queries for or manipulates cookies in HTTP requests and responses # @@ -80,10 +80,10 @@ namespace eval ::testcl::HTTP { # HTTP::cookie httponly [enable|disable] # HTTP::cookie sanitize <-attributes|-names> # -proc ::testcl::HTTP::cookie {args} { - log::log debug "HTTP::cookie $args invoked" +proc ::testcl::HTTP::cookie {cmd args} { + log::log debug "HTTP::cookie $cmd $args invoked" - set cmdargs [concat HTTP::cookie $args] + set cmdargs [concat HTTP::cookie $cmd $args] #set rc [catch { return [testcl::expected {*}$cmdargs] } res] set rc [catch { return [eval testcl::expected $cmdargs] } res] if {$rc != 1500} { @@ -93,8 +93,138 @@ proc ::testcl::HTTP::cookie {args} { } return -code $rc $res } - error "HTTP::cookie command is not implemented - use on HTTP::cookie..." - TODO !important: should reuse headers + + variable headers + if { ![array exists headers] } { + array set headers {} + } + + set name [string tolower [lindex $args 0]] + + switch $cmd { + value { + # HTTP::cookie [value] + if { ![info exists headers($name)] } { + log::log debug "there is no value for cookie: $name" + return {} + } + set v [lindex $headers($name) end] + log::log debug "cookie '$name' last value is: $v" + return $v + } + values { + # HTTP::cookie values + if { ![info exists headers($name)] } { + log::log debug "there is no value for cookie: $name" + return {} + } + log::log debug "cookie '$name' values are: $headers($name)" + return $headers($name) + } + names { + # HTTP::cookie names + set res {} + foreach l [array names headers] { + lappend res [lrepeat [llength $headers($l)] $l] + } + log::log debug "cookie names: $res" + return $res + } + count { + # HTTP::cookie count + if { $name eq "" } { + #return number of all cookies + set res 0 + foreach l [array names headers] { + incr res [llength $headers($l)] + } + log::log debug "number of all cookies: $res" + return $res + } + if { ![info exists headers($name)] } { + log::log debug "number of cookies with name '$name': 0" + return 0 + } + set cnt [llength $headers($name)] + log::log debug "number of cookies with name '$name': $cnt" + return $cnt + } + exists { + # HTTP::cookie exists + set res [info exists headers($name)] + log::log debug "cookie '$name' exists: $res" + return $res + } + insert { + # HTTP::cookie insert [ ]+ + variable sent + if { [info exists sent] } { + error "response to client was already sent - HTTP::cookie insert call not allowed (sent: $sent)" + } + foreach {n v} $args { + set n [string tolower $n] + log::log debug "appending cookie '$n' value: $v" + lappend headers($n) $v + } + } + replace { + # HTTP::cookie replace [] + variable sent + if { [info exists sent] } { + error "response to client was already sent - HTTP::cookie replace call not allowed" + } + set v [lindex $args 1] + if { [info exists headers($name)] } { + log::log debug "replace cookie '$name' with value: $v" + set headers($name) [lreplace $headers($name)[set headers($name) {}] end end $v] + } else { + log::log debug "append cookie '$name' with value: $v" + lappend headers($name) $v + } + } + remove { + # HTTP::cookie remove + variable sent + if { [info exists sent] } { + error "response to client was already sent - HTTP::cookie remove call not allowed" + } + if { $name eq "" } { + array unset headers + variable lws + set lws 0 + log::log debug "all cookies removed" + } else { + array unset headers $name + log::log debug "removed cookie '$name'" + } + } + version { error "HTTP:cookie $cmd call is not yet implemented." } + path { error "HTTP:cookie $cmd call is not yet implemented." } + domain { error "HTTP:cookie $cmd call is not yet implemented." } + ports { error "HTTP:cookie $cmd call is not yet implemented." } + maxage { error "HTTP:cookie $cmd call is not yet implemented." } + expires { error "HTTP:cookie $cmd call is not yet implemented." } + comment { error "HTTP:cookie $cmd call is not yet implemented." } + secure { error "HTTP:cookie $cmd call is not yet implemented." } + commenturl { error "HTTP:cookie $cmd call is not yet implemented." } + encrypt { error "HTTP:cookie $cmd call is not yet implemented." } + decrypt { error "HTTP:cookie $cmd call is not yet implemented." } + httponly { error "HTTP:cookie $cmd call is not yet implemented." } + sanitize { error "HTTP:cookie $cmd call is not yet implemented." } + default { + # HTTP::cookie [value] + #without command name + set name [string tolower $cmd] + if { ![info exists headers($name)] } { + log::log debug "there is no value for cookie: $name" + return {} + } + set v [lindex $headers($name) end] + log::log debug "cookie '$name' last value is: $v" + return $v + } + } + return {} } From 08c83eff4706890489788731b1abd87bd9255ba9 Mon Sep 17 00:00:00 2001 From: Christoffer Kugg Jerkeby Date: Tue, 13 Nov 2018 14:33:16 +0100 Subject: [PATCH 2/3] Added rudimentary cookie support to HTTP::. --- src/irulehttp.tcl | 142 ++++++++++++++++++++++++++++++++++++++++++++-- 1 file changed, 136 insertions(+), 6 deletions(-) diff --git a/src/irulehttp.tcl b/src/irulehttp.tcl index f926357..f18f04f 100644 --- a/src/irulehttp.tcl +++ b/src/irulehttp.tcl @@ -45,7 +45,7 @@ namespace eval ::testcl::HTTP { } -# testcl::HTTP::cookie -- !!! TODO !!! +# testcl::HTTP::cookie -- # # stub for the iRule HTTP::cookie - Queries for or manipulates cookies in HTTP requests and responses # @@ -80,10 +80,10 @@ namespace eval ::testcl::HTTP { # HTTP::cookie httponly [enable|disable] # HTTP::cookie sanitize <-attributes|-names> # -proc ::testcl::HTTP::cookie {args} { - log::log debug "HTTP::cookie $args invoked" +proc ::testcl::HTTP::cookie {cmd args} { + log::log debug "HTTP::cookie $cmd $args invoked" - set cmdargs [concat HTTP::cookie $args] + set cmdargs [concat HTTP::cookie $cmd $args] #set rc [catch { return [testcl::expected {*}$cmdargs] } res] set rc [catch { return [eval testcl::expected $cmdargs] } res] if {$rc != 1500} { @@ -93,8 +93,138 @@ proc ::testcl::HTTP::cookie {args} { } return -code $rc $res } - error "HTTP::cookie command is not implemented - use on HTTP::cookie..." - TODO !important: should reuse headers + + variable headers + if { ![array exists headers] } { + array set headers {} + } + + set name [string tolower [lindex $args 0]] + + switch $cmd { + value { + # HTTP::cookie [value] + if { ![info exists headers($name)] } { + log::log debug "there is no value for cookie: $name" + return {} + } + set v [lindex $headers($name) end] + log::log debug "cookie '$name' last value is: $v" + return $v + } + values { + # HTTP::cookie values + if { ![info exists headers($name)] } { + log::log debug "there is no value for cookie: $name" + return {} + } + log::log debug "cookie '$name' values are: $headers($name)" + return $headers($name) + } + names { + # HTTP::cookie names + set res {} + foreach l [array names headers] { + lappend res [lrepeat [llength $headers($l)] $l] + } + log::log debug "cookie names: $res" + return $res + } + count { + # HTTP::cookie count + if { $name eq "" } { + #return number of all cookies + set res 0 + foreach l [array names headers] { + incr res [llength $headers($l)] + } + log::log debug "number of all cookies: $res" + return $res + } + if { ![info exists headers($name)] } { + log::log debug "number of cookies with name '$name': 0" + return 0 + } + set cnt [llength $headers($name)] + log::log debug "number of cookies with name '$name': $cnt" + return $cnt + } + exists { + # HTTP::cookie exists + set res [info exists headers($name)] + log::log debug "cookie '$name' exists: $res" + return $res + } + insert { + # HTTP::cookie insert [ ]+ + variable sent + if { [info exists sent] } { + error "response to client was already sent - HTTP::cookie insert call not allowed (sent: $sent)" + } + foreach {n v} $args { + set n [string tolower $n] + log::log debug "appending cookie '$n' value: $v" + lappend headers($n) $v + } + } + replace { + # HTTP::cookie replace [] + variable sent + if { [info exists sent] } { + error "response to client was already sent - HTTP::cookie replace call not allowed" + } + set v [lindex $args 1] + if { [info exists headers($name)] } { + log::log debug "replace cookie '$name' with value: $v" + set headers($name) [lreplace $headers($name)[set headers($name) {}] end end $v] + } else { + log::log debug "append cookie '$name' with value: $v" + lappend headers($name) $v + } + } + remove { + # HTTP::cookie remove + variable sent + if { [info exists sent] } { + error "response to client was already sent - HTTP::cookie remove call not allowed" + } + if { $name eq "" } { + array unset headers + variable lws + set lws 0 + log::log debug "all cookies removed" + } else { + array unset headers $name + log::log debug "removed cookie '$name'" + } + } + version { error "HTTP:cookie $cmd call is not yet implemented." } + path { error "HTTP:cookie $cmd call is not yet implemented." } + domain { error "HTTP:cookie $cmd call is not yet implemented." } + ports { error "HTTP:cookie $cmd call is not yet implemented." } + maxage { error "HTTP:cookie $cmd call is not yet implemented." } + expires { error "HTTP:cookie $cmd call is not yet implemented." } + comment { error "HTTP:cookie $cmd call is not yet implemented." } + secure { error "HTTP:cookie $cmd call is not yet implemented." } + commenturl { error "HTTP:cookie $cmd call is not yet implemented." } + encrypt { error "HTTP:cookie $cmd call is not yet implemented." } + decrypt { error "HTTP:cookie $cmd call is not yet implemented." } + httponly { error "HTTP:cookie $cmd call is not yet implemented." } + sanitize { error "HTTP:cookie $cmd call is not yet implemented." } + default { + # HTTP::cookie [value] + #without command name + set name [string tolower $cmd] + if { ![info exists headers($name)] } { + log::log debug "there is no value for cookie: $name" + return {} + } + set v [lindex $headers($name) end] + log::log debug "cookie '$name' last value is: $v" + return $v + } + } + return {} } From 1098ea698bf0142a70b3f28cd07e20b4ef7bc025 Mon Sep 17 00:00:00 2001 From: Christoffer Kugg Jerkeby Date: Mon, 19 Nov 2018 21:38:11 +0100 Subject: [PATCH 3/3] Updated HTTP::cookie to adhere to documentation. Added testcase and irule file. --- irules/cookie_irule.tcl | 16 +++ src/irulehttp.tcl | 209 ++++++++++++++++++++++++++-------------- test/test_cookie.tcl | 56 +++++++++++ 3 files changed, 208 insertions(+), 73 deletions(-) create mode 100644 irules/cookie_irule.tcl create mode 100644 test/test_cookie.tcl diff --git a/irules/cookie_irule.tcl b/irules/cookie_irule.tcl new file mode 100644 index 0000000..d080df6 --- /dev/null +++ b/irules/cookie_irule.tcl @@ -0,0 +1,16 @@ +rule cookie { + when HTTP_REQUEST { + set c [HTTP::cookie "testcookie"] + switch -- c { + pos { + pool pos + } + named { + pool named + } + directive { + pool directive + } + } + } +} diff --git a/src/irulehttp.tcl b/src/irulehttp.tcl index f18f04f..df801db 100644 --- a/src/irulehttp.tcl +++ b/src/irulehttp.tcl @@ -41,7 +41,7 @@ namespace eval ::testcl::HTTP { namespace export version #DEBUG - #namespace export debug + namespace export debug } @@ -82,7 +82,6 @@ namespace eval ::testcl::HTTP { # proc ::testcl::HTTP::cookie {cmd args} { log::log debug "HTTP::cookie $cmd $args invoked" - set cmdargs [concat HTTP::cookie $cmd $args] #set rc [catch { return [testcl::expected {*}$cmdargs] } res] set rc [catch { return [eval testcl::expected $cmdargs] } res] @@ -93,109 +92,180 @@ proc ::testcl::HTTP::cookie {cmd args} { } return -code $rc $res } + # List of supported attributes. Add new attributes here! + set supported [list name value path domain version] variable headers if { ![array exists headers] } { array set headers {} } + + variable attributes + if { ![array exists attributes] } { + array set attributes {} + } set name [string tolower [lindex $args 0]] - - switch $cmd { + switch -- $cmd { value { # HTTP::cookie [value] - if { ![info exists headers($name)] } { - log::log debug "there is no value for cookie: $name" + # Sets or gets the value of an existing cookie with the given + # name. You can omit the keyword "value" from this command if + # the cookie name does not collide with any of the other + # commands. If the cookie does not exist when retrieving a + # cookie value, a null string will be returned. + if { ![info exists headers(Cookie)] } { + log::log debug "There is no cookie header." return {} } - set v [lindex $headers($name) end] - log::log debug "cookie '$name' last value is: $v" - return $v - } - values { - # HTTP::cookie values - if { ![info exists headers($name)] } { - log::log debug "there is no value for cookie: $name" - return {} + set arg [lindex $args 0] + set cookies [lindex $headers(Cookie)] + foreach cookie $cookies { + if { [catch {array set cookarr [lindex $cookie]} fid] } { + error "A malformed cookie was found! $fid" + continue + } + if { $cookarr(name) eq $arg } { + #error "cookie '$arg' exists." + return $cookarr(value) + } } - log::log debug "cookie '$name' values are: $headers($name)" - return $headers($name) } names { # HTTP::cookie names - set res {} - foreach l [array names headers] { - lappend res [lrepeat [llength $headers($l)] $l] + # Returns a TCL list containing the names of all the cookies + # present in the HTTP headers. + if { ![info exists headers(Cookie)] } { + log::log debug "There is no Cookie header." + return {} } - log::log debug "cookie names: $res" - return $res - } - count { - # HTTP::cookie count - if { $name eq "" } { - #return number of all cookies - set res 0 - foreach l [array names headers] { - incr res [llength $headers($l)] + + set cookies [lindex $headers(Cookie)] + set names {} + foreach cookie $cookies { + if { [catch {array set cookarr [lindex $cookie] } fid] } { + error "A malformed cookie was found! $fid" + continue } - log::log debug "number of all cookies: $res" - return $res + lappend names $cookarr(name) } - if { ![info exists headers($name)] } { - log::log debug "number of cookies with name '$name': 0" - return 0 + return $names + } + count { + # HTTP::cookie count + # Returns the number of cookies present in the HTTP headers. + if { ![info exists headers(Cookie)] } { + log::log debug "There is no Cookie header." + return {} } - set cnt [llength $headers($name)] - log::log debug "number of cookies with name '$name': $cnt" - return $cnt + set cookies [lindex $headers(Cookie)] + set res [llength cookies] + + log::log debug "number of all cookies: $res" + return $res } exists { # HTTP::cookie exists - set res [info exists headers($name)] - log::log debug "cookie '$name' exists: $res" - return $res + # Returns a true value if the cookie exists. + # + # Note: The iRule documentation syntax is HTTP::cookie exist + # But implementation syntax is HTTP::cookie exist + if { ![info exists headers(Cookie)] } { + error "There is no Cookie header." + return false + } + set cookies [lindex $headers(Cookie)] + set arg [lindex $args 0] + + foreach cookie $cookies { + if { [catch { array set cookarr [lindex $cookie] } fid] } { + error "Unable to parse cookie $fid." + continue + } + + if { $cookarr(name) == $arg } { + log::log debug "Cookie '$arg' exists." + return true + } + } + return false } insert { - # HTTP::cookie insert [ ]+ + # HTTP::cookie insert name value [path ] [domain ] [version <0 | 1 | 2>] + # Note: Documentation syntax variation + # HTTP::cookie insert name value [path ] [domain ] [version <0 | 1 | 2>] + # * In an HTTP response, adds an additional Set-Cookie header. + # The default value for the version is 0. If the cookie already + # exists, a second cookie will be inserted (tested in 9.2.4). + # * Within the HTTP_REQUEST event, this command adds an + # additional Cookie header (tested in 10.2.4) which is not RFC + # compliant and is known to cause issues on certain web + # servers. Although the behavior renders the command useless + # within a request, the behavior is not a bug and is by design. + # To correctly insert a cookie in a request, compliant with + # RFC 6265, use HTTP::header to modify the value of the cookie + # header directly. variable sent if { [info exists sent] } { error "response to client was already sent - HTTP::cookie insert call not allowed (sent: $sent)" } - foreach {n v} $args { - set n [string tolower $n] - log::log debug "appending cookie '$n' value: $v" - lappend headers($n) $v + set supported [list name value path domain version] + + if { [llength $args] == 0 } { + return {} } - } - replace { - # HTTP::cookie replace [] - variable sent - if { [info exists sent] } { - error "response to client was already sent - HTTP::cookie replace call not allowed" + + if {[lsearch -exact $args {name}] == -1} { + # Positional arguments will be parsed and named. + set argno 0 + set newargs {} + while {$argno < [llength $args]} { + lappend newargs [lindex $supported $argno] + lappend newargs [lindex $args $argno] + incr argno + } + set args $newargs } - set v [lindex $args 1] - if { [info exists headers($name)] } { - log::log debug "replace cookie '$name' with value: $v" - set headers($name) [lreplace $headers($name)[set headers($name) {}] end end $v] - } else { - log::log debug "append cookie '$name' with value: $v" - lappend headers($name) $v + + if {[expr [llength $args] % 2 ] != 0 } { + error "Odd amount of cookie headers [llength $args]" + # TODO: In this case a name parsing function should + # detect known singleton cookie names (such as httpOnly) + # and assign the value true. } + # If named args are even we should have a perfect array list. + array set cookie [lindex $args] + lappend headers(Cookie) [array get cookie] } remove { # HTTP::cookie remove + # Removes a cookie. variable sent if { [info exists sent] } { error "response to client was already sent - HTTP::cookie remove call not allowed" } + if { ![info exists headers(Cookie)] } { + error "There is no Cookie header." + return + } + + set newcookies {} if { $name eq "" } { - array unset headers - variable lws - set lws 0 + unset $headers(Cookie) log::log debug "all cookies removed" } else { - array unset headers $name - log::log debug "removed cookie '$name'" + set arg [lindex $args 0] + set cookies [lindex $headers(Cookie)] + foreach cookie $cookies { + if { [catch { array set cookarr [lindex $cookie] } fid] } { + log::log debug "Unable to parse cookie, $fid." + } + if { $cookarr(name) != $arg } { + lappend newcookies $cookie + } + } + set headers(Cookie) $newcookies + log::log debug "Removed cookie '$name'" } } version { error "HTTP:cookie $cmd call is not yet implemented." } @@ -213,15 +283,8 @@ proc ::testcl::HTTP::cookie {cmd args} { sanitize { error "HTTP:cookie $cmd call is not yet implemented." } default { # HTTP::cookie [value] - #without command name - set name [string tolower $cmd] - if { ![info exists headers($name)] } { - log::log debug "there is no value for cookie: $name" - return {} - } - set v [lindex $headers($name) end] - log::log debug "cookie '$name' last value is: $v" - return $v + # Without command name. + return [::testcl::HTTP::cookie value $cmd] } } return {} diff --git a/test/test_cookie.tcl b/test/test_cookie.tcl new file mode 100644 index 0000000..a0365a0 --- /dev/null +++ b/test/test_cookie.tcl @@ -0,0 +1,56 @@ +package require -exact testcl 1.0.13 +namespace import ::testcl::* + +before { + event HTTP_REQUEST +} + +it "should store cookie as position arg" { + event HTTP_REQUEST + HTTP::cookie insert "testcookie" "pos" + verify "Cookie is set" "pos" == {HTTP::cookie value "testcookie"} + run irules/cookie_irule.tcl cookie +} + +it "should only contain one cookie" { + event HTTP_REQUEST + verify "There should be one cookie" 1 == {HTTP::cookie count "testcookie"} + HTTP::cookie insert "testcookie" "pos" + run irules/cookie_irule.tcl cookie +} + +it "should have a cookie with the name stored" { + event HTTP_REQUEST + HTTP::cookie insert "testcookie" "pos" + verify "A cookie with the name should exist" {testcookie} == {HTTP::cookie names} + run irules/cookie_irule.tcl cookie +} + +it "should store cookie as named arg" { + event HTTP_REQUEST + HTTP::cookie insert name "testcook" value "named" + verify "The cookie value should be set" "named" == {HTTP::cookie "testcook"} + run irules/cookie_irule.tcl cookie +} + +it "should store cookie directives" { + event HTTP_REQUEST + HTTP::cookie insert name "directive_cookie" value "directive" path "/" domain "example.com" version "1" + verify "The directive cookie should be set" "directive" == {HTTP::cookie value "directive_cookie"} + run irules/cookie_irule.tcl cookie +} + +it "should exist" { + event HTTP_REQUEST + HTTP::cookie insert name "existing" value "existing" + verify "The cookie existing should exist(s)" true == {HTTP::cookie exists "existing"} + run irules/cookie_irule.tcl cookie +} + +it "should delete a cookie" { + event HTTP_REQUEST + HTTP::cookie insert name "remove_me" value "remove_me" + HTTP::cookie remove "remove_me" + verify "The remove_me cookie should be removed" false == {HTTP::cookie exists "remove_me"} + run irules/cookie_irule.tcl cookie +}