1: # This module defines and implements a class that represents
2: # a connection to a lond daemon.
3: #
4: # $Id: LondConnection.pm,v 1.41 2006/08/11 20:07:52 albertel Exp $
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/
27: #
28:
29: package LondConnection;
30:
31: use strict;
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;
39: use LONCAPA::lonlocal;
40: use LONCAPA::lonssl;
41:
42:
43:
44:
45: my $DebugLevel=0;
46: my %hostshash;
47: my %perlvar;
48: my $LocalDns = ""; # Need not be defined for managers.
49: my $InsecureOk;
50:
51: #
52: # Set debugging level
53: #
54: sub SetDebug {
55: $DebugLevel = shift;
56: }
57:
58: #
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:
66: # Read the configuration file for apache to get the perl
67: # variables set.
68:
69: sub ReadConfig {
70: Debug(8, "ReadConfig called");
71:
72: my $perlvarref = read_conf('loncapa.conf');
73: %perlvar = %{$perlvarref};
74: my $hoststab = read_hosts(
75: "$perlvar{lonTabDir}/hosts.tab") ||
76: die "Can't read host table!!";
77: %hostshash = %{$hoststab};
78: $ConfigRead = 1;
79:
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");
92: }
93:
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 {
109:
110: my ($MyHost, $Filename) = @_;
111:
112: &Debug(4, "ReadForeignConfig $MyHost $Filename\n");
113:
114: $perlvar{lonHostID} = $MyHost; # Rmember my host.
115: my $hosttab = read_hosts($Filename) ||
116: die "Can't read hosts table!!";
117: %hostshash = %{$hosttab};
118: if($DebugLevel > 3) {
119: foreach my $host (keys %hostshash) {
120: print STDERR "host $host => $hostshash{$host}\n";
121: }
122: }
123: $ConfigRead = 1;
124:
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:
135: }
136:
137: sub Debug {
138:
139: my ($level, $message) = @_;
140:
141: if ($level < $DebugLevel) {
142: print STDERR ($message."\n");
143: }
144: }
145:
146: =pod
147:
148: =head2 Dump
149:
150: Dump the internal state of the object: For debugging purposes, to stderr.
151:
152: =cut
153:
154: sub Dump {
155: my $self = shift;
156: my $level = shift;
157: my $now = time;
158: my $local = localtime($now);
159:
160: if ($level >= $DebugLevel) {
161: return;
162: }
163:
164:
165: my $key;
166: my $value;
167: print STDERR "[ $local ] Dumping LondConnectionObject:\n";
168: print STDERR join(':',caller(1))."\n";
169: while(($key, $value) = each %$self) {
170: print STDERR "$key -> $value\n";
171: }
172: print STDERR "-------------------------------\n";
173: }
174:
175: =pod
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:
181: =cut
182:
183: sub Transition {
184:
185: my ($self, $newstate) = @_;
186:
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:
195:
196:
197: =pod
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:
213: =cut
214:
215: sub new {
216: my ($class, $DnsName, $Port) = @_;
217:
218: if (!$ConfigRead) {
219: ReadConfig();
220: $ConfigRead = 1;
221: }
222: &Debug(4,$class."::new( ".$DnsName.",".$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{$DnsName}) {
231: &Debug(8, "No Such host $DnsName");
232: return undef; # No such host!!!
233: }
234: my @ConfigLine = @{$hostshash{$DnsName}};
235: my $Hostname = $ConfigLine[0]; # 0'th item is the msu id of host.
236: Debug(5, "Connecting to ".$DnsName);
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");
240: # Now create the object...
241: my $self = { Host => $DnsName,
242: LoncapaHim => $Hostname,
243: Port => $Port,
244: State => "Initialized",
245: AuthenticationMode => "",
246: TransactionRequest => "",
247: TransactionReply => "",
248: NextRequest => "",
249: InformReadable => 0,
250: InformWritable => 0,
251: TimeoutCallback => undef,
252: TransitionCallback => undef,
253: Timeoutable => 0,
254: TimeoutValue => 30,
255: TimeoutRemaining => 0,
256: LocalKeyFile => "",
257: CipherKey => "",
258: LondVersion => "Unknown",
259: Cipher => undef};
260: bless($self, $class);
261: unless ($self->{Socket} = IO::Socket::INET->new(PeerHost => $self->{Host},
262: PeerPort => $self->{Port},
263: Type => SOCK_STREAM,
264: Proto => "tcp",
265: Timeout => 3)) {
266: Debug(8, "Error? \n$@ \n$!");
267: return undef; # Inidicates the socket could not be made.
268: }
269: my $socket = $self->{Socket}; # For local use only.
270: # If we are local, we'll first try local auth mode, otherwise, we'll try
271: # the ssl auth mode:
272:
273: my $key;
274: my $keyfile;
275: if ($DnsName eq '127.0.0.1') {
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:
300: }
301: else {
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: }
323: }
324:
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
330: $self->{Timeoutable} = 1; # Timeout allowed during startup negotiation.
331:
332:
333: #
334: # Set socket to nonblocking I/O.
335: #
336: my $socket = $self->{Socket};
337: my $flags = fcntl($socket, F_GETFL,0);
338: if(!$flags) {
339: $socket->close;
340: return undef;
341: }
342: if(!fcntl($socket, F_SETFL, $flags | O_NONBLOCK)) {
343: $socket->close;
344: return undef;
345: }
346:
347: # return the object :
348:
349: Debug(9, "Initial object state: ");
350: $self->Dump(9);
351:
352: return $self;
353: }
354:
355: =pod
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.
378:
379: =cut
380:
381: sub Readable {
382: my $self = shift;
383: my $socket = $self->{Socket};
384: my $data = '';
385: my $rv;
386: my $ConnectionMode = $self->{AuthenticationMode};
387:
388: if ($socket) {
389: eval {
390: $rv = $socket->recv($data, POSIX::BUFSIZ, 0);
391: }
392: } else {
393: $self->Transition("Disconnected");
394: return -1;
395: }
396: my $errno = $! + 0; # Force numeric context.
397:
398: unless (defined($rv) && length $data) {# Read failed,
399: if(($errno == POSIX::EWOULDBLOCK) ||
400: ($errno == POSIX::EAGAIN) ||
401: ($errno == POSIX::EINTR)) {
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;
416: if($self->{TransactionReply} =~ m/\n$/) {
417: &Debug(8,"Readable End of line detected");
418:
419:
420: if ($self->{State} eq "Initialized") { # We received the challenge:
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";
498: }
499:
500:
501: } elsif ($self->{State} eq "ChallengeReplied") {
502: if($self->{TransactionReply} ne "ok\n") {
503: $self->Transition("Disconnected");
504: $socket->close();
505: return -1;
506: }
507: $self->ToVersionRequest();
508: return 0;
509:
510: } elsif ($self->{State} eq "ReadingVersionString") {
511: chomp($self->{TransactionReply});
512: $self->{LondVersion} = $self->{TransactionReply};
513: $self->Transition("SetHost");
514: $self->{InformReadable} = 0;
515: $self->{InformWritable} = 1;
516: my $peer = $self->{LoncapaHim};
517: $self->{TransactionRequest}= "sethost:$peer\n";
518: return 0;
519: } elsif ($self->{State} eq "HostSet") { # should be ok.
520: if($self->{TransactionReply} ne "ok\n") {
521: $self->Transition("Disconnected");
522: $socket->close();
523: return -1;
524: }
525: # If the auth mode is insecure we must still
526: # exchange session keys. Otherwise,
527: # we can just transition to idle.
528:
529: if($ConnectionMode eq "insecure") {
530: $self->Transition("RequestingKey");
531: $self->{InformReadable} = 0;
532: $self->{InformWritable} = 1;
533: $self->{TransactionRequest} = "ekey\n";
534: return 0;
535: }
536: else {
537: $self->ToIdle();
538: return 0;
539: }
540: } elsif ($self->{State} eq "ReceivingKey") {
541: my $buildkey = $self->{TransactionReply};
542: my $key = $self->{LoncapaHim}.$perlvar{'lonHostID'};
543: $key=~tr/a-z/A-Z/;
544: $key=~tr/G-P/0-9/;
545: $key=~tr/Q-Z/0-9/;
546: $key =$key.$buildkey.$key.$buildkey.$key.$buildkey;
547: $key = substr($key,0,32);
548: if(!$self->CreateCipher($key)) {
549: $self->Transition("Disconnected");
550: $socket->close();
551: return -1;
552: } else {
553: $self->ToIdle();
554: return 0;
555: }
556: } elsif ($self->{State} eq "ReceivingReply") {
557:
558: # If the data are encrypted, decrypt first.
559:
560: my $answer = $self->{TransactionReply};
561: if($answer =~ /^enc\:/) {
562: $answer = $self->Decrypt($answer);
563: $self->{TransactionReply} = "$answer\n";
564: }
565: # if we have a NextRequest do it immeadiately
566: if ($self->{NextRequest}) {
567: $self->{TransactionRequest} = $self->{NextRequest};
568: undef( $self->{NextRequest} );
569: $self->{TransactionReply} = "";
570: $self->{InformWritable} = 1;
571: $self->{InformReadable} = 0;
572: $self->{Timeoutable} = 1;
573: $self->{TimeoutRemaining} = $self->{TimeoutValue};
574: $self->Transition("SendingRequest");
575: return 0;
576: } else {
577: # finish the transaction
578:
579: $self->ToIdle();
580: return 0;
581: }
582: } elsif ($self->{State} eq "Disconnected") { # No connection.
583: return -1;
584: } else { # Internal error: Invalid state.
585: $self->Transition("Disconnected");
586: $socket->close();
587: return -1;
588: }
589: }
590:
591: return 0;
592:
593: }
594:
595:
596: =pod
597:
598: This member should be called when the Socket becomes writable.
599:
600: The action is state independent. An attempt is made to drain the
601: contents of the TransactionRequest member. Once this is drained, we
602: mark the object as waiting for readability.
603:
604: Returns 0 if successful, or -1 if not.
605:
606: =cut
607: sub Writable {
608: my $self = shift; # Get reference to the object.
609: my $socket = $self->{Socket};
610: my $nwritten;
611: if ($socket) {
612: eval {
613: $nwritten = $socket->send($self->{TransactionRequest}, 0);
614: }
615: } else {
616: # For whatever reason, there's no longer a socket left.
617:
618:
619: $self->Transition("Disconnected");
620: return -1;
621: }
622: my $errno = $! + 0;
623: unless (defined $nwritten) {
624: if($errno != POSIX::EINTR) {
625: $self->Transition("Disconnected");
626: return -1;
627: }
628:
629: }
630: if (($nwritten >= 0) ||
631: ($errno == POSIX::EWOULDBLOCK) ||
632: ($errno == POSIX::EAGAIN) ||
633: ($errno == POSIX::EINTR) ||
634: ($errno == 0)) {
635: substr($self->{TransactionRequest}, 0, $nwritten) = ""; # rmv written part
636: if(length $self->{TransactionRequest} == 0) {
637: $self->{InformWritable} = 0;
638: $self->{InformReadable} = 1;
639: $self->{TransactionReply} = '';
640: #
641: # Figure out the next state:
642: #
643: if($self->{State} eq "Connected") {
644: $self->Transition("Initialized");
645: } elsif($self->{State} eq "ChallengeReceived") {
646: $self->Transition("ChallengeReplied");
647: } elsif($self->{State} eq "RequestingVersion") {
648: $self->Transition("ReadingVersionString");
649: } elsif ($self->{State} eq "SetHost") {
650: $self->Transition("HostSet");
651: } elsif($self->{State} eq "RequestingKey") {
652: $self->Transition("ReceivingKey");
653: # $self->{InformWritable} = 0;
654: # $self->{InformReadable} = 1;
655: # $self->{TransactionReply} = '';
656: } elsif ($self->{State} eq "SendingRequest") {
657: $self->Transition("ReceivingReply");
658: $self->{TimeoutRemaining} = $self->{TimeoutValue};
659: } elsif ($self->{State} eq "Disconnected") {
660: return -1;
661: }
662: return 0;
663: }
664: } else { # The write failed (e.g. partner disconnected).
665: $self->Transition("Disconnected");
666: $socket->close();
667: return -1;
668: }
669:
670: }
671: =pod
672:
673: =head2 Tick
674:
675: Tick is called every time unit by the event framework. It
676:
677: =item 1 decrements the remaining timeout.
678:
679: =item 2 If the timeout is zero, calls TimedOut indicating that the current operation timed out.
680:
681: =cut
682:
683: sub Tick {
684: my $self = shift;
685: $self->{TimeoutRemaining}--;
686: if ($self->{TimeoutRemaining} < 0) {
687: $self->TimedOut();
688: }
689: }
690:
691: =pod
692:
693: =head2 TimedOut
694:
695: called on a timeout. If the timeout callback is defined, it is called
696: with $self as its parameters.
697:
698: =cut
699:
700: sub TimedOut {
701:
702: my $self = shift;
703: if($self->{TimeoutCallback}) {
704: my $callback = $self->{TimeoutCallback};
705: my @args = ( $self);
706: &$callback(@args);
707: }
708: }
709:
710: =pod
711:
712: =head2 InitiateTransaction
713:
714: Called to initiate a transaction. A transaction can only be initiated
715: when the object is idle... otherwise an error is returned. A
716: transaction consists of a request to the server that will have a
717: reply. This member sets the request data in the TransactionRequest
718: member, makes the state SendingRequest and sets the data to allow a
719: timout, and to request writability notification.
720:
721: =cut
722:
723: sub InitiateTransaction {
724:
725: my ($self, $data) = @_;
726:
727: Debug(1, "initiating transaction: ".$data);
728: if($self->{State} ne "Idle") {
729: Debug(0," .. but not idle here\n");
730: return -1; # Error indicator.
731: }
732: # if the transaction is to be encrypted encrypt the data:
733: (my $sethost, my $server,$data)=split(/:/,$data,3);
734:
735: if($data =~ /^encrypt\:/) {
736: $data = $self->Encrypt($data);
737: }
738:
739: # Setup the trasaction
740: # currently no version of lond supports inlining the sethost
741: if ($self->PeerVersion() <= 321) {
742: if ($server ne $self->{LoncapaHim}) {
743: $self->{NextRequest} = $data;
744: $self->{TransactionRequest} = "$sethost:$server\n";
745: $self->{LoncapaHim} = $server;
746: } else {
747: $self->{TransactionRequest} = $data;
748: }
749: } else {
750: $self->{LoncapaHim} = $server;
751: $self->{TransactionRequest} = "$sethost:$server:$data";
752: }
753: $self->{TransactionReply} = "";
754: $self->{InformWritable} = 1;
755: $self->{InformReadable} = 0;
756: $self->{Timeoutable} = 1;
757: $self->{TimeoutRemaining} = $self->{TimeoutValue};
758: $self->Transition("SendingRequest");
759: }
760:
761:
762: =pod
763:
764: =head2 SetStateTransitionCallback
765:
766: Sets a callback for state transitions. Returns a reference to any
767: prior established callback, or undef if there was none:
768:
769: =cut
770:
771: sub SetStateTransitionCallback {
772: my $self = shift;
773: my $oldCallback = $self->{TransitionCallback};
774: $self->{TransitionCallback} = shift;
775: return $oldCallback;
776: }
777:
778: =pod
779:
780: =head2 SetTimeoutCallback
781:
782: Sets the timeout callback. Returns a reference to any prior
783: established callback or undef if there was none.
784:
785: =cut
786:
787: sub SetTimeoutCallback {
788:
789: my ($self, $callback) = @_;
790:
791: my $oldCallback = $self->{TimeoutCallback};
792: $self->{TimeoutCallback} = $callback;
793: return $oldCallback;
794: }
795:
796: =pod
797:
798: =head2 Shutdown:
799:
800: Shuts down the socket.
801:
802: =cut
803:
804: sub Shutdown {
805: my $self = shift;
806: my $socket = $self->GetSocket();
807: Debug(5,"socket is -$socket-");
808: if ($socket) {
809: # Ask lond to exit too. Non blocking so
810: # there is no cost for failure.
811: eval {
812: $socket->send("exit\n", 0);
813: $socket->shutdown(2);
814: }
815: }
816: }
817:
818: =pod
819:
820: =head2 GetState
821:
822: selector for the object state.
823:
824: =cut
825:
826: sub GetState {
827: my $self = shift;
828: return $self->{State};
829: }
830:
831: =pod
832:
833: =head2 GetSocket
834:
835: selector for the object socket.
836:
837: =cut
838:
839: sub GetSocket {
840: my $self = shift;
841: return $self->{Socket};
842: }
843:
844:
845: =pod
846:
847: =head2 WantReadable
848:
849: Return the state of the flag that indicates the object wants to be
850: called when readable.
851:
852: =cut
853:
854: sub WantReadable {
855: my $self = shift;
856:
857: return $self->{InformReadable};
858: }
859:
860: =pod
861:
862: =head2 WantWritable
863:
864: Return the state of the flag that indicates the object wants write
865: notification.
866:
867: =cut
868:
869: sub WantWritable {
870: my $self = shift;
871: return $self->{InformWritable};
872: }
873:
874: =pod
875:
876: =head2 WantTimeout
877:
878: return the state of the flag that indicates the object wants to be
879: informed of timeouts.
880:
881: =cut
882:
883: sub WantTimeout {
884: my $self = shift;
885: return $self->{Timeoutable};
886: }
887:
888: =pod
889:
890: =head2 GetReply
891:
892: Returns the reply from the last transaction.
893:
894: =cut
895:
896: sub GetReply {
897: my $self = shift;
898: return $self->{TransactionReply};
899: }
900:
901: =pod
902:
903: =head2 Encrypt
904:
905: Returns the encrypted version of the command string.
906:
907: The command input string is of the form:
908:
909: encrypt:command
910:
911: The output string can be directly sent to lond as it is of the form:
912:
913: enc:length:<encodedrequest>
914:
915: =cut
916:
917: sub Encrypt {
918:
919: my ($self, $request) = @_;
920:
921:
922: # Split the encrypt: off the request and figure out it's length.
923: # the cipher works in blocks of 8 bytes.
924:
925: my $cmd = $request;
926: $cmd =~ s/^encrypt\://; # strip off encrypt:
927: chomp($cmd); # strip off trailing \n
928: my $length=length($cmd); # Get the string length.
929: $cmd .= " "; # Pad with blanks so we can fill out a block.
930:
931: # encrypt the request in 8 byte chunks to create the encrypted
932: # output request.
933:
934: my $Encoded = '';
935: for(my $index = 0; $index <= $length; $index += 8) {
936: $Encoded .=
937: unpack("H16",
938: $self->{Cipher}->encrypt(substr($cmd,
939: $index, 8)));
940: }
941:
942: # Build up the answer as enc:length:$encrequest.
943:
944: $request = "enc:$length:$Encoded\n";
945: return $request;
946:
947:
948: }
949:
950: =pod
951:
952: =head2 Decrypt
953:
954: Decrypt a response from the server. The response is in the form:
955:
956: enc:<length>:<encrypted data>
957:
958: =cut
959:
960: sub Decrypt {
961:
962: my ($self, $encrypted) = @_;
963:
964: # Bust up the response into length, and encryptedstring:
965:
966: my ($enc, $length, $EncryptedString) = split(/:/,$encrypted);
967: chomp($EncryptedString);
968:
969: # Decode the data in 8 byte blocks. The string is encoded
970: # as hex digits so there are two characters per byte:
971:
972: my $decrypted = "";
973: for(my $index = 0; $index < length($EncryptedString);
974: $index += 16) {
975: $decrypted .= $self->{Cipher}->decrypt(
976: pack("H16",
977: substr($EncryptedString,
978: $index,
979: 16)));
980: }
981: # the answer may have trailing pads to fill out a block.
982: # $length tells us the actual length of the decrypted string:
983:
984: $decrypted = substr($decrypted, 0, $length);
985: Debug(9, "Decrypted $EncryptedString to $decrypted");
986:
987: return $decrypted;
988:
989: }
990: # ToIdle
991: # Called to transition to idle... done enough it's worth subbing
992: # off to ensure it's always done right!!
993: #
994: sub ToIdle {
995: my $self = shift;
996:
997: $self->Transition("Idle");
998: $self->{InformWritiable} = 0;
999: $self->{InformReadable} = 0;
1000: $self->{Timeoutable} = 0;
1001: }
1002:
1003: # ToVersionRequest
1004: # Called to transition to "RequestVersion" also done a few times
1005: # so worth subbing out.
1006: #
1007: sub ToVersionRequest {
1008: my $self = shift;
1009:
1010: $self->Transition("RequestingVersion");
1011: $self->{InformReadable} = 0;
1012: $self->{InformWritable} = 1;
1013: $self->{TransactionRequest} = "version\n";
1014:
1015: }
1016: #
1017: # CreateCipher
1018: # Given a cipher key stores the key in the object context,
1019: # creates the cipher object, (stores that in object context),
1020: # This is done a couple of places, so it's worth factoring it out.
1021: #
1022: # Parameters:
1023: # (self)
1024: # key - The Cipher key.
1025: #
1026: # Returns:
1027: # 0 - Failure to create IDEA cipher.
1028: # 1 - Success.
1029: #
1030: sub CreateCipher {
1031: my ($self, $key) = @_; # According to coding std.
1032:
1033: $self->{CipherKey} = $key; # Save the text key...
1034: my $packedkey = pack ("H32", $key);
1035: my $cipher = new IDEA $packedkey;
1036: if($cipher) {
1037: $self->{Cipher} = $cipher;
1038: Debug("Cipher created dumping socket: ");
1039: $self->Dump(9);
1040: return 1;
1041: }
1042: else {
1043: return 0;
1044: }
1045: }
1046: # ExchangeKeysViaSSL
1047: # Called to do cipher key exchange via SSL.
1048: # The socket is promoted to an SSL socket. If that's successful,
1049: # we read out cipher key through the socket and create an IDEA
1050: # cipher object.
1051: # Parameters:
1052: # (self)
1053: # Returns:
1054: # true - Success.
1055: # false - Failure.
1056: #
1057: # Assumptions:
1058: # 1. The ssl session setup has timeout logic built in so we don't
1059: # have to worry about DOS attacks at that stage.
1060: # 2. If the ssl session gets set up we are talking to a legitimate
1061: # lond so again we don't have to worry about DOS attacks.
1062: # All this allows us just to call
1063: sub ExchangeKeysViaSSL {
1064: my $self = shift;
1065: my $socket = $self->{Socket};
1066:
1067: # Get our signed certificate, the certificate authority's
1068: # certificate and our private key file. All of these
1069: # are needed to create the ssl connection.
1070:
1071: my ($SSLCACertificate,
1072: $SSLCertificate) = lonssl::CertificateFile();
1073: my $SSLKey = lonssl::KeyFile();
1074:
1075: # Promote our connection to ssl and read the key from lond.
1076:
1077: my $SSLSocket = lonssl::PromoteClientSocket($socket,
1078: $SSLCACertificate,
1079: $SSLCertificate,
1080: $SSLKey);
1081: if(defined $SSLSocket) {
1082: my $key = <$SSLSocket>;
1083: lonssl::Close($SSLSocket);
1084: if($key) {
1085: chomp($key); # \n is not part of the key.
1086: return $self->CreateCipher($key);
1087: }
1088: else {
1089: Debug(3, "Failed to read ssl key");
1090: return 0;
1091: }
1092: }
1093: else {
1094: # Failed!!
1095: Debug(3, "Failed to negotiate SSL connection!");
1096: return 0;
1097: }
1098: # should not get here
1099: return 0;
1100:
1101: }
1102:
1103:
1104:
1105: #
1106: # CompleteInsecure:
1107: # This function is called to initiate the completion of
1108: # insecure challenge response negotiation.
1109: # To do this, we copy the challenge string to the transaction
1110: # request, flip to writability and state transition to
1111: # ChallengeReceived..
1112: # All this is only possible if InsecureOk is true.
1113: # Parameters:
1114: # (self) - This object's context hash.
1115: # Return:
1116: # 0 - Ok to transition.
1117: # -1 - Not ok to transition (InsecureOk not ok).
1118: #
1119: sub CompleteInsecure {
1120: my $self = shift;
1121: if($InsecureOk) {
1122: $self->{AuthenticationMode} = "insecure";
1123: &Debug(8," Transition out of Initialized:insecure");
1124: $self->{TransactionRequest} = $self->{TransactionReply};
1125: $self->{InformWritable} = 1;
1126: $self->{InformReadable} = 0;
1127: $self->Transition("ChallengeReceived");
1128: $self->{TimeoutRemaining} = $self->{TimeoutValue};
1129: return 0;
1130:
1131:
1132: }
1133: else {
1134: &Debug(3, "Insecure key negotiation disabled!");
1135: my $socket = $self->{Socket};
1136: $socket->close;
1137: return -1;
1138: }
1139: }
1140:
1141: =pod
1142:
1143: =head2 GetHostIterator
1144:
1145: Returns a hash iterator to the host information. Each get from
1146: this iterator returns a reference to an array that contains
1147: information read from the hosts configuration file. Array elements
1148: are used as follows:
1149:
1150: [0] - LonCapa host id.
1151: [1] - LonCapa domain name.
1152: [2] - Loncapa role (e.g. library or access).
1153: [3] - DNS name server hostname.
1154: [4] - IP address (result of e.g. nslookup [3]).
1155: [5] - Maximum connection count.
1156: [6] - Idle timeout for reducing connection count.
1157: [7] - Minimum connection count.
1158:
1159: =cut
1160:
1161: sub GetHostIterator {
1162:
1163: return HashIterator->new(\%hostshash);
1164: }
1165:
1166: ###########################################################
1167: #
1168: # The following is an unashamed kludge that is here to
1169: # allow LondConnection to be used outside of the
1170: # loncapa environment (e.g. by lonManage).
1171: #
1172: # This is a textual inclusion of pieces of the
1173: # Configuration.pm module.
1174: #
1175:
1176:
1177: my $confdir='/etc/httpd/conf/';
1178:
1179: # ------------------- Subroutine read_conf: read LON-CAPA server configuration.
1180: # This subroutine reads PerlSetVar values out of specified web server
1181: # configuration files.
1182: sub read_conf
1183: {
1184: my (@conf_files)=@_;
1185: my %perlvar;
1186: foreach my $filename (@conf_files,'loncapa_apache.conf')
1187: {
1188: if($DebugLevel > 3) {
1189: print STDERR ("Going to read $confdir.$filename\n");
1190: }
1191: open(CONFIG,'<'.$confdir.$filename) or
1192: die("Can't read $confdir$filename");
1193: while (my $configline=<CONFIG>)
1194: {
1195: if ($configline =~ /^[^\#]*PerlSetVar/)
1196: {
1197: my ($unused,$varname,$varvalue)=split(/\s+/,$configline);
1198: chomp($varvalue);
1199: $perlvar{$varname}=$varvalue;
1200: }
1201: }
1202: close(CONFIG);
1203: }
1204: if($DebugLevel > 3) {
1205: print STDERR "Dumping perlvar:\n";
1206: foreach my $var (keys %perlvar) {
1207: print STDERR "$var = $perlvar{$var}\n";
1208: }
1209: }
1210: my $perlvarref=\%perlvar;
1211: return $perlvarref;
1212: }
1213:
1214: #---------------------- Subroutine read_hosts: Read a LON-CAPA hosts.tab
1215: # formatted configuration file.
1216: #
1217: my $RequiredCount = 4; # Required item count in hosts.tab.
1218: my $DefaultMaxCon = 5; # Default value for maximum connections.
1219: my $DefaultIdle = 1000; # Default connection idle time in seconds.
1220: my $DefaultMinCon = 0; # Default value for minimum connections.
1221:
1222: sub read_hosts {
1223: my $Filename = shift;
1224: my %HostsTab;
1225:
1226: open(CONFIG,'<'.$Filename) or die("Can't read $Filename");
1227: while (my $line = <CONFIG>) {
1228: if ($line !~ /^\s*\#/) {
1229: $line=~s/\s*$//;
1230: my @items = split(/:/, $line);
1231: if(scalar @items >= $RequiredCount) {
1232: if (scalar @items == $RequiredCount) { # Only required items:
1233: $items[$RequiredCount] = $DefaultMaxCon;
1234: }
1235: if(scalar @items == $RequiredCount + 1) { # up through maxcon.
1236: $items[$RequiredCount+1] = $DefaultIdle;
1237: }
1238: if(scalar @items == $RequiredCount + 2) { # up through idle.
1239: $items[$RequiredCount+2] = $DefaultMinCon;
1240: }
1241: {
1242: my @list = @items; # probably not needed but I'm unsure of
1243: # about the scope of item so...
1244: $HostsTab{$list[3]} = \@list;
1245: }
1246: }
1247: }
1248: }
1249: close(CONFIG);
1250: my $hostref = \%HostsTab;
1251: return ($hostref);
1252: }
1253: #
1254: # Get the version of our peer. Note that this is only well
1255: # defined if the state machine has hit the idle state at least
1256: # once (well actually if it has transitioned out of
1257: # ReadingVersionString The member data LondVersion is returned.
1258: #
1259: sub PeerVersion {
1260: my $self = shift;
1261: my ($version) = ($self->{LondVersion} =~ /Revision: 1\.(\d+)/);
1262: return $version;
1263: }
1264:
1265: 1;
1266:
1267: =pod
1268:
1269: =head1 Theory
1270:
1271: The lond object is a state machine. It lives through the following states:
1272:
1273: =item Connected:
1274:
1275: a TCP connection has been formed, but the passkey has not yet been
1276: negotiated.
1277:
1278: =item Initialized:
1279:
1280: "init" sent.
1281:
1282: =item ChallengeReceived:
1283:
1284: lond sent its challenge to us.
1285:
1286: =item ChallengeReplied:
1287:
1288: We replied to lond's challenge waiting for lond's ok.
1289:
1290: =item RequestingKey:
1291:
1292: We are requesting an encryption key.
1293:
1294: =item ReceivingKey:
1295:
1296: We are receiving an encryption key.
1297:
1298: =item Idle:
1299:
1300: Connection was negotiated but no requests are active.
1301:
1302: =item SendingRequest:
1303:
1304: A request is being sent to the peer.
1305:
1306: =item ReceivingReply:
1307:
1308: Waiting for an entire reply from the peer.
1309:
1310: =item Disconnected:
1311:
1312: For whatever reason, the connection was dropped.
1313:
1314: When we need to be writing data, we have a writable event. When we
1315: need to be reading data, a readable event established. Events
1316: dispatch through the class functions Readable and Writable, and the
1317: watcher contains a reference to the associated object to allow object
1318: context to be reached.
1319:
1320: =head2 Member data.
1321:
1322: =item Host
1323:
1324: Host socket is connected to.
1325:
1326: =item Port
1327:
1328: The port the remote lond is listening on.
1329:
1330: =item Socket
1331:
1332: Socket open on the connection.
1333:
1334: =item State
1335:
1336: The current state.
1337:
1338: =item AuthenticationMode
1339:
1340: How authentication is being done. This can be any of:
1341:
1342: o local - Authenticate via a key exchanged in a file.
1343: o ssl - Authenticate via a key exchaned through a temporary ssl tunnel.
1344: o insecure - Exchange keys in an insecure manner.
1345:
1346: insecure is only allowed if the configuration parameter loncAllowInsecure
1347: is nonzero.
1348:
1349: =item TransactionRequest
1350:
1351: The request being transmitted.
1352:
1353: =item TransactionReply
1354:
1355: The reply being received from the transaction.
1356:
1357: =item InformReadable
1358:
1359: True if we want to be called when socket is readable.
1360:
1361: =item InformWritable
1362:
1363: True if we want to be informed if the socket is writable.
1364:
1365: =item Timeoutable
1366:
1367: True if the current operation is allowed to timeout.
1368:
1369: =item TimeoutValue
1370:
1371: Number of seconds in the timeout.
1372:
1373: =item TimeoutRemaining
1374:
1375: Number of seconds left in the timeout.
1376:
1377: =item CipherKey
1378:
1379: The key that was negotiated with the peer.
1380:
1381: =item Cipher
1382:
1383: The cipher obtained via the key.
1384:
1385:
1386: =head2 The following are callback like members:
1387:
1388: =item Tick:
1389:
1390: Called in response to a timer tick. Used to managed timeouts etc.
1391:
1392: =item Readable:
1393:
1394: Called when the socket becomes readable.
1395:
1396: =item Writable:
1397:
1398: Called when the socket becomes writable.
1399:
1400: =item TimedOut:
1401:
1402: Called when a timed operation timed out.
1403:
1404:
1405: =head2 The following are operational member functions.
1406:
1407: =item InitiateTransaction:
1408:
1409: Called to initiate a new transaction
1410:
1411: =item SetStateTransitionCallback:
1412:
1413: Called to establish a function that is called whenever the object goes
1414: through a state transition. This is used by The client to manage the
1415: work flow for the object.
1416:
1417: =item SetTimeoutCallback:
1418:
1419: Set a function to be called when a transaction times out. The
1420: function will be called with the object as its sole parameter.
1421:
1422: =item Encrypt:
1423:
1424: Encrypts a block of text according to the cipher negotiated with the
1425: peer (assumes the text is a command).
1426:
1427: =item Decrypt:
1428:
1429: Decrypts a block of text according to the cipher negotiated with the
1430: peer (assumes the block was a reply.
1431:
1432: =item Shutdown:
1433:
1434: Shuts off the socket.
1435:
1436: =head2 The following are selector member functions:
1437:
1438: =item GetState:
1439:
1440: Returns the current state
1441:
1442: =item GetSocket:
1443:
1444: Gets the socekt open on the connection to lond.
1445:
1446: =item WantReadable:
1447:
1448: true if the current state requires a readable event.
1449:
1450: =item WantWritable:
1451:
1452: true if the current state requires a writable event.
1453:
1454: =item WantTimeout:
1455:
1456: true if the current state requires timeout support.
1457:
1458: =item GetHostIterator:
1459:
1460: Returns an iterator into the host file hash.
1461:
1462: =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