Annotation of loncom/LondConnection.pm, revision 1.30

1.2       albertel    1: #   This module defines and implements a class that represents
                      2: #   a connection to a lond daemon.
                      3: #
1.30    ! foxr        4: # $Id: LondConnection.pm,v 1.29 2004/03/02 22:38:07 albertel 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.14      foxr       39: 
1.1       foxr       40: 
1.12      foxr       41: 
                     42: 
                     43: 
1.6       foxr       44: my $DebugLevel=0;
1.12      foxr       45: my %hostshash;
                     46: my %perlvar;
1.1       foxr       47: 
1.14      foxr       48: #
1.16      foxr       49: #  Set debugging level
                     50: #
                     51: sub SetDebug {
                     52:     $DebugLevel = shift;
                     53: }
                     54: 
                     55: #
1.14      foxr       56: #   The config read is done in this way to support the read of
                     57: #   the non-default configuration file in the
                     58: #   event we are being used outside of loncapa.
                     59: #
                     60: 
                     61: my $ConfigRead = 0;
                     62: 
1.1       foxr       63: #   Read the configuration file for apache to get the perl
                     64: #   variable set.
                     65: 
1.12      foxr       66: sub ReadConfig {
1.14      foxr       67:     my $perlvarref = read_conf('loncapa.conf');
1.12      foxr       68:     %perlvar    = %{$perlvarref};
1.14      foxr       69:     my $hoststab   = read_hosts(
1.21      foxr       70: 				"$perlvar{lonTabDir}/hosts.tab") || 
1.14      foxr       71: 				die "Can't read host table!!";
1.12      foxr       72:     %hostshash  = %{$hoststab};
1.17      foxr       73:     $ConfigRead = 1;
1.12      foxr       74:     
                     75: }
                     76: 
1.15      foxr       77: #
                     78: #  Read a foreign configuration.
                     79: #  This sub is intended for the cases where the package
                     80: #  will be read from outside the LonCAPA environment, in that case
                     81: #  the client will need to explicitly provide:
                     82: #   - A file in hosts.tab format.
                     83: #   - Some idea of the 'lonCAPA' name of the local host (for building
                     84: #     the encryption key).
                     85: #
                     86: #  Parameters:
                     87: #      MyHost   - Name of this host as far as LonCAPA is concerned.
                     88: #      Filename - Name of a hosts.tab formatted file that will be used
                     89: #                 to build up the hosts table.
                     90: #
                     91: sub ReadForeignConfig {
1.30    ! foxr       92: 
        !            93:     my ($MyHost, $Filename) = @_;
1.15      foxr       94: 
1.17      foxr       95:     &Debug(4, "ReadForeignConfig $MyHost $Filename\n");
                     96: 
1.15      foxr       97:     $perlvar{lonHostID} = $MyHost; # Rmember my host.
                     98:     my $hosttab = read_hosts($Filename) ||
                     99: 	die "Can't read hosts table!!";
1.17      foxr      100:     %hostshash = %{$hosttab};
                    101:     if($DebugLevel > 3) {
                    102: 	foreach my $host (keys %hostshash) {
                    103: 	    print "host $host => $hostshash{$host}\n";
                    104: 	}
                    105:     }
                    106:     $ConfigRead = 1;
1.1       foxr      107: 
1.15      foxr      108: }
1.1       foxr      109: 
                    110: sub Debug {
1.30    ! foxr      111: 
        !           112:     my ($level, $message) = @_;
        !           113: 
1.1       foxr      114:     if ($level < $DebugLevel) {
                    115: 	print($message."\n");
                    116:     }
                    117: }
1.3       albertel  118: 
                    119: =pod
                    120: 
                    121: =head2 Dump
                    122: 
1.12      foxr      123: Dump the internal state of the object: For debugging purposes, to stderr.
1.3       albertel  124: 
1.1       foxr      125: =cut
                    126: 
                    127: sub Dump {
                    128:     my $self   = shift;
1.10      foxr      129:     my $key;
                    130:     my $value;
1.22      foxr      131:     print STDERR "Dumping LondConnectionObject:\n";
1.1       foxr      132:     while(($key, $value) = each %$self) {
1.22      foxr      133: 	print STDERR "$key -> $value\n";
1.1       foxr      134:     }
1.23      foxr      135:     print STDERR "-------------------------------\n";
1.1       foxr      136: }
                    137: 
                    138: =pod
1.3       albertel  139: 
                    140: Local function to do a state transition.  If the state transition
                    141: callback is defined it is called with two parameters: the self and the
                    142: old state.
                    143: 
1.1       foxr      144: =cut
1.3       albertel  145: 
1.1       foxr      146: sub Transition {
1.30    ! foxr      147: 
        !           148:     my ($self, $newstate) = @_;
        !           149: 
1.1       foxr      150:     my $oldstate = $self->{State};
                    151:     $self->{State} = $newstate;
                    152:     $self->{TimeoutRemaining} = $self->{TimeoutValue};
                    153:     if($self->{TransitionCallback}) {
                    154: 	($self->{TransitionCallback})->($self, $oldstate); 
                    155:     }
                    156: }
                    157: 
1.3       albertel  158: 
1.14      foxr      159: 
1.1       foxr      160: =pod
1.3       albertel  161: 
                    162: =head2 new
                    163: 
                    164: Construct a new lond connection.
                    165: 
                    166: Parameters (besides the class name) include:
                    167: 
                    168: =item hostname
                    169: 
                    170: host the remote lond is on. This host is a host in the hosts.tab file
                    171: 
                    172: =item port
                    173: 
                    174:  port number the remote lond is listening on.
                    175: 
1.1       foxr      176: =cut
1.3       albertel  177: 
1.1       foxr      178: sub new {
1.30    ! foxr      179: 
        !           180:     my ($class, $Hostname, $Port) = @_;
1.14      foxr      181: 
                    182:     if (!$ConfigRead) {
                    183: 	ReadConfig();
                    184: 	$ConfigRead = 1;
                    185:     }
1.1       foxr      186:     &Debug(4,$class."::new( ".$Hostname.",".$Port.")\n");
                    187: 
                    188:     # The host must map to an entry in the hosts table:
                    189:     #  We connect to the dns host that corresponds to that
                    190:     #  system and use the hostname for the encryption key 
                    191:     #  negotion.  In the objec these become the Host and
                    192:     #  LoncapaHim fields of the object respectively.
                    193:     #
                    194:     if (!exists $hostshash{$Hostname}) {
1.16      foxr      195: 	&Debug(8, "No Such host $Hostname");
1.1       foxr      196: 	return undef;		# No such host!!!
                    197:     }
                    198:     my @ConfigLine = @{$hostshash{$Hostname}};
                    199:     my $DnsName    = $ConfigLine[3]; # 4'th item is dns of host.
                    200:     Debug(5, "Connecting to ".$DnsName);
                    201:     # Now create the object...
                    202:     my $self     = { Host               => $DnsName,
1.24      foxr      203:                      LoncapaHim         => $Hostname,
                    204:                      Port               => $Port,
                    205:                      State              => "Initialized",
                    206:                      TransactionRequest => "",
                    207:                      TransactionReply   => "",
                    208:                      InformReadable     => 0,
                    209:                      InformWritable     => 0,
                    210:                      TimeoutCallback    => undef,
                    211:                      TransitionCallback => undef,
                    212:                      Timeoutable        => 0,
                    213:                      TimeoutValue       => 30,
                    214:                      TimeoutRemaining   => 0,
                    215:                      CipherKey          => "",
                    216:                      LondVersion        => "Unknown",
                    217:                      Cipher             => undef};
1.1       foxr      218:     bless($self, $class);
                    219:     unless ($self->{Socket} = IO::Socket::INET->new(PeerHost => $self->{Host},
1.27      foxr      220: 					       PeerPort => $self->{Port},
                    221: 					       Type     => SOCK_STREAM,
                    222: 					       Proto    => "tcp",
                    223: 					       Timeout  => 3)) {
1.1       foxr      224: 	return undef;		# Inidicates the socket could not be made.
                    225:     }
                    226:     #
                    227:     # We're connected.  Set the state, and the events we'll accept:
                    228:     #
                    229:     $self->Transition("Connected");
                    230:     $self->{InformWritable}     = 1;    # When  socket is writable we send init
1.9       foxr      231:     $self->{Timeoutable}        = 1;    # Timeout allowed during startup negotiation. 
1.1       foxr      232:     $self->{TransactionRequest} = "init\n";
                    233:     
                    234:     #
                    235:     # Set socket to nonblocking I/O.
                    236:     #
                    237:     my $socket = $self->{Socket};
1.10      foxr      238:     my $flags    = fcntl($socket->fileno, F_GETFL,0);
1.1       foxr      239:     if($flags == -1) {
                    240: 	$socket->close;
                    241: 	return undef;
                    242:     }
                    243:     if(fcntl($socket, F_SETFL, $flags | O_NONBLOCK) == -1) {
                    244: 	$socket->close;
                    245: 	return undef;
                    246:     }
                    247: 
                    248:     # return the object :
                    249: 
                    250:     return $self;
                    251: }
1.3       albertel  252: 
1.1       foxr      253: =pod
1.3       albertel  254: 
                    255: =head2 Readable
                    256: 
                    257: This member should be called when the Socket becomes readable.  Until
                    258: the read completes, action is state independet. Data are accepted into
                    259: the TransactionReply until a newline character is received.  At that
                    260: time actionis state dependent:
                    261: 
                    262: =item Connected
                    263: 
                    264: in this case we received challenge, the state changes to
                    265: ChallengeReceived, and we initiate a send with the challenge response.
                    266: 
                    267: =item ReceivingReply
                    268: 
                    269: In this case a reply has been received for a transaction, the state
                    270: goes to Idle and we disable write and read notification.
                    271: 
                    272: =item ChallengeReeived
                    273: 
                    274: we just got what should be an ok\n and the connection can now handle
                    275: transactions.
1.1       foxr      276: 
                    277: =cut
1.3       albertel  278: 
1.1       foxr      279: sub Readable {
                    280:     my $self    = shift;
                    281:     my $socket  = $self->{Socket};
                    282:     my $data    = '';
1.27      foxr      283:     my $rv;
                    284:     if ($socket) {
                    285: 	eval {
                    286: 	    $rv = $socket->recv($data, POSIX::BUFSIZ, 0);
                    287: 	}
                    288:     } else {
                    289: 	$self->Transition("Disconnected");
                    290: 	return -1;
                    291:     }
1.1       foxr      292:     my $errno   = $! + 0;	             # Force numeric context.
                    293: 
1.8       foxr      294:     unless (defined($rv) && length $data) {# Read failed,
1.1       foxr      295: 	if(($errno == POSIX::EWOULDBLOCK)   ||
                    296: 	   ($errno == POSIX::EAGAIN)        ||
1.8       foxr      297: 	   ($errno == POSIX::EINTR)) {
1.1       foxr      298: 	    return 0;
                    299: 	}
                    300: 
                    301: 	# Connection likely lost.
                    302: 	&Debug(4, "Connection lost");
                    303: 	$self->{TransactionRequest} = '';
                    304: 	$socket->close();
                    305: 	$self->Transition("Disconnected");
                    306: 	return -1;
                    307:     }
                    308:     #  Append the data to the buffer.  And figure out if the read is done:
                    309: 
                    310:     &Debug(9,"Received from host: ".$data);
                    311:     $self->{TransactionReply} .= $data;
1.29      albertel  312:     if($self->{TransactionReply} =~ m/\n$/) {
1.1       foxr      313: 	&Debug(8,"Readable End of line detected");
                    314: 	if ($self->{State}  eq "Initialized") { # We received the challenge:
1.10      foxr      315: 	    if($self->{TransactionReply} eq "refused\n") {	# Remote doesn't have
1.1       foxr      316: 		
                    317: 		$self->Transition("Disconnected"); # in host tables.
                    318: 		$socket->close();
                    319: 		return -1;
                    320: 	    }
1.27      foxr      321: 
1.1       foxr      322: 	    &Debug(8," Transition out of Initialized");
                    323: 	    $self->{TransactionRequest} = $self->{TransactionReply};
                    324: 	    $self->{InformWritable}     = 1;
                    325: 	    $self->{InformReadable}     = 0;
                    326: 	    $self->Transition("ChallengeReceived");
                    327: 	    $self->{TimeoutRemaining}   = $self->{TimeoutValue};
                    328: 	    return 0;
1.28      albertel  329: 	}  elsif ($self->{State} eq "ChallengeReplied") {
                    330: 	    if($self->{TransactionReply} ne "ok\n") {
                    331: 		$self->Transition("Disconnected");
                    332: 		$socket->close();
                    333: 		return -1;
                    334: 	    }
                    335: 	    $self->Transition("RequestingVersion");
                    336: 	    $self->{InformReadable}   = 0;
                    337: 	    $self->{InformWritable}   = 1;
                    338: 	    $self->{TransactionRequest} = "version\n";
                    339: 	    return 0;
                    340: 	} elsif ($self->{State} eq "ReadingVersionString") {
                    341: 	    $self->{LondVersion}       = chomp($self->{TransactionReply});
                    342: 	    $self->Transition("SetHost");
                    343: 	    $self->{InformReadable}    = 0;
                    344: 	    $self->{InformWritable}    = 1;
                    345: 	    my $peer = $self->{LoncapaHim};
                    346: 	    $self->{TransactionRequest}= "sethost:$peer\n";
                    347: 	    return 0;
1.24      foxr      348: 	} elsif ($self->{State} eq "HostSet") { # should be ok.
1.28      albertel  349: 	    if($self->{TransactionReply} ne "ok\n") {
                    350: 		$self->Transition("Disconnected");
                    351: 		$socket->close();
                    352: 		return -1;
                    353: 	    }
                    354: 	    $self->Transition("RequestingKey");
                    355: 	    $self->{InformReadable}  = 0;
                    356: 	    $self->{InformWritable}  = 1;
                    357: 	    $self->{TransactionRequest} = "ekey\n";
                    358: 	    return 0;
1.1       foxr      359: 	} elsif ($self->{State}  eq "ReceivingKey") {
                    360: 	    my $buildkey = $self->{TransactionReply};
                    361: 	    my $key = $self->{LoncapaHim}.$perlvar{'lonHostID'};
                    362: 	    $key=~tr/a-z/A-Z/;
                    363: 	    $key=~tr/G-P/0-9/;
                    364: 	    $key=~tr/Q-Z/0-9/;
                    365: 	    $key=$key.$buildkey.$key.$buildkey.$key.$buildkey;
                    366: 	    $key=substr($key,0,32);
                    367: 	    my $cipherkey=pack("H32",$key);
                    368: 	    $self->{Cipher} = new IDEA $cipherkey;
1.13      foxr      369: 	    if($self->{Cipher} eq undef) {
1.1       foxr      370: 		$self->Transition("Disconnected");
                    371: 		$socket->close();
                    372: 		return -1;
                    373: 	    } else {
                    374: 		$self->Transition("Idle");
                    375: 		$self->{InformWritable}  =  0;
                    376: 		$self->{InformReadable}  =  0;
                    377: 		$self->{Timeoutable}     = 0;
                    378: 		return 0;
                    379: 	    }
                    380: 	} elsif ($self->{State}  eq "ReceivingReply") {
                    381: 
                    382: 	    # If the data are encrypted, decrypt first.
                    383: 
                    384: 	    my $answer = $self->{TransactionReply};
                    385: 	    if($answer =~ /^enc\:/) {
                    386: 		$answer = $self->Decrypt($answer);
                    387: 		$self->{TransactionReply} = $answer;
                    388: 	    }
                    389: 
                    390: 	    # finish the transaction
                    391: 
                    392: 	    $self->{InformWritable}     = 0;
                    393: 	    $self->{InformReadable}     = 0;
                    394: 	    $self->{Timeoutable}        = 0;
                    395: 	    $self->Transition("Idle");
                    396: 	    return 0;
                    397: 	} elsif ($self->{State} eq "Disconnected") { # No connection.
                    398: 	    return -1;
                    399: 	} else {			# Internal error: Invalid state.
                    400: 	    $self->Transition("Disconnected");
                    401: 	    $socket->close();
                    402: 	    return -1;
                    403: 	}
                    404:     }
                    405: 
                    406:     return 0;
1.27      foxr      407:     
1.1       foxr      408: }
                    409: 
                    410: 
                    411: =pod
1.3       albertel  412: 
                    413: This member should be called when the Socket becomes writable.
                    414: 
                    415: The action is state independent. An attempt is made to drain the
                    416: contents of the TransactionRequest member.  Once this is drained, we
                    417: mark the object as waiting for readability.
1.1       foxr      418: 
                    419: Returns  0 if successful, or -1 if not.
1.3       albertel  420: 
1.1       foxr      421: =cut
                    422: sub Writable {
                    423:     my $self     = shift;		# Get reference to the object.
                    424:     my $socket   = $self->{Socket};
1.26      albertel  425:     my $nwritten;
                    426:     if ($socket) {
                    427: 	eval {
                    428: 	    $nwritten = $socket->send($self->{TransactionRequest}, 0);
                    429: 	}
1.27      foxr      430:     } else {
                    431: 	# For whatever reason, there's no longer a socket left.
                    432: 
                    433: 
                    434: 	$self->Transition("Disconnected");
                    435: 	return -1;
1.26      albertel  436:     }
1.1       foxr      437:     my $errno    = $! + 0;
                    438:     unless (defined $nwritten) {
                    439: 	if($errno != POSIX::EINTR) {
                    440: 	    $self->Transition("Disconnected");
                    441: 	    return -1;
                    442: 	}
                    443:       
                    444:     }
1.10      foxr      445:     if (($nwritten >= 0)                        ||
1.1       foxr      446:         ($errno == POSIX::EWOULDBLOCK)    ||
                    447: 	($errno == POSIX::EAGAIN)         ||
                    448: 	($errno == POSIX::EINTR)          ||
                    449: 	($errno ==  0)) {
                    450: 	substr($self->{TransactionRequest}, 0, $nwritten) = ""; # rmv written part
1.27      foxr      451:       if(length $self->{TransactionRequest} == 0) {
                    452:          $self->{InformWritable} = 0;
                    453:          $self->{InformReadable} = 1;
                    454:          $self->{TransactionReply} = '';
                    455:          #
                    456:          # Figure out the next state:
                    457:          #
                    458:          if($self->{State} eq "Connected") {
                    459:             $self->Transition("Initialized");
                    460:          } elsif($self->{State} eq "ChallengeReceived") {
                    461:             $self->Transition("ChallengeReplied");
                    462:          } elsif($self->{State} eq "RequestingVersion") {
                    463:             $self->Transition("ReadingVersionString");
                    464:          } elsif ($self->{State} eq "SetHost") {
                    465:             $self->Transition("HostSet");
                    466:          } elsif($self->{State} eq "RequestingKey") {
                    467:             $self->Transition("ReceivingKey");
1.24      foxr      468: #            $self->{InformWritable} = 0;
                    469: #            $self->{InformReadable} = 1;
                    470: #            $self->{TransactionReply} = '';
1.27      foxr      471:          } elsif ($self->{State} eq "SendingRequest") {
                    472:             $self->Transition("ReceivingReply");
                    473:             $self->{TimeoutRemaining} = $self->{TimeoutValue};
                    474:          } elsif ($self->{State} eq "Disconnected") {
                    475:             return -1;
                    476:          }
                    477:          return 0;
                    478:       }
                    479:    } else {			# The write failed (e.g. partner disconnected).
                    480:       $self->Transition("Disconnected");
                    481:       $socket->close();
                    482:       return -1;
                    483:    }
                    484: 	
1.1       foxr      485: }
                    486: =pod
1.3       albertel  487: 
                    488: =head2 Tick
                    489: 
1.1       foxr      490:    Tick is called every time unit by the event framework.  It
1.3       albertel  491: 
                    492: =item 1 decrements the remaining timeout.
                    493: 
                    494: =item 2 If the timeout is zero, calls TimedOut indicating that the current operation timed out.
1.1       foxr      495: 
                    496: =cut
                    497:     
                    498: sub Tick {
                    499:     my $self = shift;
                    500:     $self->{TimeoutRemaining}--;
                    501:     if ($self->{TimeoutRemaining} < 0) {
                    502: 	$self->TimedOut();
                    503:     }
                    504: }
1.3       albertel  505: 
1.1       foxr      506: =pod
                    507: 
1.3       albertel  508: =head2 TimedOut
                    509: 
                    510: called on a timeout.  If the timeout callback is defined, it is called
                    511: with $self as its parameters.
                    512: 
                    513: =cut
                    514: 
1.1       foxr      515: sub TimedOut  {
                    516: 
                    517:     my $self = shift;
                    518:     if($self->{TimeoutCallback}) {
                    519: 	my $callback = $self->{TimeoutCallback};
                    520: 	my @args = ( $self);
                    521: 	&$callback(@args);
                    522:     }
                    523: }
1.3       albertel  524: 
1.1       foxr      525: =pod
1.3       albertel  526: 
                    527: =head2 InitiateTransaction
                    528: 
                    529: Called to initiate a transaction.  A transaction can only be initiated
                    530: when the object is idle... otherwise an error is returned.  A
                    531: transaction consists of a request to the server that will have a
                    532: reply.  This member sets the request data in the TransactionRequest
                    533: member, makes the state SendingRequest and sets the data to allow a
                    534: timout, and to request writability notification.
                    535: 
1.1       foxr      536: =cut
1.3       albertel  537: 
1.1       foxr      538: sub InitiateTransaction {
1.30    ! foxr      539: 
        !           540:     my ($self, $data) = @_;
1.1       foxr      541: 
1.4       foxr      542:     Debug(1, "initiating transaction: ".$data);
1.1       foxr      543:     if($self->{State} ne "Idle") {
1.4       foxr      544: 	Debug(0," .. but not idle here\n");
1.1       foxr      545: 	return -1;		# Error indicator.
                    546:     }
                    547:     # if the transaction is to be encrypted encrypt the data:
                    548: 
                    549:     if($data =~ /^encrypt\:/) {
                    550: 	$data = $self->Encrypt($data);
                    551:     }
                    552: 
                    553:     # Setup the trasaction
                    554: 
                    555:     $self->{TransactionRequest} = $data;
                    556:     $self->{TransactionReply}   = "";
                    557:     $self->{InformWritable}     = 1;
                    558:     $self->{InformReadable}     = 0;
                    559:     $self->{Timeoutable}        = 1;
                    560:     $self->{TimeoutRemaining}   = $self->{TimeoutValue};
                    561:     $self->Transition("SendingRequest");
                    562: }
                    563: 
                    564: 
                    565: =pod
1.3       albertel  566: 
                    567: =head2 SetStateTransitionCallback
                    568: 
                    569: Sets a callback for state transitions.  Returns a reference to any
                    570: prior established callback, or undef if there was none:
                    571: 
1.1       foxr      572: =cut
1.3       albertel  573: 
1.1       foxr      574: sub SetStateTransitionCallback {
                    575:     my $self        = shift;
                    576:     my $oldCallback = $self->{TransitionCallback};
                    577:     $self->{TransitionCallback} = shift;
                    578:     return $oldCallback;
                    579: }
1.3       albertel  580: 
1.1       foxr      581: =pod
1.3       albertel  582: 
                    583: =head2 SetTimeoutCallback
                    584: 
                    585: Sets the timeout callback.  Returns a reference to any prior
                    586: established callback or undef if there was none.
                    587: 
1.1       foxr      588: =cut
1.3       albertel  589: 
1.1       foxr      590: sub SetTimeoutCallback {
1.30    ! foxr      591: 
        !           592:     my ($self, $callback) = @_;
        !           593: 
1.1       foxr      594:     my $oldCallback          = $self->{TimeoutCallback};
                    595:     $self->{TimeoutCallback} = $callback;
                    596:     return $oldCallback;
                    597: }
                    598: 
                    599: =pod
1.3       albertel  600: 
1.5       foxr      601: =head2 Shutdown:
                    602: 
                    603: Shuts down the socket.
                    604: 
                    605: =cut
                    606: 
                    607: sub Shutdown {
                    608:     my $self = shift;
                    609:     my $socket = $self->GetSocket();
1.20      albertel  610:     Debug(5,"socket is -$socket-");
                    611:     if ($socket) {
                    612: 	# Ask lond to exit too.  Non blocking so
                    613: 	# there is no cost for failure.
                    614: 	eval {
                    615: 	    $socket->send("exit\n", 0);
                    616: 	    $socket->shutdown(2);
                    617: 	}
                    618:     }
1.5       foxr      619: }
                    620: 
                    621: =pod
                    622: 
1.3       albertel  623: =head2 GetState
                    624: 
                    625: selector for the object state.
                    626: 
1.1       foxr      627: =cut
1.3       albertel  628: 
1.1       foxr      629: sub GetState {
                    630:     my $self = shift;
                    631:     return $self->{State};
                    632: }
1.3       albertel  633: 
1.1       foxr      634: =pod
1.3       albertel  635: 
                    636: =head2 GetSocket
                    637: 
                    638: selector for the object socket.
                    639: 
1.1       foxr      640: =cut
1.3       albertel  641: 
1.1       foxr      642: sub GetSocket {
                    643:     my $self  = shift;
                    644:     return $self->{Socket};
                    645: }
1.3       albertel  646: 
1.5       foxr      647: 
1.1       foxr      648: =pod
1.3       albertel  649: 
                    650: =head2 WantReadable
                    651: 
                    652: Return the state of the flag that indicates the object wants to be
                    653: called when readable.
                    654: 
1.1       foxr      655: =cut
1.3       albertel  656: 
1.1       foxr      657: sub WantReadable {
                    658:     my   $self = shift;
                    659: 
                    660:     return $self->{InformReadable};
                    661: }
1.3       albertel  662: 
1.1       foxr      663: =pod
1.3       albertel  664: 
                    665: =head2 WantWritable
                    666: 
                    667: Return the state of the flag that indicates the object wants write
                    668: notification.
                    669: 
1.1       foxr      670: =cut
1.3       albertel  671: 
1.1       foxr      672: sub WantWritable {
                    673:     my $self = shift;
                    674:     return $self->{InformWritable};
                    675: }
1.3       albertel  676: 
1.1       foxr      677: =pod
1.3       albertel  678: 
                    679: =head2 WantTimeout
                    680: 
                    681: return the state of the flag that indicates the object wants to be
                    682: informed of timeouts.
                    683: 
1.1       foxr      684: =cut
1.3       albertel  685: 
1.1       foxr      686: sub WantTimeout {
                    687:     my $self = shift;
                    688:     return $self->{Timeoutable};
                    689: }
                    690: 
                    691: =pod
1.3       albertel  692: 
                    693: =head2 GetReply
                    694: 
                    695: Returns the reply from the last transaction.
                    696: 
1.1       foxr      697: =cut
1.3       albertel  698: 
1.1       foxr      699: sub GetReply {
                    700:     my $self = shift;
                    701:     return $self->{TransactionReply};
                    702: }
                    703: 
                    704: =pod
1.3       albertel  705: 
                    706: =head2 Encrypt
                    707: 
                    708: Returns the encrypted version of the command string.
                    709: 
                    710: The command input string is of the form:
                    711: 
1.1       foxr      712:   encrypt:command
1.3       albertel  713: 
                    714: The output string can be directly sent to lond as it is of the form:
                    715: 
1.1       foxr      716:   enc:length:<encodedrequest>
1.3       albertel  717: 
1.1       foxr      718: =cut
1.3       albertel  719: 
1.1       foxr      720: sub Encrypt {
1.30    ! foxr      721:     
        !           722:     my ($self, $request) = @_;
1.1       foxr      723: 
                    724:    
                    725:     # Split the encrypt: off the request and figure out it's length.
                    726:     # the cipher works in blocks of 8 bytes.
                    727: 
                    728:     my $cmd = $request;
                    729:     $cmd    =~ s/^encrypt\://;	# strip off encrypt:
                    730:     chomp($cmd);		# strip off trailing \n
                    731:     my     $length=length($cmd);	# Get the string length.
                    732:     $cmd .= "         ";	# Pad with blanks so we can fill out a block.
                    733: 
                    734:     # encrypt the request in 8 byte chunks to create the encrypted
                    735:     # output request.
                    736: 
                    737:     my $Encoded = '';
                    738:     for(my $index = 0; $index <= $length; $index += 8) {
                    739: 	$Encoded .= 
                    740: 	    unpack("H16", 
                    741: 		   $self->{Cipher}->encrypt(substr($cmd, 
                    742: 						   $index, 8)));
                    743:     }
                    744: 
                    745:     # Build up the answer as enc:length:$encrequest.
                    746: 
                    747:     $request = "enc:$length:$Encoded\n";
                    748:     return $request;
                    749:     
                    750:     
                    751: }
1.3       albertel  752: 
                    753: =pod
                    754: 
                    755: =head2 Decrypt
                    756: 
                    757: Decrypt a response from the server.  The response is in the form:
                    758: 
                    759:  enc:<length>:<encrypted data>
                    760: 
1.1       foxr      761: =cut
1.3       albertel  762: 
1.1       foxr      763: sub Decrypt {
1.30    ! foxr      764: 
        !           765:     my ($self, $encrypted) = @_;
1.1       foxr      766: 
                    767:     #  Bust up the response into length, and encryptedstring:
                    768: 
                    769:     my ($enc, $length, $EncryptedString) = split(/:/,$encrypted);
                    770:     chomp($EncryptedString);
                    771: 
                    772:     # Decode the data in 8 byte blocks.  The string is encoded
                    773:     # as hex digits so there are two characters per byte:
                    774: 
1.10      foxr      775:     my $decrypted = "";
1.1       foxr      776:     for(my $index = 0; $index < length($EncryptedString);
                    777: 	$index += 16) {
                    778: 	$decrypted .= $self->{Cipher}->decrypt(
                    779: 				    pack("H16",
                    780: 					 substr($EncryptedString,
                    781: 						$index, 
                    782: 						16)));
                    783:     }
                    784:     #  the answer may have trailing pads to fill out a block.
                    785:     #  $length tells us the actual length of the decrypted string:
                    786: 
                    787:     $decrypted = substr($decrypted, 0, $length);
                    788: 
                    789:     return $decrypted;
                    790: 
                    791: }
                    792: 
                    793: =pod
1.3       albertel  794: 
                    795: =head2 GetHostIterator
1.1       foxr      796: 
                    797: Returns a hash iterator to the host information.  Each get from 
                    798: this iterator returns a reference to an array that contains 
                    799: information read from the hosts configuration file.  Array elements
                    800: are used as follows:
                    801: 
1.3       albertel  802:  [0]   - LonCapa host name.
                    803:  [1]   - LonCapa domain name.
                    804:  [2]   - Loncapa role (e.g. library or access).
                    805:  [3]   - DNS name server hostname.
1.11      foxr      806:  [4]   - IP address (result of e.g. nslookup [3]).
1.3       albertel  807:  [5]   - Maximum connection count.
                    808:  [6]   - Idle timeout for reducing connection count.
                    809:  [7]   - Minimum connection count.
1.1       foxr      810: 
1.3       albertel  811: =cut
1.1       foxr      812: 
                    813: sub GetHostIterator {
                    814: 
                    815:     return HashIterator->new(\%hostshash);    
                    816: }
1.14      foxr      817: 
                    818: ###########################################################
                    819: #
                    820: #  The following is an unashamed kludge that is here to
                    821: # allow LondConnection to be used outside of the
                    822: # loncapa environment (e.g. by lonManage).
                    823: # 
                    824: #   This is a textual inclusion of pieces of the
                    825: #   Configuration.pm module.
                    826: #
                    827: 
                    828: 
                    829: my $confdir='/etc/httpd/conf/';
                    830: 
                    831: # ------------------- Subroutine read_conf: read LON-CAPA server configuration.
                    832: # This subroutine reads PerlSetVar values out of specified web server
                    833: # configuration files.
                    834: sub read_conf
                    835:   {
                    836:     my (@conf_files)=@_;
                    837:     my %perlvar;
                    838:     foreach my $filename (@conf_files,'loncapa_apache.conf')
                    839:       {
1.21      foxr      840: 	  if($DebugLevel > 3) {
                    841: 	      print("Going to read $confdir.$filename\n");
                    842: 	  }
1.14      foxr      843: 	open(CONFIG,'<'.$confdir.$filename) or
                    844: 	    die("Can't read $confdir$filename");
                    845: 	while (my $configline=<CONFIG>)
                    846: 	  {
                    847: 	    if ($configline =~ /^[^\#]*PerlSetVar/)
                    848: 	      {
                    849: 		my ($unused,$varname,$varvalue)=split(/\s+/,$configline);
                    850: 		chomp($varvalue);
                    851: 		$perlvar{$varname}=$varvalue;
                    852: 	      }
                    853: 	  }
                    854: 	close(CONFIG);
                    855:       }
1.21      foxr      856:     if($DebugLevel > 3) {
                    857: 	print "Dumping perlvar:\n";
                    858: 	foreach my $var (keys %perlvar) {
                    859: 	    print "$var = $perlvar{$var}\n";
                    860: 	}
                    861:     }
1.14      foxr      862:     my $perlvarref=\%perlvar;
1.21      foxr      863:     return $perlvarref;
                    864: }
1.14      foxr      865: 
                    866: #---------------------- Subroutine read_hosts: Read a LON-CAPA hosts.tab
                    867: # formatted configuration file.
                    868: #
                    869: my $RequiredCount = 5;		# Required item count in hosts.tab.
                    870: my $DefaultMaxCon = 5;		# Default value for maximum connections.
                    871: my $DefaultIdle   = 1000;       # Default connection idle time in seconds.
                    872: my $DefaultMinCon = 0;          # Default value for minimum connections.
                    873: 
                    874: sub read_hosts {
                    875:     my $Filename = shift;
                    876:     my %HostsTab;
                    877:     
1.16      foxr      878:    open(CONFIG,'<'.$Filename) or die("Can't read $Filename");
1.14      foxr      879:     while (my $line = <CONFIG>) {
                    880: 	if (!($line =~ /^\s*\#/)) {
                    881: 	    my @items = split(/:/, $line);
                    882: 	    if(scalar @items >= $RequiredCount) {
                    883: 		if (scalar @items == $RequiredCount) { # Only required items:
                    884: 		    $items[$RequiredCount] = $DefaultMaxCon;
                    885: 		}
                    886: 		if(scalar @items == $RequiredCount + 1) { # up through maxcon.
                    887: 		    $items[$RequiredCount+1] = $DefaultIdle;
                    888: 		}
                    889: 		if(scalar @items == $RequiredCount + 2) { # up through idle.
                    890: 		    $items[$RequiredCount+2] = $DefaultMinCon;
                    891: 		}
                    892: 		{
                    893: 		    my @list = @items; # probably not needed but I'm unsure of 
                    894: 		    # about the scope of item so...
                    895: 		    $HostsTab{$list[0]} = \@list; 
                    896: 		}
                    897: 	    }
                    898: 	}
                    899:     }
                    900:     close(CONFIG);
                    901:     my $hostref = \%HostsTab;
                    902:     return ($hostref);
                    903: }
1.24      foxr      904: #
                    905: #   Get the version of our peer.  Note that this is only well
                    906: #   defined if the state machine has hit the idle state at least
                    907: #   once (well actually if it has transitioned out of 
                    908: #   ReadingVersionString   The member data LondVersion is returned.
                    909: #
                    910: sub PeerVersion {
                    911:    my $self = shift;
                    912:    
                    913:    return $self->{LondVersion};
                    914: }
1.1       foxr      915: 
                    916: 1;
                    917: 
                    918: =pod
1.3       albertel  919: 
1.1       foxr      920: =head1 Theory
                    921: 
1.3       albertel  922: The lond object is a state machine.  It lives through the following states:
                    923: 
                    924: =item Connected:
                    925: 
                    926: a TCP connection has been formed, but the passkey has not yet been
                    927: negotiated.
                    928: 
                    929: =item Initialized:
                    930: 
                    931: "init" sent.
                    932: 
                    933: =item ChallengeReceived:
                    934: 
                    935: lond sent its challenge to us.
                    936: 
                    937: =item ChallengeReplied:
                    938: 
                    939: We replied to lond's challenge waiting for lond's ok.
                    940: 
                    941: =item RequestingKey:
                    942: 
                    943: We are requesting an encryption key.
                    944: 
                    945: =item ReceivingKey:
                    946: 
                    947: We are receiving an encryption key.
                    948: 
                    949: =item Idle:
                    950: 
                    951: Connection was negotiated but no requests are active.
                    952: 
                    953: =item SendingRequest:
                    954: 
                    955: A request is being sent to the peer.
                    956: 
                    957: =item ReceivingReply:
                    958: 
                    959: Waiting for an entire reply from the peer.
                    960: 
                    961: =item Disconnected:
                    962: 
                    963: For whatever reason, the connection was dropped.
                    964: 
                    965: When we need to be writing data, we have a writable event. When we
                    966: need to be reading data, a readable event established.  Events
                    967: dispatch through the class functions Readable and Writable, and the
                    968: watcher contains a reference to the associated object to allow object
                    969: context to be reached.
1.1       foxr      970: 
                    971: =head2 Member data.
                    972: 
1.3       albertel  973: =item Host
                    974: 
                    975: Host socket is connected to.
                    976: 
                    977: =item Port
                    978: 
                    979: The port the remote lond is listening on.
                    980: 
                    981: =item Socket
                    982: 
                    983: Socket open on the connection.
                    984: 
                    985: =item State
                    986: 
                    987: The current state.
                    988: 
                    989: =item TransactionRequest
                    990: 
                    991: The request being transmitted.
                    992: 
                    993: =item TransactionReply
                    994: 
                    995: The reply being received from the transaction.
                    996: 
                    997: =item InformReadable
                    998: 
                    999: True if we want to be called when socket is readable.
                   1000: 
                   1001: =item InformWritable
                   1002: 
                   1003: True if we want to be informed if the socket is writable.
                   1004: 
                   1005: =item Timeoutable
                   1006: 
                   1007: True if the current operation is allowed to timeout.
                   1008: 
                   1009: =item TimeoutValue
                   1010: 
                   1011: Number of seconds in the timeout.
                   1012: 
                   1013: =item TimeoutRemaining
                   1014: 
                   1015: Number of seconds left in the timeout.
                   1016: 
                   1017: =item CipherKey
                   1018: 
                   1019: The key that was negotiated with the peer.
                   1020: 
                   1021: =item Cipher
                   1022: 
                   1023: The cipher obtained via the key.
1.1       foxr     1024: 
                   1025: 
                   1026: =head2 The following are callback like members:
1.3       albertel 1027: 
                   1028: =item Tick:
                   1029: 
                   1030: Called in response to a timer tick. Used to managed timeouts etc.
                   1031: 
                   1032: =item Readable:
                   1033: 
                   1034: Called when the socket becomes readable.
                   1035: 
                   1036: =item Writable:
                   1037: 
                   1038: Called when the socket becomes writable.
                   1039: 
                   1040: =item TimedOut:
                   1041: 
                   1042: Called when a timed operation timed out.
                   1043: 
1.1       foxr     1044: 
                   1045: =head2 The following are operational member functions.
1.3       albertel 1046: 
                   1047: =item InitiateTransaction:
                   1048: 
                   1049: Called to initiate a new transaction
                   1050: 
                   1051: =item SetStateTransitionCallback:
                   1052: 
                   1053: Called to establish a function that is called whenever the object goes
                   1054: through a state transition.  This is used by The client to manage the
                   1055: work flow for the object.
                   1056: 
                   1057: =item SetTimeoutCallback:
                   1058: 
                   1059: Set a function to be called when a transaction times out.  The
                   1060: function will be called with the object as its sole parameter.
                   1061: 
                   1062: =item Encrypt:
                   1063: 
                   1064: Encrypts a block of text according to the cipher negotiated with the
                   1065: peer (assumes the text is a command).
                   1066: 
                   1067: =item Decrypt:
                   1068: 
                   1069: Decrypts a block of text according to the cipher negotiated with the
                   1070: peer (assumes the block was a reply.
1.5       foxr     1071: 
                   1072: =item Shutdown:
                   1073: 
                   1074: Shuts off the socket.
1.1       foxr     1075: 
                   1076: =head2 The following are selector member functions:
                   1077: 
1.3       albertel 1078: =item GetState:
                   1079: 
                   1080: Returns the current state
                   1081: 
                   1082: =item GetSocket:
                   1083: 
                   1084: Gets the socekt open on the connection to lond.
                   1085: 
                   1086: =item WantReadable:
                   1087: 
                   1088: true if the current state requires a readable event.
                   1089: 
                   1090: =item WantWritable:
                   1091: 
                   1092: true if the current state requires a writable event.
                   1093: 
                   1094: =item WantTimeout:
                   1095: 
                   1096: true if the current state requires timeout support.
                   1097: 
                   1098: =item GetHostIterator:
                   1099: 
                   1100: Returns an iterator into the host file hash.
                   1101: 
1.1       foxr     1102: =cut

FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>