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