File Coverage

blib/lib/POE/Component/Server/Ident.pm
Criterion Covered Total %
statement 127 149 85.2
branch 28 48 58.3
condition 9 24 37.5
subroutine 22 26 84.6
pod 7 7 100.0
total 193 254 75.9


line stmt bran cond sub pod time code
1             package POE::Component::Server::Ident;
2              
3 6     6   159921 use 5.006;
  6         20  
  6         259  
4 6     6   35 use strict;
  6         10  
  6         279  
5 6     6   31 use warnings;
  6         20  
  6         208  
6 6         52 use POE qw( Wheel::SocketFactory Wheel::ReadWrite Driver::SysRW
7 6     6   7591 Filter::Line );
  6         424990  
8 6     6   942871 use Carp;
  6         18  
  6         390  
9 6     6   37 use Socket;
  6         12  
  6         4329  
10 6     6   35 use vars qw($VERSION);
  6         12  
  6         13877  
11              
12             $VERSION = '1.16';
13              
14             sub spawn {
15 5     5 1 82 my $package = shift;
16 5         45 my %opts = @_;
17 5         74 $opts{lc $_} = delete $opts{$_} for keys %opts;
18              
19 5 50       33 $opts{bindport} = 113 unless defined $opts{bindport};
20 5 100       27 $opts{multiple} = 0 unless $opts{multiple};
21 5 50       38 $opts{timeout} = 60 unless $opts{timeout};
22 5 100       26 $opts{random} = 0 unless $opts{random};
23              
24 5         22 my $self = bless \%opts, $package;
25              
26 10         116 $self->{session_id} = POE::Session->create (
27             object_states => [
28             $self => { _start => '_server_start',
29             'shutdown' => '_server_close',
30 5         21 map { ( $_ => '_' . $_ ) } qw(accept_new_client accept_failed),
31             },
32             $self => [ qw(register unregister) ],
33             ],
34             )->ID();
35 5         891 return $self;
36             }
37              
38             sub session_id {
39 0     0 1 0 return $_[0]->{session_id};
40             }
41              
42             sub getsockname {
43 5     5 1 5546 my $self = shift;
44 5         30 return $self->{listener}->getsockname();
45             }
46              
47             sub _server_start {
48 5     5   1809 my ($kernel,$self,$session) = @_[KERNEL,OBJECT,SESSION];
49 5         25 $self->{session_id} = $session->ID();
50              
51 5 50       76 $kernel->alias_set( $self->{alias} ) if $self->{alias};
52 5 50       211 $kernel->refcount_increment( $self->{session_id}, __PACKAGE__ ) unless $self->{alias};
53              
54 5 50       89 $self->{listener} = POE::Wheel::SocketFactory->new (
55             BindPort => $self->{bindport},
56             ( $self->{bindaddr} ? (BindAddr => $self->{bindaddr}) : () ),
57             Reuse => 'on',
58             SuccessEvent => 'accept_new_client',
59             FailureEvent => 'accept_failed',
60             );
61 5         7842 undef;
62             }
63              
64             sub _server_close {
65 5     5   523 my ($kernel,$self) = @_[KERNEL,OBJECT];
66 5         26 $kernel->alias_remove( $_ ) for $kernel->alias_list();
67 5 50       361 $kernel->refcount_decrement( $self->{session_id}, __PACKAGE__ ) unless $self->{alias};
68 5         13 $kernel->post( $_, 'client_timeout' ) for %{ $self->{clients} };
  5         37  
69 5         39 delete $self->{listener};
70 5         999 $kernel->refcount_decrement( $_, __PACKAGE__ ) for keys %{ $self->{sessions} };
  5         36  
71 5         211 undef;
72             }
73              
74             sub _accept_new_client {
75 5     5   16619 my ($kernel,$self,$socket,$peeraddr,$peerport) = @_[KERNEL,OBJECT,ARG0 .. ARG2];
76 5         57 $peeraddr = inet_ntoa($peeraddr);
77              
78 25         148 POE::Session->create (
79             object_states => [
80             $self => { _start => '_client_start',
81             _stop => '_client_stop',
82 5         22 map { ( $_ => '_' . $_ ) } qw(client_input client_error client_done client_timeout client_default),
83             },
84             $self => [ qw(ident_server_reply ident_server_error) ],
85             ],
86             args => [ $socket, $peeraddr, $peerport ],
87             );
88 5         646 undef;
89             }
90              
91             sub _accept_failed {
92 0     0   0 my ($kernel,$self,$function,$error) = @_[KERNEL,OBJECT,ARG0,ARG2];
93 0         0 my $package = ref $self;
94              
95 0         0 $kernel->call ( $self->{session_id}, 'shutdown' );
96              
97 0         0 warn "$package: call to $function() failed: $error";
98 0         0 undef;
99             }
100              
101             sub register {
102 5     5 1 577 my ($kernel,$self,$sender,$session) = @_[KERNEL,OBJECT,SENDER,SESSION];
103 5         22 $sender = $sender->ID();
104 5         58 $session = $session->ID();
105              
106 5         45 $self->{sessions}->{ $sender }++;
107 5 50 33     123 $kernel->refcount_increment( $sender => __PACKAGE__ )
108             if $self->{sessions}->{ $sender } == 1 and $sender ne $session;
109 5         183 undef;
110             }
111              
112              
113             sub unregister {
114 4     4 1 10532 my ($kernel,$self,$sender,$session) = @_[KERNEL,OBJECT,SENDER,SESSION];
115 4         18 my $thing = delete $self->{sessions}->{ $sender };
116 4 50 33     25 $kernel->refcount_decrement( $sender => __PACKAGE__ )
117             if $thing and $sender ne $session;
118 4         18 return;
119             }
120              
121             sub _client_start {
122 5     5   1316 my ($kernel,$session,$self,$socket,$peeraddr,$peerport) = @_[KERNEL,SESSION,OBJECT,ARG0,ARG1,ARG2];
123 5         26 my $session_id = $session->ID();
124            
125 5         42 $self->{clients}->{ $session_id }->{PeerAddr} = $peeraddr;
126 5         19 $self->{clients}->{ $session_id }->{PeerPort} = $peerport;
127              
128 5 100       43 $self->{clients}->{ $session_id }->{readwrite} =
129             POE::Wheel::ReadWrite->new(
130             Handle => $socket,
131             Filter => POE::Filter::Line->new( Literal => "\x0D\x0A" ),
132             InputEvent => 'client_input',
133             ErrorEvent => 'client_error',
134             ( $self->{'multiple'} ? () : ( FlushedEvent => 'client_timeout' ) ),
135             );
136              
137             # Set a delay to close the connection if we are idle for 60 seconds.
138 5         2062 $kernel->delay ( 'client_timeout' => $self->{'timeout'} );
139 5         644 undef;
140             }
141              
142             sub _client_stop {
143 5     5   1167 my ($kernel,$self,$session) = @_[KERNEL,OBJECT,SESSION];
144              
145 5         23 $kernel->delay ( 'client_timeout' => undef );
146 5         243 delete $self->{clients}->{ $session->ID };
147 5         46 undef;
148             }
149              
150             sub _client_input {
151 5     5   9844 my ($kernel,$self,$session,$input) = @_[KERNEL,OBJECT,SESSION,ARG0];
152 5         20 my $session_id = $session->ID();
153              
154             # Parse what is passed. We want , or nothing.
155              
156 5 100 66     80 if ( $input =~ /^\s*([0-9]+)\s*,\s*([0-9]+)\s*$/ and _valid_ports($1,$2) ) {
157 4         13 my $port1 = $1; my $port2 = $2;
  4         14  
158 4         138 $self->{clients}->{ $session_id }->{'Port1'} = $port1;
159 4         12 $self->{clients}->{ $session_id }->{'Port2'} = $port2;
160             # Okay got a sort of valid query. Send it to all interested sessions.
161 4         8 $kernel->call( $_ => 'identd_request' => $self->{clients}->{ $session_id }->{PeerAddr} => $port1 => $port2 ) for keys %{ $self->{sessions} };
  4         51  
162 4         3091 $kernel->delay ( 'client_default' => 10 );
163             } else {
164             # Client sent us rubbish.
165 1         6 $self->{clients}->{ $session_id }->{readwrite}->put("0 , 0 : ERROR : INVALID-PORT");
166             }
167 5 100       574 $kernel->delay ( 'client_timeout' => $self->{'timeout'} ) if $self->{'multiple'};
168 5         139 undef;
169             }
170              
171             sub _client_done {
172 0     0   0 my ($kernel,$self,$session) = @_[KERNEL,OBJECT,SESSION];
173 0         0 $kernel->delay ( 'client_timeout' => undef );
174 0         0 delete $self->{clients}->{ $session->ID };
175 0         0 undef;
176             }
177              
178             sub _client_error {
179 1     1   2474 my ($kernel,$self,$session) = @_[KERNEL,OBJECT,SESSION];
180 1         6 $kernel->delay ( 'client_timeout' => undef );
181 1         88 delete $self->{clients}->{ $session->ID }->{readwrite};
182 1         220 undef;
183             }
184              
185             sub _client_timeout {
186 4     4   1455 my ($kernel,$self,$session) = @_[KERNEL,OBJECT,SESSION];
187 4         25 $kernel->delay ( 'client_timeout' => undef );
188 4         439 $kernel->delay ( 'client_default' => undef );
189 4         211 delete $self->{clients}->{ $session->ID }->{readwrite};
190 4         1149 undef;
191             }
192              
193             sub _client_default {
194 3     3   30026173 my ($kernel,$self,$session) = @_[KERNEL,OBJECT,SESSION];
195 3         16 my $session_id = $session->ID();
196              
197 3         36 my $reply = $self->{clients}->{ $session_id }->{'Port1'} . " , " . $self->{clients}->{ $session_id }->{'Port2'};
198             SWITCH: {
199 3 100       7 if ( $self->{'default'} ) {
  3         24  
200 1         6 $reply .= " : USERID : UNIX : " . $self->{'default'};
201 1         4 last SWITCH;
202             }
203 2 100       13 if ( $self->{'random'} ) {
204 1         7 srand( $session_id * $$ );
205 1         2 my @numbers;
206 1         12 push @numbers, int rand (26) for 1 .. 8;
207 1         2 my $user_id = join '', map { chr($_+97) } @numbers;
  8         18  
208 1         4 $reply .= " : USERID : UNIX : $user_id";
209 1         6 last SWITCH;
210             }
211 1         5 $reply .= " : ERROR : HIDDEN-USER";
212             }
213 3 50       92 $self->{clients}->{ $session_id }->{readwrite}->put($reply) if defined $self->{clients}->{ $session_id }->{readwrite};
214 3 50       345 $kernel->delay ( 'client_timeout' => $self->{'timeout'} ) if $self->{'multiple'};
215 3         15 undef;
216             }
217              
218             sub ident_server_reply {
219 1     1 1 744 my ($kernel,$self,$session) = @_[KERNEL,OBJECT,SESSION];
220 1         4 my $session_id = $session->ID();
221              
222 1         5 my ($opsys,$userid) = @_[ARG0 .. ARG1];
223              
224 1 50       4 $opsys = "UNIX" unless defined ( $opsys );
225              
226 1         6 my $reply = $self->{clients}->{ $session_id }->{'Port1'} . " , " . $self->{clients}->{ $session_id }->{'Port2'} . " : USERID : " . $opsys . " : " . $userid;
227              
228 1 50       9 $self->{clients}->{ $session_id }->{readwrite}->put($reply) if $self->{clients}->{ $session_id }->{readwrite};
229 1 50       61 $kernel->delay ( 'client_timeout' => $self->{'timeout'} ) if $self->{'multiple'};
230 1         4 $kernel->delay ( 'client_default' => undef );
231 1         51 undef;
232             }
233              
234             sub ident_server_error {
235 0     0 1 0 my ($kernel,$self,$session,$error_type) = @_[KERNEL,OBJECT,SESSION,ARG0];
236 0         0 my $session_id = $session->ID();
237 0         0 $error_type = uc $error_type;
238              
239 0 0       0 unless ( grep {$_ eq $error_type} qw(INVALID-PORT NO-USER HIDDEN-USER UNKNOWN-ERROR) ) {
  0         0  
240 0         0 $error_type = 'UNKNOWN-ERROR';
241             }
242              
243 0         0 my $reply = $self->{clients}->{ $session_id }->{'Port1'} . " , " . $self->{clients}->{ $session_id }->{'Port2'} . " : ERROR : " . $error_type;
244              
245 0 0       0 $self->{clients}->{ $session_id }->{readwrite}->put($reply) if $self->{clients}->{ $session_id }->{readwrite};
246 0 0       0 $kernel->delay ( 'client_timeout' => $self->{'timeout'} ) if $self->{'multiple'};
247 0         0 $kernel->delay ( 'client_default' => undef );
248 0         0 undef;
249             }
250              
251             sub _valid_ports {
252 4     4   18 my ($port1,$port2) = @_;
253              
254 4 50 33     141 return 1 if ( defined ( $port1 ) and defined ( $port2 ) ) and ( $port1 >= 1 and $port1 <= 65535 ) and ( $port2 >= 1 and $port2 <= 65535 );
      33        
      33        
      33        
      33        
255 0           return 0;
256             }
257              
258             1;
259              
260             =head1 NAME
261              
262             POE::Component::Server::Ident - A POE component that provides non-blocking ident services to your sessions.
263              
264             =head1 SYNOPSIS
265              
266             use strict;
267             use warnings;
268             use POE qw(Component::Server::Ident);
269              
270             POE::Component::Server::Ident->spawn ( Alias => 'Ident-Server' );
271              
272             POE::Session->create (
273             package_states => [
274             'main' => [qw(_start identd_request)],
275             ],
276             );
277              
278             $poe_kernel->run();
279             exit 0;
280              
281             sub _start {
282             $poe_kernel->post( 'Ident-Server' => 'register' );
283             undef;
284             }
285              
286              
287             sub identd_request {
288             my ($kernel,$sender,$peeraddr,$port1,$port2) = @_[KERNEL,SENDER,ARG0,ARG1,ARG2];
289             my ($val1,$val2);
290             $val1 = $val2 = int(rand(99999));
291             $val1 =~ tr/0-9/A-Z/;
292             $kernel->call ( $sender => ident_server_reply => 'OTHER' => "$val1$val2" );
293             undef;
294             }
295              
296             =head1 DESCRIPTION
297              
298             POE::Component::Server::Ident is a L component that provides
299             a non-blocking Identd for other components and POE sessions.
300              
301             Spawn the component, give it an an optional lias and it will sit there waiting for Ident clients to connect.
302             Register with the component to receive ident events. The component will listen for client connections.
303             A valid ident request made by a client will result in an 'identd_server' event being sent to your
304             session. You may send back 'ident_server_reply' or 'ident_server_error' depending on what the client
305             sent.
306              
307             The component will automatically respond to the client requests with 'ERROR : HIDDEN-USER' if your
308             sessions do not send a respond within a 10 second timeout period. This can be adjusted with 'Random'
309             and 'Default' options to spawn().
310              
311             =head1 CONSTRUCTOR
312              
313             =over
314              
315             =item C
316              
317             Takes a number of arguments:
318              
319             'Alias', a kernel alias to address the component with;
320             'BindAddr', the IP address that the component should bind to,
321             defaults to INADDR_ANY;
322             'BindPort', the port that the component will bind to, default is 113;
323             'Multiple', specify whether the component should allow multiple ident queries
324             from clients by setting this to 1, default is 0 which terminates
325             client connections after a response has been sent;
326             'TimeOut', this is the idle timeout on client connections, default
327             is 60 seconds, accepts values between 60 and 180 seconds.
328             'Default', provide a default userid to return if your sessions don't provide a
329             response.
330             'Random', the component will generate a random userid string if your sessions
331             don't provide a response.
332            
333              
334             =back
335              
336             =head1 METHODS
337              
338             =over
339              
340             =item C
341              
342             Retrieve the component's POE session ID.
343              
344             =item C
345              
346             Access to the L method of the underlying listening socket.
347              
348             =back
349              
350             =head1 INPUT
351              
352             The component accepts the following events:
353              
354             =over
355              
356             =item C
357              
358             Takes no arguments. This registers your session with the component. The component will then send you
359             'identd_request' events when clients make valid ident requests. See below.
360              
361             =item C
362              
363             Takes no arguments. This unregisters your session with the component.
364              
365             =item C
366              
367             Takes two arguments, the first is the 'opsys' field of the ident response, the second is the 'userid'.
368              
369             =item C
370              
371             Takes one argument, the error to return to the client.
372              
373             =item C
374              
375             Terminates the component. The listener is closed and all current client connections are disconnected.
376              
377             =back
378              
379             =head1 OUTPUT
380              
381             The component will send the following events:
382              
383             =over
384              
385             =item C
386              
387             Sent by the component to 'registered' sessions when a client makes a valid ident request. ARG0 is
388             the IP address of the client, ARG1 and ARG2 are the ports as specified in the ident request. You
389             can use the 'ident_server_reply' and 'ident_server_error' to respond to the client appropriately. Please
390             note, that you send these responses to $_[SENDER] not the kernel alias of the component.
391              
392             =back
393              
394             =head1 AUTHOR
395              
396             Chris C Williams, Echris@bingosnet.co.ukE
397              
398             =head1 LICENSE
399              
400             Copyright E Chris Williams
401              
402             This module may be used, modified, and distributed under the same terms as Perl itself. Please see the license that came with your Perl distribution for details.
403              
404             =head1 SEE ALSO
405              
406             L
407              
408             RFC 1413 L
409              
410             =cut