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