[BACK]Return to lond CVS log [TXT] [DIR] Up to [LON-CAPA] / loncom

Diff for /loncom/lond between versions 1.212 and 1.217

version 1.212, 2004/07/27 10:25:07 version 1.217, 2004/07/28 21:33:22
Line 58  my $lastlog=''; Line 58  my $lastlog='';
   
 my $VERSION='$Revision$'; #' stupid emacs  my $VERSION='$Revision$'; #' stupid emacs
 my $remoteVERSION;  my $remoteVERSION;
 my $currenthostid;  my $currenthostid="default";
 my $currentdomainid;  my $currentdomainid;
   
 my $client;  my $client;
Line 1032  sub tie_user_hash { Line 1032  sub tie_user_hash {
     }      }
           
 }  }
   
   #--------------------- Request Handlers --------------------------------------------
   #
   #   By convention each request handler registers itself prior to the sub 
   #   declaration:
   #
   
   #++
   #
   #  Handles ping requests.
   #  Parameters:
   #      $cmd    - the actual keyword that invoked us.
   #      $tail   - the tail of the request that invoked us.
   #      $replyfd- File descriptor connected to the client
   #  Implicit Inputs:
   #      $currenthostid - Global variable that carries the name of the host we are
   #                       known as.
   #  Returns:
   #      1       - Ok to continue processing.
   #      0       - Program should exit.
   #  Side effects:
   #      Reply information is sent to the client.
   
   sub ping_handler {
       my ($cmd, $tail, $client) = @_;
       Debug("$cmd $tail $client .. $currenthostid:");
      
       Reply( $client,"$currenthostid\n","$cmd:$tail");
      
       return 1;
   }
   &register_handler("ping", \&ping_handler, 0, 1, 1);       # Ping unencoded, client or manager.
   
   #++
   #
   # Handles pong requests.  Pong replies with our current host id, and
   #                         the results of a ping sent to us via our lonc.
   #
   # Parameters:
   #      $cmd    - the actual keyword that invoked us.
   #      $tail   - the tail of the request that invoked us.
   #      $replyfd- File descriptor connected to the client
   #  Implicit Inputs:
   #      $currenthostid - Global variable that carries the name of the host we are
   #                       connected to.
   #  Returns:
   #      1       - Ok to continue processing.
   #      0       - Program should exit.
   #  Side effects:
   #      Reply information is sent to the client.
   
   sub pong_handler {
       my ($cmd, $tail, $replyfd) = @_;
   
       my $reply=&reply("ping",$clientname);
       &Reply( $replyfd, "$currenthostid:$reply\n", "$cmd:$tail"); 
       return 1;
   }
   &register_handler("pong", \&pong_handler, 0, 1, 1);       # Pong unencoded, client or manager
   
   #++
   #      Called to establish an encrypted session key with the remote client.
   #      Note that with secure lond, in most cases this function is never
   #      invoked.  Instead, the secure session key is established either
   #      via a local file that's locked down tight and only lives for a short
   #      time, or via an ssl tunnel...and is generated from a bunch-o-random
   #      bits from /dev/urandom, rather than the predictable pattern used by
   #      by this sub.  This sub is only used in the old-style insecure
   #      key negotiation.
   # Parameters:
   #      $cmd    - the actual keyword that invoked us.
   #      $tail   - the tail of the request that invoked us.
   #      $replyfd- File descriptor connected to the client
   #  Implicit Inputs:
   #      $currenthostid - Global variable that carries the name of the host
   #                       known as.
   #      $clientname    - Global variable that carries the name of the hsot we're connected to.
   #  Returns:
   #      1       - Ok to continue processing.
   #      0       - Program should exit.
   #  Implicit Outputs:
   #      Reply information is sent to the client.
   #      $cipher is set with a reference to a new IDEA encryption object.
   #
   sub establish_key_handler {
       my ($cmd, $tail, $replyfd) = @_;
   
       my $buildkey=time.$$.int(rand 100000);
       $buildkey=~tr/1-6/A-F/;
       $buildkey=int(rand 100000).$buildkey.int(rand 100000);
       my $key=$currenthostid.$clientname;
       $key=~tr/a-z/A-Z/;
       $key=~tr/G-P/0-9/;
       $key=~tr/Q-Z/0-9/;
       $key=$key.$buildkey.$key.$buildkey.$key.$buildkey;
       $key=substr($key,0,32);
       my $cipherkey=pack("H32",$key);
       $cipher=new IDEA $cipherkey;
       &Reply($replyfd, "$buildkey\n", "$cmd:$tail"); 
      
       return 1;
   
   }
   &register_handler("ekey", \&establish_key_handler, 0, 1,1);
   
   
   #     Handler for the load command.  Returns the current system load average
   #     to the requestor.
   #
   # Parameters:
   #      $cmd    - the actual keyword that invoked us.
   #      $tail   - the tail of the request that invoked us.
   #      $replyfd- File descriptor connected to the client
   #  Implicit Inputs:
   #      $currenthostid - Global variable that carries the name of the host
   #                       known as.
   #      $clientname    - Global variable that carries the name of the hsot we're connected to.
   #  Returns:
   #      1       - Ok to continue processing.
   #      0       - Program should exit.
   #  Side effects:
   #      Reply information is sent to the client.
   sub load_handler {
       my ($cmd, $tail, $replyfd) = @_;
   
      # Get the load average from /proc/loadavg and calculate it as a percentage of
      # the allowed load limit as set by the perl global variable lonLoadLim
   
       my $loadavg;
       my $loadfile=IO::File->new('/proc/loadavg');
      
       $loadavg=<$loadfile>;
       $loadavg =~ s/\s.*//g;                      # Extract the first field only.
      
       my $loadpercent=100*$loadavg/$perlvar{'lonLoadLim'};
   
       &Reply( $replyfd, "$loadpercent\n", "$cmd:$tail");
      
       return 1;
   }
   register_handler("load", \&load_handler, 0, 1, 0);
   
   #
   #   Process the userload request.  This sub returns to the client the current
   #  user load average.  It can be invoked either by clients or managers.
   #
   # Parameters:
   #      $cmd    - the actual keyword that invoked us.
   #      $tail   - the tail of the request that invoked us.
   #      $replyfd- File descriptor connected to the client
   #  Implicit Inputs:
   #      $currenthostid - Global variable that carries the name of the host
   #                       known as.
   #      $clientname    - Global variable that carries the name of the hsot we're connected to.
   #  Returns:
   #      1       - Ok to continue processing.
   #      0       - Program should exit
   # Implicit inputs:
   #     whatever the userload() function requires.
   #  Implicit outputs:
   #     the reply is written to the client.
   #
   sub user_load_handler {
       my ($cmd, $tail, $replyfd) = @_;
   
       my $userloadpercent=&userload();
       &Reply($replyfd, "$userloadpercent\n", "$cmd:$tail");
       
       return 1;
   }
   register_handler("userload", \&user_load_handler, 0, 1, 0);
   
   
 #---------------------------------------------------------------  #---------------------------------------------------------------
 #  #
 #   Getting, decoding and dispatching requests:  #   Getting, decoding and dispatching requests:
Line 1079  sub process_request { Line 1252  sub process_request {
     }      }
     Debug("process_request: $userinput\n");      Debug("process_request: $userinput\n");
           
 # ------------------------------------------------------------- Normal commands      #  
 # ------------------------------------------------------------------------ ping      #   The 'correct way' to add a command to lond is now to
     if ($userinput =~ /^ping/) { # client only      #   write a sub to execute it and Add it to the command dispatch
  if(isClient) {      #   hash via a call to register_handler..  The comments to that
     print $client "$currenthostid\n";      #   sub should give you enough to go on to show how to do this
  } else {      #   along with the examples that are building up as this code
     Reply($client, "refused\n", $userinput);      #   is getting refactored.   Until all branches of the
  }      #   if/elseif monster below have been factored out into
 # ------------------------------------------------------------------------ pong      #   separate procesor subs, if the dispatch hash is missing
     }elsif ($userinput =~ /^pong/) { # client only      #   the command keyword, we will fall through to the remainder
  if(isClient) {      #   of the if/else chain below in order to keep this thing in 
     my $reply=&reply("ping",$clientname);      #   working order throughout the transmogrification.
     print $client "$currenthostid:$reply\n";   
  } else {      my ($command, $tail) = split(/:/, $userinput, 2);
     Reply($client, "refused\n", $userinput);      chomp($command);
  }      chomp($tail);
 # ------------------------------------------------------------------------ ekey      $tail =~ s/(\r)//; # This helps people debugging with e.g. telnet.
     } elsif ($userinput =~ /^ekey/) { # ok for both clients & mgrs      $command =~ s/(\r)//; # And this too for parameterless commands.
  my $buildkey=time.$$.int(rand 100000);      if(!$tail) {
  $buildkey=~tr/1-6/A-F/;   $tail =""; # defined but blank.
  $buildkey=int(rand 100000).$buildkey.int(rand 100000);      }
  my $key=$currenthostid.$clientname;  
  $key=~tr/a-z/A-Z/;      &Debug("Command received: $command, encoded = $wasenc");
  $key=~tr/G-P/0-9/;  
  $key=~tr/Q-Z/0-9/;      if(defined $Dispatcher{$command}) {
  $key=$key.$buildkey.$key.$buildkey.$key.$buildkey;  
  $key=substr($key,0,32);   my $dispatch_info = $Dispatcher{$command};
  my $cipherkey=pack("H32",$key);   my $handler       = $$dispatch_info[0];
  $cipher=new IDEA $cipherkey;   my $need_encode   = $$dispatch_info[1];
  print $client "$buildkey\n";    my $client_types  = $$dispatch_info[2];
 # ------------------------------------------------------------------------ load   Debug("Matched dispatch hash: mustencode: $need_encode "
     } elsif ($userinput =~ /^load/) { # client only        ."ClientType $client_types");
  if (isClient) {        
     my $loadavg;   #  Validate the request:
     {        
  my $loadfile=IO::File->new('/proc/loadavg');   my $ok = 1;
  $loadavg=<$loadfile>;   my $requesterprivs = 0;
     }   if(&isClient()) {
     $loadavg =~ s/\s.*//g;      $requesterprivs |= $CLIENT_OK;
     my $loadpercent=100*$loadavg/$perlvar{'lonLoadLim'};   }
     print $client "$loadpercent\n";   if(&isManager()) {
  } else {      $requesterprivs |= $MANAGER_OK;
     Reply($client, "refused\n", $userinput);   }
        if($need_encode && (!$wasenc)) {
  }      Debug("Must encode but wasn't: $need_encode $wasenc");
 # -------------------------------------------------------------------- userload      $ok = 0;
     } elsif ($userinput =~ /^userload/) { # client only   }
  if(isClient) {   if(($client_types & $requesterprivs) == 0) {
     my $userloadpercent=&userload();      Debug("Client not privileged to do this operation");
     print $client "$userloadpercent\n";      $ok = 0;
    }
   
    if($ok) {
       Debug("Dispatching to handler $command $tail");
       my $keep_going = &$handler($command, $tail, $client);
       return $keep_going;
  } else {   } else {
     Reply($client, "refused\n", $userinput);      Debug("Refusing to dispatch because client did not match requirements");
           Failure($client, "refused\n", $userinput);
       return 1;
  }   }
 #  
 #        Transactions requiring encryption:      }    
 #  
   #------------------- Commands not yet in spearate handlers. --------------
   
 # ----------------------------------------------------------------- currentauth  # ----------------------------------------------------------------- currentauth
     } elsif ($userinput =~ /^currentauth/) {      if ($userinput =~ /^currentauth/) {
  if (($wasenc==1)  && isClient) { # Encoded & client only.   if (($wasenc==1)  && isClient) { # Encoded & client only.
     my ($cmd,$udom,$uname)=split(/:/,$userinput);      my ($cmd,$udom,$uname)=split(/:/,$userinput);
     my $result = GetAuthType($udom, $uname);      my $result = GetAuthType($udom, $uname);
Line 3069  sub Debug { Line 3251  sub Debug {
 #     request - Original request from client.  #     request - Original request from client.
 #  #
 sub Reply {  sub Reply {
     alarm(120);  
     my $fd      = shift;  
     my $reply   = shift;  
     my $request = shift;  
   
     my ($fd, $reply, $request) = @_;      my ($fd, $reply, $request) = @_;
     print $fd $reply;      print $fd $reply;
     Debug("Request was $request  Reply was $reply");      Debug("Request was $request  Reply was $reply");
   
     $Transactions++;      $Transactions++;
     alarm(0);  
   
   
 }  }
Removed from v.1.212  
changed lines
  Added in v.1.217

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