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