tools/iauth-test

   1 #! /usr/bin/perl
   2 # iauth-test: test script for IRC authorization (iauth) protocol
   3 # Copyright 2006 Michael Poole
   4 #
   5 # This program is free software; you can redistribute it and/or modify
   6 # it under the terms of the GNU General Public License version 2 as
   7 # published by the Free Software Foundation.
   8
   9 require 5.008; # We assume deferred signal handlers, new in 5.008.
  10 use strict;
  11 use warnings;
  12 use vars qw(%pending);
  13
  14 use Config;     # for $Config{sig_name} and $Config{sig_num}
  15 use FileHandle; # for autoflush method on file handles
  16
  17 # This script is intended to help test an implementation of the iauth
  18 # protocol by exercising every command in the protocol and by
  19 # exercising most distinct combinations of commands.  It assumes IPv4
  20 # support in the server and POSIX real-time signal support in the OS
  21 # (recognized and supported by Perl).
  22
  23 # Certain behavior is triggered by receipt of real-time signals.
  24 # SIGRTMIN + 0 -> Send server notice ('>').
  25 # SIGRTMIN + 1 -> Toggle debug level ('G').
  26 # SIGRTMIN + 2 -> Set policy options ('O').
  27 # SIGRTMIN + 3 -> Simulate config change ('a', 'A').
  28 # SIGRTMIN + 4 -> Simulate statistics change ('s', 'S').
  29 # Note that Perl's value for SIGRTMIN may be different than your OS's.
  30 # The easiest check is by running "perl -V:sig_num -V:sig_name".
  31
  32 # In the following discussion, sX means message X from the server, and
  33 # iX means message X from iauth.  The hard part is the ordering of
  34 # various events during client registration.  This includes sC, sP,
  35 # sU, su, sn, sN/d, sH and sT; and o/U/u, iN, iI, iC and iD/R/k/K.
  36
  37 # sC is first, sD/sT/iD/R/k/K is last.  If sH is sent, no more sU, su,
  38 # sn, sN, sd or sH messages may be sent.  If iI is sent, iN should
  39 # also be sent (either before or after iI).  Multiple sP, sU and iC
  40 # messages may be sent. Otherwse, the ordering of unrelated messages
  41 # from either source are not constrained, but only one message from
  42 # each set of alternatives may be sent.
  43
  44 # This means the sets of commands with interesting orderings are:
  45 # sU, su, io/U/u
  46 # sN/d, iN, iI
  47 # sH, sT or iD/R/k/K
  48
  49 # 127.x.y.z IP addresses are used to exercise these orderings; see the
  50 # %handlers variable below.
  51
  52 sub dolog ($) {
  53     print LOG "$_[0]\n";
  54 }
  55
  56 sub reply ($;$$) {
  57     my ($msg, $client, $extra) = @_;
  58
  59     if (not defined $msg) {
  60         # Accept this for easier handling of client reply messages.
  61         return;
  62     } elsif (ref $msg eq '') {
  63         $msg =~ s/^(.) ?/$1 $client->{id} $client->{ip} $client->{port} / if $client;
  64         dolog "< $msg";
  65         print "$msg\n";
  66     } elsif (ref $msg eq 'ARRAY') {
  67         grep { reply($_, $client, $extra); } @$msg;
  68     } elsif (ref $msg eq 'CODE') {
  69         &$msg($client, $extra);
  70     } else {
  71         die "Unknown reply message type.";
  72     }
  73 }
  74
  75 # Find the names of signals with values SIGRTMIN+1, +2, etc.
  76 BEGIN {
  77     my @sig_name;
  78     my %sig_num;
  79
  80     sub populate_signals () {
  81         die "No sigs?"
  82             unless $Config{sig_name} and $Config{sig_num};
  83         my @names = split ' ', $Config{sig_name};
  84         @sig_num{@names} = split ' ', $Config{sig_num};
  85         foreach (@names) { $sig_name[$sig_num{$_}] ||= $_; }
  86     }
  87
  88     sub assign_signal_handlers() {
  89         my $sigrtmin = $sig_num{RTMIN};
  90         die "No realtime signals?"
  91             unless $sigrtmin;
  92         $SIG{$sig_name[$sigrtmin+0]} = \&send_server_notice;
  93         $SIG{$sig_name[$sigrtmin+1]} = \&toggle_debug_level;
  94         $SIG{$sig_name[$sigrtmin+2]} = \&set_policy_options;
  95         $SIG{$sig_name[$sigrtmin+3]} = \&sim_config_changed;
  96         $SIG{$sig_name[$sigrtmin+4]} = \&sim_stats_change;
  97     }
  98 }
  99
 100 BEGIN {
 101     my $debug_level = 0;
 102     my $max_debug_level = 2;
 103
 104     sub toggle_debug_level () {
 105         if (++$debug_level > $max_debug_level) {
 106             $debug_level = 0;
 107         }
 108         reply "G $debug_level";
 109     }
 110 }
 111
 112 BEGIN {
 113     my %rotation = (
 114         '' => 'AU',
 115         'AU' => 'AURTW',
 116         'AURTW' => '',
 117     );
 118     my $policy = '';
 119
 120     sub set_policy_options () {
 121         $policy = $rotation{$policy};
 122         reply "O $policy";
 123     }
 124 }
 125
 126 BEGIN {
 127     my $generation = 0;
 128
 129     sub sim_config_changed () {
 130         reply "a";
 131         reply "A config $generation";
 132         $generation++;
 133     }
 134 }
 135
 136 BEGIN {
 137     my $generation = 0;
 138
 139     sub sim_stats_change () {
 140         reply "s";
 141         reply "S stats $generation";
 142         $generation++;
 143     }
 144 }
 145
 146 sub send_server_notice () {
 147     reply "> :Hello the server!";
 148 }
 149
 150 my %handlers = (
 151                 # Default handliner: immediately report done.
 152                 'default'    => { C_reply => 'D' },
 153                 # 127.0.0.x: various timings for iD/iR/ik/iK.
 154                 '127.0.0.1'  => { C_reply => 'D' },
 155                 '127.0.0.2'  => { C_reply => 'R account-1' },
 156                 '127.0.0.3'  => { C_reply => 'k' },
 157                 '127.0.0.4'  => { C_reply => 'K' },
 158                 '127.0.0.5'  => { C_reply => 'D Specials' },
 159                 '127.0.0.6'  => { C_reply => 'R account-1 Specials' },
 160                 '127.0.0.15' => { },
 161                 '127.0.0.16' => { H_reply => 'D' },
 162                 '127.0.0.17' => { H_reply => 'R account-2' },
 163                 '127.0.0.18' => { H_reply => 'k' },
 164                 '127.0.0.19' => { H_reply => 'K' },
 165                 '127.0.0.32' => { T_reply => 'D' },
 166                 '127.0.0.33' => { T_reply => 'R account-3' },
 167                 '127.0.0.34' => { T_reply => 'k' },
 168                 '127.0.0.35' => { T_reply => 'K' },
 169                 # 127.0.1.x: io/iU/iu/iM functionality.
 170                 '127.0.1.0'  => { C_reply => 'o forced',
 171                                   H_reply => 'D' },
 172                 '127.0.1.1'  => { C_reply => 'U trusted',
 173                                   H_reply => 'D' },
 174                 '127.0.1.2'  => { C_reply => 'u untrusted',
 175                                   H_reply => 'D' },
 176                 '127.0.1.3'  => { C_reply => 'M +i',
 177                                   H_reply => 'D' },
 178                 # 127.0.2.x: iI/iN functionality.
 179                 '127.0.2.0'  => { C_reply => 'N iauth.assigned.host',
 180                                   H_reply => 'D' },
 181                 '127.0.2.1'  => { C_reply => \&ip_change },
 182                 '127.0.2.2'  => { H_reply => \&host_change_and_done },
 183                 # 127.0.3.x: iC/sP functionality.
 184                 '127.0.3.0'  => { C_reply => 'C :Please enter the password.',
 185                                   P_reply => \&passwd_check },
 186 );
 187
 188 sub handle_new_client ($$$$) {
 189     my ($id, $ip, $port, $extra) = @_;
 190     my $handler = $handlers{$ip} || $handlers{default};
 191     my $client = { id => $id, ip => $ip, port => $port, handler => $handler };
 192
 193     # If we have any deferred reply handlers, we must save the client.
 194     $pending{$id} = $client if grep /^[^C]_reply$/, keys %$handler;
 195     reply $client->{handler}->{C_reply}, $client, $extra;
 196 }
 197
 198 sub ip_change ($$) {
 199     my ($client, $extra) = @_;
 200     reply 'I 127.255.255.254', $client;
 201     $client->{ip} = '127.255.255.254';
 202     reply 'N other.assigned.host', $client;
 203     reply 'D', $client;
 204 }
 205
 206 # Note to potential debuggers: You will have to change the iauth
 207 # policy before this (or any other H_reply hooks) will have any
 208 # effect.  Do this by sending two signals of $SIG{RTMIN+2} to the
 209 # iauth-test process, as noted near the beginning of this script.
 210 sub host_change_and_done ($$) {
 211     my ($client, $extra) = @_;
 212     reply 'N iauth.assigned.host', $client;
 213     reply 'D', $client;
 214 }
 215
 216 sub passwd_check ($$) {
 217     my ($client, $extra) = @_;
 218     if ($extra eq 'secret') {
 219         reply 'D', $client;
 220     } else {
 221         reply 'C :Bad password', $client;
 222     }
 223 }
 224
 225 open LOG, ">> iauth.log";
 226 populate_signals();
 227 assign_signal_handlers();
 228 autoflush LOG 1;
 229 autoflush STDOUT 1;
 230 autoflush STDERR 1;
 231 dolog "IAuth starting " . scalar(localtime(time));
 232
 233 while (<>) {
 234     my ($id, $client);
 235
 236     # Chomp newline and log incoming message.
 237     s/\r?\n?\r?$//;
 238     dolog "> $_";
 239
 240     # If there's an ID at the start of the line, parse it out.
 241     if (s/^(\d+) //) { $id = $1; $client = $pending{$id}; }
 242
 243     # Figure out how to handle the command.
 244     if (/^C (\S+) (\S+) (.+)$/) {
 245         handle_new_client($id, $1, $2, $3);
 246     } elsif (/^([DT])/ and $client) {
 247         reply $client->{handler}->{"${1}_reply"}, $client;
 248         delete $pending{$id};
 249     } elsif (/^([d])/ and $client) {
 250         reply $client->{handler}->{"${1}_reply"}, $client;
 251     } elsif (/^([HNPUu]) (.+)/ and $client) {
 252         reply $client->{handler}->{"${1}_reply"}, $client, $2;
 253     }
 254 }