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