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