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