1# -*- perl -*- 2# 3# 4# PlRPC - Perl RPC, package for writing simple, RPC like clients and 5# servers 6# 7# 8# Copyright (c) 1997,1998 Jochen Wiedmann 9# 10# You may distribute under the terms of either the GNU General Public 11# License or the Artistic License, as specified in the Perl README file. 12# 13# Author: Jochen Wiedmann 14# Email: jochen.wiedmann at freenet.de 15# 16# 17 18use strict; 19 20require Net::Daemon; 21require RPC::PlServer::Comm; 22 23 24package RPC::PlServer; 25 26@RPC::PlServer::ISA = qw(Net::Daemon); 27$RPC::PlServer::VERSION = '0.2020'; 28 29 30############################################################################ 31# 32# Name: Version (Class method) 33# 34# Purpose: Returns version string 35# 36# Inputs: $class - This class 37# 38# Result: Version string; suitable for printed by "--version" 39# 40############################################################################ 41 42sub Version ($) { 43 "RPC::PlServer application, Copyright (C) 1997, 1998, Jochen Wiedmann"; 44} 45 46 47############################################################################ 48# 49# Name: Options (Class method) 50# 51# Purpose: Returns a hash ref of command line options 52# 53# Inputs: $class - This class 54# 55# Result: Options array; any option is represented by a hash ref; 56# used keys are 'template', a string suitable for describing 57# the option to Getopt::Long::GetOptions and 'description', 58# a string for the Usage message 59# 60############################################################################ 61 62sub Options ($) { 63 my $options = shift->SUPER::Options(); 64 $options->{'maxmessage'} = 65 { 'template' => 'maxmessage=i', 66 'description' => '--maxmessage <size> ' 67 . 'Set max message size to <size> (Default 65535).' 68 }; 69 $options->{'compression'} = 70 { 'template' => 'compression=s', 71 'description' => '--compression <type> ' 72 . 'Set compression type to off (default) or gzip.' 73 }; 74 $options; 75} 76 77 78############################################################################ 79# 80# Name: AcceptApplication, AcceptVersion, AcceptUser 81# (Instance methods) 82# 83# Purpose: Called for authentication purposes; these three in common 84# are replacing Net::Daemon's Accept(). 85# 86# Inputs: $self - Server instance 87# $app - Application name 88# $version - Version number 89# $user, $password - User name and password 90# 91# Result: TRUE, if the client has successfully authorized, FALSE 92# otherwise. The AcceptUser method (being called as the 93# last) may additionally return an array ref as a TRUE 94# value: This is treated as welcome message. 95# 96############################################################################ 97 98sub AcceptApplication ($$) { 99 my $self = shift; my $app = shift; 100 $self->Debug("Client requests application $app"); 101 UNIVERSAL::isa($self, $app); 102} 103 104sub AcceptVersion ($$) { 105 my $self = shift; my $version = shift; 106 $self->Debug("Client requests version $version"); 107 no strict 'refs'; 108 my $myversion = ${ref($self) . "::VERSION"}; 109 ($version <= $myversion) ? 1 : 0; 110} 111 112sub AcceptUser ($$$) { 113 my $self = shift; my $user = shift; my $password = shift; 114 115 my $client = $self->{'client'}; 116 return 1 unless $client->{'users'}; 117 my $users = $client->{'users'}; 118 foreach my $u (@$users) { 119 my $au; 120 if (ref($u)) { 121 $au = $u; 122 $u = defined($u->{'name'}) ? $u->{'name'} : ''; 123 } 124 if ($u eq $user) { 125 $self->{'authorized_user'} = $au; 126 return 1; 127 } 128 } 129 0; 130} 131 132sub Accept ($) { 133 my $self = shift; 134 my $socket = $self->{'socket'}; 135 my $comm = $self->{'comm'}; 136 return 0 if (!$self->SUPER::Accept()); 137 my $client; 138 if ($client = $self->{'client'}) { 139 if (my $cipher = $client->{'cipher'}) { 140 $self->Debug("Host encryption: %s", $cipher); 141 $self->{'cipher'} = $cipher; 142 } 143 } 144 145 my $msg = $comm->Read($socket); 146 die "Unexpected EOF from client" unless defined $msg; 147 die "Login message: Expected array, got $msg" unless ref($msg) eq 'ARRAY'; 148 149 my $app = $self->{'application'} = $msg->[0] || ''; 150 my $version = $self->{'version'} = $msg->[1] || 0; 151 my $user = $self->{'user'} = $msg->[2] || ''; 152 my $password = $self->{'password'} = $msg->[3] || ''; 153 154 $self->Debug("Client logs in: Application %s, version %s, user %s", 155 $app, $version, $user); 156 157 if (!$self->AcceptApplication($app)) { 158 $comm->Write($socket, 159 [0, "This is a " . ref($self) . " server, go away!"]); 160 return 0; 161 } 162 if (!$self->AcceptVersion($version)) { 163 $comm->Write($socket, 164 [0, "Sorry, but I am not running version $version."]); 165 return 0; 166 } 167 my $result; 168 if (!($result = $self->AcceptUser($user, $password))) { 169 $comm->Write($socket, 170 [0, "User $user is not permitted to connect."]); 171 return 0; 172 } 173 $comm->Write($socket, (ref($result) ? $result : [1, "Welcome!"])); 174 if (my $au = $self->{'authorized_user'}) { 175 if (ref($au) && (my $cipher = $au->{'cipher'})) { 176 $self->Debug("User encryption: %s", $cipher); 177 $self->{'cipher'} = $cipher; 178 } 179 } 180 181 if (my $client = $self->{'client'}) { 182 if (my $methods = $client->{'methods'}) { 183 $self->{'methods'} = $methods; 184 } 185 } 186 if (my $au = $self->{'authorized_user'}) { 187 if (my $methods = $au->{'methods'}) { 188 $self->{'methods'} = $methods; 189 } 190 } 191 192 1; 193} 194 195 196############################################################################ 197# 198# Name: new (Class method) 199# 200# Purpose: Constructor 201# 202# Inputs: $class - This class 203# $attr - Hash ref of attributes 204# $args - Array ref of command line arguments 205# 206# Result: Server object for success, error message otherwise 207# 208############################################################################ 209 210sub new ($$;$) { 211 my $self = shift->SUPER::new(@_); 212 $self->{'comm'} = RPC::PlServer::Comm->new($self); 213 $self; 214} 215 216 217############################################################################ 218# 219# Name: Run 220# 221# Purpose: Process client requests 222# 223# Inputs: $self - Server instance 224# 225# Returns: Nothing, dies in case of errors. 226# 227############################################################################ 228 229sub Run ($) { 230 my $self = shift; 231 my $comm = $self->{'comm'}; 232 my $socket = $self->{'socket'}; 233 234 while (!$self->Done()) { 235 my $msg = $comm->Read($socket); 236 last unless defined($msg); 237 die "Expected array" unless ref($msg) eq 'ARRAY'; 238 my($error, $command); 239 if (!($command = shift @$msg)) { 240 $error = "Expected method name"; 241 } else { 242 if ($self->{'methods'}) { 243 my $class = $self->{'methods'}->{ref($self)}; 244 if (!$class || !$class->{$command}) { 245 $error = "Not permitted for method $command of class " 246 . ref($self); 247 } 248 } 249 if (!$error) { 250 $self->Debug("Client executes method $command"); 251 my @result = eval { $self->$command(@$msg) }; 252 if ($@) { 253 $error = "Failed to execute method $command: $@"; 254 } else { 255 $comm->Write($socket, \@result); 256 } 257 } 258 } 259 if ($error) { 260 $comm->Write($socket, \$error); 261 } 262 } 263} 264 265 266############################################################################ 267# 268# Name: StoreHandle, NewHandle, UseHandle, DestroyHandle, 269# CallMethod 270# 271# Purpose: Support functions for working with objects 272# 273# Inputs: $self - server instance 274# $object - Server side object 275# $handle - Client side handle 276# 277############################################################################ 278 279sub StoreHandle ($$) { 280 my $self = shift; my $object = shift; 281 my $handle = "$object"; 282 $self->{'handles'}->{$handle} = $object; 283 $handle; 284} 285 286sub NewHandle ($$$@) { 287 my($self, $handle, $method, @args) = @_; 288 my $object = $self->CallMethod($handle, $method, @args); 289 die "Constructor $method didn't return a true value" unless $object; 290 $self->StoreHandle($object) 291} 292 293sub UseHandle ($$) { 294 my $self = shift; my $handle = shift; 295 $self->{'handles'}->{$handle} || die "No such object: $handle"; 296} 297 298sub DestroyHandle ($$) { 299 my $self = shift; my $handle = shift; 300 (delete $self->{'handles'}->{$handle}) || die "No such object: $handle"; 301 (); 302} 303 304sub CallMethod ($$$@) { 305 my($self, $handle, $method, @args) = @_; 306 my($ref, $object); 307 308 my $call_by_instance; 309 { 310 my $lock = lock($Net::Daemon::RegExpLock) 311 if $Net::Daemon::RegExpLock && $self->{'mode'} eq 'threads'; 312 $call_by_instance = ($handle =~ /=\w+\(0x/); 313 } 314 if ($call_by_instance) { 315 # Looks like a call by instance 316 $object = $self->UseHandle($handle); 317 $ref = ref($object); 318 } else { 319 # Call by class 320 $ref = $object = $handle; 321 } 322 323 if ($self->{'methods'}) { 324 my $class = $self->{'methods'}->{$ref}; 325 if (!$class || !$class->{$method}) { 326 die "Not permitted for method $method of class $ref"; 327 } 328 } 329 330 $object->$method(@args); 331} 332 333 3341; 335 336 337__END__ 338 339=head1 NAME 340 341RPC::PlServer - Perl extension for writing PlRPC servers 342 343=head1 SYNOPSIS 344 345 # Create a subclass of RPC::PlServer 346 use RPC::PlServer; 347 348 package MyServer; 349 $MyServer::VERSION = '0.01'; 350 @MyServer::ISA = qw(RPC::PlServer); 351 352 # Overwrite the Run() method to handle a single connection 353 sub Run { 354 my $self = shift; 355 my $socket = $self->{'socket'}; 356 } 357 358 # Create an instance of the MyServer class 359 package main; 360 my $server = MyServer->new({'localport' => '1234'}, \@ARGV); 361 362 # Bind the server to its port to make it actually running 363 $server->Bind(); 364 365 366=head1 DESCRIPTION 367 368PlRPC (Perl RPC) is a package for implementing servers and clients that 369are written in Perl entirely. The name is borrowed from Sun's RPC 370(Remote Procedure Call), but it could as well be RMI like Java's "Remote 371Method Interface), because PlRPC gives you the complete power of Perl's 372OO framework in a very simple manner. 373 374RPC::PlServer is the package used on the server side, and you guess what 375RPC::PlClient is for. Both share the package RPC::PlServer::Comm for 376communication purposes. See L<PlRPC::Client(3)> and L<RPC::PlServer::Comm> 377for these parts. 378 379PlRPC works by defining a set of methods that may be executed by the client. 380For example, the server might offer a method "multiply" to the client. Now 381the clients method call 382 383 @result = $client->multiply($a, $b); 384 385will be immediately mapped to a method call 386 387 @result = $server->multiply($a, $b); 388 389on the server. The arguments and results will be transferred to or from 390the server automagically. (This magic has a name in Perl: It's the 391Storable module, my thanks to Raphael Manfredi for this excellent 392package.) Simple, eh? :-) 393 394The RPC::PlServer and RPC::PlClient are abstract servers and clients: You 395have to derive your own classes from it. 396 397 398=head2 Additional options 399 400The RPC::PlServer inherits all of Net::Daemon's options and attributes 401and adds the following: 402 403=over 8 404 405=item I<cipher> 406 407The attribute value is an instance of Crypt::DES, Crypt::IDEA or any 408other class with the same API for block encryption. If you supply 409such an attribute, the traffic between client and server will be 410encrypted using this option. 411 412=item I<maxmessage> (B<--maxmessage=size>) 413 414The size of messages exchanged between client and server is restricted, 415in order to omit denial of service attacks. By default the limit is 41665536 bytes. 417 418=item users 419 420This is an attribute of the client object used for Permit/Deny rules 421in the config file. It's value is an array ref of user names that 422are allowed to connect from the given client. See the example config 423file below. L<CONFIGURATION FILE>. 424 425=back 426 427=head2 Error Handling 428 429Error handling is simple with the RPC package, because it is based on 430Perl exceptions completely. Thus your typical code looks like this: 431 432 eval { 433 # Do something here. Don't care for errors. 434 ... 435 }; 436 if ($@) { 437 # An error occurred. 438 ... 439 } 440 441 442=head2 Server Constructors 443 444 my $server = RPC::PlServer(\%options, \@args); 445 446(Class method) This constructor is immediately inherited from the 447Net::Daemon package. See L<Net::Daemon(3)> for details. 448 449 450=head2 Access Control 451 452 $ok = $self->AcceptApplication($app); 453 $ok = $self->AcceptVersion($version); 454 $ok = $self->AcceptUser($user, $password); 455 456The RPC::PlServer package has a very detailed access control scheme: First 457of all it inherits Net::Daemon's host based access control. It adds 458version control and user authorization. To achieve that, the method 459I<Accept> from Net::Daemon is split into three methods, 460I<AcceptApplication>, I<AcceptVersion> and I<AcceptUser>, each of them 461returning TRUE or FALSE. The client receives the arguments as the attributes 462I<application>, I<version>, I<user> and I<password>. A client is accepted 463only if all of the above methods are returning TRUE. 464 465The default implementations are as follows: The AcceptApplication method 466returns TRUE, if B<$self> is a subclass of B<$app>. The AcceptVersion 467method returns TRUE, if the requested version is less or equal to 468B<${$class}::VERSION>, $self being an instance of B<$class>. Whether a user 469is permitted to connect depends on the client configuration. See 470L<CONFIGURATION FILE> below for examples. 471 472 473=head2 Method based access control 474 475Giving a client the ability to invoke arbitrary methods can be a terrible 476security hole. Thus the server has a I<methods> attribute. This is a hash 477ref of class names as keys, the values being hash refs again with method 478names as the keys. That is, if your hash looks as follows: 479 480 $self->{'methods'} = { 481 'CalcServer' => { 482 'NewHandle' => 1, 483 'CallMethod' => 1 }, 484 'Calculator' => { 485 'new' => 1, 486 'multiply' => 1, 487 'add' => 1, 488 'divide' => 1, 489 'subtract' => 1 } 490 }; 491 492then the client may use the CalcServer's I<NewHandle> method to create 493objects, but only via the permitted constructor Calculator->new. Once 494a Calculator object is created, the server may invoke the methods 495multiply, add, divide and subtract. 496 497 498=head1 CONFIGURATION FILE 499 500The server config file is inherited from Net::Daemon. It adds the 501I<users> and I<cipher> attribute to the client list. Thus a typical 502config file might look as follows: 503 504 # Load external modules; this is not required unless you use 505 # the chroot() option. 506 #require DBD::mysql; 507 #require DBD::CSV; 508 509 # Create keys 510 my $myhost_key = Crypt::IDEA->new('83fbd23390ade239'); 511 my $bob_key = Crypt::IDEA->new('be39893df23f98a2'); 512 513 { 514 # 'chroot' => '/var/dbiproxy', 515 'facility' => 'daemon', 516 'pidfile' => '/var/dbiproxy/dbiproxy.pid', 517 'user' => 'nobody', 518 'group' => 'nobody', 519 'localport' => '1003', 520 'mode' => 'fork', 521 522 # Access control 523 'clients' => [ 524 # Accept the local LAN (192.168.1.*) 525 { 526 'mask' => '^192\.168\.1\.\d+$', 527 'accept' => 1, 528 'users' => [ 'bob', 'jim' ], 529 'cipher' => $myhost_key 530 }, 531 # Accept myhost.company.com 532 { 533 'mask' => '^myhost\.company\.com$', 534 'accept' => 1, 535 'users' => [ { 536 'name' => 'bob', 537 'cipher' => $bob_key 538 } ] 539 }, 540 # Deny everything else 541 { 542 'mask' => '.*', 543 'accept' => 0 544 } 545 ] 546 } 547 548Things you should note: The user list of 192.168.1.* contains scalar 549values, but the user list of myhost.company.com contains hash refs: 550This is required, because the user configuration is more specific 551for user based encryption. 552 553 554 555=head1 EXAMPLE 556 557Enough wasted time, spread the example, not the word. :-) Let's write 558a simple server, say a server for MD5 digests. The server uses the 559external package MD5, but the client doesn't need to install the 560package. L<MD5(3)>. We present the server source here, the client 561is part of the RPC::PlClient man page. See L<RPC::PlClient(3)>. 562 563 564 #!/usr/bin/perl -wT 565 # Note the -T switch! This is always recommended for Perl servers. 566 567 use strict; # Always a good choice. 568 569 require RPC::PlServer; 570 require MD5; 571 572 573 package MD5_Server; # Clients need to request application 574 # "MD5_Server" 575 576 $MD5_Server::VERSION = '1.0'; # Clients will be refused, if they 577 # request version 1.1 578 @MD5_Server::ISA = qw(RPC::PlServer); 579 580 eval { 581 # Server options below can be overwritten in the config file or 582 # on the command line. 583 my $server = MD5_Server->new({ 584 'pidfile' => '/var/run/md5serv.pid', 585 'configfile' => '/etc/md5serv.conf', 586 'facility' => 'daemon', # Default 587 'user' => 'nobody', 588 'group' => 'nobody', 589 'localport' => 2000, 590 'logfile' => 0, # Use syslog 591 'mode' => 'fork', # Recommended for Unix 592 'methods' => { 593 'MD5_Server' => { 594 'ClientObject' => 1, 595 'CallMethod' => 1, 596 'NewHandle' => 1 597 }, 598 'MD5' => { 599 'new' => 1, 600 'add' => 1, 601 'hexdigest' => 1 602 }, 603 } 604 }); 605 $server->Bind(); 606 }; 607 608 609=head1 SECURITY 610 611It has to be said: PlRPC based servers are a potential security problem! 612I did my best to avoid security problems, but it is more than likely, 613that I missed something. Security was a design goal, but not *the* 614design goal. (A well known problem ...) 615 616I highly recommend the following design principles: 617 618=head2 Protection against "trusted" users 619 620=over 4 621 622=item perlsec 623 624Read the perl security FAQ (C<perldoc perlsec>) and use the C<-T> switch. 625 626=item taintperl 627 628B<Use> the C<-T> switch. I mean it! 629 630=item Verify data 631 632Never untaint strings withouth verification, better verify twice. 633For example the I<CallMethod> function first checks, whether an 634object handle is valid before coercing a method on it. 635 636=item Be restrictive 637 638Think twice, before you give a client access to a method. 639 640=item perlsec 641 642And just in case I forgot it: Read the C<perlsec> man page. :-) 643 644=back 645 646=head2 Protection against untrusted users 647 648=over 4 649 650=item Host based authorization 651 652PlRPC has a builtin host based authorization scheme; use it! 653See L</CONFIGURATION FILE>. 654 655=item User based authorization 656 657PlRPC has a builtin user based authorization scheme; use it! 658See L</CONFIGURATION FILE>. 659 660 661=item Encryption 662 663Using encryption with PlRPC is extremely easy. There is absolutely 664no reason for communicating unencrypted with the clients. Even 665more: I recommend two phase encryption: The first phase is the 666login phase, where to use a host based key. As soon as the user 667has authorized, you should switch to a user based key. See the 668DBI::ProxyServer for an example. 669 670=back 671 672=head1 AUTHOR AND COPYRIGHT 673 674The PlRPC-modules are 675 676 Copyright (C) 1998, Jochen Wiedmann 677 Email: jochen.wiedmann at freenet.de 678 679 All rights reserved. 680 681You may distribute this package under the terms of either the GNU 682General Public License or the Artistic License, as specified in the 683Perl README file. 684 685 686=head1 SEE ALSO 687 688L<RPC::PlClient(3)>, L<RPC::PlServer::Comm(3)>, L<Net::Daemon(3)>, 689L<Net::Daemon::Log(3)>, L<Storable(3)>, L<Sys::Syslog(3)>, 690L<Win32::EventLog(3)> 691 692See L<DBI::ProxyServer(3)> for an example application. 693 694=cut 695