Annotation of loncom/LondConnection.pm, revision 1.62

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

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