# httpPipeline.test
#
# Test HTTP/1.1 concurrent requests including
# queueing, pipelining and retries.
#
# Copyright (C) 2018 Keith Nash <kjnash@users.sourceforge.net>
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
package require http 2.9
set sourcedir [file normalize [file dirname [info script]]]
source [file join $sourcedir httpTest.tcl]
source [file join $sourcedir httpTestScript.tcl]
# ------------------------------------------------------------------------------
# (1) Define the test scripts that will be used to generate logs for analysis -
# and also define the "correct" results.
# ------------------------------------------------------------------------------
proc ReturnTestScriptAndResult {ca cb delay te} {
switch -- $ca {
1 {set start {
START
KEEPALIVE 0
PIPELINE 0
}}
2 {set start {
START
KEEPALIVE 0
PIPELINE 1
}}
3 {set start {
START
KEEPALIVE 1
PIPELINE 0
}}
4 {set start {
START
KEEPALIVE 1
PIPELINE 1
}}
default {
return -code error {no matching script}
}
}
set middle "
[list DELAY $delay]
"
switch -- $cb {
1 {set end {
GET a
GET b
GET c
GET a
STOP
}
set resShort {1 ? ? ?}
set resLong {1 2 3 4}
}
2 {set end {
GET a
HEAD b
GET c
HEAD a
HEAD c
STOP
}
set resShort {1 ? ? ? ?}
set resLong {1 2 3 4 5}
}
3 {set end {
HEAD a
GET b
HEAD c
HEAD b
GET a
GET b
STOP
}
set resShort {1 ? ? ? ? ?}
set resLong {1 2 3 4 5 6}
}
4 {set end {
GET a
GET b
GET c
GET a
POST b address=home code=brief paid=yes
GET c
GET a
GET b
GET c
STOP
}
set resShort {1 ? ? ? 5 ? ? ? ?}
set resLong {1 2 3 4 5 6 7 8 9}
}
5 {set end {
POST a address=home code=brief paid=yes
POST b address=home code=brief paid=yes
POST c address=home code=brief paid=yes
POST a address=home code=brief paid=yes
POST b address=home code=brief paid=yes
POST c address=home code=brief paid=yes
POST a address=home code=brief paid=yes
POST b address=home code=brief paid=yes
POST c address=home code=brief paid=yes
STOP
}
set resShort {1 2 3 4 5 6 7 8 9}
set resLong {1 2 3 4 5 6 7 8 9}
}
6 {set end {
POST a address=home code=brief paid=yes
GET b address=home code=brief paid=yes
POST c address=home code=brief paid=yes
GET a address=home code=brief paid=yes
GET b address=home code=brief paid=yes
POST c address=home code=brief paid=yes
POST a address=home code=brief paid=yes
HEAD b address=home code=brief paid=yes
GET c address=home code=brief paid=yes
STOP
}
set resShort {1 ? 3 ? ? 6 7 ? ?}
set resLong {1 2 3 4 5 6 7 8 9}
}
7 {set end {
GET b address=home code=brief paid=yes
POST a address=home code=brief paid=yes
GET a address=home code=brief paid=yes
POST c address=home code=brief paid=yes
GET b address=home code=brief paid=yes
HEAD b address=home code=brief paid=yes
POST c address=home code=brief paid=yes
POST a address=home code=brief paid=yes
GET c address=home code=brief paid=yes
STOP
}
set resShort {1 2 ? 4 ? ? 7 8 ?}
set resLong {1 2 3 4 5 6 7 8 9}
}
8 {set end {
# Telling the server to close the connection.
GET a
GET b close=y
GET c
GET a
GET b
GET c
GET a
GET b
GET c
STOP
}
set resShort {1 ? 3 ? ? ? ? ? ?}
set resLong {1 2 3 4 5 6 7 8 9}
}
9 {set end {
# Telling the server to close the connection.
GET a
POST b close=y address=home code=brief paid=yes
GET c
GET a
GET b
GET c
GET a
GET b
GET c
STOP
}
set resShort {1 2 3 ? ? ? ? ? ?}
set resLong {1 2 3 4 5 6 7 8 9}
}
10 {set end {
# Telling the server to close the connection.
GET a
GET b close=y
POST c address=home code=brief paid=yes
GET a
GET b
GET c
GET a
GET b
GET c
STOP
}
set resShort {1 ? 3 ? ? ? ? ? ?}
set resLong {1 2 3 4 5 6 7 8 9}
}
11 {set end {
# Telling the server to close the connection twice.
GET a
GET b close=y
GET c
GET a
GET b close=y
GET c
GET a
GET b
GET c
STOP
}
set resShort {1 ? 3 ? ? 6 ? ? ?}
set resLong {1 2 3 4 5 6 7 8 9}
}
12 {set end {
# Telling the server to delay before sending the response.
GET a
GET b delay=1
GET c
GET a
GET b
STOP
}
set resShort {1 ? ? ? ?}
set resLong {1 2 3 4 5}
}
13 {set end {
# Making the server close the connection (time out).
GET a
WAIT 2000
GET b
GET c
GET a
GET b
STOP
}
set resShort {1 2 ? ? ?}
set resLong {1 2 3 4 5}
}
14 {set end {
# Making the server close the connection (time out) twice.
GET a
WAIT 2000
GET b
GET c
GET a
WAIT 2000
GET b
GET c
GET a
GET b
GET c
STOP
}
set resShort {1 2 ? ? 5 ? ? ? ?}
set resLong {1 2 3 4 5 6 7 8 9}
}
15 {set end {
POST a address=home code=brief paid=yes
POST b address=home code=brief paid=yes close=y delay=1
POST c address=home code=brief paid=yes delay=1
POST a address=home code=brief paid=yes close=y
WAIT 2000
POST b address=home code=brief paid=yes delay=1
POST c address=home code=brief paid=yes close=y
POST a address=home code=brief paid=yes
POST b address=home code=brief paid=yes close=y
POST c address=home code=brief paid=yes
STOP
}
set resShort {1 2 3 4 5 6 7 8 9}
set resLong {1 2 3 4 5 6 7 8 9}
}
16 {set end {
POST a address=home code=brief paid=yes
GET b address=home code=brief paid=yes
POST c address=home code=brief paid=yes close=y
GET a address=home code=brief paid=yes
GET b address=home code=brief paid=yes close=y
POST c address=home code=brief paid=yes
WAIT 2000
POST a address=home code=brief paid=yes
HEAD b address=home code=brief paid=yes close=y
GET c address=home code=brief paid=yes
STOP
}
set resShort {1 ? 3 4 ? 6 7 ? 9}
set resLong {1 2 3 4 5 6 7 8 9}
}
17 {set end {
GET b address=home code=brief paid=yes
POST a address=home code=brief paid=yes
GET a address=home code=brief paid=yes
POST c address=home code=brief paid=yes close=y
GET b address=home code=brief paid=yes
HEAD b address=home code=brief paid=yes close=y
POST c address=home code=brief paid=yes
WAIT 2000
POST a address=home code=brief paid=yes
WAIT 2000
GET c address=home code=brief paid=yes
STOP
}
set resShort {1 2 3 4 5 ? 7 8 9}
set resLong {1 2 3 4 5 6 7 8 9}
}
18 {set end {
REPOST 0
GET a
WAIT 2000
POST b address=home code=brief paid=yes
GET c
GET a
STOP
}
set resShort {1 2 ? ?}
set resLong {1 2 3 4}
# resShort is overwritten below for the case ($te == 1).
}
19 {set end {
REPOST 0
GET a
WAIT 2000
GET b address=home code=brief paid=yes
GET c
GET a
STOP
}
set resShort {1 2 ? ?}
set resLong {1 2 3 4}
}
20 {set end {
POSTFRESH 1
GET a
WAIT 2000
POST b address=home code=brief paid=yes
GET c
GET a
STOP
}
set resShort {1 3 ?}
set resLong {1 3 4}
}
21 {set end {
POSTFRESH 1
GET a
WAIT 2000
GET b address=home code=brief paid=yes
GET c
GET a
STOP
}
set resShort {1 2 ? ?}
set resLong {1 2 3 4}
}
22 {set end {
GET a
WAIT 2000
KEEPALIVE 0
POST b address=home code=brief paid=yes
KEEPALIVE 1
GET c
GET a
STOP
}
set resShort {1 3 ?}
set resLong {1 3 4}
}
23 {set end {
GET a
WAIT 2000
KEEPALIVE 0
GET b address=home code=brief paid=yes
KEEPALIVE 1
GET c
GET a
STOP
}
set resShort {1 3 ?}
set resLong {1 3 4}
}
24 {set end {
GET a
KEEPALIVE 0
POST b address=home code=brief paid=yes
KEEPALIVE 1
GET c
GET a
STOP
}
set resShort {1 ? ?}
set resLong {1 3 4}
}
25 {set end {
GET a
KEEPALIVE 0
GET b address=home code=brief paid=yes
KEEPALIVE 1
GET c
GET a
STOP
}
set resShort {1 ? ?}
set resLong {1 3 4}
}
default {
return -code error {no matching script}
}
}
if {$ca < 3} {
# Not Keep-Alive.
set result "Passed all sanity checks."
} elseif {$ca == 3} {
# Keep-Alive, not pipelined.
set result {}
append result "Passed all sanity checks.\n"
append result "Have overlaps including response body:\n"
} else {
# Keep-Alive, pipelined: ($ca == 4)
set result {}
append result "Passed all sanity checks.\n"
append result "Overlap-free without response body:\n"
append result "$resShort"
}
# - The special case of test *.18*-testEof needs test results to be
# individually written.
# - These test -repost 0 when there is a POST to apply it to, and the server
# timeout has not been detected.
if {($cb == 18) && ($te == 1)} {
if {$ca < 3} {
# Not Keep-Alive.
set result "Passed all sanity checks."
} elseif {$ca == 3 && $delay == 0} {
# Keep-Alive, not pipelined.
set result [MakeMessage {
|Problems with sanity checks:
|Wrong sequence for token ::http::2 - {A B C D X X X}
|- and error(s) X
|Wrong sequence for token ::http::3 - {A X X}
|- and error(s) X
|Wrong sequence for token ::http::4 - {A X X X}
|- and error(s) X
|
|Have overlaps including response body:
|
}]
} elseif {$ca == 3} {
# Keep-Alive, not pipelined.
set result [MakeMessage {
|Problems with sanity checks:
|Wrong sequence for token ::http::2 - {A B C D X X X}
|- and error(s) X
|
|Have overlaps including response body:
|
}]
} elseif {$delay == 0} {
# Keep-Alive, pipelined: ($ca == 4)
set result [MakeMessage {
|Problems with sanity checks:
|Wrong sequence for token ::http::2 - {A B C D X X X}
|- and error(s) X
|Wrong sequence for token ::http::3 - {A X X}
|- and error(s) X
|Wrong sequence for token ::http::4 - {A X X X}
|- and error(s) X
|
|Overlap-free without response body:
|
}]
} else {
set result [MakeMessage {
|Problems with sanity checks:
|Wrong sequence for token ::http::2 - {A B C D X X X}
|- and error(s) X
|
|Overlap-free without response body:
|
}]
}
}
return [list "$start$middle$end" $result]
}
# ------------------------------------------------------------------------------
# Proc MakeMessage
# ------------------------------------------------------------------------------
# WHD's one-line command to generate multi-line strings from readable code.
#
# Example:
# set blurb [MakeMessage {
# |This command allows multi-line strings to be created with readable
# |code, and without breaking the rules for indentation.
# |
# |The command shifts the entire block of text to the left, omitting
# |the pipe character and the spaces to its left.
# }]
# ------------------------------------------------------------------------------
proc MakeMessage {in} {
regsub -all -line {^\s*\|} [string trim $in] {}
# N.B. Implicit Return.
}
proc ReturnTestScript {ca cb delay te} {
lassign [ReturnTestScriptAndResult $ca $cb $delay $te] script result
return $script
}
proc ReturnTestResult {ca cb delay te} {
lassign [ReturnTestScriptAndResult $ca $cb $delay $te] script result
return $result
}
# ------------------------------------------------------------------------------
# (2) Command to run a test script and use httpTest to analyse the logs.
# ------------------------------------------------------------------------------
namespace import httpTestScript::runHttpTestScript
namespace import httpTestScript::cleanupHttpTestScript
namespace import httpTest::cleanupHttpTest
namespace import httpTest::logAnalyse
namespace import httpTest::setHttpTestOptions
proc RunTest {header footer delay te} {
set num [runHttpTestScript [ReturnTestScript $header $footer $delay $te]]
set skipOverlaps 0
set notPiped {}
set notIncluded {}
# --------------------------------------------------------------------------
# Custom code for specific tests
# --------------------------------------------------------------------------
if {$header < 3} {
set skipOverlaps 1
for {set i 1} {$i <= $num} {incr i} {
lappend notPiped $i
}
} elseif {$header > 2 && $footer == 18 && $te == 1} {
set skipOverlaps 1
if {$delay == 0} {
# Transaction 1 is conventional.
# Check that transactions 2,3,4 are cancelled.
set notPiped {1}
set notIncluded $notPiped
} else {
# Transaction 1 is conventional.
# Check that transaction 2 is cancelled.
# The timing of transactions 3 and 4 is uncertain.
set notPiped {1 3 4}
set notIncluded $notPiped
}
} elseif {$footer in {20 22 23 24 25}} {
# Transaction 2 uses its own socket.
set notPiped 2
set notIncluded $notPiped
} else {
}
# --------------------------------------------------------------------------
# End of custom code for specific tests
# --------------------------------------------------------------------------
set Results [logAnalyse $num $skipOverlaps $notIncluded $notPiped]
lassign $Results msg cleanE cleanF dirtyE dirtyF
if {$msg eq {}} {
set msg "Passed all sanity checks."
} else {
set msg "Problems with sanity checks:\n$msg"
}
if 0 {
puts $msg
puts "Overlap-free including response body:\n$cleanF"
puts "Have overlaps including response body:\n$dirtyF"
puts "Overlap-free without response body:\n$cleanE"
puts "Have overlaps without response body:\n$dirtyE"
}
if {$header < 3} {
# No ordering, just check that transactions all finish
set result $msg
} elseif {$header == 3} {
# Not pipelined - check overlaps with response body.
set result "$msg\nHave overlaps including response body:\n$dirtyF"
} else {
# Pipelined - check overlaps without response body. Check that the
# first request, the first requests after replay, and POSTs are clean.
set result "$msg\nOverlap-free without response body:\n$cleanE"
}
set ::nTokens $num
return $result
}
# ------------------------------------------------------------------------------
# (3) VERBOSITY CONTROL
# ------------------------------------------------------------------------------
# If tests fail, run an individual test with -verbose 1 or 2 for diagnosis.
# If still obscure, uncomment #Log and ##Log lines in the http package.
# ------------------------------------------------------------------------------
setHttpTestOptions -verbose 0
# ------------------------------------------------------------------------------
# (4) Define the base URLs used for testing. Each must have a query string.
# ------------------------------------------------------------------------------
# - A HTTP/1.1 server is required. It should be configured to provide
# persistent connections when requested to do so, and to close these
# connections if they are idle for one second.
# - The resource must be served with status 200 in response to a valid GET or
# POST.
# - The value of "page" is always specified in the query-string. Different
# resources for the three values of "page" allow testing of both chunked and
# unchunked transfer encoding.
# - The variables "close" and "delay" may be specified in the query-string (for
# a GET) or the request body (for a POST).
# - "delay" is a numerical value in seconds, and causes the server to delay
# the response, including headers.
# - "close", if it has the value "y", instructs the server to close the
# connection ater the current request.
# - Any other variables should be ignored.
# ------------------------------------------------------------------------------
namespace eval ::httpTestScript {
variable URL
array set URL {
a http://test-tcl-http.kerlin.org/index.html?page=privacy
b http://test-tcl-http.kerlin.org/index.html?page=conditions
c http://test-tcl-http.kerlin.org/index.html?page=welcome
}
}
# ------------------------------------------------------------------------------
# (5) Define the tests
# ------------------------------------------------------------------------------
# Constraints:
# - serverNeeded - the URLs defined at (4) must be available, and must have the
# properties specified there.
# - duplicate - the value of -pipeline does not matter if -keepalive 0
# - timeout1s - tests that work correctly only if the server closes
# persistent connections after one second.
#
# Server timeout of persistent connections should be 1s. Delays of 2s are
# intended to cause timeout.
# Servers are usually configured to use a longer timeout: this will cause the
# tests to fail. The "2000" could be replaced with a larger number, but the
# tests will then be inconveniently slow.
# ------------------------------------------------------------------------------
#testConstraint serverNeeded 1
#testConstraint timeout1s 1
#testConstraint duplicate 1
# ------------------------------------------------------------------------------
# Proc SetTestEof - to edit the command ::http::KeepSocket
# ------------------------------------------------------------------------------
# The usual line in command ::http::KeepSocket is " set TEST_EOF 0".
# Whether the value set in the file is 0 or 1, change it here to the value
# specified by the argument.
#
# It is worth doing all tests for both values of the argument.
#
# test 0 - ::http::KeepSocket is unchanged, detects server eof where possible
# and closes the connection.
# test 1 - ::http::KeepSocket is edited, does not detect server eof, so the
# reaction to finding server eof can be tested without the difficulty
# of testing in the few milliseconds of an asynchronous close event.
# ------------------------------------------------------------------------------
proc SetTestEof {test} {
set body [info body ::http::KeepSocket]
set subs " set TEST_EOF $test"
set count [regsub -line -all -- {^\s*set TEST_EOF .*$} $body $subs newBody]
if {$count != 1} {
return -code error {proc ::http::KeepSocket has unexpected form}
}
proc ::http::KeepSocket {token} $newBody
return
}
for {set header 1} {$header <= 4} {incr header} {
if {$header == 4} {
setHttpTestOptions -dotted 1
set match glob
} else {
setHttpTestOptions -dotted 0
set match exact
}
if {$header == 2} {
set cons0 {serverNeeded duplicate}
} else {
set cons0 serverNeeded
}
for {set footer 1} {$footer <= 25} {incr footer} {
foreach {delay label} {
0 a
1 b
2 c
3 d
5 e
8 f
12 g
100 h
500 i
2000 j
} {
foreach te {0 1} {
if {$te} {
set tag testEof
} else {
set tag normal
}
set suffix {}
set cons $cons0
# ------------------------------------------------------------------
# Custom code for individual tests
# ------------------------------------------------------------------
if {$footer in {18}} {
# Custom code:
if {($label eq "j") && ($te == 1)} {
continue
}
if {$te == 1} {
# The test (of REPOST 0) is useful if tag is "testEof"
# (server timeout without client reaction). The same test
# has a different result if tag is "normal".
set suffix " - extra test for -repost 0 - ::http::2 must be"
append suffix " cancelled"
if {($delay == 0)} {
append suffix ", along with ::http::3 ::http::4 if"
append suffix " the test creates these before ::http::2"
append suffix " is cancelled"
}
} else {
}
} elseif {$footer in {19}} {
set suffix " - extra test for -repost 0"
} elseif {$footer in {20 21}} {
set suffix " - extra test for -postfresh 1"
if {($footer == 20)} {
append suffix " - ::http::2 uses a separate socket"
append suffix ", other requests use a persistent connection"
}
} elseif {$footer in {22 23 24 25}} {
append suffix " - ::http::2 uses a separate socket"
append suffix ", other requests use a persistent connection"
} else {
}
if {($footer >= 13 && $footer <= 23)} {
# Test use WAIT and depend on server timeout before this time.
lappend cons timeout1s
}
# ------------------------------------------------------------------
# End of custom code.
# ------------------------------------------------------------------
set name "pipeline test header $header footer $footer delay $delay $tag$suffix"
# Here's the test:
test httpPipeline-${header}.${footer}${label}-${tag} $name \
-constraints $cons \
-setup [string map [list TE $te] {
# Restore default values for tests:
http::config -pipeline 1 -postfresh 0 -repost 1
http::init
set http::http(uid) 0
SetTestEof {TE}
}] -body [list RunTest $header $footer $delay $te] -cleanup {
# Restore default values for tests:
http::config -pipeline 1 -postfresh 0 -repost 1
cleanupHttpTestScript
SetTestEof 0
cleanupHttpTest
after 2000
# Wait for persistent sockets on the server to time out.
} -result [ReturnTestResult $header $footer $delay $te] -match $match
}
}
}
}
# ------------------------------------------------------------------------------
# (*) Notes on tests *.18*-testEof, *.19*-testEof - these test -repost 0
# ------------------------------------------------------------------------------
# These tests are a bit awkward because the main test kit analyses whether all
# requests are satisfied, with retries if necessary, and it has result analysis
# for processing retry logs.
# - *.18*-testEof tests that certain requests are NOT satisfied, so the analysis
# is a one-off.
# - Tests *.18a-testEof depend on client/server timing - the test needs to call
# http::geturl for all requests before the POST (request 2) is cancelled.
# We test that requests 2, 3, 4 are all cancelled.
# - Other tests *.18*-testEof may not request 3 and 4 in time for the to be
# added to the write queue before request 2 is completed. We simply check that
# request 2 is cancelled.
# - The behaviour is different if all connections are allowed to time out
# (label "j"). This case is not needed to test -repost 0, and is omitted.
# - Tests *.18*-normal and *.19* are conventional (-repost 0 should have no
# effect).
# ------------------------------------------------------------------------------
unset header footer delay label suffix match cons name te
namespace delete ::httpTest
namespace delete ::httpTestScript
::tcltest::cleanupTests