1package Net::EasyTCP; 2 3# 4# $Header: /cvsroot/Net::EasyTCP/EasyTCP.pm,v 1.144 2004/03/17 14:14:31 mina Exp $ 5# 6 7use strict; 8use vars qw($VERSION @ISA @EXPORT @EXPORT_OK $_SERIAL %_COMPRESS_AVAILABLE %_ENCRYPT_AVAILABLE %_MISC_AVAILABLE $PACKETSIZE); 9 10use IO::Socket; 11use IO::Select; 12use Storable qw(nfreeze thaw); 13 14# 15# This block's purpose is to: 16# Put the list of available modules in %_COMPRESS_AVAILABLE and %_ENCRYPT_AVAILABLE and %_MISC_AVAILABLE 17# 18BEGIN { 19 my $version; 20 my $hasCBC; 21 my @_compress_modules = ( 22 23 # 24 # MAKE SURE WE DO NOT EVER ASSIGN THE SAME KEY TO MORE THAN ONE MODULE, EVEN OLD ONES NO LONGER IN THE LIST 25 # 26 # HIGHEST EVER USED: 2 27 # 28 [ '1', 'Compress::Zlib' ], 29 [ '2', 'Compress::LZF' ], 30 ); 31 my @_encrypt_modules = ( 32 33 # 34 # MAKE SURE WE DO NOT EVER ASSIGN THE SAME KEY TO MORE THAN ONE MODULE, EVEN OLD ONES NO LONGER IN THE LIST 35 # 36 # HIGHEST EVER USED: E 37 # 38 [ 'B', 'Crypt::RSA', 0, 0 ], 39 [ '3', 'Crypt::CBC', 0, 0 ], 40 [ 'A', 'Crypt::Rijndael', 1, 1 ], 41 [ '9', 'Crypt::RC6', 1, 1 ], 42 [ '4', 'Crypt::Blowfish', 1, 1 ], 43 [ '6', 'Crypt::DES_EDE3', 1, 1 ], 44 [ '5', 'Crypt::DES', 1, 1 ], 45 [ 'C', 'Crypt::Twofish2', 1, 1 ], 46 [ 'D', 'Crypt::Twofish', 1, 1 ], 47 [ 'E', 'Crypt::TEA', 1, 1 ], 48 [ '2', 'Crypt::CipherSaber', 0, 1 ], 49 ); 50 my @_misc_modules = ( 51 52 # 53 # MAKE SURE WE DO NOT EVER ASSIGN THE SAME KEY TO MORE THAN ONE MODULE, EVEN OLD ONES NO LONGER IN THE LIST 54 # (this is not as necessary as compress and encrypt since it's not transmitted to peers, but just in case...) 55 # 56 # HIGHEST EVER USED: 1 57 # 58 [ '1', 'Crypt::Random' ], 59 ); 60 61 # 62 # Let's reset some variables: 63 # 64 $hasCBC = 0; 65 $_COMPRESS_AVAILABLE{_order} = []; 66 $_ENCRYPT_AVAILABLE{_order} = []; 67 $_MISC_AVAILABLE{_order} = []; 68 69 # 70 # Now we check the compress array for existing modules 71 # 72 foreach (@_compress_modules) { 73 $@ = undef; 74 eval { 75 eval("require $_->[1];") || die "$_->[1] not found\n"; 76 $version = eval("\$$_->[1]::VERSION;") || die "Failed to determine version for $_->[1]\n"; 77 }; 78 if (!$@) { 79 push(@{ $_COMPRESS_AVAILABLE{_order} }, $_->[0]); 80 $_COMPRESS_AVAILABLE{ $_->[0] }{name} = $_->[1]; 81 $_COMPRESS_AVAILABLE{ $_->[0] }{version} = $version; 82 } 83 } 84 85 # 86 # Now we check the encrypt array for existing modules 87 # 88 foreach (@_encrypt_modules) { 89 $@ = undef; 90 eval { 91 eval("require $_->[1];") || die "$_->[1] not found\n"; 92 $version = eval("\$$_->[1]::VERSION;") || die "Failed to determine version for $_->[1]\n"; 93 }; 94 if (!$@) { 95 if ($_->[1] eq 'Crypt::CBC') { 96 $hasCBC = 1; 97 } 98 elsif (($hasCBC && $_->[2]) || !$_->[2]) { 99 push(@{ $_ENCRYPT_AVAILABLE{_order} }, $_->[0]); 100 $_ENCRYPT_AVAILABLE{ $_->[0] }{name} = $_->[1]; 101 $_ENCRYPT_AVAILABLE{ $_->[0] }{cbc} = $_->[2]; 102 $_ENCRYPT_AVAILABLE{ $_->[0] }{mergewithpassword} = $_->[3]; 103 $_ENCRYPT_AVAILABLE{ $_->[0] }{version} = $version; 104 } 105 } 106 } 107 108 # 109 # Now we check the misc array for existing modules 110 # 111 foreach (@_misc_modules) { 112 $@ = undef; 113 eval { 114 eval("require $_->[1];") || die "$_->[1] not found\n"; 115 $version = eval("\$$_->[1]::VERSION;") || die "Failed to determine version for $_->[1]\n"; 116 }; 117 if (!$@) { 118 push(@{ $_MISC_AVAILABLE{_order} }, $_->[0]); 119 $_MISC_AVAILABLE{ $_->[0] }{name} = $_->[1]; 120 $_MISC_AVAILABLE{ $_->[0] }{version} = $version; 121 } 122 } 123} 124 125require Exporter; 126 127@ISA = qw(Exporter); 128@EXPORT = qw(); 129$VERSION = '0.26'; 130$PACKETSIZE = 4096; 131 132# 133# POD DOCUMENTATION: 134# 135 136=head1 NAME 137 138Net::EasyTCP - Easily create secure, bandwidth-friendly TCP/IP clients and servers 139 140=head1 FEATURES 141 142=over 4 143 144=item * 145 146One easy module to create both clients and servers 147 148=item * 149 150Object Oriented interface 151 152=item * 153 154Event-based callbacks in server mode 155 156=item * 157 158Internal protocol to take care of all the common transport problems 159 160=item * 161 162Transparent encryption 163 164=item * 165 166Transparent compression 167 168=back 169 170=head1 SYNOPSIS 171 172=over 4 173 174=item SERVER EXAMPLE: 175 176 use Net::EasyTCP; 177 178 # 179 # Create the server object 180 # 181 $server = new Net::EasyTCP( 182 mode => "server", 183 port => 2345, 184 ) 185 || die "ERROR CREATING SERVER: $@\n"; 186 187 # 188 # Tell it about the callbacks to call 189 # on known events 190 # 191 $server->setcallback( 192 data => \&gotdata, 193 connect => \&connected, 194 disconnect => \&disconnected, 195 ) 196 || die "ERROR SETTING CALLBACKS: $@\n"; 197 198 # 199 # Start the server 200 # 201 $server->start() || die "ERROR STARTING SERVER: $@\n"; 202 203 # 204 # This sub gets called when a client sends us data 205 # 206 sub gotdata { 207 my $client = shift; 208 my $serial = $client->serial(); 209 my $data = $client->data(); 210 print "Client $serial sent me some data, sending it right back to them again\n"; 211 $client->send($data) || die "ERROR SENDING TO CLIENT: $@\n"; 212 if ($data eq "QUIT") { 213 $client->close() || die "ERROR CLOSING CLIENT: $@\n"; 214 } 215 elsif ($data eq "DIE") { 216 $server->stop() || die "ERROR STOPPING SERVER: $@\n"; 217 } 218 } 219 220 # 221 # This sub gets called when a new client connects 222 # 223 sub connected { 224 my $client = shift; 225 my $serial = $client->serial(); 226 print "Client $serial just connected\n"; 227 } 228 229 # 230 # This sub gets called when an existing client disconnects 231 # 232 sub disconnected { 233 my $client = shift; 234 my $serial = $client->serial(); 235 print "Client $serial just disconnected\n"; 236 } 237 238=item CLIENT EXAMPLE: 239 240 use Net::EasyTCP; 241 242 # 243 # Create a new client and connect to a server 244 # 245 $client = new Net::EasyTCP( 246 mode => "client", 247 host => 'localhost', 248 port => 2345, 249 ) 250 || die "ERROR CREATING CLIENT: $@\n"; 251 252 # 253 # Send and receive a simple string 254 # 255 $client->send("HELLO THERE") || die "ERROR SENDING: $@\n"; 256 $reply = $client->receive() || die "ERROR RECEIVING: $@\n"; 257 258 # 259 # Send and receive complex objects/strings/arrays/hashes by reference 260 # 261 %hash = ("to be or" => "not to be" , "just another" => "perl hacker"); 262 $client->send(\%hash) || die "ERROR SENDING: $@\n"; 263 $reply = $client->receive() || die "ERROR RECEIVING: $@\n"; 264 foreach (keys %{$reply}) { 265 print "Received key: $_ = $reply->{$_}\n"; 266 } 267 268 # 269 # Send and receive large binary data 270 # 271 for (1..8192) { 272 for (0..255) { 273 $largedata .= chr($_); 274 } 275 } 276 $client->send($largedata) || die "ERROR SENDING: $@\n"; 277 $reply = $client->receive() || die "ERROR RECEIVING: $@\n"; 278 279 # 280 # Cleanly disconnect from the server 281 # 282 $client->close(); 283 284=back 285 286=head1 DESCRIPTION 287 288This class allows you to easily create TCP/IP clients and servers and provides an OO interface to manage the connection(s). This allows you to concentrate on the application rather than on the transport. 289 290You still have to engineer your high-level protocol. For example, if you're writing an SMTP client-server pair, you will have to teach your client to send "HELO" when it connects, and you will have to teach your server what to do once it receives the "HELO" command, and so forth. 291 292What you won't have to do is worry about how the command will get there, about line termination, about binary data, complex-structure serialization, encryption, compression, or about fragmented packets on the received end. All of these will be taken care of by this class. 293 294=head1 CONSTRUCTOR 295 296=over 4 297 298=item new(%hash) 299 300Constructs and returns a new Net::EasyTCP object. Such an object behaves in one of two modes (that needs to be supplied to new() on creation time). You can create either a server object (which accepts connections from several clients) or a client object (which initiates a connection to a server). 301 302new() expects to be passed a hash. The following keys are accepted: 303 304=over 4 305 306=item donotcheckversion 307 308Set to 1 to force a client to continue connecting even if an encryption/compression/Storable module version mismatch is detected. (Using this is highly unrecommended, you should upgrade the module in question to the same version on both ends) 309Note that as of Net::EasyTCP version 0.20, this parameter is fairly useless since that version (and higher) do not require external modules to have the same version anymore, but instead determine compatability between different versions dynamically. See the accompanying Changes file for more details. 310(Optional and acceptable when mode is "client") 311 312=item donotcompress 313 314Set to 1 to forcefully disable L<compression|COMPRESSION AND ENCRYPTION> even if the appropriate module(s) are found. 315(Optional) 316 317=item donotcompresswith 318 319Set to a scalar or an arrayref of compression module(s) you'd like to avoid compressing with. For example, if you do not want to use Compress::LZF, you can do so by utilizing this option. 320(Optional) 321 322=item donotencrypt 323 324Set to 1 to forcefully disable L<encryption|COMPRESSION AND ENCRYPTION> even if the appropriate module(s) are found. 325(Optional) 326 327=item donotencryptwith 328 329Set to a scalar or an arrayref of encryption module(s) you'd like to avoid encrypting with. For example, Crypt::RSA takes a long time to initialize keys and encrypt/decrypt, so you can avoid using it by utilizing this option. 330(Optional) 331 332=item host 333 334Must be set to the hostname/IP address to connect to. 335(Mandatory when mode is "client") 336 337=item mode 338 339Must be set to either "client" or "server" according to the type of object you want returned. 340(Mandatory) 341 342=item password 343 344Defines a password to use for the connection. When mode is "server" this password will be required from clients before the full connection is accepted . When mode is "client" this is the password that the server connecting to requires. 345 346Also, when encryption using a symmetric encryption module is used, this password is included as part of the secret "key" for encrypting the data. 347(Optional) 348 349=item port 350 351Must be set to the port the client connects to (if mode is "client") or to the port to listen to (if mode is "server"). If you're writing a client+server pair, they must both use the same port number. 352(Mandatory) 353 354=item timeout 355 356Set to an integer (seconds) that a client attempting to establish a TCP/IP connection to a server will timeout after. If not supplied, the default is 30 seconds. (Optional and acceptable only when mode is "client") 357 358=item welcome 359 360If someone uses an interactive telnet program to telnet to the server, they will see this welcome message. 361(Optional and acceptable only when mode is "server") 362 363=back 364 365=back 366 367=head1 METHODS 368 369B<[C] = Available to objects created as mode "client"> 370 371B<[H] = Available to "hybrid" client objects, as in "the server-side client objects created when a new client connects". These are the objects passed to your server's callbacks. Such hybrid clients behave almost exactly like a normal "client" object you create yourself, except for a slight difference in the available methods to retrieve data.> 372 373B<[S] = Available to objects created as mode "server"> 374 375=over 4 376 377=item addclientip(@array) 378 379B<[S]> Adds an IP address (or IP addresses) to the list of allowed clients to a server. If this is done, the server will not accept connections from clients not in it's list. 380 381The compliment of this function is deleteclientip() . 382 383=item callback(%hash) 384 385See setcallback() 386 387=item clients() 388 389B<[S]> Returns all the clients currently connected to the server. If called in array context will return an array of client objects. If called in scalar context will return the number of clients connected. 390 391=item close() 392 393B<[C][H]> Instructs a client object to close it's connection with a server. 394 395=item compression() 396 397B<[C][H]> Returns the name of the module used as the compression module for this connection, undef if no compression occurs. 398 399=item data() 400 401B<[H]> Retrieves the previously-retrieved data associated with a hybrid client object. This method is typically used from inside the callback sub associated with the "data" event, since the callback sub is passed nothing more than a client object. 402 403=item deleteclientip(@array) 404 405B<[S]> Deletes an IP address (or IP addresses) from the list of allowed clients to a server. The IP address (or IP addresses) supplied will no longer be able to connect to the server. 406 407The compliment of this function is addclientip() . 408 409=item disconnect() 410 411See close() 412 413=item do_one_loop() 414 415B<[S]> Instructs a server object to "do one loop" and return ASAP. This method needs to be called VERY frequently for a server object to function as expected (either through some sort of loop inside your program if you need to do other things beside serve clients, or via the start() method if your entire program is dedicated to serving clients). Each one loop will help the server do it's job, including accepting new clients, receiving data from them, firing off the appropriate callbacks etc. 416 417=item encryption() 418 419B<[C][H]> Returns the name of the module used as the encryption module for this connection, undef if no encryption occurs. 420 421=item mode() 422 423B<[C][H][S]> Identifies the mode of the object. Returns either "client" or "server" 424 425=item receive($timeout) 426 427B<[C]> Receives data sent to the client by a server and returns it. It will block until data is received or until a certain timeout of inactivity (no data transferring) has occurred. 428 429It accepts an optional parameter, a timeout value in seconds. If none is supplied it will default to 300. 430 431=item remoteip() 432 433B<[C][H]> Returns the IP address of the host on the other end of the connection. 434 435=item remoteport() 436 437B<[C][H]> Returns the port of the host on the other end of the connection. 438 439=item running() 440 441B<[S]> Returns true if the server is running (started), false if it is not. 442 443=item send($data) 444 445B<[C][H]> Sends data to a server. It can be used on client objects you create with the new() constructor, clients objects returned by the clients() method, or with client objects passed to your callback subs by a running server. 446 447It accepts one parameter, and that is the data to send. The data can be a simple scalar or a reference to something more complex. 448 449=item serial() 450 451B<[H]> Retrieves the serial number of a client object, This is a simple integer that allows your callback subs to easily differentiate between different clients. 452 453=item setcallback(%hash) 454 455B<[S]> Tells the server which subroutines to call when specific events happen. For example when a client sends the server data, the server calls the "data" callback sub. 456 457setcallback() expects to be passed a hash. Each key in the hash is the callback type identifier, and the value is a reference to a sub to call once that callback type event occurs. 458 459Valid keys in that hash are: 460 461=over 4 462 463=item connect 464 465Called when a new client connects to the server 466 467=item data 468 469Called when an existing client sends data to the server 470 471=item disconnect 472 473Called when an existing client disconnects 474 475=back 476 477Whenever a callback sub is called, it is passed a single parameter, a CLIENT OBJECT. The callback code may then use any of the methods available to client objects to do whatever it wants to do (Read data sent from the client, reply to the client, close the client connection etc...) 478 479 480=item socket() 481 482B<[C][H]> Returns the handle of the socket (actually an L<IO::Socket|IO::Socket> object) associated with the supplied object. This is useful if you're interested in using L<IO::Select|IO::Select> or select() and want to add a client object's socket handle to the select list. 483 484Note that eventhough there's nothing stopping you from reading and writing directly to the socket handle you retrieve via this method, you should never do this since doing so would definately corrupt the internal protocol and may render your connection useless. Instead you should use the send() and receive() methods. 485 486=item start(subref) 487 488B<[S]> Starts a server and does NOT return until the server is stopped via the stop() method. This method is a simple while() wrapper around the do_one_loop() method and should be used if your entire program is dedicated to being a server, and does not need to do anything else concurrently. 489 490If you need to concurrently do other things when the server is running, then you can supply to start() the optional reference to a subroutine (very similar to the callback() method). If that is supplied, it will be called every loop. This is very similar to the callback subs, except that the called sub will be passed the server object that the start() method was called on (unlike normal client callbacks which are passed a client object). The other alternative to performing other tasks concurrently is to not use the start() method at all and directly call do_one_loop() repeatedly in your own program. 491 492=item stop() 493 494B<[S]> Instructs a running server to stop and returns immediately (does not wait for the server to actually stop, which may be a few seconds later). To check if the server is still running or not use the running() method. 495 496=back 497 498=head1 COMPRESSION AND ENCRYPTION 499 500Clients and servers written using this class will automatically compress and/or encrypt the transferred data if the appropriate modules are found. 501 502Compression will be automatically enabled if one (or more) of: L<Compress::Zlib|Compress::Zlib> or L<Compress::LZF|Compress::LZF> are installed on both the client and the server. 503 504As-symmetric encryption will be automatically enabled if L<Crypt::RSA|Crypt::RSA> is installed on both the client and the server. 505 506Symmetric encryption will be automatically enabled if one (or more) of: L<Crypt::Rijndael|Crypt::Rijndael>* or L<Crypt::RC6|Crypt::RC6>* or L<Crypt::Blowfish|Crypt::Blowfish>* or L<Crypt::DES_EDE3|Crypt::DES_EDE3>* or L<Crypt::DES|Crypt::DES>* or L<Crypt::Twofish2|Crypt::Twofish2>* or L<Crypt::Twofish|Crypt::Twofish>* or L<Crypt::TEA|Crypt::TEA>* or L<Crypt::CipherSaber|Crypt::CipherSaber> are installed on both the client and the server. 507 508Strong randomization will be automatically enabled if L<Crypt::Random|Crypt::Random> is installed; otherwise perl's internal rand() is used to generate random keys. 509 510Preference to the compression/encryption method used is determind by availablity checking following the order in which they are presented in the above lists. 511 512Note that during the negotiation upon connection, servers and clients written using Net::EasyTCP version lower than 0.20 communicated the version of the selected encryption/compression modules. If a version mismatch is found, the client reported a connection failure stating the reason (module version mismatch). This behavior was necessary since it was observed that different versions of the same module could produce incompatible output. If this is encountered, it is strongly recommended you upgrade the module in question to the same version on both ends, or more preferrably, Net::EasyTCP on both ends to the latest version, at a minimum 0.20. However, if you wish to forcefully connect overlooking a version mismatch (risking instability/random problems/data corruption) you may supply the "donotcheckversion" key to the new() constructor of the client object. This is no longer a requirement of Net::EasyTCP version 0.20 or higher since these newer versions have the ability to use different-version modules as long as their data was compatible, which was automatically determined at negotiation time. 513 514To find out which module(s) have been negotiated for use you can use the compression() and encryption() methods. 515 516* Note that for this class's purposes, L<Crypt::CBC|Crypt::CBC> is a requirement to use any of the encryption modules with a * next to it's name in the above list. So eventhough you may have these modules installed on both the client and the server, they will not be used unless L<Crypt::CBC|Crypt::CBC> is also installed on both ends. 517 518* Note that the nature of symmetric cryptography dictates sharing the secret keys somehow. It is therefore highly recommend to use an As-symmetric cryptography module (such as Crypt::RSA) for serious encryption needs; as a determined hacker might find it trivial to decrypt your data with other symmetric modules. 519 520* Note that if symmetric cryptography is used, then it is highly recommended to also use the "password" feature on your servers and clients; since then the "password" will, aside from authentication, be also used in the "secret key" to encrypt the data. Without a password, the secret key has to be transmitted to the other side during the handshake, significantly lowering the overall security of the data. 521 522If the above modules are installed but you want to forcefully disable compression or encryption, supply the "donotcompress" and/or "donotencrypt" keys to the new() constructor. If you would like to forcefully disable the use of only some modules, supply the "donotcompresswith" and/or "donotencryptwith" keys to the new() constructor. This could be used for example to disable the use of Crypt::RSA if you cannot afford the time it takes to generate it's keypairs etc... 523 524=head1 RETURN VALUES AND ERRORS 525 526The constructor and all methods return something that evaluates to true when successful, and to false when not successful. 527 528There are a couple of exceptions to the above rule and they are the following methods: 529 530=over 4 531 532=item * 533 534clients() 535 536=item * 537 538data() 539 540=back 541 542The above methods may return something that evaluates to false (such as an empty string, an empty array, or the string "0") eventhough there was no error. In that case check if the returned value is defined or not, using the defined() Perl function. 543 544If not successful, the variable $@ will contain a description of the error that occurred. 545 546=head1 NOTES 547 548=over 4 549 550=item Incompatability with Net::EasyTCP version 0.01 551 552Version 0.02 and later have had their internal protocol modified to a fairly large degree. This has made compatability with version 0.01 impossible. If you're going to use version 0.02 or later (highly recommended), then you will need to make sure that none of the clients/servers are still using version 0.01. It is highly recommended to use the same version of this module on both sides. 553 554=item Internal Protocol 555 556This class implements a miniature protocol when it sends and receives data between it's clients and servers. This means that a server created using this class cannot properly communicate with a normal client of any protocol (pop3/smtp/etc..) unless that client was also written using this class. It also means that a client written with this class will not properly communicate with a different server (telnet/smtp/pop3 server for example, unless that server is implemented using this class also). This limitation will not change in future releases due to the plethora of advantages the internal protocol gives us. 557 558In other words, if you write a server using this class, write the client using this class also, and vice versa. 559 560=item Delays 561 562This class does not use the fork() method whatsoever. This means that all it's input/output and multi-socket handling is done via select(). 563 564This leads to the following limitation: When a server calls one of your callback subs, it waits for it to return and therefore cannot do anything else. If your callback sub takes 5 minutes to return, then the server will not be able to do anything for 5 minutes, such as acknowledge new clients, or process input from other clients. 565 566In other words, make the code in your callbacks' subs' minimal and strive to make it return as fast as possible. 567 568=item Deadlocks 569 570As with any client-server scenario, make sure you engineer how they're going to talk to each other, and the order they're going to talk to each other in, quite carefully. If both ends of the connection are waiting for the other end to say something, you've got a deadlock. 571 572=back 573 574=head1 AUTHOR 575 576Mina Naguib 577http://www.topfx.com 578mnaguib@cpan.org 579 580=head1 SEE ALSO 581 582Perl(1), L<IO::Socket>, L<IO::Select>, L<Compress::Zlib>, L<Compress::LZF>, L<Crypt::RSA>, L<Crypt::CBC>, L<Crypt::Rijndael>, L<Crypt::RC6>, L<Crypt::Blowfish>, L<Crypt::DES_EDE3>, L<Crypt::DES>, L<Crypt::Twofish2>, L<Crypt::Twofish>, L<Crypt::TEA>, L<Crypt::CipherSaber>, L<Crypt::Random>, defined(), rand() 583 584=head1 COPYRIGHT 585 586Copyright (C) 2001-2003 Mina Naguib. All rights reserved. Use is subject to the Perl license. 587 588=cut 589 590# 591# The main constructor. This calls either _new_client or _new_server depending on the supplied mode 592# 593sub new { 594 my $class = shift; 595 my %para = @_; 596 597 # Let's lowercase all keys in %para 598 foreach (keys %para) { 599 if ($_ ne lc($_)) { 600 $para{ lc($_) } = $para{$_}; 601 delete $para{$_}; 602 } 603 } 604 if ($para{mode} =~ /^c/i) { 605 return _new_client($class, %para); 606 } 607 elsif ($para{mode} =~ /^s/i) { 608 return _new_server($class, %para); 609 } 610 else { 611 $@ = "Supplied mode '$para{mode}' unacceptable. Must be either 'client' or 'server'"; 612 return undef; 613 } 614} 615 616# 617# Make callback() a synonim to setcallback() 618# 619 620sub callback { 621 return setcallback(@_); 622} 623 624# 625# This method adds an ip address(es) to the list of valid IPs a server can accept connections 626# from. 627# 628sub addclientip { 629 my $self = shift; 630 my @ips = @_; 631 if ($self->{_mode} ne "server") { 632 $@ = "$self->{_mode} cannot use method addclientip()"; 633 return undef; 634 } 635 foreach (@ips) { 636 $self->{_clientip}{$_} = 1; 637 } 638 return 1; 639} 640 641# 642# This method does the opposite of addclient(), it removes an ip address(es) from the list 643# of valid IPs a server can accept connections from. 644# 645sub deleteclientip { 646 my $self = shift; 647 my @ips = @_; 648 if ($self->{_mode} ne "server") { 649 $@ = "$self->{_mode} cannot use method deleteclientip()"; 650 return undef; 651 } 652 foreach (@ips) { 653 delete $self->{_clientip}{$_}; 654 } 655 return 1; 656} 657 658# 659# 660# This method modifies the _callback_XYZ in a server object. These are the routines 661# the server calls when an event (data, connect, disconnect) happens 662# 663sub setcallback { 664 my $self = shift; 665 my %para = @_; 666 if ($self->{_mode} ne "server") { 667 $@ = "$self->{_mode} cannot use method setcallback()"; 668 return undef; 669 } 670 foreach (keys %para) { 671 if (ref($para{$_}) ne "CODE") { 672 $@ = "Callback $_ $para{$_} does not exist"; 673 return 0; 674 } 675 $self->{_callbacks}->{$_} = $para{$_}; 676 } 677 return 1; 678} 679 680# 681# This method starts the server and does not return until stop() is called. 682# All other behavior is delegated to do_one_loop() 683# 684sub start { 685 my $self = shift; 686 my $callback = shift; 687 if ($self->{_mode} ne "server") { 688 $@ = "$self->{_mode} cannot use method start()"; 689 return undef; 690 } 691 $self->{_running} = 1; 692 $self->{_requeststop} = 0; 693 694 # 695 # Let's loop until we're stopped: 696 # 697 while (!$self->{_requeststop}) { 698 $self->do_one_loop() || return undef; 699 if ($callback && ref($callback) eq "CODE") { 700 &{$callback}($self); 701 } 702 } 703 704 # 705 # If we reach here the server's been stopped 706 # 707 $self->{_running} = 0; 708 $self->{_requeststop} = 0; 709 return 1; 710} 711 712# 713# This method does "one loop" of server work and returns ASAP 714# It should be called very frequently, either through a while() loop in the program 715# or through the start() method 716# 717# It accepts new clients, accepts data from them, and fires off any callback events as necessary 718# 719sub do_one_loop { 720 my $self = shift; 721 my @ready; 722 my $clientsock; 723 my $tempdata; 724 my $serverclient; 725 my $realdata; 726 my $result; 727 my $negotiatingtimeout = 45; 728 my $peername; 729 my $remoteport; 730 my $remoteip; 731 732 if ($self->{_mode} ne "server") { 733 $@ = "$self->{_mode} cannot use method do_one_loop()"; 734 return undef; 735 } 736 $self->{_lastglobalkeygentime} ||= time; 737 @ready = $self->{_selector}->can_read(0.01); 738 foreach (@ready) { 739 if ($_ == $self->{_sock}) { 740 741 # 742 # The SERVER SOCKET is ready for accepting a new client 743 # 744 $clientsock = $self->{_sock}->accept(); 745 if (!$clientsock) { 746 $@ = "Error while accepting new connection: $!"; 747 return undef; 748 } 749 750 # 751 # We get remote IP and port, we'll need them to see if client is allowed or not 752 # 753 $peername = getpeername($clientsock) or next; 754 ($remoteport, $remoteip) = sockaddr_in($peername) or next; 755 $remoteip = inet_ntoa($remoteip) or next; 756 757 # 758 # We create a new client object and 759 # We see if client is allowed to connect to us 760 # 761 if (scalar(keys %{ $self->{_clientip} }) && !$self->{_clientip}{$remoteip}) { 762 763 # 764 # Client's IP is not allowed to connect to us 765 # 766 close($clientsock); 767 } 768 else { 769 770 # 771 # We add it to our SELECTOR pool : 772 # 773 $self->{_selector}->add($clientsock); 774 775 # 776 # We create a new client object: 777 # 778 $self->{_clients}->{$clientsock} = _new_client( 779 $self, 780 "_sock" => $clientsock, 781 "_remoteport" => $remoteport, 782 "_remoteip" => $remoteip 783 ); 784 785 # 786 # We initialize some client variables: 787 # 788 $self->{_clients}->{$clientsock}->{_serial} = ++$_SERIAL; 789 $self->{_clients}->{$clientsock}->{_compatabilityscalar} = _genrandstring(129); 790 $self->{_clients}->{$clientsock}->{_compatabilityreference} = _gencompatabilityreference($self->{_clients}->{$clientsock}->{_compatabilityscalar}); 791 792 # 793 # And we make it inherit some stuff from the server : 794 # 795 $self->{_clients}->{$clientsock}->{_donotencrypt} = $self->{_donotencrypt}; 796 $self->{_clients}->{$clientsock}->{_donotencryptwith} = $self->{_donotencryptwith}; 797 $self->{_clients}->{$clientsock}->{_donotcompress} = $self->{_donotcompress}; 798 $self->{_clients}->{$clientsock}->{_donotcompresswith} = $self->{_donotcompresswith}; 799 $self->{_clients}->{$clientsock}->{_password} = $self->{_password}; 800 $self->{_clients}->{$clientsock}->{_callbacks} = $self->{_callbacks}; 801 $self->{_clients}->{$clientsock}->{_welcome} = $self->{_welcome}; 802 $self->{_clients}->{$clientsock}->{_selector} = $self->{_selector}; 803 } 804 } 805 else { 806 807 # 808 # One of the CLIENT sockets are ready 809 # 810 $result = sysread($_, $tempdata, $PACKETSIZE); 811 $serverclient = $self->{_clients}->{$_}; 812 if (!defined $result) { 813 814 # 815 # Error somewhere during reading from that client 816 # 817 _callback($serverclient, "disconnect"); 818 $serverclient->close(); 819 delete $self->{_clients}->{$_}; 820 } 821 elsif ($result == 0) { 822 823 # 824 # Client closed connection 825 # 826 _callback($serverclient, "disconnect"); 827 $serverclient->close(); 828 delete $self->{_clients}->{$_}; 829 } 830 else { 831 832 # 833 # Client sent us some good data (not necessarily a full packet) 834 # 835 $serverclient->{_databuffer} .= $tempdata; 836 837 # 838 # Extract as many data buckets as possible out of the buffer 839 # 840 _extractdata($serverclient); 841 842 # 843 # Process all this client's data buckets 844 # 845 foreach (@{ $serverclient->{_databucket} }) { 846 if ($_->{realdata}) { 847 848 # 849 # This bucket is normal data 850 # 851 _callback($serverclient, "data"); 852 } 853 else { 854 855 # 856 # This bucket is internal data 857 # 858 _parseinternaldata($serverclient); 859 } 860 } 861 } 862 } 863 } 864 865 # 866 # Now we check on all the serverclients still negotiating and help them finish negotiating 867 # or weed out the ones timing out 868 # 869 foreach (keys %{ $self->{_clients} }) { 870 $serverclient = $self->{_clients}->{$_}; 871 if ($serverclient->{_negotiating}) { 872 if (_serverclient_negotiate($serverclient)) { 873 _callback($serverclient, "connect"); 874 } 875 elsif ((time - $serverclient->{_negotiating}) > $negotiatingtimeout) { 876 $serverclient->close(); 877 delete $self->{_clients}->{$_}; 878 } 879 } 880 } 881 882 # 883 # Now we re-generate the RSA keys if it's been over an hour 884 # 885 if (!$self->{_donotencrypt} && !$self->{_donotencryptwith}{"B"} && ((time - $self->{_lastglobalkeygentime}) >= 3600)) { 886 if (!_generateglobalkeypair('Crypt::RSA')) { 887 $@ = "Could not generate global Crypt::RSA keypairs. $@"; 888 return undef; 889 } 890 $self->{_lastglobalkeygentime} = time; 891 } 892 return 1; 893} 894 895# 896# This method stops the server and makes it return. 897# Note: It doesn't stop the server immediately, it sets a flag 898# and the flag should in a few seconds cause the infinite loop in start() method to stop 899# 900sub stop { 901 my $self = shift; 902 if ($self->{_mode} ne "server") { 903 $@ = "$self->{_mode} cannot call method stop()"; 904 return undef; 905 } 906 $self->{_requeststop} = 1; 907 return 1; 908} 909 910# 911# This method sends data to the socket associated with the object 912# 913sub send { 914 my $self = shift; 915 my $data = shift; 916 if ($self->{_mode} ne "client" && $self->{_mode} ne "serverclient") { 917 $@ = "$self->{_mode} cannot use method send()"; 918 return undef; 919 } 920 return _send($self, $data); 921} 922 923# 924# This method returns the serial number associated with the object 925# 926sub serial { 927 my $self = shift; 928 if (!$self->{_serial}) { 929 $self->{_serial} = ++$_SERIAL; 930 } 931 return $self->{_serial}; 932} 933 934# 935# Takes nothing, returns the oldest entry from the data bucket for a client/serverclient 936# In array context returns data and realdata flag, otherwise just data 937# (typically the code in the callback assigned to callback_data would access this method) 938# 939sub data { 940 my $self = shift; 941 my $data; 942 if ($self->{_mode} ne "client" && $self->{_mode} ne "serverclient") { 943 $@ = "$self->{_mode} cannot use method data()"; 944 return undef; 945 } 946 947 $data = shift(@{ $self->{_databucket} }); 948 949 return wantarray ? ($data->{data}, $data->{realdata}) : $data->{data}; 950} 951 952# 953# This method reads data from the socket associated with the object and returns it 954# Accepts an optional timeout as a first parameter, otherwise defaults to timeout 955# Returns the data if successful, undef if not 956# 957sub receive { 958 my $self = shift; 959 my $timeout = shift || 0; 960 my $returninternaldata = shift || 0; 961 my $temp; 962 my $realdata; 963 my $result; 964 my $lastactivity = time; 965 my $selector; 966 my @ready; 967 my $fatalerror; 968 969 if ($self->{_mode} ne "client" && $self->{_mode} ne "serverclient") { 970 $@ = "$self->{_mode} cannot use method receive()"; 971 return undef; 972 } 973 974 $selector = new IO::Select; 975 $selector->add($self->{_sock}); 976 977 # 978 # Let's try to read from the socket 979 # 980 while ($timeout ? ((time - $lastactivity) < $timeout) : 1) { 981 @ready = $selector->can_read($timeout); 982 if (!@ready) { 983 984 # 985 # Socket is not ready for reading 986 # 987 if (!$!) { 988 989 # 990 # Because of timeout 991 # 992 if (!$timeout) { 993 994 # 995 # We're doing an initial reading without blocking 996 # 997 last; 998 } 999 else { 1000 1001 # 1002 # We're blocking - let the while look take care of timeout 1003 # 1004 next; 1005 } 1006 } 1007 elsif ($! =~ /interrupt/i) { 1008 1009 # 1010 # Because of select() interrupted - ignore that 1011 # 1012 next; 1013 } 1014 else { 1015 1016 # 1017 # Because of some unknown error 1018 # 1019 last; 1020 } 1021 } 1022 else { 1023 1024 # 1025 # Socket is ready for reading 1026 # 1027 $result = sysread($self->{_sock}, $temp, $PACKETSIZE); 1028 if (!defined $result) { 1029 1030 # 1031 # Error reading from socket 1032 # 1033 $fatalerror = "Failed to read from socket: $!"; 1034 if (!$timeout) { 1035 1036 # 1037 # However we won't crap out right away, as we're doing a cursory, no-timeout read 1038 # 1039 last; 1040 } 1041 else { 1042 $@ = $fatalerror; 1043 return undef; 1044 } 1045 } 1046 elsif ($result == 0) { 1047 1048 # 1049 # Socket closed while reading 1050 # 1051 $fatalerror = "Socket closed when attempted reading"; 1052 if (!$timeout) { 1053 1054 # However we won't crap out right away, as we're doing a cursory, no-timeout read 1055 last; 1056 } 1057 else { 1058 $@ = $fatalerror; 1059 return undef; 1060 } 1061 } 1062 else { 1063 1064 # 1065 # Read good data - add it to the databuffer 1066 # 1067 $self->{_databuffer} .= $temp; 1068 $lastactivity = time; 1069 1070 if ($timeout && $result != $PACKETSIZE && _extractdata($self)) { 1071 1072 # 1073 # We're doing blocking reads, we extracted something into the bucket, and there's probably nothing else at the end of the socket 1074 # No point looping to block again 1075 # 1076 last; 1077 } 1078 } 1079 } 1080 } 1081 1082 # 1083 # Now there's nothing waiting to be received 1084 # Try to extract all possible data buckets out of the data buffer 1085 # 1086 _extractdata($self); 1087 1088 # 1089 # Now the databuffer has no full packets. If there's any data to be returned it's in the data buckets 1090 # 1091 while ((($result, $realdata) = $self->data()) && defined $result) { 1092 1093 # 1094 # We got something from the bucket 1095 # 1096 if ($realdata) { 1097 1098 # 1099 # And it's real data - return it 1100 # 1101 return $result; 1102 } 1103 else { 1104 1105 # 1106 # It's internal data 1107 # 1108 if ($returninternaldata) { 1109 1110 # 1111 # But we've been asked to return it 1112 # 1113 return $result; 1114 } 1115 else { 1116 1117 # 1118 # Don't know what to do with the internal data 1119 # 1120 _parseinternaldata($self, $result); 1121 } 1122 } 1123 } 1124 if (defined($result = $self->data())) { 1125 1126 # 1127 # We have good data to return 1128 # 1129 return $result; 1130 } 1131 1132 # 1133 # If we've reached here we have no data to return 1134 # 1135 if (!$timeout) { 1136 1137 # 1138 # We were doing a quick no-block read 1139 # 1140 if ($fatalerror) { 1141 1142 # 1143 # And we have a fatal error - don't attempt a blocking read 1144 # 1145 $@ = $fatalerror; 1146 return undef; 1147 } 1148 else { 1149 1150 # 1151 # Attempt a blocking read 1152 # 1153 return $self->receive(300); 1154 } 1155 } 1156 else { 1157 1158 # 1159 # We did a blocking read 1160 # 1161 $@ = "Timed out waiting to receive data"; 1162 return undef; 1163 } 1164} 1165 1166# 1167# This method is a synonym for close() 1168# 1169sub disconnect { 1170 return close(@_); 1171} 1172 1173# 1174# This method closes the socket associated with the object 1175# 1176sub close { 1177 my $self = shift; 1178 if ($self->{_mode} ne "client" && $self->{_mode} ne "serverclient") { 1179 $@ = "$self->{_mode} cannot use method close()"; 1180 return undef; 1181 } 1182 if ($self->{_selector} && $self->{_selector}->exists($self->{_sock})) { 1183 1184 # If the server selector reads this, let's make it not... 1185 $self->{_selector}->remove($self->{_sock}); 1186 } 1187 $self->{_sock}->close() if defined $self->{_sock}; 1188 $self->{_sock} = undef; 1189 $self->{_databucket} = []; 1190 $self->{_databuffer} = undef; 1191 return 1; 1192} 1193 1194# 1195# This method returns true or false, depending on if the server is running or not 1196# 1197sub running { 1198 my $self = shift; 1199 if ($self->{_mode} ne "server") { 1200 $@ = "$self->{_mode} cannot use method running()"; 1201 return undef; 1202 } 1203 return $self->{_running}; 1204} 1205 1206# 1207# This replies saying what type of object it's passed 1208# 1209sub mode { 1210 my $self = shift; 1211 my $mode = ($self->{_mode} eq "server") ? "server" : "client"; 1212 return $mode; 1213} 1214 1215# 1216# This method replies saying what type of encryption is used, undef if none 1217# 1218sub encryption { 1219 my $self = shift; 1220 my $modulekey = $self->{_encrypt}; 1221 if ($self->{_donotencrypt} || !$modulekey) { 1222 return undef; 1223 } 1224 return $_ENCRYPT_AVAILABLE{$modulekey}{name} || "Unknown module name for modulekey [$modulekey]"; 1225} 1226 1227# 1228# This method replies saying what type of compression is used, undef if none 1229# 1230sub compression { 1231 my $self = shift; 1232 my $modulekey = $self->{_compress}; 1233 if ($self->{_donotcompress} || !$modulekey) { 1234 return undef; 1235 } 1236 return $_COMPRESS_AVAILABLE{$modulekey}{name} || "Unknown module name for modulekey [$modulekey]"; 1237} 1238 1239# 1240# This returns the IO::Socket object associated with a connection 1241# 1242sub socket { 1243 my $self = shift; 1244 if ($self->{_mode} ne "client" && $self->{_mode} ne "serverclient") { 1245 $@ = "$self->{_mode} cannot use method socket()"; 1246 return undef; 1247 } 1248 return ($self->{_sock} || undef); 1249} 1250 1251# 1252# This returns an array of all the clients connected to a server in array context 1253# or the number of clients in scalar context 1254# or undef if there are no clients or error 1255# 1256sub clients { 1257 my $self = shift; 1258 my @clients; 1259 if ($self->{_mode} ne "server") { 1260 $@ = "$self->{_mode} cannot use method clients()"; 1261 return undef; 1262 } 1263 foreach (values %{ $self->{_clients} }) { 1264 if (!$_->{_negotiating}) { 1265 push(@clients, $_); 1266 } 1267 } 1268 if (@clients) { 1269 return wantarray ? @clients : scalar @clients; 1270 } 1271 else { 1272 return undef; 1273 } 1274} 1275 1276# 1277# This takes a client object and returns the IP address of the remote connection 1278# 1279sub remoteip { 1280 my $self = shift; 1281 my $temp; 1282 if ($self->{_mode} ne "client" && $self->{_mode} ne "serverclient") { 1283 $@ = "$self->{_mode} cannot use method remoteip()"; 1284 return undef; 1285 } 1286 return $self->{_remoteip}; 1287} 1288 1289# 1290# This takes a client object and returns the PORT of the remote connection 1291# 1292sub remoteport { 1293 my $self = shift; 1294 my $temp; 1295 if ($self->{_mode} ne "client" && $self->{_mode} ne "serverclient") { 1296 $@ = "$self->{_mode} cannot use method remoteport()"; 1297 return undef; 1298 } 1299 return $self->{_remoteport}; 1300} 1301 1302########################################################### 1303########################################################### 1304########################################################### 1305# 1306# The following are private functions (not object methods) 1307# 1308 1309# 1310# This takes 2 items (references to simple structures, or simple scalars) 1311# And returns true if they're the same, false if they're not 1312# It does NOT work for blessed objects. only scalars, hashrefs and arrayrefs 1313# 1314sub _comparereferences { 1315 my $item1 = shift; 1316 my $item2 = shift; 1317 my $ref1 = ref($item1); 1318 my $ref2 = ref($item2); 1319 my $num1; 1320 my $num2; 1321 my @keys1; 1322 my @keys2; 1323 my $temp; 1324 1325 if ($ref1 ne $ref2) { 1326 $@ = "References not same type [$ref1] [$ref2]"; 1327 return 0; 1328 } 1329 elsif (!$ref1 && $item1 ne $item2) { 1330 1331 #Scalars - do not match 1332 $@ = "Values of two scalar values not same"; 1333 return 0; 1334 } 1335 elsif ($ref1 eq "ARRAY") { 1336 $num1 = scalar @{$item1}; 1337 $num2 = scalar @{$item2}; 1338 if ($num1 != $num2) { 1339 1340 # Not same # of elements 1341 $@ = "Number of array elements not equal"; 1342 return 0; 1343 } 1344 else { 1345 for $temp (0 .. $num1 - 1) { 1346 if (!_comparereferences($item1->[$temp], $item2->[$temp])) { 1347 return 0; 1348 } 1349 } 1350 } 1351 } 1352 elsif ($ref1 eq "HASH") { 1353 @keys1 = sort keys %{$item1}; 1354 @keys2 = sort keys %{$item2}; 1355 if (scalar @keys1 != scalar @keys2) { 1356 1357 # Not same # of elements 1358 $@ = "Number of hash keys not equal"; 1359 return 0; 1360 } 1361 else { 1362 for $temp (0 .. $#keys1) { 1363 if ($keys1[$temp] ne $keys2[$temp]) { 1364 $@ = "Hash key names not equal"; 1365 return 0; 1366 } 1367 if (!_comparereferences($item1->{ $keys1[$temp] }, $item2->{ $keys2[$temp] })) { 1368 return 0; 1369 } 1370 } 1371 } 1372 } 1373 elsif ($ref1) { 1374 1375 # Unknown reference 1376 $@ = "Unknown reference type [$ref1] [$ref2] [$item1] [$item2]"; 1377 return 0; 1378 } 1379 1380 # 1381 # Everything's good 1382 # 1383 return 1; 1384} 1385 1386# 1387# This generates a global keypair and stores it globally 1388# Takes the name of a module, returns true or false 1389# 1390sub _generateglobalkeypair { 1391 my $module = shift || return undef; 1392 foreach (keys %_ENCRYPT_AVAILABLE) { 1393 if ($_ ne "_order" && $_ENCRYPT_AVAILABLE{$_}{name} eq $module) { 1394 ($_ENCRYPT_AVAILABLE{$_}{localpublickey}, $_ENCRYPT_AVAILABLE{$_}{localprivatekey}) = (); 1395 ($_ENCRYPT_AVAILABLE{$_}{localpublickey}, $_ENCRYPT_AVAILABLE{$_}{localprivatekey}) = _genkey($_) or return undef; 1396 last; 1397 } 1398 } 1399 return 1; 1400} 1401 1402# 1403# This takes any string and returns it in ascii format 1404# 1405sub _bin2asc { 1406 my $data = shift; 1407 $data =~ s/(.)/ '%' . sprintf('%02x',ord($1)) /ges; 1408 $data = uc($data); 1409 return $data; 1410} 1411 1412# 1413# This does the opposite of _bin2asc 1414# 1415sub _asc2bin { 1416 my $data = shift; 1417 $data =~ s/\%([0-9A-F]{2})/ sprintf("%c",hex($1)) /ges; 1418 return $data; 1419} 1420 1421# 1422# This does very very primitive 2-way encryption & decryption (kinda like ROT13.. works both ways) 1423# Takes a client and a string, returns the enc/dec/rypted string 1424# 1425# This encryption is used to protect the encrypted password and the public key transmitted over the wire 1426# It's a last resort of security in case none of the encryption modules were found 1427# 1428sub _munge { 1429 my $client = shift || return undef; 1430 my $data = shift; 1431 my ($c, $t); 1432 1433 # 1434 # Munge's tricky because is existed on and off in different versions 1435 # 1436 if (defined $data && ($client->{_version} == 0.07 || $client->{_version} == 0.08 || $client->{_version} >= 0.15)) { 1437 1438 # 1439 # Peer supports munge 1440 # 1441 for (0 .. length($data) - 1) { 1442 $c = substr($data, $_, 1); 1443 $t = vec($c, 0, 4); 1444 vec($c, 0, 4) = vec($c, 1, 4); 1445 vec($c, 1, 4) = $t; 1446 substr($data, $_, 1) = $c; 1447 } 1448 $data = reverse($data); 1449 } 1450 else { 1451 1452 # Our peer doesn't munge, so we won't either 1453 } 1454 return $data; 1455} 1456 1457# 1458# This takes a client object and a callback keyword and calls back the associated sub if possible 1459# 1460sub _callback { 1461 my $client = shift; 1462 my $type = shift; 1463 if (!$client->{_negotiating} && $client->{_callbacks}->{$type}) { 1464 &{ $client->{_callbacks}->{$type} }($client); 1465 } 1466} 1467 1468# 1469# This sub takes a scalar key 1470# Returns a reference to a compatability compex object made up of repeating 1471# the scalar in different combinations 1472# 1473sub _gencompatabilityreference { 1474 my $key = shift; 1475 return [ 1476 $key, 1477 { 1478 $key => $key, 1479 $key => $key, 1480 }, 1481 [ $key, { $key => $key, }, $key, ], 1482 ]; 1483} 1484 1485# 1486# This takes in an encryption key id and an optional "forcompat" boolean flag 1487# Generates a keypair (public, private) and returns them according to the type of encryption specified 1488# Returns undef on error 1489# The 2 returned keys are guaranteed to be: 1. Scalars and 2. Null-character-free. weather by their nature, or serialization or asci-fi-cation 1490# If "forcompat" is not specified and there are already a keypair for the specified module stored globally, 1491# it will return that instead of generating new ones. 1492# If "forcompat" is supplied, you're guaranteed to receive a new key that wasn't given out in the past to 1493# non-compat requests. It may be a repeat of a previous "forcompat" pair. However, the strength of that key 1494# could be possibly reduced. Such keys are safe to reveal the private portion of publicly, as during the 1495# compatability negotiation phase, however such keys must NEVER be used to encrypt any real data, as they 1496# are no longer secret. 1497# 1498sub _genkey { 1499 my $modulekey = shift; 1500 my $forcompat = shift; 1501 my $module = $_ENCRYPT_AVAILABLE{$modulekey}{name}; 1502 my $key1 = undef; 1503 my $key2 = undef; 1504 my $temp; 1505 $@ = undef; 1506 if (!$forcompat && $_ENCRYPT_AVAILABLE{$modulekey}{localpublickey} && $_ENCRYPT_AVAILABLE{$modulekey}{localprivatekey}) { 1507 $key1 = $_ENCRYPT_AVAILABLE{$modulekey}{localpublickey}; 1508 $key2 = $_ENCRYPT_AVAILABLE{$modulekey}{localprivatekey}; 1509 } 1510 elsif ($forcompat && $_ENCRYPT_AVAILABLE{$modulekey}{localcompatpublickey} && $_ENCRYPT_AVAILABLE{$modulekey}{localcompatprivatekey}) { 1511 $key1 = $_ENCRYPT_AVAILABLE{$modulekey}{localcompatpublickey}; 1512 $key2 = $_ENCRYPT_AVAILABLE{$modulekey}{localcompatprivatekey}; 1513 } 1514 elsif ($module eq 'Crypt::RSA') { 1515 eval { 1516 $temp = Crypt::RSA->new() || die "Failed to create new Crypt::RSA object for key generation: $! $@\n"; 1517 ($key1, $key2) = $temp->keygen( 1518 Size => 512, 1519 Verbosity => 0, 1520 ) 1521 or die "Failed to create RSA keypair: " . $temp->errstr() . "\n"; 1522 }; 1523 if ($key1 && $key2) { 1524 $key1 = _bin2asc(nfreeze($key1)); 1525 1526 # RSA private keys are NOT serializable with the Serialize module - we MUST use Crypt::RSA::Key::Private's undocumented serialize() method: 1527 $key2 = $key2->serialize(); 1528 if ($forcompat) { 1529 $_ENCRYPT_AVAILABLE{$modulekey}{localcompatpublickey} = $key1; 1530 $_ENCRYPT_AVAILABLE{$modulekey}{localcompatprivatekey} = $key2; 1531 } 1532 } 1533 } 1534 elsif ($module eq 'Crypt::Rijndael') { 1535 $key1 = _genrandstring(32); 1536 $key2 = $key1; 1537 } 1538 elsif ($module eq 'Crypt::RC6') { 1539 $key1 = _genrandstring(32); 1540 $key2 = $key1; 1541 } 1542 elsif ($module eq 'Crypt::Blowfish') { 1543 $key1 = _genrandstring(56); 1544 $key2 = $key1; 1545 } 1546 elsif ($module eq 'Crypt::DES_EDE3') { 1547 $key1 = _genrandstring(24); 1548 $key2 = $key1; 1549 } 1550 elsif ($module eq 'Crypt::DES') { 1551 $key1 = _genrandstring(8); 1552 $key2 = $key1; 1553 } 1554 elsif ($module eq 'Crypt::Twofish2') { 1555 $key1 = _genrandstring(32); 1556 $key2 = $key1; 1557 } 1558 elsif ($module eq 'Crypt::Twofish') { 1559 $key1 = _genrandstring(32); 1560 $key2 = $key1; 1561 } 1562 elsif ($module eq 'Crypt::TEA') { 1563 $key1 = _genrandstring(16); 1564 $key2 = $key1; 1565 } 1566 elsif ($module eq 'Crypt::CipherSaber') { 1567 $key1 = _genrandstring(32); 1568 $key2 = $key1; 1569 } 1570 else { 1571 $@ = "Unknown encryption module [$module] modulekey [$modulekey]"; 1572 } 1573 1574 if (!$key1 || !$key2) { 1575 $@ = "Could not generate encryption keys. $@"; 1576 return undef; 1577 } 1578 else { 1579 return ($key1, $key2); 1580 } 1581 1582} 1583 1584# 1585# This takes client object, and a reference to a scalar 1586# And if it can, compresses scalar, modifying the original, via the specified module in the client object 1587# Returns true if successful, false if not 1588# 1589sub _compress { 1590 my $client = shift; 1591 my $rdata = shift; 1592 my $modulekey = $client->{_compress} || return undef; 1593 my $module = $_COMPRESS_AVAILABLE{$modulekey}{name}; 1594 my $newdata; 1595 1596 # 1597 # Compress the data 1598 # 1599 if ($module eq 'Compress::Zlib') { 1600 $newdata = Compress::Zlib::compress($$rdata); 1601 } 1602 elsif ($module eq 'Compress::LZF') { 1603 $newdata = Compress::LZF::compress($$rdata); 1604 } 1605 else { 1606 $@ = "Unknown compression module [$module] modulekey [$modulekey]"; 1607 } 1608 1609 # 1610 # Finally, override reference if compression succeeded 1611 # 1612 if ($newdata) { 1613 $$rdata = $newdata; 1614 return 1; 1615 } 1616 else { 1617 return undef; 1618 } 1619 1620} 1621 1622# 1623# This does the opposite of _compress() 1624# 1625sub _decompress { 1626 my $client = shift; 1627 my $rdata = shift; 1628 my $modulekey = $client->{_compress}; 1629 my $module = $_COMPRESS_AVAILABLE{$modulekey}{name}; 1630 my $newdata; 1631 1632 if ($module eq 'Compress::Zlib') { 1633 $newdata = Compress::Zlib::uncompress($$rdata); 1634 } 1635 elsif ($module eq 'Compress::LZF') { 1636 $newdata = Compress::LZF::decompress($$rdata); 1637 } 1638 else { 1639 $@ = "Unknown decompression module [$module] modulekey [$modulekey]"; 1640 } 1641 1642 # 1643 # Finally, override reference if decompression succeeded 1644 # 1645 if ($newdata) { 1646 $$rdata = $newdata; 1647 return 1; 1648 } 1649 else { 1650 return undef; 1651 } 1652 1653} 1654 1655# 1656# This takes client object, and a reference to a scalar 1657# And if it can, encrypts scalar, modifying the original, via the specified module in the client object 1658# Returns true if successful, false if not 1659# 1660sub _encrypt { 1661 my $client = shift; 1662 my $rdata = shift; 1663 my $modulekey = $client->{_encrypt} || return undef; 1664 my $module = $_ENCRYPT_AVAILABLE{$modulekey}{name}; 1665 my $cbc = $_ENCRYPT_AVAILABLE{$modulekey}{cbc}; 1666 my $mergewithpassword = $_ENCRYPT_AVAILABLE{$modulekey}{mergewithpassword}; 1667 my $newdata; 1668 my $temp; 1669 my $publickey = $client->{_remotepublickey} || return undef; 1670 my $cleanpassword; 1671 1672 if (defined $client->{_password}) { 1673 $cleanpassword = $client->{_password}; 1674 $cleanpassword =~ s/[^a-z0-9]//gi; 1675 } 1676 else { 1677 $cleanpassword = undef; 1678 } 1679 1680 # 1681 # If there is a password for the connection, and we're using Symmetric encryption, we include the password 1682 # in the encryption key used 1683 # 1684 if ($mergewithpassword && defined $cleanpassword && length($cleanpassword) && $client->{_authenticated} && !$client->{_negotiating} && $client->{_version} >= 0.15) { 1685 if (length($cleanpassword) <= length($publickey)) { 1686 substr($publickey, 0, length($cleanpassword)) = $cleanpassword; 1687 } 1688 elsif (length($cleanpassword) > length($publickey)) { 1689 $publickey = substr($cleanpassword, 0, length($publickey)); 1690 } 1691 else { 1692 $@ = "Failed to merge password with symmetric encryption key"; 1693 return undef; 1694 } 1695 } 1696 if ($publickey =~ /^(\%[0-9A-F]{2})+$/) { 1697 1698 # 1699 # In the case of binary keys (such as RSA's) they're ascii-armored, we need to decrypt them 1700 # 1701 $publickey = thaw(_asc2bin($publickey)) || return undef; 1702 $client->{_remotepublickey} = $publickey; 1703 } 1704 1705 # 1706 # Encrypt the data into $newdata if possible 1707 # 1708 if ($module eq 'Crypt::RSA') { 1709 eval { 1710 $temp = Crypt::RSA->new() || die "Failed to create new Crypt::RSA object for encryption: $! $@\n"; 1711 $newdata = $temp->encrypt( 1712 Message => $$rdata, 1713 Key => $publickey, 1714 Armour => 0, 1715 ) 1716 or die "Failed to encrypt data with Crypt::RSA: " . $temp->errstr() . "\n"; 1717 }; 1718 } 1719 elsif ($module eq 'Crypt::CipherSaber') { 1720 $temp = Crypt::CipherSaber->new($publickey); 1721 $newdata = $temp->encrypt($$rdata); 1722 } 1723 elsif ($cbc) { 1724 $temp = Crypt::CBC->new($publickey, $module); 1725 $newdata = $temp->encrypt($$rdata); 1726 } 1727 else { 1728 $@ = "Unknown encryption module [$module] modulekey [$modulekey]"; 1729 } 1730 1731 # 1732 # Finally, override reference if encryption succeeded 1733 # 1734 if ($newdata) { 1735 $$rdata = $newdata; 1736 return 1; 1737 } 1738 else { 1739 return undef; 1740 } 1741 1742} 1743 1744# 1745# Does the opposite of _encrypt(); 1746# 1747sub _decrypt { 1748 my $client = shift; 1749 my $rdata = shift; 1750 my $modulekey = $client->{_encrypt} || return undef; 1751 my $module = $_ENCRYPT_AVAILABLE{$modulekey}{name}; 1752 my $cbc = $_ENCRYPT_AVAILABLE{$modulekey}{cbc}; 1753 my $mergewithpassword = $_ENCRYPT_AVAILABLE{$modulekey}{mergewithpassword}; 1754 my $newdata; 1755 my $temp; 1756 my $privatekey = $client->{_localprivatekey} || return undef; 1757 my $cleanpassword; 1758 1759 if (defined $client->{_password}) { 1760 $cleanpassword = $client->{_password}; 1761 $cleanpassword =~ s/[^a-z0-9]//gi; 1762 } 1763 else { 1764 $cleanpassword = undef; 1765 } 1766 1767 # 1768 # If there is a password for the connection, and we're using Symmetric encryption, we include the password 1769 # in the decryption key used 1770 # 1771 if ($mergewithpassword && defined $cleanpassword && length($cleanpassword) && $client->{_authenticated} && !$client->{_negotiating} && $client->{_version} >= 0.15) { 1772 if (length($cleanpassword) <= length($privatekey)) { 1773 substr($privatekey, 0, length($cleanpassword)) = $cleanpassword; 1774 } 1775 elsif (length($cleanpassword) > length($privatekey)) { 1776 $privatekey = substr($cleanpassword, 0, length($privatekey)); 1777 } 1778 else { 1779 $@ = "Failed to merge password with symmetric encryption key"; 1780 return undef; 1781 } 1782 } 1783 if ($privatekey =~ /^(\%[0-9A-F]{2})+$/) { 1784 1785 # 1786 # In the case of binary keys (such as RSA's) they're ascii-armored, we need to decrypt them 1787 # 1788 $privatekey = _asc2bin($privatekey); 1789 } 1790 1791 # 1792 # Decrypt the data 1793 # 1794 if ($module eq 'Crypt::RSA') { 1795 eval { 1796 if (!ref($privatekey)) { 1797 if ($privatekey =~ /bless/) { 1798 1799 # We need to deserialize the private key with Crypt::RSA::Key::Private's undocumented deserialize function 1800 $temp = Crypt::RSA::Key::Private->new() or die "Failed to initialize empty Crypt::RSA::Key::Private object\n"; 1801 $privatekey = $temp->deserialize(String => [$privatekey]) or die "Failed to deserialize Crypt::RSA private key\n"; 1802 } 1803 else { 1804 die "The Crypt::RSA private key is absolutely unusable\n"; 1805 } 1806 } 1807 $temp = Crypt::RSA->new() || die "Failed to create new Crypt::RSA object for decryption: $! $@\n"; 1808 $newdata = $temp->decrypt( 1809 Cyphertext => $$rdata, 1810 Key => $privatekey, 1811 Armour => 0, 1812 ) 1813 or die "Failed to decrypt data with Crypt::RSA : " . $temp->errstr() . "\n"; 1814 }; 1815 } 1816 elsif ($module eq 'Crypt::CipherSaber') { 1817 $temp = Crypt::CipherSaber->new($privatekey); 1818 $newdata = $temp->decrypt($$rdata); 1819 } 1820 elsif ($cbc) { 1821 $temp = Crypt::CBC->new($privatekey, $module); 1822 $newdata = $temp->decrypt($$rdata); 1823 } 1824 else { 1825 $@ = "Unknown encryption module [$module] modulekey [$modulekey]"; 1826 } 1827 1828 # 1829 # Finally, override reference if decryption succeeded 1830 # 1831 if ($newdata) { 1832 $$rdata = $newdata; 1833 return 1; 1834 } 1835 else { 1836 return undef; 1837 } 1838 1839} 1840 1841# 1842# This sub returns a random string 1843# Expects an integer (length) 1844# Accepts optional boolean that defines whether string should be made up of letters only or not 1845# 1846sub _genrandstring { 1847 my $l = shift; 1848 my $lettersonly = shift; 1849 my ($minord, $maxord); 1850 my $key; 1851 my $avoid; 1852 my $module; 1853 my $version; 1854 1855 if ($lettersonly) { 1856 $minord = 97; 1857 $maxord = 122; 1858 } 1859 else { 1860 $minord = 33; 1861 $maxord = 126; 1862 } 1863 1864 # 1865 # First, we try one of the fancy randomness modules possibly in %_MISC_AVAILABLE 1866 # 1867 foreach (@{ $_MISC_AVAILABLE{_order} }) { 1868 $module = $_MISC_AVAILABLE{$_}{name}; 1869 $version = $_MISC_AVAILABLE{$_}{version}; 1870 1871 # 1872 # Note that Crypt::Random has the makerandom_octet function ONLY in 0.34 and higher 1873 # 1874 if ($module eq "Crypt::Random" && $version >= 0.34) { 1875 for (0 .. $minord - 1, $maxord + 1 .. 255) { 1876 $avoid .= chr($_); 1877 } 1878 $key = Crypt::Random::makerandom_octet( 1879 Length => $l, 1880 Skip => $avoid, 1881 ); 1882 return $key; 1883 } 1884 } 1885 1886 # 1887 # If we've reached here, then no modules were found. We'll use perl's builtin rand() to generate 1888 # the string 1889 # 1890 for (1 .. $l) { 1891 $key .= chr(int(rand($maxord - $minord)) + $minord); 1892 } 1893 return $key; 1894} 1895 1896# 1897# Once a new client is connected it calls this to negotiate basics with the server 1898# This must return true once all negotiations succeed or false if not 1899# 1900sub _client_negotiate { 1901 my $client = shift; 1902 my $reply; 1903 my $timeout = 90; 1904 my @P; 1905 my $command; 1906 my $data; 1907 my $temp; 1908 my $temp2; 1909 my ($temppublic, $tempprivate, $tempscalar); 1910 my $version; 1911 my $evl; 1912 my $starttime = time; 1913 1914 while ((time - $starttime) < $timeout) { 1915 $reply = $client->receive($timeout, 1); 1916 if (!defined $reply) { 1917 last; 1918 } 1919 @P = split(/\x00/, $reply); 1920 $command = shift(@P); 1921 $evl = undef; 1922 $data = undef; 1923 if (!$command) { 1924 $@ = "Error negotiating with server. No command received."; 1925 return undef; 1926 } 1927 if ($command eq "PF") { 1928 1929 # 1930 # Password Failure 1931 # 1932 $client->{_authenticated} = 0; 1933 $@ = "Server rejected supplied password"; 1934 return undef; 1935 } 1936 elsif ($command eq "COS") { 1937 1938 # 1939 # Compatability Scalar 1940 # 1941 $client->{_compatabilityscalar} = _asc2bin($P[0]); 1942 $client->{_compatabilityreference} = _gencompatabilityreference($client->{_compatabilityscalar}); 1943 $data = "COS\x00" . $P[0]; 1944 } 1945 elsif ($command eq "COF") { 1946 1947 # 1948 # Compatability failure 1949 # 1950 $@ = "Compatability failure: The client and server could not negotiate compatability regarding: $P[0]"; 1951 return undef; 1952 } 1953 elsif ($command eq "CVF" && !$client->{_donotcheckversion}) { 1954 1955 # 1956 # Compression Version Failure 1957 # 1958 $temp = $_COMPRESS_AVAILABLE{ $client->{_compress} }{name}; 1959 $version = $_COMPRESS_AVAILABLE{ $client->{_compress} }{version}; 1960 $@ = "Compression version mismatch for $temp : Local version $version remote version $P[0] : Upgrade both to same version or read the documentation of this module for how to forcefully ignore this problem"; 1961 return undef; 1962 } 1963 elsif ($command eq "EVF" && !$client->{_donotcheckversion}) { 1964 1965 # 1966 # Encryption Version Failure 1967 # 1968 $temp = $_ENCRYPT_AVAILABLE{ $client->{_encrypt} }{name}; 1969 $version = $_ENCRYPT_AVAILABLE{ $client->{_encrypt} }{version}; 1970 $@ = "Encryption version mismatch for $temp : Local version $version remote version $P[0] : Upgrade both to same version or read the documentation of this module for how to forcefully ignore this problem"; 1971 return undef; 1972 } 1973 elsif ($command eq "EN") { 1974 1975 # 1976 # End of negotiation 1977 # 1978 $data = "EN"; 1979 $evl = 'return("RETURN1");'; 1980 } 1981 elsif ($command eq "VE") { 1982 1983 # 1984 # Version of module 1985 # 1986 $client->{_version} = $P[0]; 1987 $data = "VE\x00$VERSION"; 1988 } 1989 elsif ($command eq "SVE") { 1990 1991 # 1992 # Version of the Storable module 1993 # 1994 $client->{_storableversion} = $P[0]; 1995 if ($P[1]) { 1996 1997 # 1998 # New compatability method 1999 # 2000 eval { $temp = thaw(_asc2bin($P[1])); }; 2001 if (!$temp || $@) { 2002 $@ = "Error thawing compatability reference: $! $@ -- This may be because you're using binary-image-incompatible versions of the Storable module. Please update the Storable module on both ends othe the connection to the same latest stable version."; 2003 return undef; 2004 } 2005 if (!_comparereferences($temp, $client->{_compatabilityreference})) { 2006 $@ = "Incompatible version mismatch for the Storable module: Local version " . $Storable::VERSION . " remote version $P[0] : Upgrade both to compatible (preferrably same) versions : $@"; 2007 return undef; 2008 } 2009 } 2010 $data = "SVE\x00" . $Storable::VERSION; 2011 if ($client->{_compatabilityreference}) { 2012 $data .= "\x00" . _bin2asc(nfreeze($client->{_compatabilityreference})); 2013 } 2014 } 2015 elsif ($command eq "SVF" && !$client->{_donotcheckversion}) { 2016 2017 # 2018 # Storable Module Version Failure 2019 # 2020 $version = $Storable::VERSION; 2021 $@ = "Version mismatch for the Storable module : Local version $version remote version $P[0] : Upgrade both to same version or read the documentation of this module for how to forcefully ignore this problem"; 2022 return undef; 2023 } 2024 elsif ($command eq "CS") { 2025 2026 # 2027 # Crypt Salt 2028 # 2029 # We assume that we've authenticated successfully 2030 $client->{_authenticated} = 1; 2031 $temp = _munge($client, crypt($client->{_password}, $P[0])); 2032 $data = "CP\x00$temp"; 2033 } 2034 elsif ($command eq "EK") { 2035 2036 # 2037 # Encryption key 2038 # 2039 $client->{_remotepublickey} = _munge($client, $P[0]); 2040 $data = "EK\x00"; 2041 $data .= _munge($client, $client->{_localpublickey}); 2042 } 2043 elsif ($command eq "EM") { 2044 2045 # 2046 # Encryption module 2047 # 2048 if ($client->{_donotencryptwith}{ $P[0] }) { 2049 $data = "NO\x00I do not encrypt with this module"; 2050 } 2051 elsif (!$client->{_donotencrypt}) { 2052 2053 # 2054 # Let's see if we can handle decrypting this module 2055 # 2056 $tempprivate = _asc2bin($P[2]); 2057 $tempscalar = _asc2bin($P[3]); 2058 2059 # 2060 # Sometimes the tempprivate is frozen. If we can thaw it, let's do it: 2061 # 2062 eval { $temp = thaw $tempprivate }; 2063 if (!$@) { 2064 $tempprivate = $temp; 2065 } 2066 $client->{_encrypt} = $P[0]; 2067 $client->{_localprivatekey} = $tempprivate; 2068 if (_decrypt($client, \$tempscalar) && $tempscalar eq $client->{_compatabilityscalar}) { 2069 2070 # 2071 # This is a viable module that we can decrypt. 2072 # 2073 ($temppublic, $tempprivate) = _genkey($P[0], 1); 2074 if ($temppublic && $tempprivate) { 2075 2076 # 2077 # I created a keypair with that module type successfully 2078 # 2079 $client->{_remotepublickey} = $temppublic; 2080 if (_encrypt($client, \$tempscalar)) { 2081 $data = "EM\x00$P[0]\x00" . $_ENCRYPT_AVAILABLE{ $P[0] }{version} . "\x00" . _bin2asc(ref($tempprivate) ? nfreeze $tempprivate : $tempprivate) . "\x00" . _bin2asc($tempscalar); 2082 } 2083 delete $client->{_remotepublickey}; 2084 } 2085 else { 2086 2087 # 2088 # Failed to create a keypair - no way I could encrypt with that 2089 # 2090 $data = "NO\x00$@"; 2091 } 2092 } 2093 else { 2094 2095 # 2096 # Failed to decrypt message from server 2097 # 2098 $data = "NO\x00$@"; 2099 } 2100 delete $client->{_encrypt}; 2101 delete $client->{_localprivatekey}; 2102 } 2103 else { 2104 2105 # 2106 # I was told not to encrypt 2107 # 2108 $data = "NO\x00I do not encrypt"; 2109 2110 } 2111 } 2112 elsif ($command eq "EU") { 2113 2114 # 2115 # Encryption Use 2116 # 2117 if ($client->{_donotencryptwith}{ $P[0] }) { 2118 $data = "NO\x00I do not encrypt with this module"; 2119 } 2120 elsif (!$client->{_donotencrypt}) { 2121 $temp2 = $P[0]; 2122 $data = "EU\x00$temp2"; 2123 $evl = '$client->{_encrypt} = $temp2;'; 2124 $evl .= '($client->{_localpublickey},$client->{_localprivatekey}) ='; 2125 $evl .= ' _genkey($client->{_encrypt}) or '; 2126 $evl .= ' return("RETURN0"); '; 2127 } 2128 else { 2129 $data = "NO\x00I do not encrypt"; 2130 } 2131 } 2132 elsif ($command eq "EA") { 2133 2134 # 2135 # Encryption available 2136 # 2137 $temp2 = ""; 2138 $version = ""; 2139 if (!$client->{_donotencrypt}) { 2140 foreach (@P) { 2141 if ($_ENCRYPT_AVAILABLE{$_}) { 2142 $temp2 = $_; 2143 $version = $_ENCRYPT_AVAILABLE{$_}{version}; 2144 last; 2145 } 2146 } 2147 $temp2 ||= ""; 2148 $version ||= ""; 2149 } 2150 $data = "EU\x00$temp2\x00$version"; 2151 if ($temp2) { 2152 $evl = '$client->{_encrypt} = $temp2;'; 2153 $evl .= '($client->{_localpublickey},$client->{_localprivatekey}) ='; 2154 $evl .= ' _genkey($client->{_encrypt}) or '; 2155 $evl .= ' return("RETURN0"); '; 2156 } 2157 } 2158 elsif ($command eq "CM") { 2159 2160 # 2161 # Compression module 2162 # 2163 if ($client->{_donotcompresswith}{ $P[0] }) { 2164 $data = "NO\x00I do not compress with this module"; 2165 } 2166 elsif (!$client->{_donotcompress}) { 2167 2168 # 2169 # Let's see if we can decompress this 2170 # 2171 $tempscalar = _asc2bin($P[2]); 2172 $client->{_compress} = $P[0]; 2173 if (_decompress($client, \$tempscalar) && $tempscalar eq $client->{_compatabilityscalar}) { 2174 2175 # 2176 # This is a viable module that we can decompress. 2177 # 2178 if (_compress($client, \$tempscalar)) { 2179 $data = "CM\x00$P[0]\x00" . $_COMPRESS_AVAILABLE{ $P[0] }{version} . "\x00" . _bin2asc($tempscalar); 2180 } 2181 } 2182 else { 2183 2184 # 2185 # Failed to decompress message from server 2186 # 2187 $data = "NO\x00$@"; 2188 } 2189 delete $client->{_compress}; 2190 } 2191 else { 2192 2193 # 2194 # I was told not to compress 2195 # 2196 $data = "NO\x00I do not compress"; 2197 } 2198 } 2199 elsif ($command eq "CU") { 2200 2201 # 2202 # Compression Use 2203 # 2204 if ($client->{_donotcompresswith}{ $P[0] }) { 2205 $data = "NO\x00I do not compress with this module"; 2206 } 2207 elsif (!$client->{_donotcompress}) { 2208 $temp2 = $P[0]; 2209 $data = "CU\x00$temp2"; 2210 $evl = '$client->{_compress} = $temp2;'; 2211 } 2212 else { 2213 $data = "NO\x00I do not compress"; 2214 } 2215 } 2216 elsif ($command eq "CA") { 2217 2218 # 2219 # Compression available 2220 # 2221 $temp2 = ""; 2222 $version = ""; 2223 if (!$client->{_donotcompress}) { 2224 foreach (@P) { 2225 if ($_COMPRESS_AVAILABLE{$_}) { 2226 $temp2 = $_; 2227 $version = $_COMPRESS_AVAILABLE{$_}{version}; 2228 last; 2229 } 2230 } 2231 $temp2 ||= ""; 2232 $version ||= ""; 2233 } 2234 $data = "CU\x00$temp2\x00$version"; 2235 if ($temp2) { 2236 $evl = '$client->{_compress} = $temp2;'; 2237 } 2238 } 2239 else { 2240 2241 # 2242 # No Operation (do nothing) 2243 # 2244 $data = "NO\x00I don't understand you"; 2245 } 2246 if (defined $data && !_send($client, $data, 0)) { 2247 $@ = "Error negotiating with server: Could not send : $@"; 2248 return undef; 2249 } 2250 2251 # 2252 # NOW WE SEE IF WE NEED TO EVL ANYTHING 2253 # IF THE RESULT OF THE EVAL IS "RETURNx" WHERE X IS A NUMBER, WE RETURN 2254 # OTHERWISE WE KEEP GOING 2255 # 2256 if (defined $evl) { 2257 $evl = eval($evl); 2258 if ($evl =~ /^RETURN(.+)$/) { 2259 return (($1) ? $1 : undef); 2260 } 2261 } 2262 } 2263 $@ = "Client timed out while negotiating with server [" . (time - $starttime) . "/$timeout] : $@"; 2264 return undef; 2265} 2266 2267# 2268# Once the server accepts a new connection, it calls this to negotiate basics with the client 2269# Unlike _client_negotiate() which does not return until negotiation is over, this sub 2270# sends 1 command or parses one reply at a time then returns immediately 2271# Although this is much more complicated, it needs to be done so 2272# the server does not block when a client is negotiating with it 2273# 2274# Expects a client object 2275# 2276sub _serverclient_negotiate { 2277 my $client = shift; 2278 my ($tempprivate, $tempscalar); 2279 my $reply; 2280 my $temp; 2281 my @P; 2282 my $command; 2283 my $version; 2284 2285 if (!$client->{_negotiating}) { 2286 return 1; 2287 } 2288 2289 $reply = $client->data(); 2290 2291 # Let's avoid some strict claimings 2292 if (!defined $reply) { $reply = "" } 2293 if (!defined $client->{_negotiating_lastevent}) { $client->{_negotiating_lastevent} = "" } 2294 2295 if (length($reply)) { 2296 2297 # 2298 # We're parsing a reply the other end sent us 2299 # 2300 @P = split(/\x00/, $reply); 2301 $command = shift(@P); 2302 if (!$command) { 2303 $@ = "Error negotiating. No command received from client : $@"; 2304 return undef; 2305 } 2306 $client->{_negotiating_lastevent} = "received"; 2307 if ($command eq "EU") { 2308 2309 # 2310 # Encryption Use 2311 # 2312 $client->{_encrypt} = $P[0]; 2313 if ($client->{_encrypt}) { 2314 $version = $_ENCRYPT_AVAILABLE{ $P[0] }{version}; 2315 if ($version ne $P[1] && !$client->{_negotiatedencryptcompatability}) { 2316 unshift(@{ $client->{_negotiating_commands} }, "EVF\x00$version"); 2317 } 2318 ($client->{_localpublickey}, $client->{_localprivatekey}) = _genkey($client->{_encrypt}) or return undef; 2319 } 2320 $temp = "EK\x00"; 2321 $temp .= _munge($client, $client->{_localpublickey}); 2322 unshift(@{ $client->{_negotiating_commands} }, $temp); 2323 } 2324 elsif ($command eq "EM") { 2325 2326 # 2327 # Encryption module 2328 # 2329 if ($client->{_donotencryptwith}{ $P[0] }) { 2330 2331 # 2332 # I was told not to encrypt with this module 2333 # 2334 } 2335 elsif (!$client->{_donotencrypt}) { 2336 2337 # 2338 # Let's see if we can decrypt this module 2339 # 2340 $tempprivate = _asc2bin($P[2]); 2341 $tempscalar = _asc2bin($P[3]); 2342 2343 # 2344 # Sometimes the tempprivate is frozen. If we can thaw it, let's do it: 2345 # 2346 eval { $temp = thaw $tempprivate }; 2347 if (!$@) { 2348 $tempprivate = $temp; 2349 } 2350 $client->{_encrypt} = $P[0]; 2351 $client->{_localprivatekey} = $tempprivate; 2352 if (_decrypt($client, \$tempscalar) && $tempscalar eq $client->{_compatabilityscalar}) { 2353 2354 # 2355 # This is a viable module that I (the server) can decrypt 2356 # Since this is the second-reply to my EM, I know that the client can also decrypt using this module 2357 # So we use it ! 2358 # 2359 unshift(@{ $client->{_negotiating_commands} }, "EU\x00$P[0]"); 2360 2361 # 2362 # Yank out any future EMs we were going to send the client since they're weaker 2363 # 2364 $client->{_negotiating_commands} = [ grep { $_ !~ /^EM\x00/ } @{ $client->{_negotiating_commands} } ]; 2365 } 2366 delete $client->{_localprivatekey}; 2367 delete $client->{_encrypt}; 2368 2369 # 2370 # Don't try EAs after this - we know the client supports EMs 2371 # 2372 $client->{_negotiatedencryptcompatability} = 1; 2373 } 2374 else { 2375 2376 # 2377 # I was told not to encrypt 2378 # 2379 } 2380 } 2381 elsif ($command eq "CP") { 2382 2383 # 2384 # Crypt Password 2385 # 2386 if (_munge($client, $P[0]) eq crypt($client->{_password}, $client->{_cryptsalt})) { 2387 $client->{_authenticated} = 1; 2388 } 2389 else { 2390 $client->{_authenticated} = 0; 2391 unshift(@{ $client->{_negotiating_commands} }, "PF"); 2392 } 2393 } 2394 elsif ($command eq "COS") { 2395 2396 # 2397 # Compatability scalar 2398 # 2399 if ($client->{_compatabilityscalar} ne _asc2bin($P[0])) { 2400 unshift(@{ $client->{_negotiating_commands} }, "COF\x00Initial scalar exchange"); 2401 } 2402 } 2403 elsif ($command eq "VE") { 2404 2405 # 2406 # Version 2407 # 2408 $client->{_version} = $P[0]; 2409 } 2410 elsif ($command eq "SVE") { 2411 2412 # 2413 # Version of Storable 2414 # 2415 $client->{_storableversion} = $P[0]; 2416 if ($P[1]) { 2417 2418 # 2419 # New method 2420 # 2421 $temp = thaw(_asc2bin($P[1])); 2422 if (!$temp) { 2423 unshift(@{ $client->{_negotiating_commands} }, "COF\x00Thawing compatability reference with the Storable module"); 2424 } 2425 if (!_comparereferences($temp, $client->{_compatabilityreference})) { 2426 unshift(@{ $client->{_negotiating_commands} }, "COF\x00Comparing compatability reference with the Storable module"); 2427 } 2428 } 2429 elsif ($P[0] ne $Storable::VERSION) { 2430 2431 # 2432 # Old method 2433 # 2434 unshift(@{ $client->{_negotiating_commands} }, "SVF\x00" . $Storable::VERSION); 2435 } 2436 } 2437 elsif ($command eq "CM") { 2438 2439 # 2440 # Compression module 2441 # 2442 if ($client->{_donotcompresswith}{ $P[0] }) { 2443 2444 # I was told not to compress with this module 2445 } 2446 elsif (!$client->{_donotcompress}) { 2447 2448 # 2449 # Let's see if we can decompress this module 2450 # 2451 $tempscalar = _asc2bin($P[2]); 2452 $client->{_compress} = $P[0]; 2453 if (_decompress($client, \$tempscalar) && $tempscalar eq $client->{_compatabilityscalar}) { 2454 2455 # 2456 # This is a viable module that I (the server) can decompress 2457 # Since this is the second-reply to my CM, I know that the client can also decrypt using this module 2458 # So we use it ! 2459 # 2460 unshift(@{ $client->{_negotiating_commands} }, "CU\x00$P[0]"); 2461 2462 # 2463 # Yank out any future CMs we were going to send the client since they're weaker 2464 # 2465 $client->{_negotiating_commands} = [ grep { $_ !~ /^CM\x00/ } @{ $client->{_negotiating_commands} } ]; 2466 } 2467 delete $client->{_compress}; 2468 2469 # 2470 # Don't try CAs after this - we know the client supports CMs 2471 # 2472 $client->{_negotiatedcompresscompatability} = 1; 2473 } 2474 else { 2475 2476 # 2477 # I was told not to compress 2478 # 2479 } 2480 } 2481 elsif ($command eq "CU") { 2482 2483 # 2484 # Compression Use 2485 # 2486 $client->{_compress} = $P[0]; 2487 if ($client->{_compress}) { 2488 $version = $_COMPRESS_AVAILABLE{ $P[0] }{version}; 2489 if ($version ne $P[1] && !$client->{_negotiatedcompresscompatability}) { 2490 unshift(@{ $client->{_negotiating_commands} }, "CVF\x00$version"); 2491 } 2492 } 2493 } 2494 elsif ($command eq "EK") { 2495 2496 # 2497 # Encryption Key 2498 # 2499 $client->{_remotepublickey} = _munge($client, $P[0]); 2500 } 2501 elsif ($command eq "EN") { 2502 2503 # 2504 # End (of negotiation) 2505 # 2506 if ((defined $client->{_password} && length($client->{_password})) && !$client->{_authenticated}) { 2507 return undef; 2508 } 2509 else { 2510 $client->{_negotiating} = 0; 2511 delete $client->{_negotiating_lastevent}; 2512 delete $client->{_negotiating_commands}; 2513 return 1; 2514 } 2515 } 2516 else { 2517 2518 # received unknown reply. so what.. 2519 } 2520 } 2521 elsif ($client->{_negotiating_lastevent} ne "sent") { 2522 2523 # We're sending a command to the other end, now we have to figure out which one 2524 _serverclient_negotiate_sendnext($client); 2525 } 2526 return undef; 2527} 2528 2529# 2530# This is called by _serverclient_negotiate(). It's job is to figure out what's the next command to send 2531# to the other end and send it. 2532# 2533# Expects a client object 2534# 2535sub _serverclient_negotiate_sendnext { 2536 my $client = shift; 2537 my $data; 2538 my $class = $client; 2539 my ($temppublic, $tempprivate, $tempscalar); 2540 my $key; 2541 my @available; 2542 $class =~ s/=.*//g; 2543 2544 if (!defined $client->{_negotiating_commands}) { 2545 2546 # 2547 # Let's initialize the sequence of commands we send 2548 # 2549 $data = "\r\n\r\n\r\n\r\n\r\n\r\n\r\n\r\n"; 2550 $data .= "-----BEGIN CLEARTEXT WELCOME MESSAGE-----\r\n"; 2551 $data .= "::\r\n"; 2552 $data .= ":: HELLO :: $class VERSION $VERSION :: SERVER READY ::\r\n"; 2553 $data .= "::\r\n"; 2554 if ($client->{_welcome}) { 2555 $data .= ":: $client->{_welcome}\r\n"; 2556 $data .= "::\r\n"; 2557 } 2558 $data .= "-----END CLEARTEXT WELCOME MESSAGE-----\r\n"; 2559 push(@{ $client->{_negotiating_commands} }, $data); 2560 $data = "VE\x00$VERSION"; 2561 push(@{ $client->{_negotiating_commands} }, $data); 2562 $data = "COS\x00" . _bin2asc($client->{_compatabilityscalar}); 2563 push(@{ $client->{_negotiating_commands} }, $data); 2564 $data = "SVE\x00" . $Storable::VERSION . "\x00" . _bin2asc(nfreeze($client->{_compatabilityreference})); 2565 push(@{ $client->{_negotiating_commands} }, $data); 2566 2567 if (!$client->{_donotencrypt}) { 2568 2569 @available = (); 2570 2571 # 2572 # New method 2573 # 2574 foreach $key (@{ $_ENCRYPT_AVAILABLE{_order} }) { 2575 if ($client->{_donotencryptwith}{$key}) { 2576 2577 # I was told not to encrypt with this module 2578 next; 2579 } 2580 ($temppublic, $tempprivate) = _genkey($key, 1) or next; 2581 $client->{_remotepublickey} = $temppublic; 2582 $client->{_encrypt} = $key; 2583 $tempscalar = $client->{_compatabilityscalar}; 2584 if (_encrypt($client, \$tempscalar)) { 2585 push(@available, $key); 2586 $data = "EM\x00$key\x00" . $_ENCRYPT_AVAILABLE{$key}{version} . "\x00" . _bin2asc(ref($tempprivate) ? nfreeze $tempprivate : $tempprivate) . "\x00" . _bin2asc($tempscalar); 2587 push(@{ $client->{_negotiating_commands} }, $data); 2588 } 2589 delete $client->{_remotepublickey}; 2590 delete $client->{_encrypt}; 2591 } 2592 2593 # 2594 # Old method 2595 # 2596 $data = "EA" . join("", map { "\x00$_" } @available); 2597 push(@{ $client->{_negotiating_commands} }, $data); 2598 } 2599 if (!$client->{_donotcompress}) { 2600 2601 @available = (); 2602 2603 # 2604 # New method 2605 # 2606 foreach $key (@{ $_COMPRESS_AVAILABLE{_order} }) { 2607 if ($client->{_donotcompresswith}{$key}) { 2608 2609 # I was told not to compress with this module 2610 next; 2611 } 2612 $client->{_compress} = $key; 2613 $tempscalar = $client->{_compatabilityscalar}; 2614 if (_compress($client, \$tempscalar)) { 2615 push(@available, $key); 2616 $data = "CM\x00$_\x00" . $_COMPRESS_AVAILABLE{$_}{version} . "\x00" . _bin2asc($tempscalar); 2617 push(@{ $client->{_negotiating_commands} }, $data); 2618 } 2619 delete $client->{_compress}; 2620 } 2621 2622 # 2623 # Old method 2624 # 2625 $data = "CA" . join("", map { "\x00$_" } @available); 2626 push(@{ $client->{_negotiating_commands} }, $data); 2627 } 2628 if (defined $client->{_password}) { 2629 if (!exists $client->{_cryptsalt}) { 2630 $client->{_cryptsalt} = _genrandstring(2, 1); 2631 } 2632 $data = "CS\x00" . $client->{_cryptsalt}; 2633 push(@{ $client->{_negotiating_commands} }, $data); 2634 } 2635 push(@{ $client->{_negotiating_commands} }, "EN"); 2636 } 2637 2638 $data = shift @{ $client->{_negotiating_commands} }; 2639 if (($data =~ /^EA\x00/ && $client->{_negotiatedencryptcompatability}) || ($data =~ /^CA\x00/ && $client->{_negotiatedcompresscompatability})) { 2640 2641 # 2642 # We've already negotiated through compatability. No need to re-negotiate based on versions 2643 # 2644 $data = "NO\x00Already negotiated through compatability"; 2645 } 2646 if (!defined $data) { 2647 return undef; 2648 } 2649 if (!_send($client, $data, 0)) { 2650 $@ = "Error negotiating with client. Could not send : $@"; 2651 return undef; 2652 } 2653 $client->{_negotiating_lastevent} = "sent"; 2654 return 1; 2655} 2656 2657# 2658# This is called whenever a client (true client or serverclient) receives data without the realdata bit set 2659# Takes client as first argument 2660# Takes optional data as second argument, otherwise calls data() method to get it 2661# It would parse the data and probably set variables inside the client object 2662# 2663sub _parseinternaldata { 2664 my $client = shift; 2665 my $data = shift; 2666 if ($client->{_mode} eq "serverclient" && $client->{_negotiating}) { 2667 2668 # The serverclient is still negotiating 2669 if (_serverclient_negotiate($client)) { 2670 2671 # Negotiation's complete and successful 2672 _callback($client, "connect"); 2673 } 2674 } 2675 else { 2676 2677 # 2678 # It's normal internal data 2679 # 2680 if (!defined $data) { 2681 2682 # 2683 # Data was not supplied - get it from bucket 2684 # 2685 $data = $client->data(); 2686 } 2687 2688 # Now do something with it 2689 } 2690} 2691 2692# 2693# This takes an integer, packs it as tightly as possible as a binary representation 2694# and returns the binary value 2695# 2696sub _packint { 2697 my $int = shift; 2698 my $bin; 2699 $bin = pack("N", $int); 2700 $bin =~ s/^\0+//; 2701 return $bin; 2702} 2703 2704# 2705# This does the opposite of _packint. It takes a packed binary produced by _packint and 2706# returns the integer 2707# 2708sub _unpackint { 2709 my $bin = shift; 2710 my $int; 2711 $int = "\0" x (4 - length($bin)) . $bin; 2712 $int = unpack("N", $int); 2713 return $int; 2714} 2715 2716# 2717# This creates a new client object and outgoing connection and returns it as an object 2718# , or returns undef if unsuccessful 2719# If special parameter _sock is supplied, it will be taken as an existing connection 2720# and no outgoing connection will be made 2721# 2722sub _new_client { 2723 my $class = shift; 2724 my %para = @_; 2725 my $sock; 2726 my $self = {}; 2727 my $temp; 2728 my $remoteip; 2729 my $remoteport; 2730 my $key; 2731 my $timeout = $para{timeout} || 30; 2732 $class =~ s/=.*//g; 2733 2734 if (!$para{_sock}) { 2735 if (!$para{host}) { 2736 $@ = "Invalid host"; 2737 return undef; 2738 } 2739 elsif (!$para{port}) { 2740 $@ = "Invalid port"; 2741 return undef; 2742 } 2743 $sock = new IO::Socket::INET( 2744 PeerAddr => $para{host}, 2745 PeerPort => $para{port}, 2746 Proto => 'tcp', 2747 Timeout => $timeout, 2748 ); 2749 $self->{_mode} = "client"; 2750 $self->{_negotiating} = time; 2751 } 2752 else { 2753 $sock = $para{_sock}; 2754 $self->{_mode} = "serverclient"; 2755 $self->{_negotiating} = time; 2756 $self->{_authenticated} = 0; 2757 } 2758 if (!$sock) { 2759 $@ = "Could not connect to $para{host}:$para{port}: $!"; 2760 return undef; 2761 } 2762 $sock->autoflush(1); 2763 if ($para{_remoteport} && $para{_remoteip}) { 2764 $self->{_remoteport} = $para{_remoteport}; 2765 $self->{_remoteip} = $para{_remoteip}; 2766 } 2767 else { 2768 if (!($temp = getpeername($sock))) { 2769 $@ = "Error getting peername"; 2770 return undef; 2771 } 2772 if (!(($remoteport, $remoteip) = sockaddr_in($temp))) { 2773 $@ = "Error getting socket address"; 2774 return undef; 2775 } 2776 if (!($self->{_remoteip} = inet_ntoa($remoteip))) { 2777 $@ = "Error determing remote IP"; 2778 return undef; 2779 } 2780 $self->{_remoteport} = $remoteport; 2781 } 2782 $self->{_sock} = $sock; 2783 $self->{_password} = $para{password}; 2784 $self->{_donotcompress} = ($para{donotcompress}) ? 1 : 0; 2785 $self->{_donotencrypt} = ($para{donotencrypt}) ? 1 : 0; 2786 $self->{_donotcheckversion} = ($para{donotcheckversion}) ? 1 : 0; 2787 $self->{_localpublickey} = ""; 2788 $self->{_databucket} = []; 2789 2790 # 2791 # Populate donotcompresswith with the keys of the supplied module names 2792 # 2793 $self->{_donotcompresswith} = {}; 2794 if (ref($para{donotcompresswith}) ne "ARRAY") { 2795 $para{donotcompresswith} = [ $para{donotcompresswith} ]; 2796 } 2797 foreach $key (keys %_COMPRESS_AVAILABLE) { 2798 if ($key ne "_order" && grep { $_COMPRESS_AVAILABLE{$key}{name} eq $_ } @{ $para{donotcompresswith} }) { 2799 $self->{_donotcompresswith}{$key} = 1; 2800 } 2801 } 2802 2803 # 2804 # Populate donotencryptwith with the keys of the supplied module names 2805 # 2806 $self->{_donotencryptwith} = {}; 2807 if (ref($para{donotencryptwith}) ne "ARRAY") { 2808 $para{donotencryptwith} = [ $para{donotencryptwith} ]; 2809 } 2810 foreach $key (keys %_ENCRYPT_AVAILABLE) { 2811 if ($key ne "_order" && grep { $_ENCRYPT_AVAILABLE{$key}{name} eq $_ } @{ $para{donotencryptwith} }) { 2812 $self->{_donotencryptwith}{$key} = 1; 2813 } 2814 } 2815 2816 bless($self, $class); 2817 2818 if ($self->{_mode} eq "client") { 2819 if (!_client_negotiate($self)) { 2820 2821 # Bad server 2822 $self->close(); 2823 $@ = "Error negotiating with server: $@"; 2824 return undef; 2825 } 2826 else { 2827 $self->{_negotiating} = 0; 2828 } 2829 } 2830 return $self; 2831} 2832 2833# 2834# This creates a new listening server object and returns it, or returns undef if unsuccessful 2835# 2836# Expects a class 2837# 2838sub _new_server { 2839 my $class = shift; 2840 my %para = @_; 2841 my $sock; 2842 my $key; 2843 my $self = {}; 2844 if (!$para{port}) { 2845 $@ = "Invalid port"; 2846 return undef; 2847 } 2848 $sock = new IO::Socket::INET( 2849 LocalPort => $para{port}, 2850 Proto => 'tcp', 2851 Listen => SOMAXCONN, 2852 Reuse => 1, 2853 ); 2854 if (!$sock) { 2855 $@ = "Could not create listening socket on port $para{port}: $!"; 2856 return undef; 2857 } 2858 $sock->autoflush(1); 2859 $self->{_sock} = $sock; 2860 $self->{_selector} = new IO::Select; 2861 $self->{_selector}->add($sock); 2862 $self->{_mode} = "server"; 2863 $self->{_welcome} = $para{welcome}; 2864 $self->{_password} = $para{password}; 2865 $self->{_donotcompress} = ($para{donotcompress}) ? 1 : 0; 2866 $self->{_donotencrypt} = ($para{donotencrypt}) ? 1 : 0; 2867 $self->{_clients} = {}; 2868 $self->{_clientip} = {}; 2869 2870 # 2871 # Populate donotcompresswith with the keys of the supplied module names 2872 # 2873 $self->{_donotcompresswith} = {}; 2874 if (ref($para{donotcompresswith}) ne "ARRAY") { 2875 $para{donotcompresswith} = [ $para{donotcompresswith} ]; 2876 } 2877 foreach $key (keys %_COMPRESS_AVAILABLE) { 2878 if ($key ne "_order" && grep { $_COMPRESS_AVAILABLE{$key}{name} eq $_ } @{ $para{donotcompresswith} }) { 2879 $self->{_donotcompresswith}{$key} = 1; 2880 } 2881 } 2882 2883 # 2884 # Populate donotencryptwith with the keys of the supplied module names 2885 # 2886 $self->{_donotencryptwith} = {}; 2887 if (ref($para{donotencryptwith}) ne "ARRAY") { 2888 $para{donotencryptwith} = [ $para{donotencryptwith} ]; 2889 } 2890 foreach $key (keys %_ENCRYPT_AVAILABLE) { 2891 if ($key ne "_order" && grep { $_ENCRYPT_AVAILABLE{$key}{name} eq $_ } @{ $para{donotencryptwith} }) { 2892 $self->{_donotencryptwith}{$key} = 1; 2893 } 2894 } 2895 2896 # 2897 # To avoid key-gen delays while running, let's create global RSA keypairs right now 2898 # 2899 if (!$self->{_donotencrypt} && !$self->{_donotencryptwith}{'B'}) { 2900 if (!_generateglobalkeypair('Crypt::RSA')) { 2901 $@ = "Could not generate global Crypt::RSA keypairs. $@"; 2902 return undef; 2903 } 2904 } 2905 2906 bless($self, $class); 2907 return $self; 2908} 2909 2910# 2911# This takes a client object and tries to extract as many data buckets as possible out of it's data buffer 2912# If no buckets were extracted, returns false 2913# Otherwise returns true 2914# 2915sub _extractdata { 2916 my $client = shift; 2917 my ($alwayson, $complexstructure, $realdata, $reserved, $encrypted, $compressed, $lenlen); 2918 my $lendata; 2919 my $len; 2920 my $data; 2921 my $key = (defined $client->{_databuffer}) ? substr($client->{_databuffer}, 0, 2) : ''; 2922 if (length($key) != 2) { 2923 return undef; 2924 } 2925 $alwayson = vec($key, 0, 1); 2926 $complexstructure = vec($key, 1, 1); 2927 $realdata = vec($key, 2, 1); 2928 $encrypted = vec($key, 3, 1); 2929 $compressed = vec($key, 4, 1); 2930 $reserved = vec($key, 5, 1); 2931 $reserved = vec($key, 6, 1); 2932 $reserved = vec($key, 7, 1); 2933 $lenlen = vec($key, 1, 8); 2934 2935 if (!$alwayson) { 2936 return undef; 2937 } 2938 $len = substr($client->{_databuffer}, 2, $lenlen); 2939 $lendata = _unpackint($len); 2940 if (length($client->{_databuffer}) < (2 + $lenlen + $lendata)) { 2941 return undef; 2942 } 2943 $data = substr($client->{_databuffer}, 2 + $lenlen, $lendata); 2944 if (length($data) != $lendata) { 2945 return undef; 2946 } 2947 substr($client->{_databuffer}, 0, 2 + $lenlen + $lendata) = ''; 2948 if ($encrypted) { 2949 _decrypt($client, \$data) || return undef; 2950 } 2951 if ($compressed) { 2952 _decompress($client, \$data) || return undef; 2953 } 2954 if ($complexstructure) { 2955 $data = thaw($data); 2956 if (!$data) { 2957 $@ = "Error decompressing complex structure: $!"; 2958 return undef; 2959 } 2960 } 2961 2962 # 2963 # We extracted it fine from the buffer, we add it in the data buckets 2964 # 2965 push( 2966 @{ $client->{_databucket} }, 2967 { 2968 data => $data, 2969 realdata => $realdata, 2970 } 2971 ); 2972 2973 # 2974 # Let's push our luck and see if we can extract more :) 2975 # 2976 _extractdata($client); 2977 2978 # 2979 # All is good, we know we extracted at least 1 bucket 2980 # 2981 return (1); 2982} 2983 2984# 2985# This takes a client object and data, serializes the data if necesary, constructs a proprietary protocol packet 2986# containing the user's data in it, implements crypto and compression as needed, and sends the packet to the supplied socket 2987# Returns 1 for success, undef on failure 2988# 2989sub _send { 2990 local $SIG{'PIPE'} = 'IGNORE'; 2991 my $client = shift; 2992 my $data = shift; 2993 my $realdata = shift; 2994 my $sock = $client->{_sock}; 2995 my $encrypted; 2996 my $compressed; 2997 my $lendata; 2998 my $lenlen; 2999 my $len; 3000 my $key; 3001 my $finaldata; 3002 my $packet; 3003 my $temp; 3004 my $bytes_written; 3005 my $complexstructure = ref($data); 3006 3007 if (!$sock) { 3008 $@ = "Error sending data: Socket handle not supplied"; 3009 return undef; 3010 } 3011 elsif (!defined $data) { 3012 $@ = "Error sending data: Data not supplied"; 3013 return undef; 3014 } 3015 if ($complexstructure) { 3016 $data = nfreeze $data; 3017 } 3018 $compressed = ($client->{_donotcompress}) ? 0 : _compress($client, \$data); 3019 $encrypted = ($client->{_donotencrypt}) ? 0 : _encrypt($client, \$data); 3020 $lendata = length($data); 3021 $len = _packint($lendata); 3022 $lenlen = length($len); 3023 3024 # Reset the key byte into 0-filled bits 3025 $key = chr(0) x 2; 3026 vec($key, 0, 16) = 0; 3027 3028 # 1 BIT: ALWAYSON : 3029 vec($key, 0, 1) = 1; 3030 3031 # 1 BIT: COMPLEXSTRUCTURE : 3032 vec($key, 1, 1) = ($complexstructure) ? 1 : 0; 3033 3034 # 1 BIT: REAL DATA: 3035 vec($key, 2, 1) = (defined $realdata && !$realdata) ? 0 : 1; 3036 3037 # 1 BIT: ENCRYPTED : 3038 vec($key, 3, 1) = ($encrypted) ? 1 : 0; 3039 3040 # 1 BIT: COMPRESSED : 3041 vec($key, 4, 1) = ($compressed) ? 1 : 0; 3042 3043 # 1 BIT: RESERVED : 3044 vec($key, 5, 1) = 0; 3045 3046 # 1 BIT: RESERVED : 3047 vec($key, 6, 1) = 0; 3048 3049 # 1 BIT: RESERVED : 3050 vec($key, 7, 1) = 0; 3051 3052 # 8 BITS: LENGTH OF "DATA LENGTH STRING" 3053 vec($key, 1, 8) = $lenlen; 3054 3055 # Construct the final data and send it: 3056 $finaldata = $key . $len . $data; 3057 $len = length($finaldata); 3058 $temp = 0; 3059 while (length($finaldata)) { 3060 $packet = substr($finaldata, 0, $PACKETSIZE); 3061 substr($finaldata, 0, $PACKETSIZE) = ''; 3062 $bytes_written = syswrite($sock, $packet, length($packet)); 3063 if (!defined $bytes_written) { 3064 $@ = "Error writing to socket while sending data: $!"; 3065 return undef; 3066 } 3067 $temp += $bytes_written; 3068 } 3069 if ($temp != $len) { 3070 $@ = "Error sending data: $!"; 3071 return undef; 3072 } 3073 else { 3074 return 1; 3075 } 3076} 3077 3078# 3079# Leave me alone: 3080# 30811; 3082