"Fossies" - the Fresh Open Source Software Archive

Member "redis-6.0.8/tests/support/server.tcl" (10 Sep 2020, 17753 Bytes) of package /linux/misc/redis-6.0.8.tar.gz:


As a special service "Fossies" has tried to format the requested source page into HTML format using (guessed) Tcl/Tk source code syntax highlighting (style: standard) with prefixed line numbers and code folding option. Alternatively you can here view or download the uninterpreted source code file. See also the latest Fossies "Diffs" side-by-side code changes report for "server.tcl": 6.0.7_vs_6.0.8.

    1 set ::global_overrides {}
    2 set ::tags {}
    3 set ::valgrind_errors {}
    4 
    5 proc start_server_error {config_file error} {
    6     set err {}
    7     append err "Can't start the Redis server\n"
    8     append err "CONFIGURATION:"
    9     append err [exec cat $config_file]
   10     append err "\nERROR:"
   11     append err [string trim $error]
   12     send_data_packet $::test_server_fd err $err
   13 }
   14 
   15 proc check_valgrind_errors stderr {
   16     set res [find_valgrind_errors $stderr]
   17     if {$res != ""} {
   18         send_data_packet $::test_server_fd err "Valgrind error: $res\n"
   19     }
   20 }
   21 
   22 proc clean_persistence config {
   23     # we may wanna keep the logs for later, but let's clean the persistence
   24     # files right away, since they can accumulate and take up a lot of space
   25     set config [dict get $config "config"]
   26     set rdb [format "%s/%s" [dict get $config "dir"] "dump.rdb"]
   27     set aof [format "%s/%s" [dict get $config "dir"] "appendonly.aof"]
   28     catch {exec rm -rf $rdb}
   29     catch {exec rm -rf $aof}
   30 }
   31 
   32 proc kill_server config {
   33     # nothing to kill when running against external server
   34     if {$::external} return
   35 
   36     # nevermind if its already dead
   37     if {![is_alive $config]} {
   38         # Check valgrind errors if needed
   39         if {$::valgrind} {
   40             check_valgrind_errors [dict get $config stderr]
   41         }
   42         return
   43     }
   44     set pid [dict get $config pid]
   45 
   46     # check for leaks
   47     if {![dict exists $config "skipleaks"]} {
   48         catch {
   49             if {[string match {*Darwin*} [exec uname -a]]} {
   50                 tags {"leaks"} {
   51                     test "Check for memory leaks (pid $pid)" {
   52                         set output {0 leaks}
   53                         catch {exec leaks $pid} output
   54                         if {[string match {*process does not exist*} $output] ||
   55                             [string match {*cannot examine*} $output]} {
   56                             # In a few tests we kill the server process.
   57                             set output "0 leaks"
   58                         }
   59                         set output
   60                     } {*0 leaks*}
   61                 }
   62             }
   63         }
   64     }
   65 
   66     # kill server and wait for the process to be totally exited
   67     send_data_packet $::test_server_fd server-killing $pid
   68     catch {exec kill $pid}
   69     if {$::valgrind} {
   70         set max_wait 60000
   71     } else {
   72         set max_wait 10000
   73     }
   74     while {[is_alive $config]} {
   75         incr wait 10
   76 
   77         if {$wait >= $max_wait} {
   78             puts "Forcing process $pid to exit..."
   79             catch {exec kill -KILL $pid}
   80         } elseif {$wait % 1000 == 0} {
   81             puts "Waiting for process $pid to exit..."
   82         }
   83         after 10
   84     }
   85 
   86     # Check valgrind errors if needed
   87     if {$::valgrind} {
   88         check_valgrind_errors [dict get $config stderr]
   89     }
   90 
   91     # Remove this pid from the set of active pids in the test server.
   92     send_data_packet $::test_server_fd server-killed $pid
   93 }
   94 
   95 proc is_alive config {
   96     set pid [dict get $config pid]
   97     if {[catch {exec ps -p $pid} err]} {
   98         return 0
   99     } else {
  100         return 1
  101     }
  102 }
  103 
  104 proc ping_server {host port} {
  105     set retval 0
  106     if {[catch {
  107         if {$::tls} {
  108             set fd [::tls::socket $host $port] 
  109         } else {
  110             set fd [socket $host $port]
  111         }
  112         fconfigure $fd -translation binary
  113         puts $fd "PING\r\n"
  114         flush $fd
  115         set reply [gets $fd]
  116         if {[string range $reply 0 0] eq {+} ||
  117             [string range $reply 0 0] eq {-}} {
  118             set retval 1
  119         }
  120         close $fd
  121     } e]} {
  122         if {$::verbose} {
  123             puts -nonewline "."
  124         }
  125     } else {
  126         if {$::verbose} {
  127             puts -nonewline "ok"
  128         }
  129     }
  130     return $retval
  131 }
  132 
  133 # Return 1 if the server at the specified addr is reachable by PING, otherwise
  134 # returns 0. Performs a try every 50 milliseconds for the specified number
  135 # of retries.
  136 proc server_is_up {host port retrynum} {
  137     after 10 ;# Use a small delay to make likely a first-try success.
  138     set retval 0
  139     while {[incr retrynum -1]} {
  140         if {[catch {ping_server $host $port} ping]} {
  141             set ping 0
  142         }
  143         if {$ping} {return 1}
  144         after 50
  145     }
  146     return 0
  147 }
  148 
  149 # doesn't really belong here, but highly coupled to code in start_server
  150 proc tags {tags code} {
  151     # If we 'tags' contain multiple tags, quoted and seperated by spaces,
  152     # we want to get rid of the quotes in order to have a proper list
  153     set tags [string map { \" "" } $tags]
  154     set ::tags [concat $::tags $tags]
  155     # We skip unwanted tags
  156     foreach tag $::denytags {
  157         if {[lsearch $::tags $tag] >= 0} {
  158             incr ::num_aborted
  159             send_data_packet $::test_server_fd ignore "Tag: $tag"
  160             set ::tags [lrange $::tags 0 end-[llength $tags]]
  161             return
  162         }
  163     }
  164     uplevel 1 $code
  165     set ::tags [lrange $::tags 0 end-[llength $tags]]
  166 }
  167 
  168 # Write the configuration in the dictionary 'config' in the specified
  169 # file name.
  170 proc create_server_config_file {filename config} {
  171     set fp [open $filename w+]
  172     foreach directive [dict keys $config] {
  173         puts -nonewline $fp "$directive "
  174         puts $fp [dict get $config $directive]
  175     }
  176     close $fp
  177 }
  178 
  179 proc spawn_server {config_file stdout stderr} {
  180     if {$::valgrind} {
  181         set pid [exec valgrind --track-origins=yes --trace-children=yes --suppressions=[pwd]/src/valgrind.sup --show-reachable=no --show-possibly-lost=no --leak-check=full src/redis-server $config_file >> $stdout 2>> $stderr &]
  182     } elseif ($::stack_logging) {
  183         set pid [exec /usr/bin/env MallocStackLogging=1 MallocLogFile=/tmp/malloc_log.txt src/redis-server $config_file >> $stdout 2>> $stderr &]
  184     } else {
  185         set pid [exec src/redis-server $config_file >> $stdout 2>> $stderr &]
  186     }
  187 
  188     if {$::wait_server} {
  189         set msg "server started PID: $pid. press any key to continue..."
  190         puts $msg
  191         read stdin 1
  192     }
  193 
  194     # Tell the test server about this new instance.
  195     send_data_packet $::test_server_fd server-spawned $pid
  196     return $pid
  197 }
  198 
  199 # Wait for actual startup, return 1 if port is busy, 0 otherwise
  200 proc wait_server_started {config_file stdout pid} {
  201     set checkperiod 100; # Milliseconds
  202     set maxiter [expr {120*1000/$checkperiod}] ; # Wait up to 2 minutes.
  203     set port_busy 0
  204     while 1 {
  205         if {[regexp -- " PID: $pid" [exec cat $stdout]]} {
  206             break
  207         }
  208         after $checkperiod
  209         incr maxiter -1
  210         if {$maxiter == 0} {
  211             start_server_error $config_file "No PID detected in log $stdout"
  212             puts "--- LOG CONTENT ---"
  213             puts [exec cat $stdout]
  214             puts "-------------------"
  215             break
  216         }
  217 
  218         # Check if the port is actually busy and the server failed
  219         # for this reason.
  220         if {[regexp {Could not create server TCP} [exec cat $stdout]]} {
  221             set port_busy 1
  222             break
  223         }
  224     }
  225     return $port_busy
  226 }
  227 
  228 proc start_server {options {code undefined}} {
  229     # setup defaults
  230     set baseconfig "default.conf"
  231     set overrides {}
  232     set tags {}
  233     set keep_persistence false
  234 
  235     # parse options
  236     foreach {option value} $options {
  237         switch $option {
  238             "config" {
  239                 set baseconfig $value
  240             }
  241             "overrides" {
  242                 set overrides $value
  243             }
  244             "tags" {
  245                 # If we 'tags' contain multiple tags, quoted and seperated by spaces,
  246                 # we want to get rid of the quotes in order to have a proper list
  247                 set tags [string map { \" "" } $value]
  248                 set ::tags [concat $::tags $tags]
  249             }
  250             "keep_persistence" {
  251                 set keep_persistence $value
  252             }
  253             default {
  254                 error "Unknown option $option"
  255             }
  256         }
  257     }
  258 
  259     # We skip unwanted tags
  260     foreach tag $::denytags {
  261         if {[lsearch $::tags $tag] >= 0} {
  262             incr ::num_aborted
  263             send_data_packet $::test_server_fd ignore "Tag: $tag"
  264             set ::tags [lrange $::tags 0 end-[llength $tags]]
  265             return
  266         }
  267     }
  268 
  269     # If we are running against an external server, we just push the
  270     # host/port pair in the stack the first time
  271     if {$::external} {
  272         if {[llength $::servers] == 0} {
  273             set srv {}
  274             dict set srv "host" $::host
  275             dict set srv "port" $::port
  276             set client [redis $::host $::port 0 $::tls]
  277             dict set srv "client" $client
  278             $client select 9
  279 
  280             set config {}
  281             dict set config "port" $::port
  282             dict set srv "config" $config
  283 
  284             # append the server to the stack
  285             lappend ::servers $srv
  286         }
  287         r flushall
  288         if {[catch {set retval [uplevel 1 $code]} error]} {
  289             if {$::durable} {
  290                 set msg [string range $error 10 end]
  291                 lappend details $msg
  292                 lappend details $::errorInfo
  293                 lappend ::tests_failed $details
  294 
  295                 incr ::num_failed
  296                 send_data_packet $::test_server_fd err [join $details "\n"]
  297             } else {
  298                 # Re-raise, let handler up the stack take care of this.
  299                 error $error $::errorInfo
  300             }
  301         }
  302         set ::tags [lrange $::tags 0 end-[llength $tags]]
  303         return
  304     }
  305 
  306     set data [split [exec cat "tests/assets/$baseconfig"] "\n"]
  307     set config {}
  308     if {$::tls} {
  309         dict set config "tls-cert-file" [format "%s/tests/tls/redis.crt" [pwd]]
  310         dict set config "tls-key-file" [format "%s/tests/tls/redis.key" [pwd]]
  311         dict set config "tls-dh-params-file" [format "%s/tests/tls/redis.dh" [pwd]]
  312         dict set config "tls-ca-cert-file" [format "%s/tests/tls/ca.crt" [pwd]]
  313         dict set config "loglevel" "debug"
  314     }
  315     foreach line $data {
  316         if {[string length $line] > 0 && [string index $line 0] ne "#"} {
  317             set elements [split $line " "]
  318             set directive [lrange $elements 0 0]
  319             set arguments [lrange $elements 1 end]
  320             dict set config $directive $arguments
  321         }
  322     }
  323 
  324     # use a different directory every time a server is started
  325     dict set config dir [tmpdir server]
  326 
  327     # start every server on a different port
  328     set port [find_available_port $::baseport $::portcount]
  329     if {$::tls} {
  330         dict set config "port" 0
  331         dict set config "tls-port" $port
  332         dict set config "tls-cluster" "yes"
  333         dict set config "tls-replication" "yes"
  334     } else {
  335         dict set config port $port
  336     }
  337 
  338     set unixsocket [file normalize [format "%s/%s" [dict get $config "dir"] "socket"]]
  339     dict set config "unixsocket" $unixsocket
  340 
  341     # apply overrides from global space and arguments
  342     foreach {directive arguments} [concat $::global_overrides $overrides] {
  343         dict set config $directive $arguments
  344     }
  345 
  346     # write new configuration to temporary file
  347     set config_file [tmpfile redis.conf]
  348     create_server_config_file $config_file $config
  349 
  350     set stdout [format "%s/%s" [dict get $config "dir"] "stdout"]
  351     set stderr [format "%s/%s" [dict get $config "dir"] "stderr"]
  352 
  353     # if we're inside a test, write the test name to the server log file
  354     if {[info exists ::cur_test]} {
  355         set fd [open $stdout "a+"]
  356         puts $fd "### Starting server for test $::cur_test"
  357         close $fd
  358     }
  359 
  360     # We need a loop here to retry with different ports.
  361     set server_started 0
  362     while {$server_started == 0} {
  363         if {$::verbose} {
  364             puts -nonewline "=== ($tags) Starting server ${::host}:${port} "
  365         }
  366 
  367         send_data_packet $::test_server_fd "server-spawning" "port $port"
  368 
  369         set pid [spawn_server $config_file $stdout $stderr]
  370 
  371         # check that the server actually started
  372         set port_busy [wait_server_started $config_file $stdout $pid]
  373 
  374         # Sometimes we have to try a different port, even if we checked
  375         # for availability. Other test clients may grab the port before we
  376         # are able to do it for example.
  377         if {$port_busy} {
  378             puts "Port $port was already busy, trying another port..."
  379             set port [find_available_port $::baseport $::portcount]
  380             if {$::tls} {
  381                 dict set config "tls-port" $port
  382             } else {
  383                 dict set config port $port
  384             }
  385             create_server_config_file $config_file $config
  386 
  387             # Truncate log so wait_server_started will not be looking at
  388             # output of the failed server.
  389             close [open $stdout "w"]
  390 
  391             continue; # Try again
  392         }
  393 
  394         if {$::valgrind} {set retrynum 1000} else {set retrynum 100}
  395         if {$code ne "undefined"} {
  396             set serverisup [server_is_up $::host $port $retrynum]
  397         } else {
  398             set serverisup 1
  399         }
  400 
  401         if {$::verbose} {
  402             puts ""
  403         }
  404 
  405         if {!$serverisup} {
  406             set err {}
  407             append err [exec cat $stdout] "\n" [exec cat $stderr]
  408             start_server_error $config_file $err
  409             return
  410         }
  411         set server_started 1
  412     }
  413 
  414     # setup properties to be able to initialize a client object
  415     set port_param [expr $::tls ? {"tls-port"} : {"port"}]
  416     set host $::host
  417     if {[dict exists $config bind]} { set host [dict get $config bind] }
  418     if {[dict exists $config $port_param]} { set port [dict get $config $port_param] }
  419 
  420     # setup config dict
  421     dict set srv "config_file" $config_file
  422     dict set srv "config" $config
  423     dict set srv "pid" $pid
  424     dict set srv "host" $host
  425     dict set srv "port" $port
  426     dict set srv "stdout" $stdout
  427     dict set srv "stderr" $stderr
  428     dict set srv "unixsocket" $unixsocket
  429 
  430     # if a block of code is supplied, we wait for the server to become
  431     # available, create a client object and kill the server afterwards
  432     if {$code ne "undefined"} {
  433         set line [exec head -n1 $stdout]
  434         if {[string match {*already in use*} $line]} {
  435             error_and_quit $config_file $line
  436         }
  437 
  438         while 1 {
  439             # check that the server actually started and is ready for connections
  440             if {[exec grep -i "Ready to accept" | wc -l < $stdout] > 0} {
  441                 break
  442             }
  443             after 10
  444         }
  445 
  446         # append the server to the stack
  447         lappend ::servers $srv
  448 
  449         # connect client (after server dict is put on the stack)
  450         reconnect
  451 
  452         # execute provided block
  453         set num_tests $::num_tests
  454         if {[catch { uplevel 1 $code } error]} {
  455             set backtrace $::errorInfo
  456 
  457             # fetch srv back from the server list, in case it was restarted by restart_server (new PID)
  458             set srv [lindex $::servers end]
  459 
  460             # pop the server object
  461             set ::servers [lrange $::servers 0 end-1]
  462 
  463             # Kill the server without checking for leaks
  464             dict set srv "skipleaks" 1
  465             kill_server $srv
  466 
  467             # Print warnings from log
  468             puts [format "\nLogged warnings (pid %d):" [dict get $srv "pid"]]
  469             set warnings [warnings_from_file [dict get $srv "stdout"]]
  470             if {[string length $warnings] > 0} {
  471                 puts "$warnings"
  472             } else {
  473                 puts "(none)"
  474             }
  475             puts ""
  476 
  477             if {$::durable} {
  478                 set msg [string range $error 10 end]
  479                 lappend details $msg
  480                 lappend details $backtrace
  481                 lappend ::tests_failed $details
  482 
  483                 incr ::num_failed
  484                 send_data_packet $::test_server_fd err [join $details "\n"]
  485             } else {
  486                 # Re-raise, let handler up the stack take care of this.
  487                 error $error $backtrace
  488             }
  489         }
  490 
  491         # fetch srv back from the server list, in case it was restarted by restart_server (new PID)
  492         set srv [lindex $::servers end]
  493 
  494         # Don't do the leak check when no tests were run
  495         if {$num_tests == $::num_tests} {
  496             dict set srv "skipleaks" 1
  497         }
  498 
  499         # pop the server object
  500         set ::servers [lrange $::servers 0 end-1]
  501 
  502         set ::tags [lrange $::tags 0 end-[llength $tags]]
  503         kill_server $srv
  504         if {!$keep_persistence} {
  505             clean_persistence $srv
  506         }
  507         set _ ""
  508     } else {
  509         set ::tags [lrange $::tags 0 end-[llength $tags]]
  510         set _ $srv
  511     }
  512 }
  513 
  514 proc restart_server {level wait_ready} {
  515     set srv [lindex $::servers end+$level]
  516     kill_server $srv
  517 
  518     set stdout [dict get $srv "stdout"]
  519     set stderr [dict get $srv "stderr"]
  520     set config_file [dict get $srv "config_file"]
  521 
  522     # if we're inside a test, write the test name to the server log file
  523     if {[info exists ::cur_test]} {
  524         set fd [open $stdout "a+"]
  525         puts $fd "### Restarting server for test $::cur_test"
  526         close $fd
  527     }
  528 
  529     set prev_ready_count [exec grep -i "Ready to accept" | wc -l < $stdout]
  530 
  531     set pid [spawn_server $config_file $stdout $stderr]
  532 
  533     # check that the server actually started
  534     wait_server_started $config_file $stdout $pid
  535 
  536     # update the pid in the servers list
  537     dict set srv "pid" $pid
  538     # re-set $srv in the servers list
  539     lset ::servers end+$level $srv
  540 
  541     if {$wait_ready} {
  542         while 1 {
  543             # check that the server actually started and is ready for connections
  544             if {[exec grep -i "Ready to accept" | wc -l < $stdout] > $prev_ready_count + 1} {
  545                 break
  546             }
  547             after 10
  548         }
  549     }
  550     reconnect $level
  551 }