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