1# httpTestScript.tcl 2# 3# Test HTTP/1.1 concurrent requests including 4# queueing, pipelining and retries. 5# 6# Copyright (C) 2018 Keith Nash <kjnash@users.sourceforge.net> 7# 8# See the file "license.terms" for information on usage and redistribution 9# of this file, and for a DISCLAIMER OF ALL WARRANTIES. 10 11# ------------------------------------------------------------------------------ 12# "Package" httpTestScript for executing test scripts written in a convenient 13# shorthand. 14# ------------------------------------------------------------------------------ 15 16# ------------------------------------------------------------------------------ 17# Documentation for "package" httpTestScript. 18# ------------------------------------------------------------------------------ 19# To use the package: 20# (a) define URLs as the values of elements in the array ::httpTestScript 21# (b) define a script in terms of the commands 22# START STOP DELAY KEEPALIVE WAIT PIPELINE GET HEAD POST 23# referring to URLs by the name of the corresponding array element. The 24# script can include any other Tcl commands, and evaluates in the 25# httpTestScript namespace. 26# (c) Use the command httpTestScript::runHttpTestScript to evaluate the script. 27# (d) For tcltest tests, wrap the runHttpTestScript call in a suitable "test" 28# command. 29# ------------------------------------------------------------------------------ 30# START 31# Must be the first command of the script. 32# 33# STOP 34# Must be present in the script to avoid waiting for client timeout. 35# Usually the last command, but can be elsewhere to end a script prematurely. 36# Subsequent httpTestScript commands will have no effect. 37# 38# DELAY ms 39# If there are no WAIT commands, this sets the delay in ms between subsequent 40# calls to http::geturl. Default 500ms. 41# 42# KEEPALIVE 43# Set the value passed to http::geturl for the -keepalive option. The command 44# applies to subsequent requests in the script. Default 1. 45# 46# WAIT ms 47# Pause for a time in ms before sending subsequent requests. 48# 49# PIPELINE boolean 50# Set the value of -pipeline using http::config. The last PIPELINE command 51# in the script applies to every request. Default 1. 52# 53# POSTFRESH boolean 54# Set the value of -postfresh using http::config. The last POSTFRESH command 55# in the script applies to every request. Default 0. 56# 57# REPOST boolean 58# Set the value of -repost using http::config. The last REPOST command 59# in the script applies to every request. Default 1 for httpTestScript. 60# (Default value in http is 0). 61# 62# GET uriCode ?arg ...? 63# Send a HTTP request using the GET method. 64# Arguments: 65# uriCode - the code for the base URI - the value must be stored in 66# ::httpTestScript::URL($uriCode). 67# args - strings that will be joined by "&" and appended to the query 68# string with a preceding "&". 69# 70# HEAD uriCode ?arg ...? 71# Send a HTTP request using the HEAD method. 72# Arguments: as for GET 73# 74# POST uriCode ?arg ...? 75# Send a HTTP request using the POST method. 76# Arguments: 77# uriCode - the code for the base URI - the value must be stored in 78# ::httpTestScript::URL($uriCode). 79# args - strings that will be joined by "&" and used as the request body. 80# ------------------------------------------------------------------------------ 81 82namespace eval ::httpTestScript { 83 namespace export runHttpTestScript cleanupHttpTestScript 84} 85 86# httpTestScript::START -- 87# Initialise, and create a long-stop timeout. 88 89proc httpTestScript::START {} { 90 variable CountRequestedSoFar 91 variable RequestsWhenStopped 92 variable KeepAlive 93 variable Delay 94 variable TimeOutCode 95 variable TimeOutDone 96 variable StartDone 97 variable StopDone 98 variable CountFinishedSoFar 99 variable RequestList 100 variable RequestsMade 101 variable ExtraTime 102 variable ActualKeepAlive 103 104 if {[info exists StartDone] && ($StartDone == 1)} { 105 set msg {START has been called twice without an intervening STOP} 106 return -code error $msg 107 } 108 109 set StartDone 1 110 set StopDone 0 111 set TimeOutDone 0 112 set CountFinishedSoFar 0 113 set CountRequestedSoFar 0 114 set RequestList {} 115 set RequestsMade {} 116 set ExtraTime 0 117 set ActualKeepAlive 1 118 119 # Undefined until a STOP command: 120 unset -nocomplain RequestsWhenStopped 121 122 # Default values: 123 set KeepAlive 1 124 set Delay 500 125 126 # Default values for tests: 127 KEEPALIVE 1 128 PIPELINE 1 129 POSTFRESH 0 130 REPOST 1 131 132 set TimeOutCode [after 30000 httpTestScript::TimeOutNow] 133# set TimeOutCode [after 4000 httpTestScript::TimeOutNow] 134 return 135} 136 137# httpTestScript::STOP -- 138# Do not process any more commands. The commands will be executed but will 139# silently do nothing. 140 141proc httpTestScript::STOP {} { 142 variable CountRequestedSoFar 143 variable CountFinishedSoFar 144 variable RequestsWhenStopped 145 variable TimeOutCode 146 variable StartDone 147 variable StopDone 148 variable RequestsMade 149 150 if {$StopDone} { 151 # Don't do anything on a second call. 152 return 153 } 154 155 if {![info exists StartDone]} { 156 return -code error {initialise the script by calling command START} 157 } 158 159 set StopDone 1 160 set StartDone 0 161 set RequestsWhenStopped $CountRequestedSoFar 162 unset -nocomplain StartDone 163 164 if {$CountFinishedSoFar == $RequestsWhenStopped} { 165 if {[info exists TimeOutCode]} { 166 after cancel $TimeOutCode 167 } 168 set ::httpTestScript::FOREVER 0 169 } 170 return 171} 172 173# httpTestScript::DELAY -- 174# If there are no WAIT commands, this sets the delay in ms between subsequent 175# calls to http::geturl. Default 500ms. 176 177proc httpTestScript::DELAY {t} { 178 variable StartDone 179 variable StopDone 180 181 if {$StopDone} { 182 return 183 } 184 185 if {![info exists StartDone]} { 186 return -code error {initialise the script by calling command START} 187 } 188 189 variable Delay 190 191 set Delay $t 192 return 193} 194 195# httpTestScript::KEEPALIVE -- 196# Set the value passed to http::geturl for the -keepalive option. Default 1. 197 198proc httpTestScript::KEEPALIVE {b} { 199 variable StartDone 200 variable StopDone 201 202 if {$StopDone} { 203 return 204 } 205 206 if {![info exists StartDone]} { 207 return -code error {initialise the script by calling command START} 208 } 209 210 variable KeepAlive 211 set KeepAlive $b 212 return 213} 214 215# httpTestScript::WAIT -- 216# Pause for a time in ms before processing any more commands. 217 218proc httpTestScript::WAIT {t} { 219 variable StartDone 220 variable StopDone 221 variable ExtraTime 222 223 if {$StopDone} { 224 return 225 } 226 227 if {![info exists StartDone]} { 228 return -code error {initialise the script by calling command START} 229 } 230 231 if {(![string is integer -strict $t]) || $t < 0} { 232 return -code error {argument to WAIT must be a non-negative integer} 233 } 234 235 incr ExtraTime $t 236 237 return 238} 239 240# httpTestScript::PIPELINE -- 241# Pass a value to http::config -pipeline. 242 243proc httpTestScript::PIPELINE {b} { 244 variable StartDone 245 variable StopDone 246 247 if {$StopDone} { 248 return 249 } 250 251 if {![info exists StartDone]} { 252 return -code error {initialise the script by calling command START} 253 } 254 255 ::http::config -pipeline $b 256 ##::http::Log http(-pipeline) is now [::http::config -pipeline] 257 return 258} 259 260# httpTestScript::POSTFRESH -- 261# Pass a value to http::config -postfresh. 262 263proc httpTestScript::POSTFRESH {b} { 264 variable StartDone 265 variable StopDone 266 267 if {$StopDone} { 268 return 269 } 270 271 if {![info exists StartDone]} { 272 return -code error {initialise the script by calling command START} 273 } 274 275 ::http::config -postfresh $b 276 ##::http::Log http(-postfresh) is now [::http::config -postfresh] 277 return 278} 279 280# httpTestScript::REPOST -- 281# Pass a value to http::config -repost. 282 283proc httpTestScript::REPOST {b} { 284 variable StartDone 285 variable StopDone 286 287 if {$StopDone} { 288 return 289 } 290 291 if {![info exists StartDone]} { 292 return -code error {initialise the script by calling command START} 293 } 294 295 ::http::config -repost $b 296 ##::http::Log http(-repost) is now [::http::config -repost] 297 return 298} 299 300# httpTestScript::GET -- 301# Send a HTTP request using the GET method. 302# Arguments: 303# uriCode - the code for the base URI - the value must be stored in 304# ::httpTestScript::URL($uriCode). 305# args - strings that will each be preceded by "&" and appended to the query 306# string. 307 308proc httpTestScript::GET {uriCode args} { 309 variable RequestList 310 lappend RequestList GET 311 RequestAfter $uriCode 0 {} {*}$args 312 return 313} 314 315# httpTestScript::HEAD -- 316# Send a HTTP request using the HEAD method. 317# Arguments: as for GET 318 319proc httpTestScript::HEAD {uriCode args} { 320 variable RequestList 321 lappend RequestList HEAD 322 RequestAfter $uriCode 1 {} {*}$args 323 return 324} 325 326# httpTestScript::POST -- 327# Send a HTTP request using the POST method. 328# Arguments: 329# uriCode - the code for the base URI - the value must be stored in 330# ::httpTestScript::URL($uriCode). 331# args - strings that will be joined by "&" and used as the request body. 332 333proc httpTestScript::POST {uriCode args} { 334 variable RequestList 335 lappend RequestList POST 336 RequestAfter $uriCode 0 {use} {*}$args 337 return 338} 339 340 341proc httpTestScript::RequestAfter {uriCode validate query args} { 342 variable CountRequestedSoFar 343 variable Delay 344 variable ExtraTime 345 variable StartDone 346 variable StopDone 347 variable KeepAlive 348 349 if {$StopDone} { 350 return 351 } 352 353 if {![info exists StartDone]} { 354 return -code error {initialise the script by calling command START} 355 } 356 357 incr CountRequestedSoFar 358 set idelay [expr {($CountRequestedSoFar - 1) * $Delay + 10 + $ExtraTime}] 359 360 # Could pass values of -pipeline, -postfresh, -repost if it were 361 # useful to change these mid-script. 362 after $idelay [list httpTestScript::Requester $uriCode $KeepAlive $validate $query {*}$args] 363 return 364} 365 366proc httpTestScript::Requester {uriCode keepAlive validate query args} { 367 variable URL 368 369 ::http::config -accept {*/*} 370 371 set absUrl $URL($uriCode) 372 if {$query eq {}} { 373 if {$args ne {}} { 374 append absUrl & [join $args &] 375 } 376 set queryArgs {} 377 } elseif {$validate} { 378 return -code error {cannot have both -validate (HEAD) and -query (POST)} 379 } else { 380 set queryArgs [list -query [join $args &]] 381 } 382 383 if {[catch { 384 ::http::geturl $absUrl \ 385 -validate $validate \ 386 -timeout 10000 \ 387 {*}$queryArgs \ 388 -keepalive $keepAlive \ 389 -command ::httpTestScript::WhenFinished 390 } token]} { 391 set msg $token 392 catch {puts stdout "Error: $msg"} 393 return 394 } else { 395 # Request will begin. 396 } 397 398 return 399 400} 401 402proc httpTestScript::TimeOutNow {} { 403 variable TimeOutDone 404 405 set TimeOutDone 1 406 set ::httpTestScript::FOREVER 0 407 return 408} 409 410proc httpTestScript::WhenFinished {hToken} { 411 variable CountFinishedSoFar 412 variable RequestsWhenStopped 413 variable TimeOutCode 414 variable StopDone 415 variable RequestList 416 variable RequestsMade 417 variable ActualKeepAlive 418 419 upvar #0 $hToken state 420 421 if {[catch { 422 if { [info exists state(transfer)] 423 && ($state(transfer) eq "chunked") 424 } { 425 set Trans chunked 426 } else { 427 set Trans unchunked 428 } 429 430 if { [info exists ::httpTest::testOptions(-verbose)] 431 && ($::httpTest::testOptions(-verbose) > 0) 432 } { 433 puts "Token $hToken 434Response $state(http) 435Status $state(status) 436Method $state(method) 437Transfer $Trans 438Size $state(currentsize) 439URL $state(url) 440" 441 } 442 443 if {!$state(-keepalive)} { 444 set ActualKeepAlive 0 445 } 446 447 if {[info exists state(method)]} { 448 lappend RequestsMade $state(method) 449 } else { 450 lappend RequestsMade UNKNOWN 451 } 452 set tk [namespace tail $hToken] 453 454 if { ($state(http) != {HTTP/1.1 200 OK}) 455 || ($state(status) != {ok}) 456 || (($state(currentsize) == 0) && ($state(method) ne "HEAD")) 457 } { 458 ::http::Log ^X$tk unexpected result Response $state(http) Status $state(status) Size $state(currentsize) - token $hToken 459 } 460 } err]} { 461 ::http::Log ^X$tk httpTestScript::WhenFinished failed with error status: $err - token $hToken 462 } 463 464 incr CountFinishedSoFar 465 if {$StopDone && ($CountFinishedSoFar == $RequestsWhenStopped)} { 466 if {[info exists TimeOutCode]} { 467 after cancel $TimeOutCode 468 } 469 if {$RequestsMade ne $RequestList && $ActualKeepAlive} { 470 ::http::Log ^X$tk unexpected result - Script asked for "{$RequestList}" but got "{$RequestsMade}" - token $hToken 471 } 472 set ::httpTestScript::FOREVER 0 473 } 474 475 return 476} 477 478 479proc httpTestScript::runHttpTestScript {scr} { 480 variable TimeOutDone 481 variable RequestsWhenStopped 482 483 after idle [list namespace eval ::httpTestScript $scr] 484 vwait ::httpTestScript::FOREVER 485 # N.B. does not automatically execute in this namespace, unlike some other events. 486 # Release when all requests have been served or have timed out. 487 488 if {$TimeOutDone} { 489 return -code error {test script timed out} 490 } 491 492 return $RequestsWhenStopped 493} 494 495 496proc httpTestScript::cleanupHttpTestScript {} { 497 variable TimeOutDone 498 variable RequestsWhenStopped 499 500 if {![info exists RequestsWhenStopped]} { 501 return -code error {Cleanup Failed: RequestsWhenStopped is undefined} 502 } 503 504 for {set i 1} {$i <= $RequestsWhenStopped} {incr i} { 505 http::cleanup ::http::$i 506 } 507 508 return 509} 510