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