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