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