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

Diff for /loncom/lond between versions 1.102 and 1.108

version 1.102, 2002/10/07 13:50:36 version 1.108, 2003/02/03 18:03:52
Line 31 Line 31
 # 10/7,10/8,10/9,10/11,10/13,10/15,11/4,11/16,  # 10/7,10/8,10/9,10/11,10/13,10/15,11/4,11/16,
 # 12/7,12/15,01/06,01/11,01/12,01/14,2/8,  # 12/7,12/15,01/06,01/11,01/12,01/14,2/8,
 # 03/07,05/31 Gerd Kortemeyer  # 03/07,05/31 Gerd Kortemeyer
 # 06/26 Scott Harrison  
 # 06/29,06/30,07/14,07/15,07/17,07/20,07/25,09/18 Gerd Kortemeyer  # 06/29,06/30,07/14,07/15,07/17,07/20,07/25,09/18 Gerd Kortemeyer
 # 12/05 Scott Harrison  
 # 12/05,12/13,12/29 Gerd Kortemeyer  # 12/05,12/13,12/29 Gerd Kortemeyer
 # YEAR=2001  # YEAR=2001
 # Jan 01 Scott Harrison  
 # 02/12 Gerd Kortemeyer  # 02/12 Gerd Kortemeyer
 # 03/15 Scott Harrison  
 # 03/24 Gerd Kortemeyer  # 03/24 Gerd Kortemeyer
 # 04/02 Scott Harrison  
 # 05/11,05/28,08/30 Gerd Kortemeyer  # 05/11,05/28,08/30 Gerd Kortemeyer
 # 9/30,10/22,11/13,11/15,11/16 Scott Harrison  
 # 11/26,11/27 Gerd Kortemeyer  # 11/26,11/27 Gerd Kortemeyer
 # 12/20 Scott Harrison  
 # 12/22 Gerd Kortemeyer  # 12/22 Gerd Kortemeyer
 # YEAR=2002  # YEAR=2002
 # 01/20/02,02/05 Gerd Kortemeyer  # 01/20/02,02/05 Gerd Kortemeyer
 # 02/05 Guy Albertelli  # 02/05 Guy Albertelli
 # 02/07 Scott Harrison  
 # 02/12 Gerd Kortemeyer  # 02/12 Gerd Kortemeyer
 # 02/19 Matthew Hall  # 02/19 Matthew Hall
 # 02/25 Gerd Kortemeyer  # 02/25 Gerd Kortemeyer
 # 05/11 Scott Harrison  # 01/xx/2003 Ron Fox.. Remove preforking.  This makes the general daemon
   #      logic simpler (and there were problems maintaining the preforked
   #      population).  Since the time averaged connection rate is close to zero
   #      because lonc's purpose is to maintain near continuous connnections,
   #      preforking is not really needed.
 ###  ###
   
 # based on "Perl Cookbook" ISBN 1-56592-243-3  
 # preforker - server who forks first  
 # runs as a daemon  
 # HUPs  
 # uses IDEA encryption  
   
 use lib '/home/httpd/lib/perl/';  use lib '/home/httpd/lib/perl/';
 use LONCAPA::Configuration;  use LONCAPA::Configuration;
Line 340  sub status { Line 331  sub status {
     my $now=time;      my $now=time;
     my $local=localtime($now);      my $local=localtime($now);
     $status=$local.': '.$what;      $status=$local.': '.$what;
       $0='lond: '.$what.' '.$local;
 }  }
   
 # -------------------------------------------------------- Escape Special Chars  # -------------------------------------------------------- Escape Special Chars
Line 490  close(PIDSAVE); Line 482  close(PIDSAVE);
 &logthis("<font color=red>CRITICAL: ---------- Starting ----------</font>");  &logthis("<font color=red>CRITICAL: ---------- Starting ----------</font>");
 &status('Starting');  &status('Starting');
   
 # ------------------------------------------------------- Now we are on our own  
       
 # Fork off our children.  
 for (1 .. $PREFORK) {  
     make_new_child();  
 }  
   
 # ----------------------------------------------------- Install signal handlers  # ----------------------------------------------------- Install signal handlers
   
 &status('Forked children');  
   
 $SIG{CHLD} = \&REAPER;  $SIG{CHLD} = \&REAPER;
 $SIG{INT}  = $SIG{TERM} = \&HUNTSMAN;  $SIG{INT}  = $SIG{TERM} = \&HUNTSMAN;
 $SIG{HUP}  = \&HUPSMAN;  $SIG{HUP}  = \&HUPSMAN;
 $SIG{USR1} = \&checkchildren;  $SIG{USR1} = \&checkchildren;
   
 # And maintain the population.  
   
   # --------------------------------------------------------------
   #   Accept connections.  When a connection comes in, it is validated
   #   and if good, a child process is created to process transactions
   #   along the connection.
   
 while (1) {  while (1) {
     &status('Sleeping');      $client = $server->accept() or next;
     sleep;                          # wait for a signal (i.e., child's death)      make_new_child($client);
     &logthis('Woke up');  
     &status('Woke up');  
     for ($i = $children; $i < $PREFORK; $i++) {  
         make_new_child();           # top up the child pool  
     }  
 }  }
   
 sub make_new_child {  sub make_new_child {
       my $client;
     my $pid;      my $pid;
     my $cipher;      my $cipher;
     my $sigset;      my $sigset;
   
       $client = shift;
     &logthis("Attempting to start child");          &logthis("Attempting to start child");    
     # block signal for fork      # block signal for fork
     $sigset = POSIX::SigSet->new(SIGINT);      $sigset = POSIX::SigSet->new(SIGINT);
Line 554  sub make_new_child { Line 544  sub make_new_child {
         &Authen::Krb5::init_context();          &Authen::Krb5::init_context();
         &Authen::Krb5::init_ets();          &Authen::Krb5::init_ets();
   
         # handle connections until we've reached $MAX_CLIENTS_PER_CHILD  
         for ($i=0; $i < $MAX_CLIENTS_PER_CHILD; $i++) {  
             &status('Idle, waiting for connection');  
             $client = $server->accept()     or last;  
             &status('Accepted connection');              &status('Accepted connection');
 # =============================================================================  # =============================================================================
             # do something with the connection              # do something with the connection
Line 565  sub make_new_child { Line 551  sub make_new_child {
     $client->sockopt(SO_KEEPALIVE, 1);# Enable monitoring of      $client->sockopt(SO_KEEPALIVE, 1);# Enable monitoring of
                                       # connection liveness.                                        # connection liveness.
             # see if we know client and check for spoof IP by challenge              # see if we know client and check for spoof IP by challenge
             my $caller=getpeername($client);   my $caller = getpeername($client);
             my ($port,$iaddr)=unpack_sockaddr_in($caller);              my ($port,$iaddr)=unpack_sockaddr_in($caller);
             my $clientip=inet_ntoa($iaddr);              my $clientip=inet_ntoa($iaddr);
             my $clientrec=($hostid{$clientip} ne undef);              my $clientrec=($hostid{$clientip} ne undef);
Line 720  sub make_new_child { Line 706  sub make_new_child {
       }        }
       }        }
                           } elsif ($howpwd eq 'krb4') {                            } elsif ($howpwd eq 'krb4') {
                              $null=pack("C",0);                                $null=pack("C",0);
      unless ($upass=~/$null/) {                                unless ($upass=~/$null/) {
                               $pwdcorrect=(                                    my $krb4_error = &Authen::Krb4::get_pw_in_tkt
                                  Authen::Krb4::get_pw_in_tkt($uname,"",                                        ($uname,"",$contentpwd,'krbtgt',
                                         $contentpwd,'krbtgt',$contentpwd,1,                                         $contentpwd,1,$upass);
      $upass) == 0);                                    if (!$krb4_error) {
      } else { $pwdcorrect=0; }                                        $pwdcorrect = 1;
                                     } else { 
                                         $pwdcorrect=0; 
                                         # log error if it is not a bad password
                                         if ($krb4_error != 62) {
          &logthis('krb4:'.$uname.','.$contentpwd.','.
                   &Authen::Krb4::get_err_txt($Authen::Krb4::error));
                                         }
                                     }
                                 }
                           } elsif ($howpwd eq 'krb5') {                            } elsif ($howpwd eq 'krb5') {
       $null=pack("C",0);        $null=pack("C",0);
       unless ($upass=~/$null/) {        unless ($upass=~/$null/) {
Line 1217  sub make_new_child { Line 1212  sub make_new_child {
                        } else {                         } else {
                            print $client "error:$!\n";                             print $client "error:$!\n";
                        }                         }
   # ----------------------------------------------------------------- dumpcurrent
                      } elsif ($userinput =~ /^currentdump/) {
                          my ($cmd,$udom,$uname,$namespace)
                             =split(/:/,$userinput);
                          $namespace=~s/\//\_/g;
                          $namespace=~s/\W//g;
                          my $qresult='';
                          my $proname=propath($udom,$uname);
                          if (tie(%hash,'GDBM_File',
                                  "$proname/$namespace.db",
                                  &GDBM_READER(),0640)) {
                              # Structure of %data:
                              # $data{$symb}->{$parameter}=$value;
                              # $data{$symb}->{'v.'.$parameter}=$version;
                              # since $parameter will be unescaped, we do not
                              # have to worry about silly parameter names...
                              my %data = ();
                              while (my ($key,$value) = each(%hash)) {
                                 my ($v,$symb,$param) = split(/:/,$key);
                                 next if ($v eq 'version' || $symb eq 'keys');
                                 next if (exists($data{$symb}) && 
                                          exists($data{$symb}->{$param}) &&
                                          $data{$symb}->{'v.'.$param} > $v);
                                 $data{$symb}->{$param}=$value;
                                 $data{$symb}->{'v.'.$param}=$v;
                              }
                              if (untie(%hash)) {
                                while (my ($symb,$param_hash) = each(%data)) {
                                  while(my ($param,$value) = each (%$param_hash)){
                                    next if ($param =~ /^v\./);
                                    $qresult.=$symb.':'.$param.'='.$value.'&';
                                  }
                                }
                                chop($qresult);
                                print $client "$qresult\n";
                              } else {
                                print $client "error:$!\n";
                              }
                          } else {
                              print $client "error:$!\n";
                          }
 # ------------------------------------------------------------------------ dump  # ------------------------------------------------------------------------ dump
                    } elsif ($userinput =~ /^dump/) {                     } elsif ($userinput =~ /^dump/) {
                        my ($cmd,$udom,$uname,$namespace,$regexp)                         my ($cmd,$udom,$uname,$namespace,$regexp)
Line 1494  sub make_new_child { Line 1530  sub make_new_child {
                 &logthis("<font color=blue>WARNING: "                  &logthis("<font color=blue>WARNING: "
                 ."Rejected client $clientip, closing connection</font>");                  ."Rejected client $clientip, closing connection</font>");
             }              }
  }                 }             
   
 # =============================================================================  # =============================================================================
                 
  &logthis("<font color=red>CRITICAL: "   &logthis("<font color=red>CRITICAL: "
  ."Disconnect from $clientip ($hostid{$clientip})</font>");       ."Disconnect from $clientip ($hostid{$clientip})</font>");    
         # tidy up gracefully and finish  
       
         $server->close();  
   
         # this exit is VERY important, otherwise the child will become          # this exit is VERY important, otherwise the child will become
         # a producer of more and more children, forking yourself into          # a producer of more and more children, forking yourself into
         # process death.          # process death.
         exit;          exit;
     }      
 }  }
   
   
Removed from v.1.102  
changed lines
  Added in v.1.108

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