]>
Commit | Line | Data |
---|---|---|
9f8856e9 | 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 | ||
30 | # In the following discussion, sX means message X from the server, and | |
31 | # iX means message X from iauth. The hard part is the ordering of | |
32 | # various events during client registration. This includes sC, sP, | |
33 | # sU, su, sn, sN/d, sH and sT; and o/U/u, iN, iI, iC and iD/R/k/K. | |
34 | ||
35 | # sC is first, sD/sT/iD/R/k/K is last. If sH is sent, no more sU, su, | |
36 | # sn, sN, sd or sH messages may be sent. If iI is sent, iN should | |
37 | # also be sent (either before or after iI). Multiple sP, sU and iC | |
38 | # messages may be sent. Otherwse, the ordering of unrelated messages | |
39 | # from either source are not constrained, but only one message from | |
40 | # each set of alternatives may be sent. | |
41 | ||
42 | # This means the sets of commands with interesting orderings are: | |
43 | # sU, su, io/U/u | |
44 | # sN/d, iN, iI | |
45 | # sH, sT or iD/R/k/K | |
46 | ||
47 | # 127.x.y.z IP addresses are used to exercise these orderings; see the | |
48 | # %handlers variable below. | |
49 | ||
50 | sub dolog ($) { | |
51 | print LOG "$_[0]\n"; | |
52 | } | |
53 | ||
54 | sub reply ($;$$) { | |
55 | my ($msg, $client, $extra) = @_; | |
56 | ||
57 | if (not defined $msg) { | |
58 | # Accept this for easier handling of client reply messages. | |
59 | return; | |
60 | } elsif (ref $msg eq '') { | |
61 | $msg =~ s/^(.) ?/$1 $client->{id} $client->{ip} $client->{port} / if $client; | |
62 | dolog "< $msg"; | |
63 | print "$msg\n"; | |
64 | } elsif (ref $msg eq 'ARRAY') { | |
65 | grep { reply($_, $client, $extra); } @$msg; | |
66 | } elsif (ref $msg eq 'CODE') { | |
67 | &$msg($client, $extra); | |
68 | } else { | |
69 | die "Unknown reply message type."; | |
70 | } | |
71 | } | |
72 | ||
73 | # Find the names of signals with values SIGRTMIN+1, +2, etc. | |
74 | BEGIN { | |
75 | my @sig_name; | |
76 | my %sig_num; | |
77 | ||
78 | sub populate_signals () { | |
79 | die "No sigs?" | |
80 | unless $Config{sig_name} and $Config{sig_num}; | |
81 | my @names = split ' ', $Config{sig_name}; | |
82 | @sig_num{@names} = split ' ', $Config{sig_num}; | |
83 | foreach (@names) { $sig_name[$sig_num{$_}] ||= $_; } | |
84 | } | |
85 | ||
86 | sub assign_signal_handlers() { | |
87 | my $sigrtmin = $sig_num{RTMIN}; | |
88 | die "No realtime signals?" | |
89 | unless $sigrtmin; | |
90 | $SIG{$sig_name[$sigrtmin+0]} = \&send_server_notice; | |
91 | $SIG{$sig_name[$sigrtmin+1]} = \&toggle_debug_level; | |
92 | $SIG{$sig_name[$sigrtmin+2]} = \&set_policy_options; | |
93 | $SIG{$sig_name[$sigrtmin+3]} = \&sim_config_changed; | |
94 | $SIG{$sig_name[$sigrtmin+4]} = \&sim_stats_change; | |
95 | } | |
96 | } | |
97 | ||
98 | BEGIN { | |
99 | my $debug_level = 0; | |
100 | my $max_debug_level = 2; | |
101 | ||
102 | sub toggle_debug_level () { | |
103 | if (++$debug_level > $max_debug_level) { | |
104 | $debug_level = 0; | |
105 | } | |
106 | reply "G $debug_level"; | |
107 | } | |
108 | } | |
109 | ||
110 | BEGIN { | |
111 | my %rotation = ( | |
112 | '' => 'AU', | |
113 | 'AU' => 'AURTW', | |
114 | 'AURTW' => '', | |
115 | ); | |
116 | my $policy = ''; | |
117 | ||
118 | sub set_policy_options () { | |
119 | $policy = $rotation{$policy}; | |
120 | reply "O $policy"; | |
121 | } | |
122 | } | |
123 | ||
124 | BEGIN { | |
125 | my $generation = 0; | |
126 | ||
127 | sub sim_config_changed () { | |
128 | reply "a"; | |
129 | reply "A config $generation"; | |
130 | $generation++; | |
131 | } | |
132 | } | |
133 | ||
134 | BEGIN { | |
135 | my $generation = 0; | |
136 | ||
137 | sub sim_stats_change () { | |
138 | reply "s"; | |
139 | reply "S stats $generation"; | |
140 | $generation++; | |
141 | } | |
142 | } | |
143 | ||
144 | sub send_server_notice () { | |
145 | reply "> :Hello the server!"; | |
146 | } | |
147 | ||
148 | my %handlers = ( | |
149 | # Default handliner: immediately report done. | |
150 | 'default' => { C_reply => 'D' }, | |
151 | # 127.0.0.x: various timings for iD/iR/ik/iK. | |
152 | '127.0.0.1' => { C_reply => 'D' }, | |
153 | '127.0.0.2' => { C_reply => 'R account-1' }, | |
154 | '127.0.0.3' => { C_reply => 'k' }, | |
155 | '127.0.0.4' => { C_reply => 'K' }, | |
156 | '127.0.0.15' => { }, | |
157 | '127.0.0.16' => { H_reply => 'D' }, | |
158 | '127.0.0.17' => { H_reply => 'R account-2' }, | |
159 | '127.0.0.18' => { H_reply => 'k' }, | |
160 | '127.0.0.19' => { H_reply => 'K' }, | |
161 | '127.0.0.32' => { T_reply => 'D' }, | |
162 | '127.0.0.33' => { T_reply => 'R account-3' }, | |
163 | '127.0.0.34' => { T_reply => 'k' }, | |
164 | '127.0.0.35' => { T_reply => 'K' }, | |
165 | # 127.0.1.x: io/iU/iu functionality. | |
166 | '127.0.1.0' => { C_reply => 'o forced', | |
167 | H_reply => 'D' }, | |
168 | '127.0.1.1' => { C_reply => 'U trusted', | |
169 | H_reply => 'D' }, | |
170 | '127.0.1.2' => { C_reply => 'u untrusted', | |
171 | H_reply => 'D' }, | |
172 | # 127.0.2.x: iI/iN functionality. | |
173 | '127.0.2.0' => { C_reply => 'N iauth.assigned.host', | |
174 | H_reply => 'D' }, | |
175 | '127.0.2.1' => { C_reply => \&ip_change }, | |
176 | # 127.0.3.x: iC/sP functionality. | |
177 | '127.0.3.0' => { C_reply => 'C :Please enter the password.', | |
178 | P_reply => \&passwd_check }, | |
179 | ); | |
180 | ||
181 | sub handle_new_client ($$$$) { | |
182 | my ($id, $ip, $port, $extra) = @_; | |
183 | my $handler = $handlers{$ip} || $handlers{default}; | |
184 | my $client = { id => $id, ip => $ip, port => $port, handler => $handler }; | |
185 | ||
186 | # If we have any deferred reply handlers, we must save the client. | |
187 | $pending{$id} = $client if grep /^[^C]_reply$/, keys %$handler; | |
188 | reply $client->{handler}->{C_reply}, $client, $extra; | |
189 | } | |
190 | ||
191 | sub ip_change ($$) { | |
192 | my ($client, $extra) = @_; | |
193 | reply 'I 127.255.255.254', $client; | |
194 | $client->{ip} = '127.255.255.254'; | |
195 | reply 'N other.assigned.host', $client; | |
196 | reply 'D', $client; | |
197 | } | |
198 | ||
199 | sub passwd_check ($$) { | |
200 | my ($client, $extra) = @_; | |
201 | if ($extra eq 'secret') { | |
202 | reply 'D', $client; | |
203 | } else { | |
204 | reply 'C :Bad password', $client; | |
205 | } | |
206 | } | |
207 | ||
208 | open LOG, ">> iauth.log"; | |
209 | populate_signals(); | |
210 | assign_signal_handlers(); | |
211 | autoflush LOG 1; | |
212 | autoflush STDOUT 1; | |
213 | autoflush STDERR 1; | |
214 | dolog "IAuth starting " . scalar(localtime(time)); | |
215 | ||
216 | while (<>) { | |
217 | my ($id, $client); | |
218 | ||
219 | # Chomp newline and log incoming message. | |
220 | s/\r?\n?\r?$//; | |
221 | dolog "> $_"; | |
222 | ||
223 | # If there's an ID at the start of the line, parse it out. | |
224 | if (s/^(\d+) //) { $id = $1; $client = $pending{$id}; } | |
225 | ||
226 | # Figure out how to handle the command. | |
227 | if (/^C (\S+) (\S+) (.+)$/) { | |
228 | handle_new_client($id, $1, $2, $3); | |
229 | } elsif (/^([DT])/ and $client) { | |
230 | reply $client->{handler}->{"${1}_reply"}, $client; | |
231 | delete $pending{$id}; | |
232 | } elsif (/^([d])/ and $client) { | |
233 | reply $client->{handler}->{"${1}_reply"}, $client; | |
234 | } elsif (/^([HNPUu]) (.+)/ and $client) { | |
235 | reply $client->{handler}->{"${1}_reply"}, $client, $2; | |
236 | } | |
237 | } |