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