506 lines
17 KiB
Tcl
506 lines
17 KiB
Tcl
|
# httpTest.tcl
|
||
|
#
|
||
|
# 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.
|
||
|
|
||
|
# ------------------------------------------------------------------------------
|
||
|
# "Package" httpTest for analysis of Log output of http requests.
|
||
|
# ------------------------------------------------------------------------------
|
||
|
# This is a specialised test kit for examining the presence, ordering, and
|
||
|
# overlap of multiple HTTP transactions over a persistent ("Keep-Alive")
|
||
|
# connection; and also for testing reconnection in accordance with RFC 7230 when
|
||
|
# the connection is lost.
|
||
|
#
|
||
|
# This kit is probably not useful for other purposes. It depends on the
|
||
|
# presence of specific Log commands in the http library, and it interprets the
|
||
|
# logs that these commands create.
|
||
|
# ------------------------------------------------------------------------------
|
||
|
|
||
|
package require http
|
||
|
|
||
|
namespace eval ::http {
|
||
|
variable TestStartTimeInMs [clock milliseconds]
|
||
|
# catch {puts stdout "Start time (zero ms) is $TestStartTimeInMs"}
|
||
|
}
|
||
|
|
||
|
namespace eval ::httpTest {
|
||
|
variable testResults {}
|
||
|
variable testOptions
|
||
|
array set testOptions {
|
||
|
-verbose 0
|
||
|
-dotted 1
|
||
|
}
|
||
|
# -verbose - 0 quiet 1 write to stdout 2 write more
|
||
|
# -dotted - (boolean) use dots for absences in lists of transactions
|
||
|
}
|
||
|
|
||
|
proc httpTest::Puts {txt} {
|
||
|
variable testOptions
|
||
|
if {$testOptions(-verbose) > 0} {
|
||
|
puts stdout $txt
|
||
|
flush stdout
|
||
|
}
|
||
|
return
|
||
|
}
|
||
|
|
||
|
# http::Log
|
||
|
#
|
||
|
# A special-purpose logger used for running tests.
|
||
|
# - Processes Log calls that have "^" in their arguments, and records them in
|
||
|
# variable ::httpTest::testResults.
|
||
|
# - Also writes them to stdout (using Puts) if ($testOptions(-verbose) > 0).
|
||
|
# - Also writes Log calls that do not have "^", if ($testOptions(-verbose) > 1).
|
||
|
|
||
|
proc http::Log {args} {
|
||
|
variable TestStartTimeInMs
|
||
|
set time [expr {[clock milliseconds] - $TestStartTimeInMs}]
|
||
|
set txt [list $time {*}$args]
|
||
|
if {[string first ^ $txt] >= 0} {
|
||
|
::httpTest::LogRecord $txt
|
||
|
::httpTest::Puts $txt
|
||
|
} elseif {$::httpTest::testOptions(-verbose) > 1} {
|
||
|
::httpTest::Puts $txt
|
||
|
}
|
||
|
return
|
||
|
}
|
||
|
|
||
|
|
||
|
# Called by http::Log (the "testing" version) to record logs for later analysis.
|
||
|
|
||
|
proc httpTest::LogRecord {txt} {
|
||
|
variable testResults
|
||
|
|
||
|
set pos [string first ^ $txt]
|
||
|
set len [string length $txt]
|
||
|
if {$pos > $len - 3} {
|
||
|
puts stdout "Logging Error: $txt"
|
||
|
puts stdout "Fix this call to Log in http-*.tm so it has ^ then\
|
||
|
a letter then a numeral."
|
||
|
flush stdout
|
||
|
} elseif {$pos < 0} {
|
||
|
# Called by mistake.
|
||
|
} else {
|
||
|
set letter [string index $txt [incr pos]]
|
||
|
set number [string index $txt [incr pos]]
|
||
|
# Max 9 requests!
|
||
|
lappend testResults [list $letter $number]
|
||
|
}
|
||
|
|
||
|
return
|
||
|
}
|
||
|
|
||
|
|
||
|
# ------------------------------------------------------------------------------
|
||
|
# Commands for analysing the logs recorded when calling http::geturl.
|
||
|
# ------------------------------------------------------------------------------
|
||
|
|
||
|
# httpTest::TestOverlaps --
|
||
|
#
|
||
|
# The main test for correct behaviour of pipelined and sequential
|
||
|
# (non-pipelined) transactions. Other tests should be run first to detect
|
||
|
# any inconsistencies in the data (e.g. absence of the elements that are
|
||
|
# examined here).
|
||
|
#
|
||
|
# Examine the sequence $someResults for each transaction from 1 to $n,
|
||
|
# ignoring any that are listed in $badTrans.
|
||
|
# Determine whether the elements "B" to $term for one transaction overlap
|
||
|
# elements "B" to $term for the previous and following transactions.
|
||
|
#
|
||
|
# Transactions in the list $badTrans are not included in "clean" or
|
||
|
# "dirty", but their possible overlap with other transactions is noted.
|
||
|
# Transactions in the list $notPiped are a subset of $badTrans, and
|
||
|
# their possible overlap with other transactions is NOT noted.
|
||
|
#
|
||
|
# Arguments:
|
||
|
# someResults - list of results, each of the form {letter numeral}
|
||
|
# n - number of HTTP transactions
|
||
|
# term - letter that indicated end of search range. "E" for testing
|
||
|
# overlaps from start of request to end of response headers.
|
||
|
# "F" to extend to the end of the response body.
|
||
|
# msg - the cumulative message from sanity checks. Append to it only
|
||
|
# to report a test failure.
|
||
|
# badTrans - list of transaction numbers not to be assessed as "clean" or
|
||
|
# "dirty"
|
||
|
# notPiped - subset of badTrans. List of transaction numbers that cannot
|
||
|
# taint another transaction by overlapping with it, because it
|
||
|
# used a different socket.
|
||
|
#
|
||
|
# Return value: [list $msg $clean $dirty]
|
||
|
# msg - warning messages: nothing will be appended to argument $msg if there
|
||
|
# is an error with the test.
|
||
|
# clean - list of transactions that have no overlap with other transactions
|
||
|
# dirty - list of transactions that have YES overlap with other transactions
|
||
|
|
||
|
proc httpTest::TestOverlaps {someResults n term msg badTrans notPiped} {
|
||
|
variable testOptions
|
||
|
|
||
|
# Check whether transactions overlap:
|
||
|
set clean {}
|
||
|
set dirty {}
|
||
|
for {set i 1} {$i <= $n} {incr i} {
|
||
|
if {$i in $badTrans} {
|
||
|
continue
|
||
|
}
|
||
|
set myStart [lsearch -exact $someResults [list B $i]]
|
||
|
set myEnd [lsearch -exact $someResults [list $term $i]]
|
||
|
|
||
|
if {($myStart < 0 || $myEnd < 0)} {
|
||
|
set res "Cannot find positions of transaction $i"
|
||
|
append msg $res \n
|
||
|
Puts $res
|
||
|
}
|
||
|
|
||
|
set overlaps {}
|
||
|
for {set j $myStart} {$j <= $myEnd} {incr j} {
|
||
|
lassign [lindex $someResults $j] letter number
|
||
|
if {$number != $i && $letter ne "A" && $number ni $notPiped} {
|
||
|
lappend overlaps $number
|
||
|
}
|
||
|
}
|
||
|
|
||
|
if {[llength $overlaps] == 0} {
|
||
|
set res "Transaction $i has no overlaps"
|
||
|
Puts $res
|
||
|
lappend clean $i
|
||
|
if {$testOptions(-dotted)} {
|
||
|
# N.B. results from different segments are concatenated.
|
||
|
lappend dirty .
|
||
|
} else {
|
||
|
}
|
||
|
} else {
|
||
|
set res "Transaction $i overlaps with [join $overlaps { }]"
|
||
|
Puts $res
|
||
|
lappend dirty $i
|
||
|
if {$testOptions(-dotted)} {
|
||
|
# N.B. results from different segments are concatenated.
|
||
|
lappend clean .
|
||
|
} else {
|
||
|
}
|
||
|
}
|
||
|
}
|
||
|
return [list $msg $clean $dirty]
|
||
|
}
|
||
|
|
||
|
# httpTest::PipelineNext --
|
||
|
#
|
||
|
# Test whether prevPair, pair are valid as consecutive elements of a pipelined
|
||
|
# sequence (Start 1), (End 1), (Start 2), (End 2) ...
|
||
|
# Numbers are integers increasing (by 1 if argument "any" is false), and need
|
||
|
# not begin with 1.
|
||
|
# The first element of the sequence has prevPair {} and is always passed as
|
||
|
# valid.
|
||
|
#
|
||
|
# Arguments;
|
||
|
# Start - string that labels the start of a segment
|
||
|
# End - string that labels the end of a segment
|
||
|
# prevPair - previous "pair" (list of string and number) element of a
|
||
|
# sequence, or {} if argument "pair" is the first in the
|
||
|
# sequence.
|
||
|
# pair - current "pair" (list of string and number) element of a
|
||
|
# sequence
|
||
|
# any - (boolean) iff true, accept any increasing sequence of integers.
|
||
|
# If false, integers must increase by 1.
|
||
|
#
|
||
|
# Return value - boolean, true iff the two pairs are valid consecutive elements.
|
||
|
|
||
|
proc httpTest::PipelineNext {Start End prevPair pair any} {
|
||
|
if {$prevPair eq {}} {
|
||
|
return 1
|
||
|
}
|
||
|
|
||
|
lassign $prevPair letter number
|
||
|
lassign $pair newLetter newNumber
|
||
|
if {$letter eq $Start} {
|
||
|
return [expr {($newLetter eq $End) && ($newNumber == $number)}]
|
||
|
} elseif {$any} {
|
||
|
set nxt [list $Start [expr {$number + 1}]]
|
||
|
return [expr {($newLetter eq $Start) && ($newNumber > $number)}]
|
||
|
} else {
|
||
|
set nxt [list $Start [expr {$number + 1}]]
|
||
|
return [expr {($newLetter eq $Start) && ($newNumber == $number + 1)}]
|
||
|
}
|
||
|
}
|
||
|
|
||
|
# httpTest::TestPipeline --
|
||
|
#
|
||
|
# Given a sequence of "pair" elements, check that the elements whose string is
|
||
|
# $Start or $End form a valid pipeline. Ignore other elements.
|
||
|
#
|
||
|
# Return value: {} if valid pipeline, otherwise a non-empty error message.
|
||
|
|
||
|
proc httpTest::TestPipeline {someResults n Start End msg desc badTrans} {
|
||
|
set sequence {}
|
||
|
set prevPair {}
|
||
|
set ok 1
|
||
|
set any [llength $badTrans]
|
||
|
foreach pair $someResults {
|
||
|
lassign $pair letter number
|
||
|
if {($letter in [list $Start $End]) && ($number ni $badTrans)} {
|
||
|
lappend sequence $pair
|
||
|
if {![PipelineNext $Start $End $prevPair $pair $any]} {
|
||
|
set ok 0
|
||
|
break
|
||
|
}
|
||
|
set prevPair $pair
|
||
|
}
|
||
|
}
|
||
|
|
||
|
if {!$ok} {
|
||
|
set res "$desc are not pipelined: {$sequence}"
|
||
|
append msg $res \n
|
||
|
Puts $res
|
||
|
}
|
||
|
return $msg
|
||
|
}
|
||
|
|
||
|
# httpTest::TestSequence --
|
||
|
#
|
||
|
# Examine each transaction from 1 to $n, ignoring any that are listed
|
||
|
# in $badTrans.
|
||
|
# Check that each transaction has elements A to F, in alphabetical order.
|
||
|
|
||
|
proc httpTest::TestSequence {someResults n msg badTrans} {
|
||
|
variable testOptions
|
||
|
|
||
|
for {set i 1} {$i <= $n} {incr i} {
|
||
|
if {$i in $badTrans} {
|
||
|
continue
|
||
|
}
|
||
|
set sequence {}
|
||
|
foreach pair $someResults {
|
||
|
lassign $pair letter number
|
||
|
if {$number == $i} {
|
||
|
lappend sequence $letter
|
||
|
}
|
||
|
}
|
||
|
if {$sequence eq {A B C D E F}} {
|
||
|
} else {
|
||
|
set res "Wrong sequence for token ::http::$i - {$sequence}"
|
||
|
append msg $res \n
|
||
|
Puts $res
|
||
|
if {"X" in $sequence} {
|
||
|
set res "- and error(s) X"
|
||
|
append msg $res \n
|
||
|
Puts $res
|
||
|
}
|
||
|
if {"Y" in $sequence} {
|
||
|
set res "- and warnings(s) Y"
|
||
|
append msg $res \n
|
||
|
Puts $res
|
||
|
}
|
||
|
}
|
||
|
}
|
||
|
return $msg
|
||
|
}
|
||
|
|
||
|
#
|
||
|
# Arguments:
|
||
|
# someResults - list of elements, each a list of a letter and a number
|
||
|
# n - (positive integer) the number of HTTP requests
|
||
|
# msg - accumulated warning messages
|
||
|
# skipOverlaps - (boolean) whether to skip testing of transaction overlaps
|
||
|
# badTrans - list of transaction numbers not to be assessed as "clean" or
|
||
|
# "dirty" by their overlaps
|
||
|
# for 1/2 includes all transactions
|
||
|
# for 3/4 includes an increasing (with recursion) set that will not be included in the list because they are already handled.
|
||
|
# notPiped - subset of badTrans. List of transaction numbers that cannot
|
||
|
# taint another transaction by overlapping with it, because it
|
||
|
# used a different socket.
|
||
|
#
|
||
|
# Return value: [list $msg $cleanE $cleanF $dirtyE $dirtyF]
|
||
|
# msg - warning messages: nothing will be appended to argument $msg if there
|
||
|
# is no error with the test.
|
||
|
# cleanE - list of transactions that have no overlap with other transactions
|
||
|
# (not considering response body)
|
||
|
# dirtyE - list of transactions that have YES overlap with other transactions
|
||
|
# (not considering response body)
|
||
|
# cleanF - list of transactions that have no overlap with other transactions
|
||
|
# (including response body)
|
||
|
# dirtyF - list of transactions that have YES overlap with other transactions
|
||
|
# (including response body)
|
||
|
|
||
|
proc httpTest::MostAnalysis {someResults n msg skipOverlaps badTrans notPiped} {
|
||
|
variable testOptions
|
||
|
|
||
|
# Check that stages for "good" transactions are all present and correct:
|
||
|
set msg [TestSequence $someResults $n $msg $badTrans]
|
||
|
|
||
|
# Check that requests are pipelined:
|
||
|
set msg [TestPipeline $someResults $n B C $msg Requests $notPiped]
|
||
|
|
||
|
# Check that responses are pipelined:
|
||
|
set msg [TestPipeline $someResults $n D F $msg Responses $notPiped]
|
||
|
|
||
|
if {$skipOverlaps} {
|
||
|
set cleanE {}
|
||
|
set dirtyE {}
|
||
|
set cleanF {}
|
||
|
set dirtyF {}
|
||
|
} else {
|
||
|
Puts "Overlaps including response body (test for non-pipelined case)"
|
||
|
lassign [TestOverlaps $someResults $n F $msg $badTrans $notPiped] msg cleanF dirtyF
|
||
|
|
||
|
Puts "Overlaps without response body (test for pipelined case)"
|
||
|
lassign [TestOverlaps $someResults $n E $msg $badTrans $notPiped] msg cleanE dirtyE
|
||
|
}
|
||
|
|
||
|
return [list $msg $cleanE $cleanF $dirtyE $dirtyF]
|
||
|
}
|
||
|
|
||
|
# httpTest::ProcessRetries --
|
||
|
#
|
||
|
# Command to examine results for socket-changing records [PQR],
|
||
|
# divide the results into segments for each connection, and analyse each segment
|
||
|
# individually.
|
||
|
# (Could add $sock to the logging to simplify this, but never mind.)
|
||
|
#
|
||
|
# In each segment, identify any transactions that are not included, and
|
||
|
# any that are aborted, to assist subsequent testing.
|
||
|
#
|
||
|
# Prepend A records (socket-independent) to each segment for transactions that
|
||
|
# were scheduled (by A) but not completed (by F). Pass each segment to
|
||
|
# MostAnalysis for processing.
|
||
|
|
||
|
proc httpTest::ProcessRetries {someResults n msg skipOverlaps notIncluded notPiped} {
|
||
|
variable testOptions
|
||
|
|
||
|
set nextRetry [lsearch -glob -index 0 $someResults {[PQR]}]
|
||
|
if {$nextRetry < 0} {
|
||
|
return [MostAnalysis $someResults $n $msg $skipOverlaps $notIncluded $notPiped]
|
||
|
}
|
||
|
set badTrans $notIncluded
|
||
|
set tryCount 0
|
||
|
set try $nextRetry
|
||
|
incr tryCount
|
||
|
lassign [lindex $someResults $try] letter number
|
||
|
Puts "Processing retry [lindex $someResults $try]"
|
||
|
set beforeTry [lrange $someResults 0 $try-1]
|
||
|
Puts [join $beforeTry \n]
|
||
|
set afterTry [lrange $someResults $try+1 end]
|
||
|
|
||
|
set dummyTry {}
|
||
|
for {set i 1} {$i <= $n} {incr i} {
|
||
|
set first [lsearch -exact $beforeTry [list A $i]]
|
||
|
set last [lsearch -exact $beforeTry [list F $i]]
|
||
|
if {$first < 0} {
|
||
|
set res "Transaction $i was not started in connection number $tryCount"
|
||
|
# So lappend it to badTrans and don't include it in the call below of MostAnalysis.
|
||
|
# append msg $res \n
|
||
|
Puts $res
|
||
|
if {$i ni $badTrans} {
|
||
|
lappend badTrans $i
|
||
|
} else {
|
||
|
}
|
||
|
} elseif {$last < 0} {
|
||
|
set res "Transaction $i was started but unfinished in connection number $tryCount"
|
||
|
# So lappend it to badTrans and don't include it in the call below of MostAnalysis.
|
||
|
# append msg $res \n
|
||
|
Puts $res
|
||
|
lappend badTrans $i
|
||
|
lappend dummyTry [list A $i]
|
||
|
} else {
|
||
|
set res "Transaction $i was started and finished in connection number $tryCount"
|
||
|
# So include it in the call below of MostAnalysis.
|
||
|
# So lappend it to notIncluded and don't include it in the recursive call of
|
||
|
# ProcessRetries which handles the later connections.
|
||
|
# append msg $res \n
|
||
|
Puts $res
|
||
|
lappend notIncluded $i
|
||
|
}
|
||
|
}
|
||
|
|
||
|
# Analyse the part of the results before the first replay:
|
||
|
set HeadResults [MostAnalysis $beforeTry $n $msg $skipOverlaps $badTrans $notPiped]
|
||
|
lassign $HeadResults msg cleanE1 cleanF1 dirtyE1 dirtyF1
|
||
|
|
||
|
# Pass the rest of the results to be processed recursively.
|
||
|
set afterTry [concat $dummyTry $afterTry]
|
||
|
set TailResults [ProcessRetries $afterTry $n $msg $skipOverlaps $notIncluded $notPiped]
|
||
|
lassign $TailResults msg cleanE2 cleanF2 dirtyE2 dirtyF2
|
||
|
|
||
|
set cleanE [concat $cleanE1 $cleanE2]
|
||
|
set cleanF [concat $cleanF1 $cleanF2]
|
||
|
set dirtyE [concat $dirtyE1 $dirtyE2]
|
||
|
set dirtyF [concat $dirtyF1 $dirtyF2]
|
||
|
return [list $msg $cleanE $cleanF $dirtyE $dirtyF]
|
||
|
}
|
||
|
|
||
|
# httpTest::logAnalyse --
|
||
|
#
|
||
|
# The main command called to analyse logs for a single test.
|
||
|
#
|
||
|
# Arguments:
|
||
|
# n - (positive integer) the number of HTTP requests
|
||
|
# skipOverlaps - (boolean) whether to skip testing of transaction overlaps
|
||
|
# notIncluded - list of transaction numbers not to be assessed as "clean" or
|
||
|
# "dirty" by their overlaps
|
||
|
# notPiped - subset of notIncluded. List of transaction numbers that cannot
|
||
|
# taint another transaction by overlapping with it, because it
|
||
|
# used a different socket.
|
||
|
#
|
||
|
# Return value: [list $msg $cleanE $cleanF $dirtyE $dirtyF]
|
||
|
# msg - warning messages: {} if there is no error with the test.
|
||
|
# cleanE - list of transactions that have no overlap with other transactions
|
||
|
# (not considering response body)
|
||
|
# dirtyE - list of transactions that have YES overlap with other transactions
|
||
|
# (not considering response body)
|
||
|
# cleanF - list of transactions that have no overlap with other transactions
|
||
|
# (including response body)
|
||
|
# dirtyF - list of transactions that have YES overlap with other transactions
|
||
|
# (including response body)
|
||
|
|
||
|
proc httpTest::logAnalyse {n skipOverlaps notIncluded notPiped} {
|
||
|
variable testResults
|
||
|
variable testOptions
|
||
|
|
||
|
# Check that each data item has the correct form {letter numeral}.
|
||
|
set ii 0
|
||
|
set ok 1
|
||
|
foreach pair $testResults {
|
||
|
lassign $pair letter number
|
||
|
if { [string match {[A-Z]} $letter]
|
||
|
&& [string match {[0-9]} $number]
|
||
|
} {
|
||
|
# OK
|
||
|
} else {
|
||
|
set ok 0
|
||
|
set res "Error: testResults has bad element {$pair} at position $ii"
|
||
|
append msg $res \n
|
||
|
Puts $res
|
||
|
}
|
||
|
incr ii
|
||
|
}
|
||
|
|
||
|
if {!$ok} {
|
||
|
return $msg
|
||
|
}
|
||
|
set msg {}
|
||
|
|
||
|
Puts [join $testResults \n]
|
||
|
ProcessRetries $testResults $n $msg $skipOverlaps $notIncluded $notPiped
|
||
|
# N.B. Implicit Return.
|
||
|
}
|
||
|
|
||
|
proc httpTest::cleanupHttpTest {} {
|
||
|
variable testResults
|
||
|
set testResults {}
|
||
|
return
|
||
|
}
|
||
|
|
||
|
proc httpTest::setHttpTestOptions {key args} {
|
||
|
variable testOptions
|
||
|
if {$key ni {-dotted -verbose}} {
|
||
|
return -code error {valid options are -dotted, -verbose}
|
||
|
}
|
||
|
set testOptions($key) {*}$args
|
||
|
}
|
||
|
|
||
|
namespace eval httpTest {
|
||
|
namespace export cleanupHttpTest logAnalyse setHttpTestOptions
|
||
|
}
|