Annotation of loncom/LondConnection.pm, revision 1.52
1.2 albertel 1: # This module defines and implements a class that represents
2: # a connection to a lond daemon.
3: #
1.52 ! foxr 4: # $Id: LondConnection.pm,v 1.51 2011/01/20 11:16:20 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: }
345: # Append the data to the buffer. And figure out if the read is done:
346:
1.50 foxr 347: $self->{TimeoutRemaining} = $self->{TimeoutValue}; # getting data resets the timeout period.
348:
1.1 foxr 349: &Debug(9,"Received from host: ".$data);
350: $self->{TransactionReply} .= $data;
1.29 albertel 351: if($self->{TransactionReply} =~ m/\n$/) {
1.1 foxr 352: &Debug(8,"Readable End of line detected");
1.31 foxr 353:
354:
1.1 foxr 355: if ($self->{State} eq "Initialized") { # We received the challenge:
1.31 foxr 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";
1.1 foxr 433: }
1.27 foxr 434:
1.31 foxr 435:
1.28 albertel 436: } elsif ($self->{State} eq "ChallengeReplied") {
437: if($self->{TransactionReply} ne "ok\n") {
438: $self->Transition("Disconnected");
439: $socket->close();
440: return -1;
441: }
1.31 foxr 442: $self->ToVersionRequest();
1.28 albertel 443: return 0;
1.31 foxr 444:
1.28 albertel 445: } elsif ($self->{State} eq "ReadingVersionString") {
1.38 albertel 446: chomp($self->{TransactionReply});
447: $self->{LondVersion} = $self->{TransactionReply};
1.28 albertel 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;
1.24 foxr 454: } elsif ($self->{State} eq "HostSet") { # should be ok.
1.28 albertel 455: if($self->{TransactionReply} ne "ok\n") {
456: $self->Transition("Disconnected");
457: $socket->close();
458: return -1;
459: }
1.31 foxr 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: }
1.1 foxr 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/;
1.31 foxr 481: $key =$key.$buildkey.$key.$buildkey.$key.$buildkey;
482: $key = substr($key,0,32);
483: if(!$self->CreateCipher($key)) {
1.1 foxr 484: $self->Transition("Disconnected");
485: $socket->close();
486: return -1;
487: } else {
1.31 foxr 488: $self->ToIdle();
1.1 foxr 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);
1.34 foxr 498: $self->{TransactionReply} = "$answer\n";
1.1 foxr 499: }
1.39 albertel 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 {
1.1 foxr 511: # finish the transaction
512:
1.39 albertel 513: $self->ToIdle();
514: return 0;
515: }
1.1 foxr 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;
1.27 foxr 526:
1.1 foxr 527: }
528:
529:
530: =pod
1.3 albertel 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.
1.1 foxr 537:
538: Returns 0 if successful, or -1 if not.
1.3 albertel 539:
1.1 foxr 540: =cut
541: sub Writable {
542: my $self = shift; # Get reference to the object.
543: my $socket = $self->{Socket};
1.26 albertel 544: my $nwritten;
545: if ($socket) {
546: eval {
547: $nwritten = $socket->send($self->{TransactionRequest}, 0);
548: }
1.27 foxr 549: } else {
550: # For whatever reason, there's no longer a socket left.
551:
552:
553: $self->Transition("Disconnected");
554: return -1;
1.26 albertel 555: }
1.1 foxr 556: my $errno = $! + 0;
557: unless (defined $nwritten) {
558: if($errno != POSIX::EINTR) {
559: $self->Transition("Disconnected");
560: return -1;
561: }
562:
563: }
1.10 foxr 564: if (($nwritten >= 0) ||
1.1 foxr 565: ($errno == POSIX::EWOULDBLOCK) ||
566: ($errno == POSIX::EAGAIN) ||
567: ($errno == POSIX::EINTR) ||
568: ($errno == 0)) {
1.50 foxr 569: $self->{TimeoutRemaining} = $self->{TimeoutValue};
1.1 foxr 570: substr($self->{TransactionRequest}, 0, $nwritten) = ""; # rmv written part
1.50 foxr 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");
1.24 foxr 588: # $self->{InformWritable} = 0;
589: # $self->{InformReadable} = 1;
590: # $self->{TransactionReply} = '';
1.50 foxr 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:
1.1 foxr 605: }
606: =pod
1.3 albertel 607:
608: =head2 Tick
609:
1.1 foxr 610: Tick is called every time unit by the event framework. It
1.3 albertel 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.
1.1 foxr 615:
616: =cut
617:
618: sub Tick {
619: my $self = shift;
620: $self->{TimeoutRemaining}--;
621: if ($self->{TimeoutRemaining} < 0) {
622: $self->TimedOut();
623: }
624: }
1.3 albertel 625:
1.1 foxr 626: =pod
627:
1.3 albertel 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:
1.1 foxr 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: }
1.3 albertel 644:
1.1 foxr 645: =pod
1.3 albertel 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:
1.1 foxr 656: =cut
1.3 albertel 657:
1.1 foxr 658: sub InitiateTransaction {
1.30 foxr 659:
660: my ($self, $data) = @_;
1.1 foxr 661:
1.4 foxr 662: Debug(1, "initiating transaction: ".$data);
1.1 foxr 663: if($self->{State} ne "Idle") {
1.4 foxr 664: Debug(0," .. but not idle here\n");
1.1 foxr 665: return -1; # Error indicator.
666: }
667: # if the transaction is to be encrypted encrypt the data:
1.39 albertel 668: (my $sethost, my $server,$data)=split(/:/,$data,3);
1.1 foxr 669:
670: if($data =~ /^encrypt\:/) {
671: $data = $self->Encrypt($data);
672: }
673:
674: # Setup the trasaction
1.39 albertel 675: # currently no version of lond supports inlining the sethost
1.40 albertel 676: if ($self->PeerVersion() <= 321) {
1.39 albertel 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 {
1.40 albertel 685: $self->{LoncapaHim} = $server;
1.39 albertel 686: $self->{TransactionRequest} = "$sethost:$server:$data";
687: }
1.1 foxr 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
1.3 albertel 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:
1.1 foxr 704: =cut
1.3 albertel 705:
1.1 foxr 706: sub SetStateTransitionCallback {
707: my $self = shift;
708: my $oldCallback = $self->{TransitionCallback};
709: $self->{TransitionCallback} = shift;
710: return $oldCallback;
711: }
1.3 albertel 712:
1.1 foxr 713: =pod
1.3 albertel 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:
1.1 foxr 720: =cut
1.3 albertel 721:
1.1 foxr 722: sub SetTimeoutCallback {
1.30 foxr 723:
724: my ($self, $callback) = @_;
725:
1.1 foxr 726: my $oldCallback = $self->{TimeoutCallback};
727: $self->{TimeoutCallback} = $callback;
728: return $oldCallback;
729: }
730:
731: =pod
1.3 albertel 732:
1.5 foxr 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();
1.20 albertel 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: }
1.50 foxr 751: $self->{Timeoutable} = 0; # Shutdown sockets can't timeout.
1.5 foxr 752: }
753:
754: =pod
755:
1.3 albertel 756: =head2 GetState
757:
758: selector for the object state.
759:
1.1 foxr 760: =cut
1.3 albertel 761:
1.1 foxr 762: sub GetState {
763: my $self = shift;
764: return $self->{State};
765: }
1.3 albertel 766:
1.1 foxr 767: =pod
1.3 albertel 768:
769: =head2 GetSocket
770:
771: selector for the object socket.
772:
1.1 foxr 773: =cut
1.3 albertel 774:
1.1 foxr 775: sub GetSocket {
776: my $self = shift;
777: return $self->{Socket};
778: }
1.3 albertel 779:
1.5 foxr 780:
1.1 foxr 781: =pod
1.3 albertel 782:
783: =head2 WantReadable
784:
785: Return the state of the flag that indicates the object wants to be
786: called when readable.
787:
1.1 foxr 788: =cut
1.3 albertel 789:
1.1 foxr 790: sub WantReadable {
791: my $self = shift;
792:
793: return $self->{InformReadable};
794: }
1.3 albertel 795:
1.1 foxr 796: =pod
1.3 albertel 797:
798: =head2 WantWritable
799:
800: Return the state of the flag that indicates the object wants write
801: notification.
802:
1.1 foxr 803: =cut
1.3 albertel 804:
1.1 foxr 805: sub WantWritable {
806: my $self = shift;
807: return $self->{InformWritable};
808: }
1.3 albertel 809:
1.1 foxr 810: =pod
1.3 albertel 811:
812: =head2 WantTimeout
813:
814: return the state of the flag that indicates the object wants to be
815: informed of timeouts.
816:
1.1 foxr 817: =cut
1.3 albertel 818:
1.1 foxr 819: sub WantTimeout {
820: my $self = shift;
821: return $self->{Timeoutable};
822: }
823:
824: =pod
1.3 albertel 825:
826: =head2 GetReply
827:
828: Returns the reply from the last transaction.
829:
1.1 foxr 830: =cut
1.3 albertel 831:
1.1 foxr 832: sub GetReply {
833: my $self = shift;
834: return $self->{TransactionReply};
835: }
836:
837: =pod
1.3 albertel 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:
1.1 foxr 845: encrypt:command
1.3 albertel 846:
847: The output string can be directly sent to lond as it is of the form:
848:
1.1 foxr 849: enc:length:<encodedrequest>
1.3 albertel 850:
1.1 foxr 851: =cut
1.3 albertel 852:
1.1 foxr 853: sub Encrypt {
1.30 foxr 854:
855: my ($self, $request) = @_;
1.1 foxr 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: }
1.3 albertel 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:
1.1 foxr 894: =cut
1.3 albertel 895:
1.1 foxr 896: sub Decrypt {
1.30 foxr 897:
898: my ($self, $encrypted) = @_;
1.1 foxr 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:
1.10 foxr 908: my $decrypted = "";
1.1 foxr 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);
1.34 foxr 921: Debug(9, "Decrypted $EncryptedString to $decrypted");
1.1 foxr 922:
923: return $decrypted;
924:
925: }
1.31 foxr 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: ");
1.32 foxr 975: $self->Dump(9);
1.31 foxr 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: }
1.1 foxr 1076:
1.14 foxr 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:
1.43 raeburn 1088: my @confdirs=('/etc/httpd/conf/','/etc/apache2/');
1.14 foxr 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)=@_;
1.43 raeburn 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);
1.14 foxr 1117: chomp($varvalue);
1118: $perlvar{$varname}=$varvalue;
1.43 raeburn 1119: }
1120: }
1.14 foxr 1121: close(CONFIG);
1.43 raeburn 1122: }
1.21 foxr 1123: if($DebugLevel > 3) {
1.31 foxr 1124: print STDERR "Dumping perlvar:\n";
1.21 foxr 1125: foreach my $var (keys %perlvar) {
1.31 foxr 1126: print STDERR "$var = $perlvar{$var}\n";
1.21 foxr 1127: }
1128: }
1.14 foxr 1129: my $perlvarref=\%perlvar;
1.21 foxr 1130: return $perlvarref;
1131: }
1.14 foxr 1132:
1.24 foxr 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;
1.40 albertel 1141: my ($version) = ($self->{LondVersion} =~ /Revision: 1\.(\d+)/);
1142: return $version;
1.24 foxr 1143: }
1.1 foxr 1144:
1.52 ! foxr 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:
1.1 foxr 1160: 1;
1161:
1162: =pod
1.3 albertel 1163:
1.1 foxr 1164: =head1 Theory
1165:
1.3 albertel 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.
1.1 foxr 1214:
1215: =head2 Member data.
1216:
1.3 albertel 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:
1.31 foxr 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:
1.3 albertel 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.
1.1 foxr 1279:
1280:
1281: =head2 The following are callback like members:
1.3 albertel 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:
1.1 foxr 1299:
1300: =head2 The following are operational member functions.
1.3 albertel 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.
1.5 foxr 1326:
1327: =item Shutdown:
1328:
1329: Shuts off the socket.
1.1 foxr 1330:
1331: =head2 The following are selector member functions:
1332:
1.3 albertel 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:
1.1 foxr 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