X-Git-Url: http://git.pk910.de/?p=ircu2.10.12-pk.git;a=blobdiff_plain;f=tools%2Fiauth-test;fp=tools%2Fiauth-test;h=c3dd1f25e15b7d3fd482c94dcf49b02889b2b2c2;hp=0000000000000000000000000000000000000000;hb=0400a5a6479398d82526785c18c0df8bc8b92dce;hpb=d17e10da972ce5776c60b4c317267c6abe0e1ead diff --git a/tools/iauth-test b/tools/iauth-test new file mode 100755 index 0000000..c3dd1f2 --- /dev/null +++ b/tools/iauth-test @@ -0,0 +1,254 @@ +#! /usr/bin/perl +# iauth-test: test script for IRC authorization (iauth) protocol +# Copyright 2006 Michael Poole +# +# This program is free software; you can redistribute it and/or modify +# it under the terms of the GNU General Public License version 2 as +# published by the Free Software Foundation. + +require 5.008; # We assume deferred signal handlers, new in 5.008. +use strict; +use warnings; +use vars qw(%pending); + +use Config; # for $Config{sig_name} and $Config{sig_num} +use FileHandle; # for autoflush method on file handles + +# This script is intended to help test an implementation of the iauth +# protocol by exercising every command in the protocol and by +# exercising most distinct combinations of commands. It assumes IPv4 +# support in the server and POSIX real-time signal support in the OS +# (recognized and supported by Perl). + +# Certain behavior is triggered by receipt of real-time signals. +# SIGRTMIN + 0 -> Send server notice ('>'). +# SIGRTMIN + 1 -> Toggle debug level ('G'). +# SIGRTMIN + 2 -> Set policy options ('O'). +# SIGRTMIN + 3 -> Simulate config change ('a', 'A'). +# SIGRTMIN + 4 -> Simulate statistics change ('s', 'S'). +# Note that Perl's value for SIGRTMIN may be different than your OS's. +# The easiest check is by running "perl -V:sig_num -V:sig_name". + +# In the following discussion, sX means message X from the server, and +# iX means message X from iauth. The hard part is the ordering of +# various events during client registration. This includes sC, sP, +# sU, su, sn, sN/d, sH and sT; and o/U/u, iN, iI, iC and iD/R/k/K. + +# sC is first, sD/sT/iD/R/k/K is last. If sH is sent, no more sU, su, +# sn, sN, sd or sH messages may be sent. If iI is sent, iN should +# also be sent (either before or after iI). Multiple sP, sU and iC +# messages may be sent. Otherwse, the ordering of unrelated messages +# from either source are not constrained, but only one message from +# each set of alternatives may be sent. + +# This means the sets of commands with interesting orderings are: +# sU, su, io/U/u +# sN/d, iN, iI +# sH, sT or iD/R/k/K + +# 127.x.y.z IP addresses are used to exercise these orderings; see the +# %handlers variable below. + +sub dolog ($) { + print LOG "$_[0]\n"; +} + +sub reply ($;$$) { + my ($msg, $client, $extra) = @_; + + if (not defined $msg) { + # Accept this for easier handling of client reply messages. + return; + } elsif (ref $msg eq '') { + $msg =~ s/^(.) ?/$1 $client->{id} $client->{ip} $client->{port} / if $client; + dolog "< $msg"; + print "$msg\n"; + } elsif (ref $msg eq 'ARRAY') { + grep { reply($_, $client, $extra); } @$msg; + } elsif (ref $msg eq 'CODE') { + &$msg($client, $extra); + } else { + die "Unknown reply message type."; + } +} + +# Find the names of signals with values SIGRTMIN+1, +2, etc. +BEGIN { + my @sig_name; + my %sig_num; + + sub populate_signals () { + die "No sigs?" + unless $Config{sig_name} and $Config{sig_num}; + my @names = split ' ', $Config{sig_name}; + @sig_num{@names} = split ' ', $Config{sig_num}; + foreach (@names) { $sig_name[$sig_num{$_}] ||= $_; } + } + + sub assign_signal_handlers() { + my $sigrtmin = $sig_num{RTMIN}; + die "No realtime signals?" + unless $sigrtmin; + $SIG{$sig_name[$sigrtmin+0]} = \&send_server_notice; + $SIG{$sig_name[$sigrtmin+1]} = \&toggle_debug_level; + $SIG{$sig_name[$sigrtmin+2]} = \&set_policy_options; + $SIG{$sig_name[$sigrtmin+3]} = \&sim_config_changed; + $SIG{$sig_name[$sigrtmin+4]} = \&sim_stats_change; + } +} + +BEGIN { + my $debug_level = 0; + my $max_debug_level = 2; + + sub toggle_debug_level () { + if (++$debug_level > $max_debug_level) { + $debug_level = 0; + } + reply "G $debug_level"; + } +} + +BEGIN { + my %rotation = ( + '' => 'AU', + 'AU' => 'AURTW', + 'AURTW' => '', + ); + my $policy = ''; + + sub set_policy_options () { + $policy = $rotation{$policy}; + reply "O $policy"; + } +} + +BEGIN { + my $generation = 0; + + sub sim_config_changed () { + reply "a"; + reply "A config $generation"; + $generation++; + } +} + +BEGIN { + my $generation = 0; + + sub sim_stats_change () { + reply "s"; + reply "S stats $generation"; + $generation++; + } +} + +sub send_server_notice () { + reply "> :Hello the server!"; +} + +my %handlers = ( + # Default handliner: immediately report done. + 'default' => { C_reply => 'D' }, + # 127.0.0.x: various timings for iD/iR/ik/iK. + '127.0.0.1' => { C_reply => 'D' }, + '127.0.0.2' => { C_reply => 'R account-1' }, + '127.0.0.3' => { C_reply => 'k' }, + '127.0.0.4' => { C_reply => 'K' }, + '127.0.0.5' => { C_reply => 'D Specials' }, + '127.0.0.6' => { C_reply => 'R account-1 Specials' }, + '127.0.0.15' => { }, + '127.0.0.16' => { H_reply => 'D' }, + '127.0.0.17' => { H_reply => 'R account-2' }, + '127.0.0.18' => { H_reply => 'k' }, + '127.0.0.19' => { H_reply => 'K' }, + '127.0.0.32' => { T_reply => 'D' }, + '127.0.0.33' => { T_reply => 'R account-3' }, + '127.0.0.34' => { T_reply => 'k' }, + '127.0.0.35' => { T_reply => 'K' }, + # 127.0.1.x: io/iU/iu/iM functionality. + '127.0.1.0' => { C_reply => 'o forced', + H_reply => 'D' }, + '127.0.1.1' => { C_reply => 'U trusted', + H_reply => 'D' }, + '127.0.1.2' => { C_reply => 'u untrusted', + H_reply => 'D' }, + '127.0.1.3' => { C_reply => 'M +i', + H_reply => 'D' }, + # 127.0.2.x: iI/iN functionality. + '127.0.2.0' => { C_reply => 'N iauth.assigned.host', + H_reply => 'D' }, + '127.0.2.1' => { C_reply => \&ip_change }, + '127.0.2.2' => { H_reply => \&host_change_and_done }, + # 127.0.3.x: iC/sP functionality. + '127.0.3.0' => { C_reply => 'C :Please enter the password.', + P_reply => \&passwd_check }, +); + +sub handle_new_client ($$$$) { + my ($id, $ip, $port, $extra) = @_; + my $handler = $handlers{$ip} || $handlers{default}; + my $client = { id => $id, ip => $ip, port => $port, handler => $handler }; + + # If we have any deferred reply handlers, we must save the client. + $pending{$id} = $client if grep /^[^C]_reply$/, keys %$handler; + reply $client->{handler}->{C_reply}, $client, $extra; +} + +sub ip_change ($$) { + my ($client, $extra) = @_; + reply 'I 127.255.255.254', $client; + $client->{ip} = '127.255.255.254'; + reply 'N other.assigned.host', $client; + reply 'D', $client; +} + +# Note to potential debuggers: You will have to change the iauth +# policy before this (or any other H_reply hooks) will have any +# effect. Do this by sending two signals of $SIG{RTMIN+2} to the +# iauth-test process, as noted near the beginning of this script. +sub host_change_and_done ($$) { + my ($client, $extra) = @_; + reply 'N iauth.assigned.host', $client; + reply 'D', $client; +} + +sub passwd_check ($$) { + my ($client, $extra) = @_; + if ($extra eq 'secret') { + reply 'D', $client; + } else { + reply 'C :Bad password', $client; + } +} + +open LOG, ">> iauth.log"; +populate_signals(); +assign_signal_handlers(); +autoflush LOG 1; +autoflush STDOUT 1; +autoflush STDERR 1; +dolog "IAuth starting " . scalar(localtime(time)); + +while (<>) { + my ($id, $client); + + # Chomp newline and log incoming message. + s/\r?\n?\r?$//; + dolog "> $_"; + + # If there's an ID at the start of the line, parse it out. + if (s/^(\d+) //) { $id = $1; $client = $pending{$id}; } + + # Figure out how to handle the command. + if (/^C (\S+) (\S+) (.+)$/) { + handle_new_client($id, $1, $2, $3); + } elsif (/^([DT])/ and $client) { + reply $client->{handler}->{"${1}_reply"}, $client; + delete $pending{$id}; + } elsif (/^([d])/ and $client) { + reply $client->{handler}->{"${1}_reply"}, $client; + } elsif (/^([HNPUu]) (.+)/ and $client) { + reply $client->{handler}->{"${1}_reply"}, $client, $2; + } +}