File:  [LON-CAPA] / loncom / LondConnection.pm
Revision 1.52: download - view: text, annotated - select for diffs
Mon Jan 24 11:02:32 2011 UTC (11 years, 10 months ago) by foxr
Branches: MAIN
CVS tags: version_2_10_X, version_2_10_1, version_2_10_0, loncapaMITrelate_1, language_hyphenation_merge, language_hyphenation, HEAD, BZ4492-merge, BZ4492-feature_horizontal_radioresponse, BZ4492-feature_Support_horizontal_radioresponse, BZ4492-Support_horizontal_radioresponse
Add a 'ClientData' member to LondConnection and have loncnew use it to
properly keep track of which connection is which.
(Bug 6377 comment 43).

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

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