1# $File: //depot/libOurNet/BBS/lib/OurNet/BBS/Client.pm $ $Author: autrijus $
2# $Revision: #5 $ $Change: 3958 $ $DateTime: 2003/01/28 02:21:52 $
3
4package OurNet::BBS::Client;
5
6use strict;
7no warnings 'deprecated';
8use OurNet::BBS::Base;
9
10# Declaration {{{
11
12our ($AUTOLOAD, $Ego, $Port, $NoCache);
13
14use overload (
15    '""'   => sub { overload::AddrRef($_[0]) },
16    '<=>'  => sub { "$_[0]" cmp "$_[1]" },
17    'cmp'  => sub { "$_[0]" cmp "$_[1]" },
18    'bool' => sub { 1 },
19    '0+'   => sub { 0 },
20    '&{}'  => sub {
21	my $self = ${$_[0]};
22	$Ego = $self->[0];
23	return sub {
24	    $AUTOLOAD = 'OurNet::BBS::Client::EXECUTE';
25	    EXECUTE(bless(\[$self, 'CODE_'], __PACKAGE__), @_);
26	};
27    },
28    map {
29	my $type = $_;
30	( SIGILS->[$type].'{}' => sub {
31	    my $self = ${$_[0]};
32	    $Ego = $self->[0];
33	    return $self->[$type];
34	} );
35    } ( HASH .. ARRAY ),
36);
37
38use RPC::PlClient;
39use Digest::MD5 qw/md5/;
40use OurNet::BBS::Authen;
41
42use enum qw/id remote_ref optree/;
43use enum qw/BITMASK:CIPHER_ NONE BASIC PGP/;
44use enum qw/BITMASK:AUTH_   NONE CRYPT PGP/;
45
46sub UNTIE() {}
47sub DESTROY() {}
48
49# }}}
50
51# Initialization {{{
52
53$Port = 7979;
54
55my $OP = $OurNet::BBS::Authen::OP;
56my (%Cache, @delegators, @arguments);
57
58tie my %obj  => __PACKAGE__, 'HASH_';
59tie my @obj  => __PACKAGE__, 'ARRAY_';
60tie my $code => __PACKAGE__, 'CODE_'; # XXX: not working
61tie my $glob => __PACKAGE__, 'GLOB_'; # XXX: not working
62
63sub TIEHASH   { bless(\[$_[1]], $_[0]) }
64sub TIEARRAY  { bless(\[$_[1]], $_[0]) }
65sub TIESCALAR { bless(\[$_[1]], $_[0]) }
66
67use constant IsWin32 => ($^O eq 'MSWin32');
68
69if (IsWin32 and not Win32::IsWinNT()) {
70    require Net::Daemon::Log;
71
72    no strict 'refs';
73    no warnings 'redefine';
74
75    *{'Net::Daemon::Log'}	= sub { return };
76    *{'Net::Daemon::Log::Log'}	= sub { return };
77}
78
79# }}}
80
81sub _spawn {
82    # spawn (optree_id)
83    my $self = [ $Ego->[id], @_ ];
84
85    show("SPAWN: @_\n");
86
87    # warning: one-arg bless!
88    return bless(\[$self, \%obj, \@obj, \$code, \$glob, 'OBJECT_']);
89}
90
91sub new {
92    my $class    = shift;
93    my $peeraddr = shift;
94    my $peerport = shift || $Port;
95    my @args = (
96	peeraddr    => $peeraddr,
97	peerport    => $peerport,
98	application => 'OurNet::BBS::Server',
99	version     => $OurNet::BBS::Authen::VERSION,
100    );
101
102    my $id = @delegators; # 1 more than max
103    $arguments[$id] = [\@args, @_];
104
105    return $class->generate($id);
106}
107
108sub generate {
109    my ($class, $id) = @_;
110    my $self = []; $self->[id] = $id;
111
112    if ($delegators[$id]) {
113	delete $delegators[$id]{client};
114	$delegators[$id]->DESTROY;
115    }
116
117    $delegators[$id] = RPC::PlClient->new(
118	@{$arguments[$id][0]}
119    )->ClientObject('__', 'spawn');
120
121    my $obj = bless(\[$self, \%obj, \@obj, \$code, \$glob, 'OBJECT_'], $class);
122    return $obj->init(@{$arguments[$id]}[1 .. $#{$arguments[$id]}]);
123}
124
125## Handshake Phase ####################################################
126# spawn a handle and get server's accepted modes. {{{
127
128sub init {
129    my ($obj, $keyid, $user, $pass, $cipher_level, $auth_level) = @_;
130    my $self = ${$obj}->[0];
131
132    my $client = $delegators[$self->[id]];
133
134    unless ($OurNet::BBS::BYPASS_NEGOTIATION) {
135	($cipher_level, $auth_level) = $client->handshake(
136	    OurNet::BBS::Authen->adjust(
137		$cipher_level, $auth_level, $keyid, 1
138	    )
139	) or print "[Client] initialization failed.\n" and die;
140
141	my ($status, $auth) = negotiate_cipher($client, $cipher_level)
142	    or print "[Client] cipher negotiation failed.\n" and die;
143
144	negotiate_auth($client, $auth_level, $auth, $keyid, $user, $pass)
145	    or print "[Client] authentication failed.\n" and die;
146
147	$self->[remote_ref] = negotiate_locate($client)
148	    or print "[Client] object location failed.\n" and die;
149    }
150
151    show("done!\n");
152
153    return $obj;
154}
155
156sub negotiate_locate {
157    my $client = shift;
158
159    return $client->locate(@_);
160}
161
162sub make_auth {
163    my ($keyid, $pubkey) = @_;
164
165    my $auth = OurNet::BBS::Authen->new($keyid) or return;
166    $auth->import_key($pubkey);
167
168    return $auth;
169}
170
171# }}}
172
173## Cipher Phase #######################################################
174# gets supported cipher suites and (optionally) server's public key {{{
175
176sub negotiate_cipher {
177    my ($client, $mode, $auth) = @_;
178
179    my $cipher = OurNet::BBS::Authen->suites($client->get_suites)
180	if $mode & (CIPHER_BASIC | CIPHER_PGP);
181
182    show("[Client] agreed on cipher: $cipher ") if $cipher;
183
184    if ($cipher and $mode & CIPHER_PGP) {
185	$auth = make_auth($client->get_pubkey);
186
187	if ($auth and cipher_pgp($client, $cipher, $auth)) {
188	    show("in secure mode.\n");
189	    return(CIPHER_PGP, $auth);
190	}
191    }
192
193    if ($cipher and $mode & CIPHER_BASIC) {
194	if (cipher_basic($client, $cipher)) {
195	    show("in insecure mode.\n");
196	    return(CIPHER_BASIC, $auth);
197	}
198    }
199
200    if ($mode & CIPHER_NONE and cipher_none($client)) {
201	show("[Client] warning: using plaintext communication.\n");
202	return(CIPHER_NONE, $auth);
203    }
204
205    show("failed!\n");
206    return;
207}
208
209sub cipher_pgp {
210    my ($client, $cipher, $auth) = @_;
211
212    my $keysize = $cipher->keysize || (
213	$cipher eq 'Crypt::Blowfish' ? 56 : 8
214    );
215
216    # make session key
217    my $session_key = md5(rand);
218    $session_key .= md5(rand) until length($session_key) >= $keysize;
219    $session_key = substr($session_key, 0, $keysize);
220
221    my $authcrypt = $auth->encrypt($session_key) or return; # encrypt it
222    $client->cipher_pgp($cipher, $authcrypt) or return;	    # send it back
223
224    $client->{client}{cipher} = $cipher->new($session_key);
225
226    return $auth;
227}
228
229sub cipher_basic {
230    my ($client, $cipher) = @_;
231    my ($status, $session) = $client->cipher_basic($cipher) or return;
232
233    return ($client->{client}{cipher} = $cipher->new($session));
234}
235
236sub cipher_none {
237    my ($client) = @_;
238    return $client->cipher_none;
239}
240
241# }}}
242
243## Auth Phase #########################################################
244# log in by trying each mutually acceptable authentication schemes {{{
245
246sub negotiate_auth {
247    my ($client, $mode, $auth, $keyid, $user, $pass) = @_;
248
249    # Authentication Negotiation
250    show("[Client] begin authentication...");
251
252    if ($mode & AUTH_PGP and $auth ||= make_auth($client->get_pubkey)) {
253	# public key authentication
254	show("trying pubkey...");
255	return AUTH_PGP if auth_pgp(
256	    $client, $auth, $keyid, $user, $pass
257	);
258    }
259
260    if ($mode & AUTH_CRYPT and $user) {
261	# crypt-based authentication
262	show("trying crypt...");
263	return AUTH_CRYPT if auth_crypt($client, $user, $pass);
264    }
265
266    if ($mode & AUTH_NONE and $client->auth_none($user)) {
267	# no authentication at all
268	show("fallback to none...");
269	return AUTH_NONE;
270    }
271
272    show("failed!\n");
273    return;
274}
275
276sub auth_pgp {
277    my ($client, $auth, $keyid, $login, $passphrase) = @_;
278    return unless $keyid and $login and defined $passphrase;
279
280    $auth->{keyid} = $keyid;
281    $auth->setpass($passphrase);
282
283    my $challenge = $client->auth_pgp($login);
284
285    if ($challenge eq $OP->{STATUS_NO_USER}) {
286	show('no such user! ');
287	return;
288    }
289    elsif ($challenge eq $OP->{STATUS_NO_PUBKEY}) {
290	show('no public key info! ');
291	return;
292    }
293    elsif ($challenge eq $OP->{STATUS_OK}) {
294	show("challenge($challenge)");
295	$challenge = $client->set_pubkey($auth->export_key);
296    }
297
298    if ($challenge eq $OP->{STATUS_BAD_PUBKEY}) {
299	show('public key mismatch! ');
300	return;
301    }
302
303    my $signature = $auth->clearsign($challenge)
304	or (show('cannot make signature! ') and return);
305
306    if ($client->set_sign($signature) eq $OP->{STATUS_BAD_SIGNATURE}) {
307	show('signature rejected! ');
308	return;
309    }
310
311    return 1;
312}
313
314sub auth_crypt {
315    my ($client, $user, $pass) = @_;
316    my ($status, $salt) = $client->auth_crypt($user) or return;
317
318    if ($status eq $OP->{STATUS_NO_USER}) {
319	show('no such user! ');
320	return;
321    }
322
323    return (
324	$client->set_crypted(crypt($pass, $salt)) eq $OP->{STATUS_ACCEPTED}
325    );
326}
327
328sub auth_none {
329    my ($client) = @_;
330    return $client->auth_none;
331}
332
333sub quit {
334    foreach my $client (@delegators) {
335	$client->quit if $client;
336    }
337
338    undef @delegators;
339}
340
341sub show {
342    no warnings 'once';
343    print $_[0] if $OurNet::BBS::DEBUG;
344}
345
346sub register_callback {
347    my $coderef = shift;
348    my $proxy   = bless(\"$coderef", '__CODE__');
349
350    show("$coderef registered for callback\n");
351
352    $RPC::PlServer::Comm::Callback{"$coderef"} = $coderef;
353    return $proxy;
354}
355
356# }}}
357
358## Connected ##########################################################
359# do the real job via AUTOLOAD passing and ArrayHashMonster magic {{{
360
361sub AUTOLOAD {
362    my ($ego, $op);
363
364    no strict 'refs';
365    return unless $delegators[$Ego->[id]];
366
367    my $action = substr($AUTOLOAD, (
368	(rindex($AUTOLOAD, ':') + 1) || return
369    ));
370
371    # install a closure-based handler for future use instead of AUTOLOAD
372*{$AUTOLOAD} = sub {
373    no warnings 'uninitialized';
374
375    my ($self, $op) = @{${+shift}}[0, -1];
376
377    local $Ego = $self if ($op eq 'OBJECT_');
378
379    $op .= $action;
380
381    my @result;
382
383    do { eval {
384	undef $@;
385	@result = $delegators[$Ego->[id]]->__(
386	    $OP->{$op} || $op, $Ego->[optree], map {
387		ref($_) eq __PACKAGE__
388		    ? bless(\(${$_}->[0][optree]), '__') :
389		ref($_) eq 'CODE'
390		    ? register_callback($_)
391		: $_;
392	    } @_
393	);
394    } } while (
395	$@ and $@ =~ /^Error while reading socket:/ and
396	__PACKAGE__->generate($Ego->[id])
397    );
398
399    die $@ if $@;
400
401    if (@result == 4 and !$result[0] and my $opcode = $result[1]) {
402        return ($NoCache ? _spawn(@result[2, 3])
403			 : ($Cache{$result[2]} ||= _spawn(@result[2, 3])))
404	    if $OP->{$opcode} eq 'OBJECT_SPAWN';
405
406	return @result if $OP->{$opcode} eq 'STATUS_IGNORED';
407
408        die "@result[2, 3] [$OP->{$opcode}]\n";
409    }
410
411#   print ("<==:  ".(wantarray ? "@result" : $result[0]), "\n");
412    return wantarray ? @result : $result[0];
413} unless exists(&{$AUTOLOAD});
414
415    goto &{$AUTOLOAD};
416}
417
418# }}}
419
4201;
421