1#!/usr/bin/perl -w
2#
3# Copyright (C) Internet Systems Consortium, Inc. ("ISC")
4#
5# This Source Code Form is subject to the terms of the Mozilla Public
6# License, v. 2.0. If a copy of the MPL was not distributed with this
7# file, you can obtain one at https://mozilla.org/MPL/2.0/.
8#
9# See the COPYRIGHT file distributed with this work for additional
10# information regarding copyright ownership.
11
12# Framework for starting test servers.
13# Based on the type of server specified, check for port availability, remove
14# temporary files, start the server, and verify that the server is running.
15# If a server is specified, start it. Otherwise, start all servers for test.
16
17use strict;
18use warnings;
19
20use Cwd ':DEFAULT', 'abs_path';
21use English '-no_match_vars';
22use Getopt::Long;
23use Time::HiRes 'sleep'; # allows sleeping fractional seconds
24
25# Usage:
26#   perl start.pl [--noclean] [--restart] [--port port] [--taskset cpus] test [server [options]]
27#
28#   --noclean       Do not cleanup files in server directory.
29#
30#   --restart       Indicate that the server is being restarted, so get the
31#                   server to append output to an existing log file instead of
32#                   starting a new one.
33#
34#   --port port     Specify the default port being used by the server to answer
35#                   queries (default 5300).  This script will interrogate the
36#                   server on this port to see if it is running. (Note: for
37#                   "named" nameservers, this can be overridden by the presence
38#                   of the file "named.port" in the server directory containing
39#                   the number of the query port.)
40#
41#   --taskset cpus  Use taskset to signal which cpus can be used. For example
42#                   cpus=fff0 means all cpus aexcept for 0, 1, 2, and 3 are
43#                   eligible.
44#
45#   test            Name of the test directory.
46#
47#   server          Name of the server directory.  This will be of the form
48#                   "nsN" or "ansN", where "N" is an integer between 1 and 8.
49#                   If not given, the script will start all the servers in the
50#                   test directory.
51#
52#   options         Alternate options for the server.
53#
54#                   NOTE: options must be specified with '-- "<option list>"',
55#                   for instance: start.pl . ns1 -- "-c n.conf -d 43"
56#
57#                   ALSO NOTE: this variable will be filled with the contents
58#                   of the first non-commented/non-blank line of args in a file
59#                   called "named.args" in an ns*/ subdirectory. Only the FIRST
60#                   non-commented/non-blank line is used (everything else in
61#                   the file is ignored). If "options" is already set, then
62#                   "named.args" is ignored.
63
64my $usage = "usage: $0 [--noclean] [--restart] [--port <port>] [--taskset <cpus>] test-directory [server-directory [server-options]]";
65my $clean = 1;
66my $restart = 0;
67my $queryport = 5300;
68my $taskset = "";
69
70GetOptions(
71	'clean!'    => \$clean,
72	'restart!'  => \$restart,
73	'port=i'    => \$queryport,
74	'taskset=s' => \$taskset,
75) or die "$usage\n";
76
77my( $test, $server_arg, $options_arg ) = @ARGV;
78
79if (!$test) {
80	die "$usage\n";
81}
82
83# Global variables
84my $builddir = $ENV{'builddir'};
85my $srcdir = $ENV{'srcdir'};
86my $testdir = "$builddir/$test";
87
88if (! -d $testdir) {
89	die "No test directory: \"$testdir\"\n";
90}
91
92if ($server_arg && ! -d "$testdir/$server_arg") {
93	die "No server directory: \"$testdir/$server_arg\"\n";
94}
95
96my $NAMED = $ENV{'NAMED'};
97my $DIG = $ENV{'DIG'};
98my $PERL = $ENV{'PERL'};
99my $PYTHON = $ENV{'PYTHON'};
100
101# Start the server(s)
102
103my @ns;
104my @ans;
105
106if ($server_arg) {
107	if ($server_arg =~ /^ns/) {
108		push(@ns, $server_arg);
109	} elsif ($server_arg =~ /^ans/) {
110		push(@ans, $server_arg);
111	} else {
112		print "$0: ns or ans directory expected";
113		print "I:$test:failed";
114	}
115} else {
116	# Determine which servers need to be started for this test.
117	opendir DIR, $testdir or die "unable to read test directory: \"$test\" ($OS_ERROR)\n";
118	my @files = sort readdir DIR;
119	closedir DIR;
120
121	@ns = grep /^ns[0-9]*$/, @files;
122	@ans = grep /^ans[0-9]*$/, @files;
123}
124
125# Start the servers we found.
126
127foreach my $name(@ns) {
128	&check_ns_port($name);
129	&start_ns_server($name, $options_arg);
130	&verify_ns_server($name);
131}
132
133foreach my $name(@ans) {
134	&start_ans_server($name);
135}
136
137# Subroutines
138
139sub read_ns_port {
140	my ( $server ) = @_;
141	my $port = $queryport;
142	my $options = "";
143
144	if ($server) {
145		my $file = $testdir . "/" . $server . "/named.port";
146
147		if (-e $file) {
148			open(my $fh, "<", $file) or die "unable to read ports file \"$file\" ($OS_ERROR)";
149
150			my $line = <$fh>;
151
152			if ($line) {
153				chomp $line;
154				$port = $line;
155			}
156		}
157	}
158	return ($port);
159}
160
161sub check_ns_port {
162	my ( $server ) = @_;
163	my $options = "";
164	my $port = read_ns_port($server);
165
166	if ($server =~ /(\d+)$/) {
167		$options = "-i $1";
168	}
169
170	my $tries = 0;
171
172	while (1) {
173		my $return = system("$PERL $srcdir/testsock.pl -p $port $options");
174
175		if ($return == 0) {
176			last;
177		}
178
179		$tries++;
180
181		if ($tries > 4) {
182			print "$0: could not bind to server addresses, still running?\n";
183			print "I:$test:server sockets not available\n";
184			print "I:$test:failed\n";
185
186			system("$PERL $srcdir/stop.pl $test"); # Is this the correct behavior?
187
188			exit 1;
189		}
190
191		print "I:$test:Couldn't bind to socket (yet)\n";
192		sleep 2;
193	}
194}
195
196sub start_server {
197	my ( $server, $command, $pid_file ) = @_;
198
199	chdir "$testdir/$server" or die "unable to chdir \"$testdir/$server\" ($OS_ERROR)\n";
200
201	# start the server
202	my $child = `$command`;
203	chomp($child);
204
205	# wait up to 25 seconds for the server to start and to write the
206	# pid file otherwise kill this server and any others that have
207	# already been started
208	my $tries = 0;
209	while (!-s $pid_file) {
210		if (++$tries > 250) {
211			print "I:$test:Couldn't start server $command (pid=$child)\n";
212			print "I:$test:failed\n";
213			kill "ABRT", $child if ("$child" ne "");
214			chdir "$testdir";
215			system "$PERL $srcdir/stop.pl $test";
216			exit 1;
217		}
218		sleep 0.1;
219	}
220
221	# go back to the top level directory
222	chdir $builddir;
223}
224
225sub construct_ns_command {
226	my ( $server, $options ) = @_;
227
228	my $command;
229
230	if ($ENV{'USE_VALGRIND'}) {
231		$command = "valgrind -q --gen-suppressions=all --num-callers=48 --fullpath-after= --log-file=named-$server-valgrind-%p.log ";
232
233		if ($ENV{'USE_VALGRIND'} eq 'helgrind') {
234			$command .= "--tool=helgrind ";
235		} else {
236			$command .= "--tool=memcheck --track-origins=yes --leak-check=full ";
237		}
238
239		$command .= "$NAMED -m none ";
240	} else {
241		if ($taskset) {
242			$command = "taskset $taskset $NAMED ";
243		} else {
244			$command = "$NAMED ";
245		}
246	}
247
248	my $args_file = $testdir . "/" . $server . "/" . "named.args";
249
250	if ($options) {
251		$command .= $options;
252	} elsif (-e $args_file) {
253		open(my $fh, "<", $args_file) or die "unable to read args_file \"$args_file\" ($OS_ERROR)\n";
254
255		while(my $line=<$fh>) {
256			next if ($line =~ /^\s*$/); #discard blank lines
257			next if ($line =~ /^\s*#/); #discard comment lines
258
259			chomp $line;
260
261			$line =~ s/#.*$//;
262
263			$command .= $line;
264
265			last;
266		}
267	} else {
268		$command .= "-D $test-$server ";
269		$command .= "-X named.lock ";
270		$command .= "-m record ";
271
272		foreach my $t_option(
273			"dropedns", "ednsformerr", "ednsnotimp", "ednsrefused",
274			"noaa", "noedns", "nosoa", "maxudp512", "maxudp1460",
275		    ) {
276			if (-e "$testdir/$server/named.$t_option") {
277				$command .= "-T $t_option "
278			}
279		}
280
281		$command .= "-c named.conf -d 99 -g -U 4 -T maxcachesize=2097152";
282	}
283
284	if (-e "$testdir/$server/named.notcp") {
285		$command .= " -T notcp"
286	}
287
288	if ($restart) {
289		$command .= " >>named.run 2>&1 &";
290	} else {
291		$command .= " >named.run 2>&1 &";
292	}
293
294	# get the shell to report the pid of the server ($!)
295	$command .= " echo \$!";
296
297	return $command;
298}
299
300sub start_ns_server {
301	my ( $server, $options ) = @_;
302
303	my $cleanup_files;
304	my $command;
305	my $pid_file;
306
307	$cleanup_files = "{./*.jnl,./*.bk,./*.st,./named.run}";
308
309	$command = construct_ns_command($server, $options);
310
311	$pid_file = "named.pid";
312
313	if ($clean) {
314		unlink glob $cleanup_files;
315	}
316
317	start_server($server, $command, $pid_file);
318}
319
320sub construct_ans_command {
321	my ( $server, $options ) = @_;
322
323	my $command;
324	my $n;
325
326	if ($server =~ /^ans(\d+)/) {
327		$n = $1;
328	} else {
329		die "unable to parse server number from name \"$server\"\n";
330	}
331
332	if (-e "$testdir/$server/ans.py") {
333		$command = "$PYTHON -u ans.py 10.53.0.$n $queryport";
334	} elsif (-e "$testdir/$server/ans.pl") {
335		$command = "$PERL ans.pl";
336	} else {
337		$command = "$PERL $srcdir/ans.pl 10.53.0.$n";
338	}
339
340	if ($options) {
341		$command .= $options;
342	}
343
344	if ($restart) {
345		$command .= " >>ans.run 2>&1 &";
346	} else {
347		$command .= " >ans.run 2>&1 &";
348	}
349
350	# get the shell to report the pid of the server ($!)
351	$command .= " echo \$!";
352
353	return $command;
354}
355
356sub start_ans_server {
357	my ( $server, $options ) = @_;
358
359	my $cleanup_files;
360	my $command;
361	my $pid_file;
362
363	$cleanup_files = "{./ans.run}";
364	$command = construct_ans_command($server, $options);
365	$pid_file = "ans.pid";
366
367	if ($clean) {
368		unlink glob $cleanup_files;
369	}
370
371	start_server($server, $command, $pid_file);
372}
373
374sub verify_ns_server {
375	my ( $server ) = @_;
376
377	my $tries = 0;
378
379	my $runfile = "$testdir/$server/named.run";
380
381	while (1) {
382		# the shell *ought* to have created the file immediately, but this
383		# logic allows the creation to be delayed without issues
384		if (open(my $fh, "<", $runfile)) {
385			# the two non-whitespace blobs should be the date and time
386			# but we don't care about them really, only that they are there
387			if (grep /^\S+ \S+ running\R/, <$fh>) {
388				last;
389			}
390		}
391
392		$tries++;
393
394		if ($tries >= 30) {
395			print "I:$test:server $server seems to have not started\n";
396			print "I:$test:failed\n";
397
398			system("$PERL $srcdir/stop.pl $test");
399
400			exit 1;
401		}
402
403		sleep 2;
404	}
405
406	$tries = 0;
407
408	my $port = read_ns_port($server);
409	my $tcp = "+tcp";
410	my $n;
411
412	if ($server =~ /^ns(\d+)/) {
413		$n = $1;
414	} else {
415		die "unable to parse server number from name \"$server\"\n";
416	}
417
418	if (-e "$testdir/$server/named.notcp") {
419		$tcp = "";
420	}
421
422	while (1) {
423		my $return = system("$DIG $tcp +noadd +nosea +nostat +noquest +nocomm +nocmd +noedns -p $port version.bind. chaos txt \@10.53.0.$n > /dev/null");
424
425		last if ($return == 0);
426
427		$tries++;
428
429		if ($tries >= 30) {
430			print "I:$test:no response from $server\n";
431			print "I:$test:failed\n";
432
433			system("$PERL $srcdir/stop.pl $test");
434
435			exit 1;
436		}
437
438		sleep 2;
439	}
440}
441