1# $File: //depot/libOurNet/BBS/lib/OurNet/BBS/Server.pm $ $Author: autrijus $ 2# $Revision: #4 $ $Change: 3852 $ $DateTime: 2003/01/25 22:39:28 $ 3 4package OurNet::BBS::Server; 5 6use strict; 7no warnings 'deprecated'; 8use OurNet::BBS::Authen; 9use base qw/RPC::PlServer/; 10 11our ($Port, $Mode, $Childs, $LocalAddr, %Options); 12 13$OurNet::BBS::Server::VERSION = $OurNet::BBS::Authen::VERSION; 14 15$Port = 7979; 16$Mode = 'fork'; 17$Childs = undef; # max. concurrent connections. 18$LocalAddr = 'localhost'; 19%Options = (); 20 21sub Loop { 22 $_[0]->{done} = 1; 23} 24 25sub daemonize { 26 my ($class, $root, $port) = splice(@_, 0, 3); 27 28 # Server options below can be overwritten in the config file or 29 # on the command line. 30 __::daemonize($root, __PACKAGE__->new({ 31 pidfile => 'none', 32 facility => 'daemon', # Default 33 localaddr => $LocalAddr, 34 localport => $port || $Port, 35 options => \%Options, 36 methods => { 37 'OurNet::BBS::Server' => { 38 ## Default ########## 39 NewHandle => 1, 40 CallMethod => 1, 41 DestroyHandle => 1, 42 }, 43 '__' => { 44 ## Initialization ### 45 spawn => 1, 46 handshake => 1, 47 ## Seed Phase ####### 48 get_suites => 0, 49 get_pubkey => 0, 50 ## Cipher Phase ##### 51 cipher_pgp => 0, 52 cipher_basic => 0, 53 cipher_none => 0, 54 ## Auth Phase ####### 55 auth_pgp => 0, 56 set_pubkey => 0, 57 set_sign => 0, 58 auth_crypt => 0, 59 set_crypted => 0, 60 auth_none => 0, 61 ## Locate Phase ##### 62 locate => 0, 63 relay => 0, 64 ## Connected ######## 65 __ => $OurNet::BBS::BYPASS_NEGOTIATION, 66 #################### 67 quit => $OurNet::BBS::BYPASS_NEGOTIATION, 68 #################### 69 }, 70 }, 71 mode => $Mode, 72 childs => $Childs, 73 }), @_); 74} 75 76####################################################################### 77 78package __; 79 80use strict; 81no warnings 'deprecated'; 82use Digest::MD5 qw/md5 md5_hex/; 83 84my $OP = $OurNet::BBS::Authen::OP; 85my $OPREV = $OurNet::BBS::Authen::OPREV; 86my @OPTREE = (''); 87 88my ($ROOT, $Server, $Auth, @CipherSuites, %Cache, %Perm); 89my ($CipherLevel, $AuthLevel, $CipherMode, $AuthMode, $GuestId); 90 91use enum qw/BITMASK:CIPHER_ NONE BASIC PGP/; 92use enum qw/BITMASK:AUTH_ NONE CRYPT PGP/; 93 94use constant OP_WRITE => ' STORE DELETE PUSH POP SHIFT UNSHIFT '; 95use constant OP_IGNORE => ' DESTROY daemonize initvars writeok readok '. 96 ' new timestamp fillmod fillin remove pack unpack '; 97sub daemonize { 98 ($ROOT, $Server, my ( 99 $keyid, $passphrase, $cipher_level, $auth_level, $guest_id 100 )) = @_; 101 102 ($CipherLevel, $AuthLevel) = OurNet::BBS::Authen->adjust( 103 $cipher_level, $auth_level, ($passphrase and $keyid) 104 ); 105 106 if ($CipherLevel & CIPHER_PGP or $AuthLevel & AUTH_PGP) { 107 $Auth = OurNet::BBS::Authen->new($keyid, $passphrase); 108 109 die "can't access private key; please check passphrase.\n" 110 unless $Auth->test; 111 112 die "can't export public key; please check key ring.\n" 113 unless $OurNet::BBS::Authen::Pubkey; 114 } 115 116 if ($AuthLevel & (AUTH_CRYPT | AUTH_PGP)) { 117 if (UNIVERSAL::isa($ROOT, 'OurNet::BBS')) { 118 no warnings; 119 120 my $users = eval { $ROOT->{users} }; 121 my $sysop = eval { $users->{SYSOP} } || []; 122 my $guest = eval { $users->{guest} } || []; 123 124 local $@; 125 126 $AuthLevel &= ~AUTH_CRYPT unless eval{ 127 $sysop->{passwd} 128 } or eval { 129 $guest->{passwd} 130 }; 131 132 $AuthLevel &= ~AUTH_PGP unless eval{ 133 $sysop->{plans} 134 } or eval { 135 $guest->{plans} 136 }; 137 } 138 else { 139 $AuthLevel &= ~(AUTH_CRYPT | AUTH_PGP) 140 } 141 } 142 143 if ($AuthLevel & AUTH_NONE and $GuestId = $guest_id) { 144 $AuthLevel &= ~AUTH_NONE 145 unless $GuestId =~ /^\*/ or exists $ROOT->{users}{$guest_id}; 146 } 147 148 if ($CipherLevel & (CIPHER_PGP | CIPHER_BASIC)) { 149 $CipherLevel &= ~(CIPHER_PGP | CIPHER_BASIC) 150 unless @CipherSuites = OurNet::BBS::Authen->suites; 151 } 152 153 die "no cipher modes available" unless $CipherLevel; 154 die "no authentication modes available" unless $AuthLevel; 155 156 show("[Server] OurNet service started.\n"); 157 158 $Server->Bind; 159 return $Server; 160} 161 162## Initialization ##################################################### 163 164sub spawn { 165 return (bless(\$ROOT, __PACKAGE__)); 166} 167 168sub handshake { 169 my ($self, $cipher_level, $auth_level) = @_; 170 171 nextstate('get_suites', 'get_pubkey', 'cipher_none'); 172 $Server->{methods}{__}{handshake} = 1; # allows re-authenticate 173 174 $CipherLevel &= ~CIPHER_PGP and $AuthLevel &= ~AUTH_PGP 175 unless UNIVERSAL::isa($Auth, 'UNIVERSAL') and $Auth->test; 176 177 return ($CipherLevel & $cipher_level, $AuthLevel & $auth_level); 178} 179 180## Seed Phase ######################################################### 181 182sub get_suites { 183 nextstate('cipher_basic'); 184 return @CipherSuites; 185} 186 187sub get_pubkey { 188 nextstate($CipherMode ? 'auth_pgp' : 'cipher_pgp'); 189 return ($Auth->{who}, $OurNet::BBS::Authen::Pubkey || die "can't export"); 190} 191 192## Cipher Phase ####################################################### 193 194sub cipher_pgp { 195 my ($self, $cipher, $authcrypt) = @_; 196 return unless ($CipherLevel & CIPHER_PGP and $cipher and $authcrypt); 197 198 my $session_key; 199 200 $cipher = OurNet::BBS::Authen->suites($cipher) and 201 $session_key = $Auth->decrypt($authcrypt) and 202 $self->{newciph} = $cipher->new($session_key) 203 or nextstate() and return; 204 205 nextstate('auth_pgp', 'auth_crypt', 'auth_none'); 206 return ($CipherMode = CIPHER_PGP); 207} 208 209sub cipher_basic { 210 my ($self, $cipher) = @_; 211 return unless $CipherLevel & CIPHER_BASIC and $cipher; 212 213 $cipher = OurNet::BBS::Authen->suites($cipher); 214 215 nextstate() and return unless UNIVERSAL::isa($cipher, 'UNIVERSAL'); 216 217 my $keysize = $cipher->keysize || ( 218 $cipher eq 'Crypt::Blowfish' ? 56 : 8 219 ); 220 221 # make session key 222 my $session_key = md5(rand); 223 $session_key .= md5(rand) until length($session_key) >= $keysize; 224 $session_key = substr($session_key, 0, $keysize); 225 226 $self->{newciph} = $cipher->new($session_key) 227 or nextstate() and return; 228 229 # XXX AUTH_CRYPT over CIPHER_BASIC considered harmful! 230 nextstate('auth_pgp', 'auth_crypt', 'auth_none'); 231 return ($CipherMode = CIPHER_BASIC, $session_key); 232} 233 234sub cipher_none { 235 my ($self) = @_; 236 return unless $CipherLevel & CIPHER_NONE; 237 238 $AuthLevel &= ~AUTH_CRYPT; 239 240 nextstate('auth_pgp', 'auth_crypt', 'auth_none'); 241 return ($CipherMode = CIPHER_NONE); 242} 243 244## Auth Phase ######################################################### 245 246sub auth_pgp { 247 my ($self, $login) = @_; 248 return unless $AuthLevel & AUTH_PGP; 249 250 show("[Server] $login: login"); 251 252 $Auth->{user} = $ROOT->{users}{$login} or return $OP->{STATUS_NO_USER}; 253 $Auth->{login} = $login; 254 255 my $plan = ($Auth->{user})->{plans} || ''; 256 257 if ($plan =~ /^#\s+pubkey:\s*(?:\d+\w\/)?([^\s]+)/) { 258 $Auth->{keyid} = $1; 259 } 260 else { 261 show("...failed! (no pubkey id)"); 262 nextstate(); 263 return $OP->{STATUS_NO_PUBKEY}; 264 } 265 266 my $pubkey = ($Auth->{user})->{pubkey}; 267 268 if ($pubkey and $pubkey eq $Auth->export_key) { 269 nextstate('set_sign'); 270 return ($Auth->{challenge} = md5_hex(rand)); 271 } 272 else { 273 nextstate('set_pubkey'); 274 return $OP->{STATUS_OK}; 275 } 276} 277 278sub set_pubkey { 279 my ($self, $pubkey) = @_; 280 281 show("...setpubkey");; 282 283 $Auth->import_key($pubkey); 284 285 if (compare_keys($pubkey, $Auth->export_key)) { 286 $Auth->{user}{pubkey} = $pubkey or return; 287 nextstate('set_sign'); 288 return ($Auth->{challenge} = md5_hex(rand)); 289 } 290 else { 291 show("...failed! (keyid doesn't match)\n");; 292 nextstate(); 293 return $OP->{STATUS_BAD_PUBKEY}; 294 } 295} 296 297sub compare_keys { 298 my ($key1, $key2) = @_; 299 300 # strip version info and final checksum 301 $key1 =~ s/.*\n\n+//s; $key1 =~ s/\n.*//s; 302 $key2 =~ s/.*\n\n+//s; $key2 =~ s/\n.*//s; 303 304 return ($key1 eq $key2); 305} 306 307sub set_sign { 308 my ($self, $signature) = @_; 309 310 show("...setsign"); 311 312 my $response = $Auth->verify($signature); 313 314 if (!$response or 315 index($response, "key ID $Auth->{keyid}") > -1 and 316 index($response, "gpg: BAD signature") == -1 and 317 index($signature, "$Auth->{challenge}\n") > -1) 318 { 319 show("...done!\n"); 320 nextstate('locate', 'relay'); 321 return ($OP->{STATUS_ACCEPTED}, AUTH_PGP); 322 } 323 else { 324 show("...failed! ($signature, $response)\n"); 325 nextstate(); 326 return $OP->{STATUS_BAD_SIGNATURE} 327 } 328} 329 330sub auth_crypt { 331 my ($self, $login) = @_; 332 return unless $AuthLevel & AUTH_CRYPT; 333 334 $Auth->{user} = $ROOT->{users}{$login} or return $OP->{NO_USER}; 335 336 my $passwd = ($Auth->{user})->{passwd}; 337 return unless length($passwd); 338 339 $Auth->{login} = $login; 340 341 show("[Server] $login: login");; 342 nextstate('set_crypted'); 343 return ($OP->{STATUS_OK}, substr($passwd, 0, 2)); 344} 345 346sub set_crypted { 347 my ($self, $crypted) = @_; 348 349 if (($Auth->{user})->{passwd} eq $crypted) { 350 show("...done!\n");; 351 nextstate('locate', 'relay'); 352 return ($OP->{STATUS_ACCEPTED}, $AuthMode = AUTH_CRYPT); 353 } 354 355 show("...failed! (crypt mismatch)\n");; 356 nextstate(); 357 return $OP->{STATUS_BAD_SIGNATURE}; 358} 359 360sub auth_none { 361 my ($self, $login) = @_; 362 return unless $AuthLevel & AUTH_NONE; 363 364 if ($Auth->{login} = $GuestId) { 365 $Auth->{login} = ($login || substr($GuestId, 1)) 366 or return $OP->{NO_USER} if $GuestId =~ /^\*/; # AUTH_LOCAL 367 $Auth->{user} = $ROOT->{users}{$Auth->{login}} 368 or return $OP->{NO_USER}; 369 } 370 else { 371 undef $Auth->{user}; # clean up previous auth 372 undef $Auth->{login}; # clean up previous auth 373 } 374 375 nextstate('locate', 'relay'); 376 return ($OP->{STATUS_ACCEPTED}, $AuthMode = AUTH_NONE); 377} 378 379## Locate Phase ####################################################### 380 381sub locate { 382 nextstate('__', 'quit'); 383 return "$ROOT"; 384} 385 386sub relay { 387 nextstate('__', 'quit'); 388 return "$ROOT"; # XXX unimplemented 389} 390 391## Connected ########################################################## 392 393sub __ { 394 my $obj = ${$_[0]}; 395 my $parent = $_[2]; 396 my ($op, $param, @ret); 397 398 @_[2, 3] = ([map { 399 my $proxy; 400 ref($_) eq __PACKAGE__ 401 ? __($_[0], undef, ${$_}, undef) : 402 ref($_) eq '__CODE__' 403 ? (($proxy = "${$_}") and sub { 404 push @RPC::PlServer::Comm::CallQueue, [ $proxy, map { 405 _sanitize($_, 'OBJECT_CACHE', "$_", 0, 1) 406 } @_ ]; 407 }) 408 : $_; 409 } @_[3..$#_]], $_[2]); $#_ = 3; 410 411 while ($_[-1]) { 412 @_[$#_ .. $#_ + 2] = @OPTREE[$_[-1] .. $_[-1] + 2]; 413 } 414 415 foreach my $i (2 .. (scalar @_ / 2)) { return eval { 416 no warnings 'exiting'; # intended! arbitary! 417 418 my ($op, $param) = @_[ 419 ($#_ - ($i * 2)) + 2, 420 ($#_ - ($i * 2)) + 3, 421 ]; 422 423 unless (defined $op) { 424 return $obj; 425 } 426 427 my $action = $OPREV->{$op}; 428 $op = $OP->{$op} if $action; # do name translation 429 $action ||= substr($op, index($op, '_') + 1); 430 431 if ((index(OP_IGNORE, " $action ") > -1)) { 432 show("ignored op: $obj $op\n"); 433 return('', $OP->{STATUS_IGNORED}, $action, ''); 434 } 435 436 if ($op =~ m/^OBJECT_/) { 437 return { %{$obj} } if $action eq 'SPAWN'; 438 return ref($obj) if $action eq 'REF'; 439 # return undef($obj) if $action eq 'DESTROY'; 440 $obj = $Cache{__}{$param} and next if $action eq 'CACHE'; 441 442 my @ret = $obj->$action(@{$param}); 443 $obj = $ret[0] and next unless $#ret; 444 return @ret; # return unless single arg 445 } 446 447 return $obj->(@$param) if $op eq 'CODE_EXECUTE'; 448 449 if (not $Perm{"$obj $op $param->[0]"} and $Auth->{user} 450 and substr(ref($obj), 0, 11) eq 'OurNet::BBS' 451 ) { 452 return ( 453 '', $OP->{STATUS_FORBIDDEN}, $action, 454 "not permitted: $obj $op $param->[0]", 455 ) unless ( 456 (index(OP_WRITE, " $action ") > -1) 457 ? $obj->writeok($Auth->{user}, $action, $param) 458 : $obj->readok($Auth->{user}, $action, $param) 459 ); 460 461 $Perm{"$obj $op $param->[0]"} = 1; 462 } 463 464 # XXX: experimental. 465 return keys(%$obj) if $action eq 'KEYS'; 466 467 my $arg = $param->[0] if @{$param}; 468 469 if ($op eq 'HASH_FETCH') { 470 # perl uses fetch to get val from 2-arg each. 471 $obj = exists $Cache{$obj}{$arg} 472 ? delete($Cache{$obj}{$arg}) : $obj->{$arg}; 473 } elsif ($op eq 'HASH_FIRSTKEY') { 474 my @ret = UNIVERSAL::can($obj, 'FIRSTKEY') 475 ? $obj->FIRSTKEY 476 : (scalar keys(%$obj) ? each(%$obj) : undef); 477 478 $Cache{$obj}{$ret[0]} = $ret[1] if defined $ret[0]; 479 return $ret[0]; 480 } elsif ($op eq 'HASH_NEXTKEY') { 481 my @ret = UNIVERSAL::can($obj, 'ego') 482 ? $obj->NEXTKEY 483 : each(%$obj); 484 485 $Cache{$obj}{$ret[0]} = $ret[1] if defined $ret[0]; 486 return $ret[0]; 487 # } elsif ($op eq 'HASH_DESTROY') { 488 # return undef($obj); 489 # } elsif ($op eq 'ARRAY_DESTROY') { 490 # return undef($obj); 491 } elsif ($op eq 'ARRAY_FETCH') { 492 $obj = $obj->[$arg]; 493 # print "$op $obj $arg\n"; 494 } elsif ($op eq 'ARRAY_FETCHSIZE') { 495 return scalar @{$obj}; 496 } elsif ($op eq 'ARRAY_DEREFERENCE') { 497 return @{$obj}; 498 } elsif ($op eq 'HASH_DEREFERENCE') { 499 return %{$obj}; 500 } elsif ($op eq 'ARRAY_STORE') { 501 # $obj = $obj->[$arg] = $param->[1]; 502 return (($obj->[$arg] = $param->[1]) ? 1 : undef); 503 } elsif ($op eq 'HASH_STORE') { 504 # $obj = $obj->{$arg} = $param->[1]; 505 return (($obj->{$arg} = $param->[1]) ? 1 : undef); 506 } elsif ($op eq 'ARRAY_DELETE') { 507 $obj = (delete $obj->[$arg]); 508 } elsif ($op eq 'HASH_DELETE') { 509 $obj = (delete $obj->{$arg}); 510 } elsif ($op eq 'ARRAY_PUSH') { 511 $obj = push(@{$obj}, @{$param}); 512 } elsif ($op eq 'ARRAY_POP') { 513 $obj = pop(@{$obj->{$arg}}); 514 } elsif ($op eq 'ARRAY_SHIFT') { 515 $obj = shift(@{$obj->{$arg}}); 516 } elsif ($op eq 'HASH_EXISTS') { 517 return exists ($obj->{$arg}); 518 } elsif ($op eq 'ARRAY_EXISTS') { 519 return exists ($obj->[$arg]); 520 } elsif ($op eq 'ARRAY_UNSHIFT') { 521 return (unshift @{$obj}, @{$param}); 522 } else { 523 warn "Unknown OP: $op (@{$param})\n"; 524 return ('', $OP->{STATUS_UNKNOWN_OP}, '', ''); 525 } 526 527 next; 528 }; 529 530 if ($@) { 531 show("execution failed: $@\n"); 532 return ('', $OP->{STATUS_FAILED}, '', $@); 533 } 534 }; 535 536 return _sanitize($obj, @_[1, 2], $parent, 0); 537} 538 539sub _sanitize { 540 my $obj = shift; 541 my $blessed = pop; 542 543 return $obj unless UNIVERSAL::isa(ref($obj), 'UNIVERSAL') 544 or ref($obj) eq 'CODE'; 545 546 # so, here's an overloaded object / coderef. 547 548 push @OPTREE, @_; 549 $Cache{__}{"$obj"} = $obj if $blessed; 550 551 return $blessed ? bless( 552 ['', $OP->{OBJECT_SPAWN}, "$obj", $#OPTREE - 2], 553 '__SPAWN__' 554 ) : ('', $OP->{OBJECT_SPAWN}, "$obj", $#OPTREE - 2); 555} 556 557sub quit { 558 return unless $OurNet::DEBUG; 559 exit if $Server->{mode} ne 'fork'; 560 $Server->{done} = 1; 561} 562 563## Utilities ########################################################## 564 565sub show { 566 print $_[0] if $OurNet::BBS::DEBUG; 567} 568 569sub nextstate { 570 my $caller = substr((caller(1))[3], 4); # subroutine name 571 572 $Server->{methods}{__}{$caller} = 0; 573 $Server->{methods}{__}{$_} = 1 foreach @_; 574} 575 5761; 577 578package OurNet::BBS::Server; 579 580####################################################################### 581# The following section is a modified version of RPC::PlServer code, 582# with added support for following features: 583# 584# - Changing cipher mode *after* a CallMethod has been made 585# - Passing the actual server instance instead of the registered object. 586# - Special hooks for package-based handlers for the '__' package. 587# 588# Because this makes the new server's behaviour incompatible from 589# existing PlRPC's, I choose to fork a specific version just for 590# OurNet::BBS's purpose. I'll notify the author once this modification 591# proves to be stable and useful enough. 592# 593# According to the Artistic License, the copyright information of 594# RPC::PlServer is acknowledged here: 595# 596# PlRPC - Perl RPC, package for writing simple, RPC like clients and 597# servers 598# 599# Copyright (c) 1997,1998 Jochen Wiedmann 600# 601# You may distribute under the terms of either the GNU General Public 602# License or the Artistic License, as specified in the Perl README file. 603# 604# Author: Jochen Wiedmann 605# Am Eisteich 9 606# 72555 Metzingen 607# Germany 608# 609# Email: joe@ispsoft.de 610# Phone: +49 7123 14887 611# 612# The source code PlRPC is very possibly on your computer right now, 613# since OurNet::BBS::Server depend on that library to run. Nevertheless, 614# you may obtain the PlRPC source via the Bundle::PlRPC package from 615# CPAN at http://www.cpan.org/. 616# 617####################################################################### 618 619sub CallMethod ($$$@) { 620 my($self, $handle, $method, @args) = @_; 621 my($ref, $object); 622 623 my $call_by_instance; 624 { 625 my $lock = lock($Net::Daemon::RegExpLock) 626 if $Net::Daemon::RegExpLock && $self->{'mode'} eq 'threads'; 627 $call_by_instance = ($handle =~ /=\w+\(0x/); 628 } 629 if ($call_by_instance) { 630 # Looks like a call by instance 631 $object = $self->UseHandle($handle); 632 $ref = ref($object); 633 } else { 634 # Call by class 635 $ref = $object = $handle; 636 } 637 638 if ($self->{'methods'}) { 639 my $class = $self->{'methods'}->{$ref}; 640 if (!$class || !$class->{$method}) { 641 die "Not permitted for method $method of class $ref"; 642 } 643 } 644 645 if ($method eq '__') { 646 $object->$method(@args); 647 } 648 else { 649 no strict 'refs'; 650 &{"$ref\::$method"}($self, @args); 651 } 652} 653 654sub Run ($) { 655 my $self = shift; 656 my $socket = $self->{'socket'}; 657 658 while (!$self->Done) { 659 my $msg; 660 661 if (my $timeout = $self->{'connection-timeout'}) { 662 eval { 663 local $SIG{ALRM} = sub { die "alarm\n" }; 664 alarm $timeout; 665 $msg = $self->RPC::PlServer::Comm::Read; 666 alarm 0; 667 } 668 } 669 else { 670 $msg = $self->RPC::PlServer::Comm::Read; 671 } 672 673 last unless defined($msg); 674 die "Expected array" unless ref($msg) eq 'ARRAY'; 675 my($error, $command); 676 if (!($command = shift @$msg)) { 677 $error = "Expected method name"; 678 } else { 679 if ($self->{'methods'}) { 680 my $class = $self->{'methods'}->{ref($self)}; 681 if (!$class || !$class->{$command}) { 682 $error = "Not permitted for method $command of class " 683 . ref($self); 684 } 685 } 686 if (!$error) { 687 $self->Debug("Client executes method $command"); 688 my @result = eval { $self->$command(@$msg) }; 689 if ($@) { 690 $error = "Failed to execute method $command: $@"; 691 } else { 692 $self->RPC::PlServer::Comm::Write(\@result); 693 } 694 695 if ($self->{newciph}) { 696 $self->{cipher} = $self->{newciph}; 697 delete $self->{newciph}; 698 } 699 } 700 } 701 if ($error) { 702 $self->RPC::PlServer::Comm::Write(\$error); 703 } 704 } 705} 706 7071; 708