Annotation of loncom/LondConnection.pm, revision 1.50
1.2 albertel 1: # This module defines and implements a class that represents
2: # a connection to a lond daemon.
3: #
1.50 ! foxr 4: # $Id: LondConnection.pm,v 1.49 2010/11/11 15:01:13 raeburn 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",
192: Cipher => undef};
1.1 foxr 193: bless($self, $class);
194: unless ($self->{Socket} = IO::Socket::INET->new(PeerHost => $self->{Host},
1.27 foxr 195: PeerPort => $self->{Port},
196: Type => SOCK_STREAM,
197: Proto => "tcp",
198: Timeout => 3)) {
1.36 albertel 199: Debug(8, "Error? \n$@ \n$!");
1.1 foxr 200: return undef; # Inidicates the socket could not be made.
201: }
1.31 foxr 202: my $socket = $self->{Socket}; # For local use only.
1.33 foxr 203: # If we are local, we'll first try local auth mode, otherwise, we'll try
204: # the ssl auth mode:
1.31 foxr 205:
206: my $key;
207: my $keyfile;
1.36 albertel 208: if ($DnsName eq '127.0.0.1') {
1.31 foxr 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:
1.42 albertel 233: } else {
1.33 foxr 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";
1.47 raeburn 244: $self->{TransactionRequest} = "init:ssl:$perlvar{'lonVersion'}\n";
1.33 foxr 245: } else {
246: if($InsecureOk) { # Allowed to do insecure:
247: $self->{AuthenticationMode} = "insecure";
1.47 raeburn 248: $self->{TransactionRequest} = "init::$perlvar{'lonVersion'}\n";
1.33 foxr 249: }
250: else { # Not allowed to do insecure...
251: $socket->close;
252: return undef;
253: }
254: }
1.31 foxr 255: }
256:
1.1 foxr 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
1.9 foxr 262: $self->{Timeoutable} = 1; # Timeout allowed during startup negotiation.
1.31 foxr 263:
1.1 foxr 264:
265: #
266: # Set socket to nonblocking I/O.
267: #
1.31 foxr 268: my $flags = fcntl($socket, F_GETFL,0);
269: if(!$flags) {
1.1 foxr 270: $socket->close;
271: return undef;
272: }
1.31 foxr 273: if(!fcntl($socket, F_SETFL, $flags | O_NONBLOCK)) {
1.1 foxr 274: $socket->close;
275: return undef;
276: }
277:
278: # return the object :
279:
1.31 foxr 280: Debug(9, "Initial object state: ");
1.32 foxr 281: $self->Dump(9);
1.31 foxr 282:
1.1 foxr 283: return $self;
284: }
1.3 albertel 285:
1.1 foxr 286: =pod
1.3 albertel 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.
1.1 foxr 309:
310: =cut
1.3 albertel 311:
1.1 foxr 312: sub Readable {
313: my $self = shift;
314: my $socket = $self->{Socket};
315: my $data = '';
1.27 foxr 316: my $rv;
1.31 foxr 317: my $ConnectionMode = $self->{AuthenticationMode};
318:
1.27 foxr 319: if ($socket) {
320: eval {
321: $rv = $socket->recv($data, POSIX::BUFSIZ, 0);
322: }
323: } else {
324: $self->Transition("Disconnected");
325: return -1;
326: }
1.1 foxr 327: my $errno = $! + 0; # Force numeric context.
328:
1.8 foxr 329: unless (defined($rv) && length $data) {# Read failed,
1.1 foxr 330: if(($errno == POSIX::EWOULDBLOCK) ||
331: ($errno == POSIX::EAGAIN) ||
1.8 foxr 332: ($errno == POSIX::EINTR)) {
1.1 foxr 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:
1.50 ! foxr 345: $self->{TimeoutRemaining} = $self->{TimeoutValue}; # getting data resets the timeout period.
! 346:
1.1 foxr 347: &Debug(9,"Received from host: ".$data);
348: $self->{TransactionReply} .= $data;
1.29 albertel 349: if($self->{TransactionReply} =~ m/\n$/) {
1.1 foxr 350: &Debug(8,"Readable End of line detected");
1.31 foxr 351:
352:
1.1 foxr 353: if ($self->{State} eq "Initialized") { # We received the challenge:
1.31 foxr 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";
1.1 foxr 431: }
1.27 foxr 432:
1.31 foxr 433:
1.28 albertel 434: } elsif ($self->{State} eq "ChallengeReplied") {
435: if($self->{TransactionReply} ne "ok\n") {
436: $self->Transition("Disconnected");
437: $socket->close();
438: return -1;
439: }
1.31 foxr 440: $self->ToVersionRequest();
1.28 albertel 441: return 0;
1.31 foxr 442:
1.28 albertel 443: } elsif ($self->{State} eq "ReadingVersionString") {
1.38 albertel 444: chomp($self->{TransactionReply});
445: $self->{LondVersion} = $self->{TransactionReply};
1.28 albertel 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;
1.24 foxr 452: } elsif ($self->{State} eq "HostSet") { # should be ok.
1.28 albertel 453: if($self->{TransactionReply} ne "ok\n") {
454: $self->Transition("Disconnected");
455: $socket->close();
456: return -1;
457: }
1.31 foxr 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: }
1.1 foxr 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/;
1.31 foxr 479: $key =$key.$buildkey.$key.$buildkey.$key.$buildkey;
480: $key = substr($key,0,32);
481: if(!$self->CreateCipher($key)) {
1.1 foxr 482: $self->Transition("Disconnected");
483: $socket->close();
484: return -1;
485: } else {
1.31 foxr 486: $self->ToIdle();
1.1 foxr 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);
1.34 foxr 496: $self->{TransactionReply} = "$answer\n";
1.1 foxr 497: }
1.39 albertel 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 {
1.1 foxr 509: # finish the transaction
510:
1.39 albertel 511: $self->ToIdle();
512: return 0;
513: }
1.1 foxr 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;
1.27 foxr 524:
1.1 foxr 525: }
526:
527:
528: =pod
1.3 albertel 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.
1.1 foxr 535:
536: Returns 0 if successful, or -1 if not.
1.3 albertel 537:
1.1 foxr 538: =cut
539: sub Writable {
540: my $self = shift; # Get reference to the object.
541: my $socket = $self->{Socket};
1.26 albertel 542: my $nwritten;
543: if ($socket) {
544: eval {
545: $nwritten = $socket->send($self->{TransactionRequest}, 0);
546: }
1.27 foxr 547: } else {
548: # For whatever reason, there's no longer a socket left.
549:
550:
551: $self->Transition("Disconnected");
552: return -1;
1.26 albertel 553: }
1.1 foxr 554: my $errno = $! + 0;
555: unless (defined $nwritten) {
556: if($errno != POSIX::EINTR) {
557: $self->Transition("Disconnected");
558: return -1;
559: }
560:
561: }
1.10 foxr 562: if (($nwritten >= 0) ||
1.1 foxr 563: ($errno == POSIX::EWOULDBLOCK) ||
564: ($errno == POSIX::EAGAIN) ||
565: ($errno == POSIX::EINTR) ||
566: ($errno == 0)) {
1.50 ! foxr 567: $self->{TimeoutRemaining} = $self->{TimeoutValue};
1.1 foxr 568: substr($self->{TransactionRequest}, 0, $nwritten) = ""; # rmv written part
1.50 ! foxr 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");
1.24 foxr 586: # $self->{InformWritable} = 0;
587: # $self->{InformReadable} = 1;
588: # $self->{TransactionReply} = '';
1.50 ! foxr 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:
1.1 foxr 603: }
604: =pod
1.3 albertel 605:
606: =head2 Tick
607:
1.1 foxr 608: Tick is called every time unit by the event framework. It
1.3 albertel 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.
1.1 foxr 613:
614: =cut
615:
616: sub Tick {
617: my $self = shift;
618: $self->{TimeoutRemaining}--;
619: if ($self->{TimeoutRemaining} < 0) {
620: $self->TimedOut();
621: }
622: }
1.3 albertel 623:
1.1 foxr 624: =pod
625:
1.3 albertel 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:
1.1 foxr 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: }
1.3 albertel 642:
1.1 foxr 643: =pod
1.3 albertel 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:
1.1 foxr 654: =cut
1.3 albertel 655:
1.1 foxr 656: sub InitiateTransaction {
1.30 foxr 657:
658: my ($self, $data) = @_;
1.1 foxr 659:
1.4 foxr 660: Debug(1, "initiating transaction: ".$data);
1.1 foxr 661: if($self->{State} ne "Idle") {
1.4 foxr 662: Debug(0," .. but not idle here\n");
1.1 foxr 663: return -1; # Error indicator.
664: }
665: # if the transaction is to be encrypted encrypt the data:
1.39 albertel 666: (my $sethost, my $server,$data)=split(/:/,$data,3);
1.1 foxr 667:
668: if($data =~ /^encrypt\:/) {
669: $data = $self->Encrypt($data);
670: }
671:
672: # Setup the trasaction
1.39 albertel 673: # currently no version of lond supports inlining the sethost
1.40 albertel 674: if ($self->PeerVersion() <= 321) {
1.39 albertel 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 {
1.40 albertel 683: $self->{LoncapaHim} = $server;
1.39 albertel 684: $self->{TransactionRequest} = "$sethost:$server:$data";
685: }
1.1 foxr 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
1.3 albertel 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:
1.1 foxr 702: =cut
1.3 albertel 703:
1.1 foxr 704: sub SetStateTransitionCallback {
705: my $self = shift;
706: my $oldCallback = $self->{TransitionCallback};
707: $self->{TransitionCallback} = shift;
708: return $oldCallback;
709: }
1.3 albertel 710:
1.1 foxr 711: =pod
1.3 albertel 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:
1.1 foxr 718: =cut
1.3 albertel 719:
1.1 foxr 720: sub SetTimeoutCallback {
1.30 foxr 721:
722: my ($self, $callback) = @_;
723:
1.1 foxr 724: my $oldCallback = $self->{TimeoutCallback};
725: $self->{TimeoutCallback} = $callback;
726: return $oldCallback;
727: }
728:
729: =pod
1.3 albertel 730:
1.5 foxr 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();
1.20 albertel 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: }
1.50 ! foxr 749: $self->{Timeoutable} = 0; # Shutdown sockets can't timeout.
1.5 foxr 750: }
751:
752: =pod
753:
1.3 albertel 754: =head2 GetState
755:
756: selector for the object state.
757:
1.1 foxr 758: =cut
1.3 albertel 759:
1.1 foxr 760: sub GetState {
761: my $self = shift;
762: return $self->{State};
763: }
1.3 albertel 764:
1.1 foxr 765: =pod
1.3 albertel 766:
767: =head2 GetSocket
768:
769: selector for the object socket.
770:
1.1 foxr 771: =cut
1.3 albertel 772:
1.1 foxr 773: sub GetSocket {
774: my $self = shift;
775: return $self->{Socket};
776: }
1.3 albertel 777:
1.5 foxr 778:
1.1 foxr 779: =pod
1.3 albertel 780:
781: =head2 WantReadable
782:
783: Return the state of the flag that indicates the object wants to be
784: called when readable.
785:
1.1 foxr 786: =cut
1.3 albertel 787:
1.1 foxr 788: sub WantReadable {
789: my $self = shift;
790:
791: return $self->{InformReadable};
792: }
1.3 albertel 793:
1.1 foxr 794: =pod
1.3 albertel 795:
796: =head2 WantWritable
797:
798: Return the state of the flag that indicates the object wants write
799: notification.
800:
1.1 foxr 801: =cut
1.3 albertel 802:
1.1 foxr 803: sub WantWritable {
804: my $self = shift;
805: return $self->{InformWritable};
806: }
1.3 albertel 807:
1.1 foxr 808: =pod
1.3 albertel 809:
810: =head2 WantTimeout
811:
812: return the state of the flag that indicates the object wants to be
813: informed of timeouts.
814:
1.1 foxr 815: =cut
1.3 albertel 816:
1.1 foxr 817: sub WantTimeout {
818: my $self = shift;
819: return $self->{Timeoutable};
820: }
821:
822: =pod
1.3 albertel 823:
824: =head2 GetReply
825:
826: Returns the reply from the last transaction.
827:
1.1 foxr 828: =cut
1.3 albertel 829:
1.1 foxr 830: sub GetReply {
831: my $self = shift;
832: return $self->{TransactionReply};
833: }
834:
835: =pod
1.3 albertel 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:
1.1 foxr 843: encrypt:command
1.3 albertel 844:
845: The output string can be directly sent to lond as it is of the form:
846:
1.1 foxr 847: enc:length:<encodedrequest>
1.3 albertel 848:
1.1 foxr 849: =cut
1.3 albertel 850:
1.1 foxr 851: sub Encrypt {
1.30 foxr 852:
853: my ($self, $request) = @_;
1.1 foxr 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: }
1.3 albertel 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:
1.1 foxr 892: =cut
1.3 albertel 893:
1.1 foxr 894: sub Decrypt {
1.30 foxr 895:
896: my ($self, $encrypted) = @_;
1.1 foxr 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:
1.10 foxr 906: my $decrypted = "";
1.1 foxr 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);
1.34 foxr 919: Debug(9, "Decrypted $EncryptedString to $decrypted");
1.1 foxr 920:
921: return $decrypted;
922:
923: }
1.31 foxr 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: ");
1.32 foxr 973: $self->Dump(9);
1.31 foxr 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: }
1.1 foxr 1074:
1.14 foxr 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:
1.43 raeburn 1086: my @confdirs=('/etc/httpd/conf/','/etc/apache2/');
1.14 foxr 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)=@_;
1.43 raeburn 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);
1.14 foxr 1115: chomp($varvalue);
1116: $perlvar{$varname}=$varvalue;
1.43 raeburn 1117: }
1118: }
1.14 foxr 1119: close(CONFIG);
1.43 raeburn 1120: }
1.21 foxr 1121: if($DebugLevel > 3) {
1.31 foxr 1122: print STDERR "Dumping perlvar:\n";
1.21 foxr 1123: foreach my $var (keys %perlvar) {
1.31 foxr 1124: print STDERR "$var = $perlvar{$var}\n";
1.21 foxr 1125: }
1126: }
1.14 foxr 1127: my $perlvarref=\%perlvar;
1.21 foxr 1128: return $perlvarref;
1129: }
1.14 foxr 1130:
1.24 foxr 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;
1.40 albertel 1139: my ($version) = ($self->{LondVersion} =~ /Revision: 1\.(\d+)/);
1140: return $version;
1.24 foxr 1141: }
1.1 foxr 1142:
1143: 1;
1144:
1145: =pod
1.3 albertel 1146:
1.1 foxr 1147: =head1 Theory
1148:
1.3 albertel 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.
1.1 foxr 1197:
1198: =head2 Member data.
1199:
1.3 albertel 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:
1.31 foxr 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:
1.3 albertel 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.
1.1 foxr 1262:
1263:
1264: =head2 The following are callback like members:
1.3 albertel 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:
1.1 foxr 1282:
1283: =head2 The following are operational member functions.
1.3 albertel 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.
1.5 foxr 1309:
1310: =item Shutdown:
1311:
1312: Shuts off the socket.
1.1 foxr 1313:
1314: =head2 The following are selector member functions:
1315:
1.3 albertel 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:
1.1 foxr 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