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