Annotation of loncom/LondConnection.pm, revision 1.31
1.2 albertel 1: # This module defines and implements a class that represents
2: # a connection to a lond daemon.
3: #
1.31 ! foxr 4: # $Id: LondConnection.pm,v 1.30 2004/06/01 10:05:16 foxr Exp $
1.2 albertel 5: #
6: # Copyright Michigan State University Board of Trustees
7: #
8: # This file is part of the LearningOnline Network with CAPA (LON-CAPA).
9: #
10: # LON-CAPA is free software; you can redistribute it and/or modify
11: # it under the terms of the GNU General Public License as published by
12: # the Free Software Foundation; either version 2 of the License, or
13: # (at your option) any later version.
14: #
15: # LON-CAPA is distributed in the hope that it will be useful,
16: # but WITHOUT ANY WARRANTY; without even the implied warranty of
17: # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
18: # GNU General Public License for more details.
19: #
20: # You should have received a copy of the GNU General Public License
21: # along with LON-CAPA; if not, write to the Free Software
22: # Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
23: #
24: # /home/httpd/html/adm/gpl.txt
25: #
26: # http://www.lon-capa.org/
1.1 foxr 27: #
1.14 foxr 28:
1.1 foxr 29: package LondConnection;
30:
1.10 foxr 31: use strict;
1.1 foxr 32: use IO::Socket;
33: use IO::Socket::INET;
34: use IO::Handle;
35: use IO::File;
36: use Fcntl;
37: use POSIX;
38: use Crypt::IDEA;
1.31 ! foxr 39: use LONCAPA::lonlocal;
! 40: use LONCAPA::lonssl;
1.14 foxr 41:
1.1 foxr 42:
1.12 foxr 43:
44:
1.31 ! foxr 45: my $DebugLevel=11;
1.12 foxr 46: my %hostshash;
47: my %perlvar;
1.31 ! foxr 48: my $LocalDns = ""; # Need not be defined for managers.
! 49: my $InsecureOk;
1.1 foxr 50:
1.14 foxr 51: #
1.16 foxr 52: # Set debugging level
53: #
54: sub SetDebug {
55: $DebugLevel = shift;
56: }
57:
58: #
1.14 foxr 59: # The config read is done in this way to support the read of
60: # the non-default configuration file in the
61: # event we are being used outside of loncapa.
62: #
63:
64: my $ConfigRead = 0;
65:
1.1 foxr 66: # Read the configuration file for apache to get the perl
1.31 ! foxr 67: # variables set.
1.1 foxr 68:
1.12 foxr 69: sub ReadConfig {
1.31 ! foxr 70: Debug(8, "ReadConfig called");
! 71:
1.14 foxr 72: my $perlvarref = read_conf('loncapa.conf');
1.12 foxr 73: %perlvar = %{$perlvarref};
1.14 foxr 74: my $hoststab = read_hosts(
1.21 foxr 75: "$perlvar{lonTabDir}/hosts.tab") ||
1.14 foxr 76: die "Can't read host table!!";
1.12 foxr 77: %hostshash = %{$hoststab};
1.17 foxr 78: $ConfigRead = 1;
1.12 foxr 79:
1.31 ! foxr 80: my $myLonCapaName = $perlvar{lonHostID};
! 81: Debug(8, "My loncapa name is $myLonCapaName");
! 82:
! 83: if(defined $hostshash{$myLonCapaName}) {
! 84: Debug(8, "My loncapa name is in hosthash");
! 85: my @ConfigLine = @{$hostshash{$myLonCapaName}};
! 86: $LocalDns = $ConfigLine[3];
! 87: Debug(8, "Got local name $LocalDns");
! 88: }
! 89: $InsecureOk = $perlvar{loncAllowInsecure};
! 90:
! 91: Debug(3, "ReadConfig - LocalDNS = $LocalDns");
1.12 foxr 92: }
93:
1.15 foxr 94: #
95: # Read a foreign configuration.
96: # This sub is intended for the cases where the package
97: # will be read from outside the LonCAPA environment, in that case
98: # the client will need to explicitly provide:
99: # - A file in hosts.tab format.
100: # - Some idea of the 'lonCAPA' name of the local host (for building
101: # the encryption key).
102: #
103: # Parameters:
104: # MyHost - Name of this host as far as LonCAPA is concerned.
105: # Filename - Name of a hosts.tab formatted file that will be used
106: # to build up the hosts table.
107: #
108: sub ReadForeignConfig {
1.30 foxr 109:
110: my ($MyHost, $Filename) = @_;
1.15 foxr 111:
1.17 foxr 112: &Debug(4, "ReadForeignConfig $MyHost $Filename\n");
113:
1.15 foxr 114: $perlvar{lonHostID} = $MyHost; # Rmember my host.
115: my $hosttab = read_hosts($Filename) ||
116: die "Can't read hosts table!!";
1.17 foxr 117: %hostshash = %{$hosttab};
118: if($DebugLevel > 3) {
119: foreach my $host (keys %hostshash) {
1.31 ! foxr 120: print STDERR "host $host => $hostshash{$host}\n";
1.17 foxr 121: }
122: }
123: $ConfigRead = 1;
1.1 foxr 124:
1.31 ! foxr 125: my $myLonCapaName = $perlvar{lonHostID};
! 126:
! 127: if(defined $hostshash{$myLonCapaName}) {
! 128: my @ConfigLine = @{$hostshash{$myLonCapaName}};
! 129: $LocalDns = $ConfigLine[3];
! 130: }
! 131: $InsecureOk = $perlvar{loncAllowInsecure};
! 132:
! 133: Debug(3, "ReadForeignConfig - LocalDNS = $LocalDns");
! 134:
1.15 foxr 135: }
1.1 foxr 136:
137: sub Debug {
1.30 foxr 138:
139: my ($level, $message) = @_;
140:
1.1 foxr 141: if ($level < $DebugLevel) {
1.31 ! foxr 142: print STDERR ($message."\n");
1.1 foxr 143: }
144: }
1.3 albertel 145:
146: =pod
147:
148: =head2 Dump
149:
1.12 foxr 150: Dump the internal state of the object: For debugging purposes, to stderr.
1.3 albertel 151:
1.1 foxr 152: =cut
153:
154: sub Dump {
155: my $self = shift;
1.10 foxr 156: my $key;
157: my $value;
1.22 foxr 158: print STDERR "Dumping LondConnectionObject:\n";
1.1 foxr 159: while(($key, $value) = each %$self) {
1.22 foxr 160: print STDERR "$key -> $value\n";
1.1 foxr 161: }
1.23 foxr 162: print STDERR "-------------------------------\n";
1.1 foxr 163: }
164:
165: =pod
1.3 albertel 166:
167: Local function to do a state transition. If the state transition
168: callback is defined it is called with two parameters: the self and the
169: old state.
170:
1.1 foxr 171: =cut
1.3 albertel 172:
1.1 foxr 173: sub Transition {
1.30 foxr 174:
175: my ($self, $newstate) = @_;
176:
1.1 foxr 177: my $oldstate = $self->{State};
178: $self->{State} = $newstate;
179: $self->{TimeoutRemaining} = $self->{TimeoutValue};
180: if($self->{TransitionCallback}) {
181: ($self->{TransitionCallback})->($self, $oldstate);
182: }
183: }
184:
1.3 albertel 185:
1.14 foxr 186:
1.1 foxr 187: =pod
1.3 albertel 188:
189: =head2 new
190:
191: Construct a new lond connection.
192:
193: Parameters (besides the class name) include:
194:
195: =item hostname
196:
197: host the remote lond is on. This host is a host in the hosts.tab file
198:
199: =item port
200:
201: port number the remote lond is listening on.
202:
1.1 foxr 203: =cut
1.3 albertel 204:
1.1 foxr 205: sub new {
1.30 foxr 206:
207: my ($class, $Hostname, $Port) = @_;
1.14 foxr 208:
209: if (!$ConfigRead) {
210: ReadConfig();
211: $ConfigRead = 1;
212: }
1.1 foxr 213: &Debug(4,$class."::new( ".$Hostname.",".$Port.")\n");
214:
215: # The host must map to an entry in the hosts table:
216: # We connect to the dns host that corresponds to that
217: # system and use the hostname for the encryption key
218: # negotion. In the objec these become the Host and
219: # LoncapaHim fields of the object respectively.
220: #
221: if (!exists $hostshash{$Hostname}) {
1.16 foxr 222: &Debug(8, "No Such host $Hostname");
1.1 foxr 223: return undef; # No such host!!!
224: }
225: my @ConfigLine = @{$hostshash{$Hostname}};
226: my $DnsName = $ConfigLine[3]; # 4'th item is dns of host.
227: Debug(5, "Connecting to ".$DnsName);
228: # Now create the object...
229: my $self = { Host => $DnsName,
1.24 foxr 230: LoncapaHim => $Hostname,
231: Port => $Port,
232: State => "Initialized",
1.31 ! foxr 233: AuthenticationMode => "",
1.24 foxr 234: TransactionRequest => "",
235: TransactionReply => "",
236: InformReadable => 0,
237: InformWritable => 0,
238: TimeoutCallback => undef,
239: TransitionCallback => undef,
240: Timeoutable => 0,
241: TimeoutValue => 30,
242: TimeoutRemaining => 0,
1.31 ! foxr 243: LocalKeyFile => "",
1.24 foxr 244: CipherKey => "",
245: LondVersion => "Unknown",
246: Cipher => undef};
1.1 foxr 247: bless($self, $class);
248: unless ($self->{Socket} = IO::Socket::INET->new(PeerHost => $self->{Host},
1.27 foxr 249: PeerPort => $self->{Port},
250: Type => SOCK_STREAM,
251: Proto => "tcp",
252: Timeout => 3)) {
1.1 foxr 253: return undef; # Inidicates the socket could not be made.
254: }
1.31 ! foxr 255: my $socket = $self->{Socket}; # For local use only.
! 256: # If we are local, we'll first try local auth mode, otherwise, we'll try the
! 257: # ssl auth mode:
! 258:
! 259: Debug(8, "Connecting to $DnsName I am $LocalDns");
! 260: my $key;
! 261: my $keyfile;
! 262: if ($DnsName eq $LocalDns) {
! 263: $self->{AuthenticationMode} = "local";
! 264: ($key, $keyfile) = lonlocal::CreateKeyFile();
! 265: Debug(8, "Local key: $key, stored in $keyfile");
! 266:
! 267: # If I can't make the key file fall back to insecure if
! 268: # allowed...else give up right away.
! 269:
! 270: if(!(defined $key) || !(defined $keyfile)) {
! 271: if($InsecureOk) {
! 272: $self->{AuthenticationMode} = "insecure";
! 273: $self->{TransactionRequest} = "init\n";
! 274: }
! 275: else {
! 276: $socket->close;
! 277: return undef;
! 278: }
! 279: }
! 280: $self->{TransactionRequest} = "init:local:$keyfile\n";
! 281: Debug(9, "Init string is init:local:$keyfile");
! 282: if(!$self->CreateCipher($key)) { # Nothing's going our way...
! 283: $socket->close;
! 284: return undef;
! 285: }
! 286:
! 287: }
! 288: else {
! 289: $self->{AuthenticationMode} = "ssl";
! 290: $self->{TransactionRequest} = "init:ssl\n";
! 291: }
! 292:
1.1 foxr 293: #
294: # We're connected. Set the state, and the events we'll accept:
295: #
296: $self->Transition("Connected");
297: $self->{InformWritable} = 1; # When socket is writable we send init
1.9 foxr 298: $self->{Timeoutable} = 1; # Timeout allowed during startup negotiation.
1.31 ! foxr 299:
1.1 foxr 300:
301: #
302: # Set socket to nonblocking I/O.
303: #
304: my $socket = $self->{Socket};
1.31 ! foxr 305: my $flags = fcntl($socket, F_GETFL,0);
! 306: if(!$flags) {
1.1 foxr 307: $socket->close;
308: return undef;
309: }
1.31 ! foxr 310: if(!fcntl($socket, F_SETFL, $flags | O_NONBLOCK)) {
1.1 foxr 311: $socket->close;
312: return undef;
313: }
314:
315: # return the object :
316:
1.31 ! foxr 317: Debug(9, "Initial object state: ");
! 318: $self->Dump();
! 319:
1.1 foxr 320: return $self;
321: }
1.3 albertel 322:
1.1 foxr 323: =pod
1.3 albertel 324:
325: =head2 Readable
326:
327: This member should be called when the Socket becomes readable. Until
328: the read completes, action is state independet. Data are accepted into
329: the TransactionReply until a newline character is received. At that
330: time actionis state dependent:
331:
332: =item Connected
333:
334: in this case we received challenge, the state changes to
335: ChallengeReceived, and we initiate a send with the challenge response.
336:
337: =item ReceivingReply
338:
339: In this case a reply has been received for a transaction, the state
340: goes to Idle and we disable write and read notification.
341:
342: =item ChallengeReeived
343:
344: we just got what should be an ok\n and the connection can now handle
345: transactions.
1.1 foxr 346:
347: =cut
1.3 albertel 348:
1.1 foxr 349: sub Readable {
350: my $self = shift;
351: my $socket = $self->{Socket};
352: my $data = '';
1.27 foxr 353: my $rv;
1.31 ! foxr 354: my $ConnectionMode = $self->{AuthenticationMode};
! 355:
1.27 foxr 356: if ($socket) {
357: eval {
358: $rv = $socket->recv($data, POSIX::BUFSIZ, 0);
359: }
360: } else {
361: $self->Transition("Disconnected");
362: return -1;
363: }
1.1 foxr 364: my $errno = $! + 0; # Force numeric context.
365:
1.8 foxr 366: unless (defined($rv) && length $data) {# Read failed,
1.1 foxr 367: if(($errno == POSIX::EWOULDBLOCK) ||
368: ($errno == POSIX::EAGAIN) ||
1.8 foxr 369: ($errno == POSIX::EINTR)) {
1.1 foxr 370: return 0;
371: }
372:
373: # Connection likely lost.
374: &Debug(4, "Connection lost");
375: $self->{TransactionRequest} = '';
376: $socket->close();
377: $self->Transition("Disconnected");
378: return -1;
379: }
380: # Append the data to the buffer. And figure out if the read is done:
381:
382: &Debug(9,"Received from host: ".$data);
383: $self->{TransactionReply} .= $data;
1.29 albertel 384: if($self->{TransactionReply} =~ m/\n$/) {
1.1 foxr 385: &Debug(8,"Readable End of line detected");
1.31 ! foxr 386:
! 387:
1.1 foxr 388: if ($self->{State} eq "Initialized") { # We received the challenge:
1.31 ! foxr 389: # Our init was replied to. What happens next depends both on
! 390: # the actual init we sent (AuthenticationMode member data)
! 391: # and the response:
! 392: # AuthenticationMode == local:
! 393: # Response ok: The key has been exchanged and
! 394: # the key file destroyed. We can jump
! 395: # into setting the host and requesting the
! 396: # Later we'll also bypass key exchange.
! 397: # Response digits:
! 398: # Old style lond. Delete the keyfile.
! 399: # If allowed fall back to insecure mode.
! 400: # else close connection and fail.
! 401: # Response other:
! 402: # Failed local auth
! 403: # Close connection and fail.
! 404: #
! 405: # AuthenticationMode == ssl:
! 406: # Response ok:ssl
! 407: # Response digits:
! 408: # Response other:
! 409: # Authentication mode == insecure
! 410: # Response digits
! 411: # Response other:
! 412:
! 413: my $Response = $self->{TransactionReply};
! 414: if($ConnectionMode eq "local") {
! 415: if($Response =~ /^ok:local/) { # Good local auth.
! 416: $self->ToVersionRequest();
! 417: return 0;
! 418: }
! 419: elsif ($Response =~/^[0-9]+/) { # Old style lond.
! 420: return $self->CompleteInsecure();
! 421:
! 422: }
! 423: else { # Complete flop
! 424: &Debug(3, "init:local : unrecognized reply");
! 425: $self->Transition("Disconnected");
! 426: $socket->close;
! 427: return -1;
! 428: }
! 429: }
! 430: elsif ($ConnectionMode eq "ssl") {
! 431: if($Response =~ /^ok:ssl/) { # Good ssl...
! 432: if($self->ExchangeKeysViaSSL()) { # Success skip to vsn stuff
! 433: # Need to reset to non blocking:
! 434:
! 435: my $flags = fcntl($socket, F_GETFL, 0);
! 436: fcntl($socket, F_SETFL, $flags | O_NONBLOCK);
! 437: $self->ToVersionRequest();
! 438: return 0;
! 439: }
! 440: else { # Failed in ssl exchange.
! 441: &Debug(3,"init:ssl failed key negotiation!");
! 442: $self->Transition("Disconnected");
! 443: $socket->close;
! 444: return -1;
! 445: }
! 446: }
! 447: elsif ($Response =~ /^[0-9]+/) { # Old style lond.
! 448: return $self->CompleteInsecure();
! 449: }
! 450: else { # Complete flop
! 451: }
! 452: }
! 453: elsif ($ConnectionMode eq "insecure") {
! 454: if($self->{TransactionReply} eq "refused\n") { # Remote doesn't have
! 455:
! 456: $self->Transition("Disconnected"); # in host tables.
! 457: $socket->close();
! 458: return -1;
! 459:
! 460: }
! 461: return $self->CompleteInsecure();
! 462: }
! 463: else {
! 464: &Debug(1,"Authentication mode incorrect");
! 465: die "BUG!!! LondConnection::Readable invalid authmode";
1.1 foxr 466: }
1.27 foxr 467:
1.31 ! foxr 468:
1.28 albertel 469: } elsif ($self->{State} eq "ChallengeReplied") {
470: if($self->{TransactionReply} ne "ok\n") {
471: $self->Transition("Disconnected");
472: $socket->close();
473: return -1;
474: }
1.31 ! foxr 475: $self->ToVersionRequest();
1.28 albertel 476: return 0;
1.31 ! foxr 477:
1.28 albertel 478: } elsif ($self->{State} eq "ReadingVersionString") {
479: $self->{LondVersion} = chomp($self->{TransactionReply});
480: $self->Transition("SetHost");
481: $self->{InformReadable} = 0;
482: $self->{InformWritable} = 1;
483: my $peer = $self->{LoncapaHim};
484: $self->{TransactionRequest}= "sethost:$peer\n";
485: return 0;
1.24 foxr 486: } elsif ($self->{State} eq "HostSet") { # should be ok.
1.28 albertel 487: if($self->{TransactionReply} ne "ok\n") {
488: $self->Transition("Disconnected");
489: $socket->close();
490: return -1;
491: }
1.31 ! foxr 492: # If the auth mode is insecure we must still
! 493: # exchange session keys. Otherwise,
! 494: # we can just transition to idle.
! 495:
! 496: if($ConnectionMode eq "insecure") {
! 497: $self->Transition("RequestingKey");
! 498: $self->{InformReadable} = 0;
! 499: $self->{InformWritable} = 1;
! 500: $self->{TransactionRequest} = "ekey\n";
! 501: return 0;
! 502: }
! 503: else {
! 504: $self->ToIdle();
! 505: return 0;
! 506: }
1.1 foxr 507: } elsif ($self->{State} eq "ReceivingKey") {
508: my $buildkey = $self->{TransactionReply};
509: my $key = $self->{LoncapaHim}.$perlvar{'lonHostID'};
510: $key=~tr/a-z/A-Z/;
511: $key=~tr/G-P/0-9/;
512: $key=~tr/Q-Z/0-9/;
1.31 ! foxr 513: $key =$key.$buildkey.$key.$buildkey.$key.$buildkey;
! 514: $key = substr($key,0,32);
! 515: if(!$self->CreateCipher($key)) {
1.1 foxr 516: $self->Transition("Disconnected");
517: $socket->close();
518: return -1;
519: } else {
1.31 ! foxr 520: $self->ToIdle();
1.1 foxr 521: return 0;
522: }
523: } elsif ($self->{State} eq "ReceivingReply") {
524:
525: # If the data are encrypted, decrypt first.
526:
527: my $answer = $self->{TransactionReply};
528: if($answer =~ /^enc\:/) {
529: $answer = $self->Decrypt($answer);
530: $self->{TransactionReply} = $answer;
531: }
532:
533: # finish the transaction
534:
1.31 ! foxr 535: $self->ToIdle();
1.1 foxr 536: return 0;
537: } elsif ($self->{State} eq "Disconnected") { # No connection.
538: return -1;
539: } else { # Internal error: Invalid state.
540: $self->Transition("Disconnected");
541: $socket->close();
542: return -1;
543: }
544: }
545:
546: return 0;
1.27 foxr 547:
1.1 foxr 548: }
549:
550:
551: =pod
1.3 albertel 552:
553: This member should be called when the Socket becomes writable.
554:
555: The action is state independent. An attempt is made to drain the
556: contents of the TransactionRequest member. Once this is drained, we
557: mark the object as waiting for readability.
1.1 foxr 558:
559: Returns 0 if successful, or -1 if not.
1.3 albertel 560:
1.1 foxr 561: =cut
562: sub Writable {
563: my $self = shift; # Get reference to the object.
564: my $socket = $self->{Socket};
1.26 albertel 565: my $nwritten;
566: if ($socket) {
567: eval {
568: $nwritten = $socket->send($self->{TransactionRequest}, 0);
569: }
1.27 foxr 570: } else {
571: # For whatever reason, there's no longer a socket left.
572:
573:
574: $self->Transition("Disconnected");
575: return -1;
1.26 albertel 576: }
1.1 foxr 577: my $errno = $! + 0;
578: unless (defined $nwritten) {
579: if($errno != POSIX::EINTR) {
580: $self->Transition("Disconnected");
581: return -1;
582: }
583:
584: }
1.10 foxr 585: if (($nwritten >= 0) ||
1.1 foxr 586: ($errno == POSIX::EWOULDBLOCK) ||
587: ($errno == POSIX::EAGAIN) ||
588: ($errno == POSIX::EINTR) ||
589: ($errno == 0)) {
590: substr($self->{TransactionRequest}, 0, $nwritten) = ""; # rmv written part
1.27 foxr 591: if(length $self->{TransactionRequest} == 0) {
592: $self->{InformWritable} = 0;
593: $self->{InformReadable} = 1;
594: $self->{TransactionReply} = '';
595: #
596: # Figure out the next state:
597: #
598: if($self->{State} eq "Connected") {
599: $self->Transition("Initialized");
600: } elsif($self->{State} eq "ChallengeReceived") {
601: $self->Transition("ChallengeReplied");
602: } elsif($self->{State} eq "RequestingVersion") {
603: $self->Transition("ReadingVersionString");
604: } elsif ($self->{State} eq "SetHost") {
605: $self->Transition("HostSet");
606: } elsif($self->{State} eq "RequestingKey") {
607: $self->Transition("ReceivingKey");
1.24 foxr 608: # $self->{InformWritable} = 0;
609: # $self->{InformReadable} = 1;
610: # $self->{TransactionReply} = '';
1.27 foxr 611: } elsif ($self->{State} eq "SendingRequest") {
612: $self->Transition("ReceivingReply");
613: $self->{TimeoutRemaining} = $self->{TimeoutValue};
614: } elsif ($self->{State} eq "Disconnected") {
615: return -1;
616: }
617: return 0;
618: }
619: } else { # The write failed (e.g. partner disconnected).
620: $self->Transition("Disconnected");
621: $socket->close();
622: return -1;
623: }
624:
1.1 foxr 625: }
626: =pod
1.3 albertel 627:
628: =head2 Tick
629:
1.1 foxr 630: Tick is called every time unit by the event framework. It
1.3 albertel 631:
632: =item 1 decrements the remaining timeout.
633:
634: =item 2 If the timeout is zero, calls TimedOut indicating that the current operation timed out.
1.1 foxr 635:
636: =cut
637:
638: sub Tick {
639: my $self = shift;
640: $self->{TimeoutRemaining}--;
641: if ($self->{TimeoutRemaining} < 0) {
642: $self->TimedOut();
643: }
644: }
1.3 albertel 645:
1.1 foxr 646: =pod
647:
1.3 albertel 648: =head2 TimedOut
649:
650: called on a timeout. If the timeout callback is defined, it is called
651: with $self as its parameters.
652:
653: =cut
654:
1.1 foxr 655: sub TimedOut {
656:
657: my $self = shift;
658: if($self->{TimeoutCallback}) {
659: my $callback = $self->{TimeoutCallback};
660: my @args = ( $self);
661: &$callback(@args);
662: }
663: }
1.3 albertel 664:
1.1 foxr 665: =pod
1.3 albertel 666:
667: =head2 InitiateTransaction
668:
669: Called to initiate a transaction. A transaction can only be initiated
670: when the object is idle... otherwise an error is returned. A
671: transaction consists of a request to the server that will have a
672: reply. This member sets the request data in the TransactionRequest
673: member, makes the state SendingRequest and sets the data to allow a
674: timout, and to request writability notification.
675:
1.1 foxr 676: =cut
1.3 albertel 677:
1.1 foxr 678: sub InitiateTransaction {
1.30 foxr 679:
680: my ($self, $data) = @_;
1.1 foxr 681:
1.4 foxr 682: Debug(1, "initiating transaction: ".$data);
1.1 foxr 683: if($self->{State} ne "Idle") {
1.4 foxr 684: Debug(0," .. but not idle here\n");
1.1 foxr 685: return -1; # Error indicator.
686: }
687: # if the transaction is to be encrypted encrypt the data:
688:
689: if($data =~ /^encrypt\:/) {
690: $data = $self->Encrypt($data);
691: }
692:
693: # Setup the trasaction
694:
695: $self->{TransactionRequest} = $data;
696: $self->{TransactionReply} = "";
697: $self->{InformWritable} = 1;
698: $self->{InformReadable} = 0;
699: $self->{Timeoutable} = 1;
700: $self->{TimeoutRemaining} = $self->{TimeoutValue};
701: $self->Transition("SendingRequest");
702: }
703:
704:
705: =pod
1.3 albertel 706:
707: =head2 SetStateTransitionCallback
708:
709: Sets a callback for state transitions. Returns a reference to any
710: prior established callback, or undef if there was none:
711:
1.1 foxr 712: =cut
1.3 albertel 713:
1.1 foxr 714: sub SetStateTransitionCallback {
715: my $self = shift;
716: my $oldCallback = $self->{TransitionCallback};
717: $self->{TransitionCallback} = shift;
718: return $oldCallback;
719: }
1.3 albertel 720:
1.1 foxr 721: =pod
1.3 albertel 722:
723: =head2 SetTimeoutCallback
724:
725: Sets the timeout callback. Returns a reference to any prior
726: established callback or undef if there was none.
727:
1.1 foxr 728: =cut
1.3 albertel 729:
1.1 foxr 730: sub SetTimeoutCallback {
1.30 foxr 731:
732: my ($self, $callback) = @_;
733:
1.1 foxr 734: my $oldCallback = $self->{TimeoutCallback};
735: $self->{TimeoutCallback} = $callback;
736: return $oldCallback;
737: }
738:
739: =pod
1.3 albertel 740:
1.5 foxr 741: =head2 Shutdown:
742:
743: Shuts down the socket.
744:
745: =cut
746:
747: sub Shutdown {
748: my $self = shift;
749: my $socket = $self->GetSocket();
1.20 albertel 750: Debug(5,"socket is -$socket-");
751: if ($socket) {
752: # Ask lond to exit too. Non blocking so
753: # there is no cost for failure.
754: eval {
755: $socket->send("exit\n", 0);
756: $socket->shutdown(2);
757: }
758: }
1.5 foxr 759: }
760:
761: =pod
762:
1.3 albertel 763: =head2 GetState
764:
765: selector for the object state.
766:
1.1 foxr 767: =cut
1.3 albertel 768:
1.1 foxr 769: sub GetState {
770: my $self = shift;
771: return $self->{State};
772: }
1.3 albertel 773:
1.1 foxr 774: =pod
1.3 albertel 775:
776: =head2 GetSocket
777:
778: selector for the object socket.
779:
1.1 foxr 780: =cut
1.3 albertel 781:
1.1 foxr 782: sub GetSocket {
783: my $self = shift;
784: return $self->{Socket};
785: }
1.3 albertel 786:
1.5 foxr 787:
1.1 foxr 788: =pod
1.3 albertel 789:
790: =head2 WantReadable
791:
792: Return the state of the flag that indicates the object wants to be
793: called when readable.
794:
1.1 foxr 795: =cut
1.3 albertel 796:
1.1 foxr 797: sub WantReadable {
798: my $self = shift;
799:
800: return $self->{InformReadable};
801: }
1.3 albertel 802:
1.1 foxr 803: =pod
1.3 albertel 804:
805: =head2 WantWritable
806:
807: Return the state of the flag that indicates the object wants write
808: notification.
809:
1.1 foxr 810: =cut
1.3 albertel 811:
1.1 foxr 812: sub WantWritable {
813: my $self = shift;
814: return $self->{InformWritable};
815: }
1.3 albertel 816:
1.1 foxr 817: =pod
1.3 albertel 818:
819: =head2 WantTimeout
820:
821: return the state of the flag that indicates the object wants to be
822: informed of timeouts.
823:
1.1 foxr 824: =cut
1.3 albertel 825:
1.1 foxr 826: sub WantTimeout {
827: my $self = shift;
828: return $self->{Timeoutable};
829: }
830:
831: =pod
1.3 albertel 832:
833: =head2 GetReply
834:
835: Returns the reply from the last transaction.
836:
1.1 foxr 837: =cut
1.3 albertel 838:
1.1 foxr 839: sub GetReply {
840: my $self = shift;
841: return $self->{TransactionReply};
842: }
843:
844: =pod
1.3 albertel 845:
846: =head2 Encrypt
847:
848: Returns the encrypted version of the command string.
849:
850: The command input string is of the form:
851:
1.1 foxr 852: encrypt:command
1.3 albertel 853:
854: The output string can be directly sent to lond as it is of the form:
855:
1.1 foxr 856: enc:length:<encodedrequest>
1.3 albertel 857:
1.1 foxr 858: =cut
1.3 albertel 859:
1.1 foxr 860: sub Encrypt {
1.30 foxr 861:
862: my ($self, $request) = @_;
1.1 foxr 863:
864:
865: # Split the encrypt: off the request and figure out it's length.
866: # the cipher works in blocks of 8 bytes.
867:
868: my $cmd = $request;
869: $cmd =~ s/^encrypt\://; # strip off encrypt:
870: chomp($cmd); # strip off trailing \n
871: my $length=length($cmd); # Get the string length.
872: $cmd .= " "; # Pad with blanks so we can fill out a block.
873:
874: # encrypt the request in 8 byte chunks to create the encrypted
875: # output request.
876:
877: my $Encoded = '';
878: for(my $index = 0; $index <= $length; $index += 8) {
879: $Encoded .=
880: unpack("H16",
881: $self->{Cipher}->encrypt(substr($cmd,
882: $index, 8)));
883: }
884:
885: # Build up the answer as enc:length:$encrequest.
886:
887: $request = "enc:$length:$Encoded\n";
888: return $request;
889:
890:
891: }
1.3 albertel 892:
893: =pod
894:
895: =head2 Decrypt
896:
897: Decrypt a response from the server. The response is in the form:
898:
899: enc:<length>:<encrypted data>
900:
1.1 foxr 901: =cut
1.3 albertel 902:
1.1 foxr 903: sub Decrypt {
1.30 foxr 904:
905: my ($self, $encrypted) = @_;
1.1 foxr 906:
907: # Bust up the response into length, and encryptedstring:
908:
909: my ($enc, $length, $EncryptedString) = split(/:/,$encrypted);
910: chomp($EncryptedString);
911:
912: # Decode the data in 8 byte blocks. The string is encoded
913: # as hex digits so there are two characters per byte:
914:
1.10 foxr 915: my $decrypted = "";
1.1 foxr 916: for(my $index = 0; $index < length($EncryptedString);
917: $index += 16) {
918: $decrypted .= $self->{Cipher}->decrypt(
919: pack("H16",
920: substr($EncryptedString,
921: $index,
922: 16)));
923: }
924: # the answer may have trailing pads to fill out a block.
925: # $length tells us the actual length of the decrypted string:
926:
927: $decrypted = substr($decrypted, 0, $length);
928:
929: return $decrypted;
930:
931: }
1.31 ! foxr 932: # ToIdle
! 933: # Called to transition to idle... done enough it's worth subbing
! 934: # off to ensure it's always done right!!
! 935: #
! 936: sub ToIdle {
! 937: my $self = shift;
! 938:
! 939: $self->Transition("Idle");
! 940: $self->{InformWritiable} = 0;
! 941: $self->{InformReadable} = 0;
! 942: $self->{Timeoutable} = 0;
! 943: }
! 944:
! 945: # ToVersionRequest
! 946: # Called to transition to "RequestVersion" also done a few times
! 947: # so worth subbing out.
! 948: #
! 949: sub ToVersionRequest {
! 950: my $self = shift;
! 951:
! 952: $self->Transition("RequestingVersion");
! 953: $self->{InformReadable} = 0;
! 954: $self->{InformWritable} = 1;
! 955: $self->{TransactionRequest} = "version\n";
! 956:
! 957: }
! 958: #
! 959: # CreateCipher
! 960: # Given a cipher key stores the key in the object context,
! 961: # creates the cipher object, (stores that in object context),
! 962: # This is done a couple of places, so it's worth factoring it out.
! 963: #
! 964: # Parameters:
! 965: # (self)
! 966: # key - The Cipher key.
! 967: #
! 968: # Returns:
! 969: # 0 - Failure to create IDEA cipher.
! 970: # 1 - Success.
! 971: #
! 972: sub CreateCipher {
! 973: my ($self, $key) = @_; # According to coding std.
! 974:
! 975: $self->{CipherKey} = $key; # Save the text key...
! 976: my $packedkey = pack ("H32", $key);
! 977: my $cipher = new IDEA $packedkey;
! 978: if($cipher) {
! 979: $self->{Cipher} = $cipher;
! 980: Debug("Cipher created dumping socket: ");
! 981: $self->Dump();
! 982: return 1;
! 983: }
! 984: else {
! 985: return 0;
! 986: }
! 987: }
! 988: # ExchangeKeysViaSSL
! 989: # Called to do cipher key exchange via SSL.
! 990: # The socket is promoted to an SSL socket. If that's successful,
! 991: # we read out cipher key through the socket and create an IDEA
! 992: # cipher object.
! 993: # Parameters:
! 994: # (self)
! 995: # Returns:
! 996: # true - Success.
! 997: # false - Failure.
! 998: #
! 999: # Assumptions:
! 1000: # 1. The ssl session setup has timeout logic built in so we don't
! 1001: # have to worry about DOS attacks at that stage.
! 1002: # 2. If the ssl session gets set up we are talking to a legitimate
! 1003: # lond so again we don't have to worry about DOS attacks.
! 1004: # All this allows us just to call
! 1005: sub ExchangeKeysViaSSL {
! 1006: my $self = shift;
! 1007: my $socket = $self->{Socket};
! 1008:
! 1009: # Get our signed certificate, the certificate authority's
! 1010: # certificate and our private key file. All of these
! 1011: # are needed to create the ssl connection.
! 1012:
! 1013: my ($SSLCACertificate,
! 1014: $SSLCertificate) = lonssl::CertificateFile();
! 1015: my $SSLKey = lonssl::KeyFile();
! 1016:
! 1017: # Promote our connection to ssl and read the key from lond.
! 1018:
! 1019: my $SSLSocket = lonssl::PromoteClientSocket($socket,
! 1020: $SSLCACertificate,
! 1021: $SSLCertificate,
! 1022: $SSLKey);
! 1023: if(defined $SSLSocket) {
! 1024: my $key = <$SSLSocket>;
! 1025: lonssl::Close($SSLSocket);
! 1026: if($key) {
! 1027: chomp($key); # \n is not part of the key.
! 1028: return $self->CreateCipher($key);
! 1029: }
! 1030: else {
! 1031: Debug(3, "Failed to read ssl key");
! 1032: return 0;
! 1033: }
! 1034: }
! 1035: else {
! 1036: # Failed!!
! 1037: Debug(3, "Failed to negotiate SSL connection!");
! 1038: return 0;
! 1039: }
! 1040: # should not get here
! 1041: return 0;
! 1042:
! 1043: }
! 1044:
! 1045:
! 1046:
! 1047: #
! 1048: # CompleteInsecure:
! 1049: # This function is called to initiate the completion of
! 1050: # insecure challenge response negotiation.
! 1051: # To do this, we copy the challenge string to the transaction
! 1052: # request, flip to writability and state transition to
! 1053: # ChallengeReceived..
! 1054: # All this is only possible if InsecureOk is true.
! 1055: # Parameters:
! 1056: # (self) - This object's context hash.
! 1057: # Return:
! 1058: # 0 - Ok to transition.
! 1059: # -1 - Not ok to transition (InsecureOk not ok).
! 1060: #
! 1061: sub CompleteInsecure {
! 1062: my $self = shift;
! 1063: if($InsecureOk) {
! 1064: $self->{AuthenticationMode} = "insecure";
! 1065: &Debug(8," Transition out of Initialized:insecure");
! 1066: $self->{TransactionRequest} = $self->{TransactionReply};
! 1067: $self->{InformWritable} = 1;
! 1068: $self->{InformReadable} = 0;
! 1069: $self->Transition("ChallengeReceived");
! 1070: $self->{TimeoutRemaining} = $self->{TimeoutValue};
! 1071: return 0;
! 1072:
! 1073:
! 1074: }
! 1075: else {
! 1076: &Debug(3, "Insecure key negotiation disabled!");
! 1077: my $socket = $self->{Socket};
! 1078: $socket->close;
! 1079: return -1;
! 1080: }
! 1081: }
1.1 foxr 1082:
1083: =pod
1.3 albertel 1084:
1085: =head2 GetHostIterator
1.1 foxr 1086:
1087: Returns a hash iterator to the host information. Each get from
1088: this iterator returns a reference to an array that contains
1089: information read from the hosts configuration file. Array elements
1090: are used as follows:
1091:
1.3 albertel 1092: [0] - LonCapa host name.
1093: [1] - LonCapa domain name.
1094: [2] - Loncapa role (e.g. library or access).
1095: [3] - DNS name server hostname.
1.11 foxr 1096: [4] - IP address (result of e.g. nslookup [3]).
1.3 albertel 1097: [5] - Maximum connection count.
1098: [6] - Idle timeout for reducing connection count.
1099: [7] - Minimum connection count.
1.1 foxr 1100:
1.3 albertel 1101: =cut
1.1 foxr 1102:
1103: sub GetHostIterator {
1104:
1105: return HashIterator->new(\%hostshash);
1106: }
1.14 foxr 1107:
1108: ###########################################################
1109: #
1110: # The following is an unashamed kludge that is here to
1111: # allow LondConnection to be used outside of the
1112: # loncapa environment (e.g. by lonManage).
1113: #
1114: # This is a textual inclusion of pieces of the
1115: # Configuration.pm module.
1116: #
1117:
1118:
1119: my $confdir='/etc/httpd/conf/';
1120:
1121: # ------------------- Subroutine read_conf: read LON-CAPA server configuration.
1122: # This subroutine reads PerlSetVar values out of specified web server
1123: # configuration files.
1124: sub read_conf
1125: {
1126: my (@conf_files)=@_;
1127: my %perlvar;
1128: foreach my $filename (@conf_files,'loncapa_apache.conf')
1129: {
1.21 foxr 1130: if($DebugLevel > 3) {
1.31 ! foxr 1131: print STDERR ("Going to read $confdir.$filename\n");
1.21 foxr 1132: }
1.14 foxr 1133: open(CONFIG,'<'.$confdir.$filename) or
1134: die("Can't read $confdir$filename");
1135: while (my $configline=<CONFIG>)
1136: {
1137: if ($configline =~ /^[^\#]*PerlSetVar/)
1138: {
1139: my ($unused,$varname,$varvalue)=split(/\s+/,$configline);
1140: chomp($varvalue);
1141: $perlvar{$varname}=$varvalue;
1142: }
1143: }
1144: close(CONFIG);
1145: }
1.21 foxr 1146: if($DebugLevel > 3) {
1.31 ! foxr 1147: print STDERR "Dumping perlvar:\n";
1.21 foxr 1148: foreach my $var (keys %perlvar) {
1.31 ! foxr 1149: print STDERR "$var = $perlvar{$var}\n";
1.21 foxr 1150: }
1151: }
1.14 foxr 1152: my $perlvarref=\%perlvar;
1.21 foxr 1153: return $perlvarref;
1154: }
1.14 foxr 1155:
1156: #---------------------- Subroutine read_hosts: Read a LON-CAPA hosts.tab
1157: # formatted configuration file.
1158: #
1159: my $RequiredCount = 5; # Required item count in hosts.tab.
1160: my $DefaultMaxCon = 5; # Default value for maximum connections.
1161: my $DefaultIdle = 1000; # Default connection idle time in seconds.
1162: my $DefaultMinCon = 0; # Default value for minimum connections.
1163:
1164: sub read_hosts {
1165: my $Filename = shift;
1166: my %HostsTab;
1167:
1.16 foxr 1168: open(CONFIG,'<'.$Filename) or die("Can't read $Filename");
1.14 foxr 1169: while (my $line = <CONFIG>) {
1170: if (!($line =~ /^\s*\#/)) {
1171: my @items = split(/:/, $line);
1172: if(scalar @items >= $RequiredCount) {
1173: if (scalar @items == $RequiredCount) { # Only required items:
1174: $items[$RequiredCount] = $DefaultMaxCon;
1175: }
1176: if(scalar @items == $RequiredCount + 1) { # up through maxcon.
1177: $items[$RequiredCount+1] = $DefaultIdle;
1178: }
1179: if(scalar @items == $RequiredCount + 2) { # up through idle.
1180: $items[$RequiredCount+2] = $DefaultMinCon;
1181: }
1182: {
1183: my @list = @items; # probably not needed but I'm unsure of
1184: # about the scope of item so...
1185: $HostsTab{$list[0]} = \@list;
1186: }
1187: }
1188: }
1189: }
1190: close(CONFIG);
1191: my $hostref = \%HostsTab;
1192: return ($hostref);
1193: }
1.24 foxr 1194: #
1195: # Get the version of our peer. Note that this is only well
1196: # defined if the state machine has hit the idle state at least
1197: # once (well actually if it has transitioned out of
1198: # ReadingVersionString The member data LondVersion is returned.
1199: #
1200: sub PeerVersion {
1201: my $self = shift;
1202:
1203: return $self->{LondVersion};
1204: }
1.1 foxr 1205:
1206: 1;
1207:
1208: =pod
1.3 albertel 1209:
1.1 foxr 1210: =head1 Theory
1211:
1.3 albertel 1212: The lond object is a state machine. It lives through the following states:
1213:
1214: =item Connected:
1215:
1216: a TCP connection has been formed, but the passkey has not yet been
1217: negotiated.
1218:
1219: =item Initialized:
1220:
1221: "init" sent.
1222:
1223: =item ChallengeReceived:
1224:
1225: lond sent its challenge to us.
1226:
1227: =item ChallengeReplied:
1228:
1229: We replied to lond's challenge waiting for lond's ok.
1230:
1231: =item RequestingKey:
1232:
1233: We are requesting an encryption key.
1234:
1235: =item ReceivingKey:
1236:
1237: We are receiving an encryption key.
1238:
1239: =item Idle:
1240:
1241: Connection was negotiated but no requests are active.
1242:
1243: =item SendingRequest:
1244:
1245: A request is being sent to the peer.
1246:
1247: =item ReceivingReply:
1248:
1249: Waiting for an entire reply from the peer.
1250:
1251: =item Disconnected:
1252:
1253: For whatever reason, the connection was dropped.
1254:
1255: When we need to be writing data, we have a writable event. When we
1256: need to be reading data, a readable event established. Events
1257: dispatch through the class functions Readable and Writable, and the
1258: watcher contains a reference to the associated object to allow object
1259: context to be reached.
1.1 foxr 1260:
1261: =head2 Member data.
1262:
1.3 albertel 1263: =item Host
1264:
1265: Host socket is connected to.
1266:
1267: =item Port
1268:
1269: The port the remote lond is listening on.
1270:
1271: =item Socket
1272:
1273: Socket open on the connection.
1274:
1275: =item State
1276:
1277: The current state.
1278:
1.31 ! foxr 1279: =item AuthenticationMode
! 1280:
! 1281: How authentication is being done. This can be any of:
! 1282:
! 1283: o local - Authenticate via a key exchanged in a file.
! 1284: o ssl - Authenticate via a key exchaned through a temporary ssl tunnel.
! 1285: o insecure - Exchange keys in an insecure manner.
! 1286:
! 1287: insecure is only allowed if the configuration parameter loncAllowInsecure
! 1288: is nonzero.
! 1289:
1.3 albertel 1290: =item TransactionRequest
1291:
1292: The request being transmitted.
1293:
1294: =item TransactionReply
1295:
1296: The reply being received from the transaction.
1297:
1298: =item InformReadable
1299:
1300: True if we want to be called when socket is readable.
1301:
1302: =item InformWritable
1303:
1304: True if we want to be informed if the socket is writable.
1305:
1306: =item Timeoutable
1307:
1308: True if the current operation is allowed to timeout.
1309:
1310: =item TimeoutValue
1311:
1312: Number of seconds in the timeout.
1313:
1314: =item TimeoutRemaining
1315:
1316: Number of seconds left in the timeout.
1317:
1318: =item CipherKey
1319:
1320: The key that was negotiated with the peer.
1321:
1322: =item Cipher
1323:
1324: The cipher obtained via the key.
1.1 foxr 1325:
1326:
1327: =head2 The following are callback like members:
1.3 albertel 1328:
1329: =item Tick:
1330:
1331: Called in response to a timer tick. Used to managed timeouts etc.
1332:
1333: =item Readable:
1334:
1335: Called when the socket becomes readable.
1336:
1337: =item Writable:
1338:
1339: Called when the socket becomes writable.
1340:
1341: =item TimedOut:
1342:
1343: Called when a timed operation timed out.
1344:
1.1 foxr 1345:
1346: =head2 The following are operational member functions.
1.3 albertel 1347:
1348: =item InitiateTransaction:
1349:
1350: Called to initiate a new transaction
1351:
1352: =item SetStateTransitionCallback:
1353:
1354: Called to establish a function that is called whenever the object goes
1355: through a state transition. This is used by The client to manage the
1356: work flow for the object.
1357:
1358: =item SetTimeoutCallback:
1359:
1360: Set a function to be called when a transaction times out. The
1361: function will be called with the object as its sole parameter.
1362:
1363: =item Encrypt:
1364:
1365: Encrypts a block of text according to the cipher negotiated with the
1366: peer (assumes the text is a command).
1367:
1368: =item Decrypt:
1369:
1370: Decrypts a block of text according to the cipher negotiated with the
1371: peer (assumes the block was a reply.
1.5 foxr 1372:
1373: =item Shutdown:
1374:
1375: Shuts off the socket.
1.1 foxr 1376:
1377: =head2 The following are selector member functions:
1378:
1.3 albertel 1379: =item GetState:
1380:
1381: Returns the current state
1382:
1383: =item GetSocket:
1384:
1385: Gets the socekt open on the connection to lond.
1386:
1387: =item WantReadable:
1388:
1389: true if the current state requires a readable event.
1390:
1391: =item WantWritable:
1392:
1393: true if the current state requires a writable event.
1394:
1395: =item WantTimeout:
1396:
1397: true if the current state requires timeout support.
1398:
1399: =item GetHostIterator:
1400:
1401: Returns an iterator into the host file hash.
1402:
1.1 foxr 1403: =cut
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>
![[BACK]](/icons/back.gif){kind=icon}
Return to LondConnection.pm CVS log ![[TXT]](/icons/text.gif){kind=icon}
![[DIR]](/icons/dir.gif){kind=icon}
Up to [LON-CAPA] / loncom