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