xref: /openbsd/regress/usr.sbin/syslogd/funcs.pl (revision 508def2a) 
1#	$OpenBSD: funcs.pl,v 1.41 2024/06/14 15:12:57 bluhm Exp $
2
3# Copyright (c) 2010-2021 Alexander Bluhm <bluhm@openbsd.org>
4#
5# Permission to use, copy, modify, and distribute this software for any
6# purpose with or without fee is hereby granted, provided that the above
7# copyright notice and this permission notice appear in all copies.
8#
9# THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
10# WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
11# MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
12# ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
13# WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
14# ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
15# OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
16
17use strict;
18use warnings;
19use Errno;
20use List::Util qw(first);
21use Socket;
22use Socket6;
23use Sys::Syslog qw(:standard :extended :macros);
24use Time::HiRes 'sleep';
25use IO::Socket;
26use IO::Socket::SSL;
27
28my $firstlog = "syslogd regress test first message";
29my $secondlog = "syslogd regress test second message";
30my $thirdlog = "syslogd regress test third message";
31my $testlog = "syslogd regress test log message";
32my $downlog = "syslogd regress client shutdown";
33my $charlog = "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz";
34
35sub find_ports {
36	my %args = @_;
37	my $num    = delete $args{num}    // 1;
38	my $domain = delete $args{domain} // AF_INET;
39	my $addr   = delete $args{addr}   // "127.0.0.1";
40	my $proto  = delete $args{proto}  // "udp";
41	$proto = "tcp" if $proto eq "tls";
42
43	my @sockets = (1..$num);
44	foreach my $s (@sockets) {
45		$s = IO::Socket::IP->new(
46		    Domain    => $domain,
47		    LocalAddr => $addr,
48		    Proto     => $proto,
49		) or die "find_ports: create and bind socket failed: $!";
50	}
51	my @ports = map { $_->sockport() } @sockets;
52
53	return wantarray ? @ports : $ports[0];
54}
55
56########################################################################
57# Client funcs
58########################################################################
59
60sub write_log {
61	my $self = shift;
62
63	write_message($self, $testlog);
64	IO::Handle::flush(\*STDOUT);
65	${$self->{syslogd}}->loggrep($testlog, 2);
66	write_shutdown($self);
67}
68
69sub write_between2logs {
70	my $self = shift;
71	my $func = shift;
72
73	write_message($self, $firstlog);
74	$func->($self, @_);
75	write_message($self, $testlog);
76	IO::Handle::flush(\*STDOUT);
77	${$self->{syslogd}}->loggrep($testlog, 2);
78	write_shutdown($self);
79}
80
81sub write_message {
82	my $self = shift;
83
84	if (defined($self->{connectdomain})) {
85		my $msg = join("", @_);
86		if ($self->{connectdomain} eq "sendsyslog") {
87			my $flags = $self->{connect}{flags} || 0;
88			sendsyslog($msg, $flags)
89			    or die ref($self), " sendsyslog failed: $!";
90		} elsif ($self->{connectproto} eq "udp") {
91			# writing UDP packets works only with syswrite()
92			defined(my $n = syswrite(STDOUT, $msg))
93			    or die ref($self), " write log line failed: $!";
94			$n == length($msg)
95			    or die ref($self), " short UDP write";
96		} else {
97			print $msg;
98			print "\n" if $self->{connectproto} =~ /^(tcp|tls)$/;
99		}
100		print STDERR "<<< $msg\n";
101	} else {
102		syslog(LOG_INFO, @_);
103	}
104}
105
106sub sendsyslog {
107	my $msg = shift;
108	my $flags = shift;
109	require 'sys/syscall.ph';
110	return syscall(&SYS_sendsyslog, $msg, length($msg), $flags) != -1;
111}
112
113sub write_shutdown {
114	my $self = shift;
115
116	setlogsock("native")
117	    or die ref($self), " setlogsock native failed: $!";
118	syslog(LOG_NOTICE, $downlog);
119
120	if (defined($self->{connectdomain}) &&
121	    $self->{connectproto} eq "tls" &&
122	    $self->{exit}) {
123		# Due to missing handshakes TLS 1.3 cannot detect all
124		# connection errors while writing.  Try to read.
125		defined(read(STDIN, my $buf, 1))
126		    or die ref($self), " error after shutdown: $!,$SSL_ERROR";
127	}
128}
129
130sub write_lines {
131	my $self = shift;
132	my ($lines, $length) = @_;
133
134	foreach (1..$lines) {
135		write_chars($self, $length, " $_");
136	}
137}
138
139sub write_lengths {
140	my $self = shift;
141	my ($lengths, $tail) = ref $_[0] ? @_ : [@_];
142
143	write_chars($self, $lengths, $tail);
144}
145
146sub generate_chars {
147	my ($len) = @_;
148
149	my $msg = "";
150	my $char = '0';
151	for (my $i = 0; $i < $len; $i++) {
152		$msg .= $char;
153		if    ($char =~ /9/) { $char = 'A' }
154		elsif ($char =~ /Z/) { $char = 'a' }
155		elsif ($char =~ /z/) { $char = '0' }
156		else                 { $char++ }
157	}
158	return $msg;
159}
160
161sub write_chars {
162	my $self = shift;
163	my ($length, $tail) = @_;
164
165	foreach my $len (ref $length ? @$length : $length) {
166		my $t = $tail // "";
167		substr($t, 0, length($t) - $len, "")
168		    if length($t) && length($t) > $len;
169		my $msg = generate_chars($len - length($t));
170		$msg .= $t if length($t);
171		write_message($self, $msg);
172		# if client is sending too fast, syslogd will not see everything
173		sleep .01;
174	}
175}
176
177sub write_unix {
178	my $self = shift;
179	my $path = shift || "/dev/log";
180	my $id = shift // $path;
181
182	my $u = IO::Socket::UNIX->new(
183	    Type  => SOCK_DGRAM,
184	    Peer => $path,
185	) or die ref($self), " connect to $path unix socket failed: $!";
186	my $msg = "id $id unix socket: $testlog";
187	print $u $msg;
188	print STDERR "<<< $msg\n";
189}
190
191sub write_tcp {
192	my $self = shift;
193	my $fh = shift || \*STDOUT;
194	my $id = shift // $fh;
195
196	my $msg = "id $id tcp socket: $testlog";
197	print $fh "$msg\n";
198	print STDERR "<<< $msg\n";
199}
200
201sub redo_connect {
202	my $self = shift;
203	my $func = shift;
204
205	$func->($self, @_);
206	if ($self->{cs}) {
207		# wait for possible icmp errors, port is open
208		sleep .1;
209		close(delete $self->{cs})
210		    or die ref($self), " close failed: $!";
211		delete $self->{ts};
212	}
213	if (my $redo = shift @{$self->{redo}}) {
214		if (my $connect = $redo->{connect}) {
215			delete $self->{logsock};
216			$self->{connectdomain} = $connect->{domain};
217			$self->{connectaddr}   = $connect->{addr};
218			$self->{connectproto}  = $connect->{proto};
219			$self->{connectport}   = $connect->{port};
220		} elsif (my $logsock = $redo->{logsock}) {
221			delete $self->{connectdomain};
222			delete $self->{connectaddr};
223			delete $self->{connectproto};
224			delete $self->{connectport};
225			$self->{logsock} = $logsock;
226		} else {
227			die ref($self), " no connect or logsock in redo";
228		}
229	} else {
230		delete $self->{connectdomain};
231		delete $self->{connectaddr};
232		delete $self->{connectproto};
233		delete $self->{connectport};
234		$self->{logsock} = { type => "native" };
235		setlogsock($self->{logsock})
236		    or die ref($self), " setlogsock failed: $!";
237		sleep .1;
238		write_log($self);
239		undef $self->{redo};
240	}
241}
242
243########################################################################
244# Server funcs
245########################################################################
246
247sub read_log {
248	my $self = shift;
249
250	read_message($self, $downlog);
251}
252
253sub read_between2logs {
254	my $self = shift;
255	my $func = shift;
256
257	read_message($self, $firstlog);
258	$func->($self, @_);
259	read_message($self, $testlog);
260	read_message($self, $downlog);
261}
262
263sub accept_between2logs {
264	my $self = shift;
265	my $func = shift;
266
267	unless ($self->{redo}) {
268		read_message($self, $firstlog);
269		$func->($self, @_);
270		$self->{redo} = 1;
271	} else {
272		$self->{redo} = 0;
273		read_message($self, $testlog);
274		read_message($self, $downlog);
275	}
276}
277
278sub read_message {
279	my $self = shift;
280	my $regex = shift;
281
282	local $_;
283	for (;;) {
284		if ($self->{listenproto} eq "udp") {
285			# reading UDP packets works only with sysread()
286			defined(my $n = sysread(STDIN, $_, 8194))
287			    or die ref($self), " read log line failed: $!";
288			last if $n == 0;
289		} else {
290			defined($_ = <STDIN>)
291			    or last;
292		}
293		chomp;
294		print STDERR ">>> $_\n";
295		last if /$regex/;
296	}
297}
298
299########################################################################
300# Script funcs
301########################################################################
302
303sub get_testlog {
304	return $testlog;
305}
306
307sub get_testgrep {
308	return qr/$testlog\r*$/;
309}
310
311sub get_firstlog {
312	return $firstlog;
313}
314
315sub get_secondlog {
316	return $secondlog;
317}
318
319sub get_thirdlog {
320	return $thirdlog;
321}
322
323sub get_charlog {
324	# add a space so that we match at the beginning of the message
325	return " $charlog";
326}
327
328sub get_between2loggrep {
329	return (
330	    qr/$firstlog/ => 1,
331	    qr/$testlog/ => 1,
332	);
333}
334
335sub get_downlog {
336	return $downlog;
337}
338
339sub selector2config {
340    my %s2m = @_;
341    my $conf = "";
342    my $i = 0;
343    foreach my $sel (sort keys %s2m) {
344	$conf .= "$sel\t\$objdir/file-$i.log\n";
345	$i++;
346    }
347    return $conf;
348}
349
350sub selector2loggrep {
351    my %s2m = @_;
352    my %allmsg;
353    @allmsg{map { @$_} values %s2m} = ();
354    my @loggrep;
355    foreach my $sel (sort keys %s2m) {
356	my @m = @{$s2m{$sel}};
357	my %msg;
358	$msg{$_}++ foreach (@m);
359	my %nomsg = %allmsg;
360	delete @nomsg{@m};
361	push @loggrep, {
362	    (map { qr/: $_$/ => $msg{$_} } sort keys %msg),
363	    (map { qr/: $_$/ => 0 } sort keys %nomsg),
364	};
365    }
366    return @loggrep;
367}
368
369sub check_logs {
370	my ($c, $r, $s, $m, %args) = @_;
371
372	return if $args{nocheck};
373
374	check_log($c, $r, $s, @$m);
375	check_out($r, %args);
376	check_fstat($c, $r, $s);
377	check_ktrace($c, $r, $s);
378	if (my $file = $s->{"outfile"}) {
379		my $pattern = $s->{filegrep} || get_testgrep();
380		check_pattern(ref $s, $file, $pattern, \&filegrep);
381	}
382	check_multifile(@{$args{multifile} || []});
383}
384
385sub compare($$) {
386	local $_ = $_[1];
387	if (/^\d+/) {
388		return $_[0] == $_;
389	} elsif (/^==(\d+)/) {
390		return $_[0] == $1;
391	} elsif (/^!=(\d+)/) {
392		return $_[0] != $1;
393	} elsif (/^>=(\d+)/) {
394		return $_[0] >= $1;
395	} elsif (/^<=(\d+)/) {
396		return $_[0] <= $1;
397	} elsif (/^~(\d+)/) {
398		return $1 * 0.8 <= $_[0] && $_[0] <= $1 * 1.2;
399	}
400	die "bad compare operator: $_";
401}
402
403sub check_pattern {
404	my ($name, $proc, $pattern, $func) = @_;
405
406	$pattern = [ $pattern ] unless ref($pattern) eq 'ARRAY';
407	foreach my $pat (@$pattern) {
408		if (ref($pat) eq 'HASH') {
409			foreach my $re (sort keys %$pat) {
410				my $num = $pat->{$re};
411				my @matches = $func->($proc, $re);
412				compare(@matches, $num)
413				    or die "$name matches '@matches': ",
414				    "'$re' => $num";
415			}
416		} else {
417			$func->($proc, $pat)
418			    or die "$name log missing pattern: $pat";
419		}
420	}
421}
422
423sub check_log {
424	foreach my $proc (@_) {
425		next unless $proc && !$proc->{nocheck};
426		my $pattern = $proc->{loggrep} || get_testgrep();
427		check_pattern(ref $proc, $proc, $pattern, \&loggrep);
428	}
429}
430
431sub loggrep {
432	my ($proc, $pattern) = @_;
433
434	return $proc->loggrep($pattern);
435}
436
437sub check_out {
438	my ($r, %args) = @_;
439
440	unless ($args{pipe}{nocheck}) {
441		$r->loggrep("bytes transferred", 1) or sleep 1;
442	}
443	foreach my $dev (qw(console user)) {
444		$args{$dev}{nocheck} ||= $args{tty}{nocheck};
445		$args{$dev}{loggrep} ||= $args{tty}{loggrep};
446		next if $args{$dev}{nocheck};
447		my $ctl = $r->{"ctl$dev"};
448		close($ctl);
449		my $file = $r->{"out$dev"};
450		open(my $fh, '<', $file)
451		    or die "Open file $file for reading failed: $!";
452		grep { /^logout/ or /^console .* off/ } <$fh> or sleep 1;
453		close($fh);
454	}
455
456	foreach my $name (qw(file pipe console user)) {
457		next if $args{$name}{nocheck};
458		my $file = $r->{"out$name"} or die;
459		my $pattern = $args{$name}{loggrep} || get_testgrep();
460		check_pattern($name, $file, $pattern, \&filegrep);
461	}
462}
463
464sub check_fstat {
465	foreach my $proc (@_) {
466		my $pattern = $proc && $proc->{fstat} or next;
467		my $file = $proc->{fstatfile} or die;
468		check_pattern("fstat", $file, $pattern, \&filegrep);
469	}
470}
471
472sub filegrep {
473	my ($file, $pattern) = @_;
474
475	open(my $fh, '<', $file)
476	    or die "Open file $file for reading failed: $!";
477	return wantarray ?
478	    grep { /$pattern/ } <$fh> : first { /$pattern/ } <$fh>;
479}
480
481sub check_ktrace {
482	foreach my $proc (@_) {
483		my $pattern = $proc && $proc->{ktrace} or next;
484		my $file = $proc->{ktracefile} or die;
485		check_pattern("ktrace", $file, $pattern, \&kdumpgrep);
486	}
487}
488
489sub kdumpgrep {
490	my ($file, $pattern) = @_;
491
492	my @sudo = ! -r $file && $ENV{SUDO} ? $ENV{SUDO} : ();
493	my @cmd = (@sudo, "kdump", "-f", $file);
494	open(my $fh, '-|', @cmd)
495	    or die "Open pipe from '@cmd' failed: $!";
496	my @matches = grep { /$pattern/ } <$fh>;
497	close($fh) or die $! ?
498	    "Close pipe from '@cmd' failed: $!" :
499	    "Command '@cmd' failed: $?";
500	return wantarray ? @matches : $matches[0];
501}
502
503sub create_multifile {
504	for (my $i = 0; $i < @_; $i++) {
505		my $file = "file-$i.log";
506		open(my $fh, '>', $file)
507		    or die "Create $file failed: $!";
508	}
509}
510
511sub check_multifile {
512	for (my $i = 0; $i < @_; $i++) {
513		my $file = "file-$i.log";
514		my $pattern = $_[$i]{loggrep} or die;
515		check_pattern("multifile $i", $file, $pattern, \&filegrep);
516	}
517}
518
5191;
520