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