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

Diff for /loncom/lond between versions 1.60 and 1.89

version 1.60, 2001/11/29 18:56:31 version 1.89, 2002/08/09 18:18:36
Line 35 Line 35
 # 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 Scott Harrison
 # 12/05,12/13,12/29 Gerd Kortemeyer  # 12/05,12/13,12/29 Gerd Kortemeyer
   # YEAR=2001
 # Jan 01 Scott Harrison  # Jan 01 Scott Harrison
 # 02/12 Gerd Kortemeyer  # 02/12 Gerd Kortemeyer
 # 03/15 Scott Harrison  # 03/15 Scott Harrison
Line 43 Line 44
 # 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  # 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
   # YEAR=2002
   # 01/20/02,02/05 Gerd Kortemeyer
   # 02/05 Guy Albertelli
   # 02/07 Scott Harrison
   # 02/12 Gerd Kortemeyer
   # 02/19 Matthew Hall
   # 02/25 Gerd Kortemeyer
   # 05/11 Scott Harrison
 ###  ###
   
 # based on "Perl Cookbook" ISBN 1-56592-243-3  # based on "Perl Cookbook" ISBN 1-56592-243-3
Line 52 Line 62
 # HUPs  # HUPs
 # uses IDEA encryption  # uses IDEA encryption
   
   use lib '/home/httpd/lib/perl/';
   use LONCAPA::Configuration;
   
 use IO::Socket;  use IO::Socket;
 use IO::File;  use IO::File;
 use Apache::File;  use Apache::File;
Line 64  use Authen::Krb4; Line 77  use Authen::Krb4;
 use lib '/home/httpd/lib/perl/';  use lib '/home/httpd/lib/perl/';
 use localauth;  use localauth;
   
   my $DEBUG = 0;       # Non zero to enable debug log entries.
   
 my $status='';  my $status='';
 my $lastlog='';  my $lastlog='';
   
Line 81  sub catchexception { Line 96  sub catchexception {
     die($error);      die($error);
 }  }
   
   sub timeout {
       &logthis("<font color=ref>CRITICAL: TIME OUT ".$$."</font>");
       &catchexception('Timeout');
   }
 # -------------------------------- Set signal handlers to record abnormal exits  # -------------------------------- Set signal handlers to record abnormal exits
   
 $SIG{'QUIT'}=\&catchexception;  $SIG{'QUIT'}=\&catchexception;
 $SIG{__DIE__}=\&catchexception;  $SIG{__DIE__}=\&catchexception;
   
 # ------------------------------------ Read httpd access.conf and get variables  # ---------------------------------- Read loncapa_apache.conf and loncapa.conf
   &status("Read loncapa_apache.conf and loncapa.conf");
 open (CONFIG,"/etc/httpd/conf/access.conf") || die "Can't read access.conf";  my $perlvarref=LONCAPA::Configuration::read_conf('loncapa_apache.conf',
                                                    'loncapa.conf');
 while ($configline=<CONFIG>) {  my %perlvar=%{$perlvarref};
     if ($configline =~ /PerlSetVar/) {  undef $perlvarref;
  my ($dummy,$varname,$varvalue)=split(/\s+/,$configline);  
         chomp($varvalue);  
         $perlvar{$varname}=$varvalue;  
     }  
 }  
 close(CONFIG);  
   
 # ----------------------------- Make sure this process is running from user=www  # ----------------------------- Make sure this process is running from user=www
 my $wwwid=getpwnam('www');  my $wwwid=getpwnam('www');
Line 128  open (CONFIG,"$perlvar{'lonTabDir'}/host Line 141  open (CONFIG,"$perlvar{'lonTabDir'}/host
   
 while ($configline=<CONFIG>) {  while ($configline=<CONFIG>) {
     my ($id,$domain,$role,$name,$ip)=split(/:/,$configline);      my ($id,$domain,$role,$name,$ip)=split(/:/,$configline);
     chomp($ip);      chomp($ip); $ip=~s/\D+$//;
     $hostid{$ip}=$id;      $hostid{$ip}=$id;
     if ($id eq $perlvar{'lonHostID'}) { $thisserver=$name; }      if ($id eq $perlvar{'lonHostID'}) { $thisserver=$name; }
     $PREFORK++;      $PREFORK++;
Line 147  $server = IO::Socket::INET->new(LocalPor Line 160  $server = IO::Socket::INET->new(LocalPor
   
 # global variables  # global variables
   
 $MAX_CLIENTS_PER_CHILD  = 5;        # number of clients each child should   $MAX_CLIENTS_PER_CHILD  = 50;        # number of clients each child should 
                                     # process                                      # process
 %children               = ();       # keys are current child process IDs  %children               = ();       # keys are current child process IDs
 $children               = 0;        # current number of children  $children               = 0;        # current number of children
Line 155  $children               = 0;        # cu Line 168  $children               = 0;        # cu
 sub REAPER {                        # takes care of dead children  sub REAPER {                        # takes care of dead children
     $SIG{CHLD} = \&REAPER;      $SIG{CHLD} = \&REAPER;
     my $pid = wait;      my $pid = wait;
     $children --;      if (defined($children{$pid})) {
     &logthis("Child $pid died");   &logthis("Child $pid died");
     delete $children{$pid};   $children --;
    delete $children{$pid};
       } else {
    &logthis("Unknown Child $pid died");
       }
 }  }
   
 sub HUNTSMAN {                      # signal handler for SIGINT  sub HUNTSMAN {                      # signal handler for SIGINT
Line 184  sub checkchildren { Line 201  sub checkchildren {
     &initnewstatus();      &initnewstatus();
     &logstatus();      &logstatus();
     &logthis('Going to check on the children');      &logthis('Going to check on the children');
     map {      $docdir=$perlvar{'lonDocRoot'};
       foreach (sort keys %children) {
  sleep 1;   sleep 1;
         unless (kill 'USR1' => $_) {          unless (kill 'USR1' => $_) {
     &logthis ('Child '.$_.' is dead');      &logthis ('Child '.$_.' is dead');
             &logstatus($$.' is dead');              &logstatus($$.' is dead');
         }           } 
     } sort keys %children;      }
       sleep 5;
       foreach (sort keys %children) {
           unless (-e "$docdir/lon-status/londchld/$_.txt") {
       &logthis('Child '.$_.' did not respond');
       kill 9 => $_;
       $emailto="$perlvar{'lonAdmEMail'},$perlvar{'lonSysEMail'}";
       $subj="LON: $perlvar{'lonHostID'} killed lond process $_";
       my $result=`echo 'Killed lond process $_.' | mailto $emailto -s '$subj' > /dev/null`;
       $execdir=$perlvar{'lonDaemons'};
       $result=`/bin/cp $execdir/logs/lond.log $execdir/logs/lond.log.$_`
           }
       }
 }  }
   
 # --------------------------------------------------------------------- Logging  # --------------------------------------------------------------------- Logging
Line 205  sub logthis { Line 235  sub logthis {
     print $fh "$local ($$): $message\n";      print $fh "$local ($$): $message\n";
 }  }
   
   # ------------------------- Conditional log if $DEBUG true.
   sub Debug {
       my $message = shift;
       if($DEBUG) {
    &logthis($message);
       }
   }
 # ------------------------------------------------------------------ Log status  # ------------------------------------------------------------------ Log status
   
 sub logstatus {  sub logstatus {
     my $docdir=$perlvar{'lonDocRoot'};      my $docdir=$perlvar{'lonDocRoot'};
       {
     my $fh=IO::File->new(">>$docdir/lon-status/londstatus.txt");      my $fh=IO::File->new(">>$docdir/lon-status/londstatus.txt");
     print $fh $$."\t".$status."\t".$lastlog."\n";      print $fh $$."\t".$status."\t".$lastlog."\n";
       $fh->close();
       }
       {
    my $fh=IO::File->new(">$docdir/lon-status/londchld/$$.txt");
           print $fh $status."\n".$lastlog."\n".time;
           $fh->close();
       }
 }  }
   
 sub initnewstatus {  sub initnewstatus {
Line 219  sub initnewstatus { Line 264  sub initnewstatus {
     my $now=time;      my $now=time;
     my $local=localtime($now);      my $local=localtime($now);
     print $fh "LOND status $local - parent $$\n\n";      print $fh "LOND status $local - parent $$\n\n";
       opendir(DIR,"$docdir/lon-status/londchld");
       while ($filename=readdir(DIR)) {
           unlink("$docdir/lon-status/londchld/$filename");
       }
       closedir(DIR);
 }  }
   
 # -------------------------------------------------------------- Status setting  # -------------------------------------------------------------- Status setting
Line 258  sub reconlonc { Line 308  sub reconlonc {
         if (kill 0 => $loncpid) {          if (kill 0 => $loncpid) {
     &logthis("lonc at pid $loncpid responding, sending USR1");      &logthis("lonc at pid $loncpid responding, sending USR1");
             kill USR1 => $loncpid;              kill USR1 => $loncpid;
             sleep 1;              sleep 5;
             if (-e "$peerfile") { return; }              if (-e "$peerfile") { return; }
             &logthis("$peerfile still not there, give it another try");              &logthis("$peerfile still not there, give it another try");
             sleep 5;              sleep 10;
             if (-e "$peerfile") { return; }              if (-e "$peerfile") { return; }
             &logthis(              &logthis(
  "<font color=blue>WARNING: $peerfile still not there, giving up</font>");   "<font color=blue>WARNING: $peerfile still not there, giving up</font>");
Line 299  sub reply { Line 349  sub reply {
     if ($answer eq 'con_lost') {      if ($answer eq 'con_lost') {
  $answer=subreply("ping",$server);   $answer=subreply("ping",$server);
         if ($answer ne $server) {          if ($answer ne $server) {
       &logthis("sub reply: answer != server");
            &reconlonc("$perlvar{'lonSockDir'}/$server");             &reconlonc("$perlvar{'lonSockDir'}/$server");
         }          }
         $answer=subreply($cmd,$server);          $answer=subreply($cmd,$server);
Line 428  sub make_new_child { Line 479  sub make_new_child {
         # Child can *not* return from this subroutine.          # Child can *not* return from this subroutine.
         $SIG{INT} = 'DEFAULT';      # make SIGINT kill us as it did before          $SIG{INT} = 'DEFAULT';      # make SIGINT kill us as it did before
         $SIG{USR1}= \&logstatus;          $SIG{USR1}= \&logstatus;
           $SIG{ALRM}= \&timeout;
         $lastlog='Forked ';          $lastlog='Forked ';
         $status='Forked';          $status='Forked';
   
Line 487  sub make_new_child { Line 539  sub make_new_child {
             }              }
             if ($clientok) {              if ($clientok) {
 # ---------------- New known client connecting, could mean machine online again  # ---------------- New known client connecting, could mean machine online again
   
       &reconlonc("$perlvar{'lonSockDir'}/$hostid{$clientip}");        &reconlonc("$perlvar{'lonSockDir'}/$hostid{$clientip}");
               &logthis(                &logthis(
        "<font color=green>Established connection: $hostid{$clientip}</font>");         "<font color=green>Established connection: $hostid{$clientip}</font>");
Line 494  sub make_new_child { Line 547  sub make_new_child {
 # ------------------------------------------------------------ Process requests  # ------------------------------------------------------------ Process requests
               while (my $userinput=<$client>) {                while (my $userinput=<$client>) {
                 chomp($userinput);                  chomp($userinput);
    Debug("Request = $userinput\n");
                 &status('Processing '.$hostid{$clientip}.': '.$userinput);                  &status('Processing '.$hostid{$clientip}.': '.$userinput);
                 my $wasenc=0;                  my $wasenc=0;
                   alarm(120);
 # ------------------------------------------------------------ See if encrypted  # ------------------------------------------------------------ See if encrypted
  if ($userinput =~ /^enc/) {   if ($userinput =~ /^enc/) {
   if ($cipher) {    if ($cipher) {
Line 509  sub make_new_child { Line 564  sub make_new_child {
     }      }
     $userinput=substr($userinput,0,$cmdlength);      $userinput=substr($userinput,0,$cmdlength);
                     $wasenc=1;                      $wasenc=1;
   }  
  }   }
         }
     
 # ------------------------------------------------------------- Normal commands  # ------------------------------------------------------------- Normal commands
 # ------------------------------------------------------------------------ ping  # ------------------------------------------------------------------------ ping
    if ($userinput =~ /^ping/) {     if ($userinput =~ /^ping/) {
Line 547  sub make_new_child { Line 603  sub make_new_child {
    } elsif ($userinput =~ /^currentauth/) {     } elsif ($userinput =~ /^currentauth/) {
      if ($wasenc==1) {       if ($wasenc==1) {
                        my ($cmd,$udom,$uname)=split(/:/,$userinput);                         my ($cmd,$udom,$uname)=split(/:/,$userinput);
                        my $proname=propath($udom,$uname);         my $result = GetAuthType($udom, $uname);
                        my $passfilename="$proname/passwd";         if($result eq "nouser") {
                        if (-e $passfilename) {     print $client "unknown_user\n";
    my $pf = IO::File->new($passfilename);         }
    my $realpasswd=<$pf>;         else {
    chomp($realpasswd);     print $client "$result\n"
    my ($howpwd,$contentpwd)=split(/:/,$realpasswd);         }
    my $availablecontent='';  
    if ($howpwd eq 'krb4') {  
        $availablecontent=$contentpwd;  
    }  
    print $client "$howpwd:$availablecontent\n";  
        } else {  
                           print $client "unknown_user\n";  
                        }  
      } else {       } else {
        print $client "refused\n";         print $client "refused\n";
      }       }
Line 597  sub make_new_child { Line 645  sub make_new_child {
   $pwdcorrect=!$?;    $pwdcorrect=!$?;
       }        }
                           } elsif ($howpwd eq 'krb4') {                            } elsif ($howpwd eq 'krb4') {
                                $null=pack("C",0);
        unless ($upass=~/$null/) {
                               $pwdcorrect=(                                $pwdcorrect=(
                                  Authen::Krb4::get_pw_in_tkt($uname,"",                                   Authen::Krb4::get_pw_in_tkt($uname,"",
                                         $contentpwd,'krbtgt',$contentpwd,1,                                          $contentpwd,'krbtgt',$contentpwd,1,
      $upass) == 0);       $upass) == 0);
        } else { $pwdcorrect=0; }
                           } elsif ($howpwd eq 'localauth') {                            } elsif ($howpwd eq 'localauth') {
     $pwdcorrect=&localauth::localauth($uname,$upass,      $pwdcorrect=&localauth::localauth($uname,$upass,
       $contentpwd);        $contentpwd);
Line 624  sub make_new_child { Line 675  sub make_new_child {
                        chomp($npass);                         chomp($npass);
                        $upass=&unescape($upass);                         $upass=&unescape($upass);
                        $npass=&unescape($npass);                         $npass=&unescape($npass);
                        my $proname=propath($udom,$uname);         &logthis("Trying to change password for $uname");
          my $proname=propath($udom,$uname);
                        my $passfilename="$proname/passwd";                         my $passfilename="$proname/passwd";
                        if (-e $passfilename) {                         if (-e $passfilename) {
    my $realpasswd;     my $realpasswd;
Line 639  sub make_new_child { Line 691  sub make_new_child {
      my $ncpass=crypt($npass,$salt);       my $ncpass=crypt($npass,$salt);
                              { my $pf = IO::File->new(">$passfilename");                               { my $pf = IO::File->new(">$passfilename");
           print $pf "internal:$ncpass\n"; }                         print $pf "internal:$ncpass\n"; }             
        &logthis("Result of password change for $uname: pwchange_success");
                              print $client "ok\n";                               print $client "ok\n";
                            } else {                             } else {
                              print $client "non_authorized\n";                               print $client "non_authorized\n";
                            }                             }
                           } else {                            } elsif ($howpwd eq 'unix') {
         # Unix means we have to access /etc/password
         # one way or another.
         # First: Make sure the current password is
         #        correct
         $contentpwd=(getpwnam($uname))[1];
         my $pwdcorrect = "0";
         my $pwauth_path="/usr/local/sbin/pwauth";
         unless ($contentpwd eq 'x') {
     $pwdcorrect=
                                       (crypt($upass,$contentpwd) eq $contentpwd);
         } elsif (-e $pwauth_path) {
     open PWAUTH, "|$pwauth_path" or
         die "Cannot invoke authentication";
     print PWAUTH "$uname\n$upass\n";
     close PWAUTH;
     $pwdcorrect=!$?;
         }
        if ($pwdcorrect) {
    my $execdir=$perlvar{'lonDaemons'};
    my $pf = IO::File->new("|$execdir/lcpasswd");
    print $pf "$uname\n$npass\n$npass\n";
    close $pf;
    my $result = ($?>0 ? 'pwchange_failure' 
          : 'ok');
    &logthis("Result of password change for $uname: $result");
    print $client "$result\n";
        } else {
    print $client "non_authorized\n";
        }
     } else {
                             print $client "auth_mode_error\n";                              print $client "auth_mode_error\n";
                           }                              }  
        } else {         } else {
Line 654  sub make_new_child { Line 737  sub make_new_child {
      }       }
 # -------------------------------------------------------------------- makeuser  # -------------------------------------------------------------------- makeuser
                    } elsif ($userinput =~ /^makeuser/) {                     } elsif ($userinput =~ /^makeuser/) {
        Debug("Make user received");
                 my $oldumask=umask(0077);                  my $oldumask=umask(0077);
      if ($wasenc==1) {       if ($wasenc==1) {
                        my                          my 
                        ($cmd,$udom,$uname,$umode,$npass)=split(/:/,$userinput);                         ($cmd,$udom,$uname,$umode,$npass)=split(/:/,$userinput);
          &Debug("cmd =".$cmd." $udom =".$udom.
       " uname=".$uname);
                        chomp($npass);                         chomp($npass);
                        $npass=&unescape($npass);                         $npass=&unescape($npass);
                        my $proname=propath($udom,$uname);                         my $proname=propath($udom,$uname);
                        my $passfilename="$proname/passwd";                         my $passfilename="$proname/passwd";
          &Debug("Password file created will be:".
       $passfilename);
                        if (-e $passfilename) {                         if (-e $passfilename) {
    print $client "already_exists\n";     print $client "already_exists\n";
                        } elsif ($udom ne $perlvar{'lonDefDomain'}) {                         } elsif ($udom ne $perlvar{'lonDefDomain'}) {
Line 674  sub make_new_child { Line 762  sub make_new_child {
                                $fpnow.='/'.$fpparts[$i];                                  $fpnow.='/'.$fpparts[$i]; 
                                unless (-e $fpnow) {                                 unless (-e $fpnow) {
    unless (mkdir($fpnow,0777)) {     unless (mkdir($fpnow,0777)) {
                                       $fperror="error:$!\n";                                        $fperror="error:$!";
                                    }                                     }
                                }                                 }
                            }                             }
Line 690  sub make_new_child { Line 778  sub make_new_child {
                                $salt=substr($salt,6,2);                                 $salt=substr($salt,6,2);
        my $ncpass=crypt($npass,$salt);         my $ncpass=crypt($npass,$salt);
                                {                                  { 
                                  my $pf = IO::File->new(">$passfilename");   &Debug("Creating internal auth");
    my $pf = IO::File->new(">$passfilename");
             print $pf "internal:$ncpass\n";               print $pf "internal:$ncpass\n"; 
                                }                                 }
                                print $client "ok\n";                                 print $client "ok\n";
Line 705  sub make_new_child { Line 794  sub make_new_child {
  my $execpath="$perlvar{'lonDaemons'}/".   my $execpath="$perlvar{'lonDaemons'}/".
               "lcuseradd";                "lcuseradd";
  {   {
        &Debug("Executing external: ".
     $execpath);
      my $se = IO::File->new("|$execpath");       my $se = IO::File->new("|$execpath");
      print $se "$uname\n";       print $se "$uname\n";
      print $se "$npass\n";       print $se "$npass\n";
Line 733  sub make_new_child { Line 824  sub make_new_child {
      umask($oldumask);       umask($oldumask);
 # -------------------------------------------------------------- changeuserauth  # -------------------------------------------------------------- changeuserauth
                    } elsif ($userinput =~ /^changeuserauth/) {                     } elsif ($userinput =~ /^changeuserauth/) {
      if ($wasenc==1) {         &Debug("Changing authorization");
         if ($wasenc==1) {
                        my                          my 
                        ($cmd,$udom,$uname,$umode,$npass)=split(/:/,$userinput);                         ($cmd,$udom,$uname,$umode,$npass)=split(/:/,$userinput);
                        chomp($npass);                         chomp($npass);
          &Debug("cmd = ".$cmd." domain= ".$udom.
         "uname =".$uname." umode= ".$umode);
                        $npass=&unescape($npass);                         $npass=&unescape($npass);
                        my $proname=propath($udom,$uname);                         my $proname=propath($udom,$uname);
                        my $passfilename="$proname/passwd";                         my $passfilename="$proname/passwd";
Line 853  sub make_new_child { Line 947  sub make_new_child {
        } else {         } else {
  print $client "rejected\n";   print $client "rejected\n";
                        }                         }
   # -------------------------------------- fetch a user file from a remote server
                      } elsif ($userinput =~ /^fetchuserfile/) {
                         my ($cmd,$fname)=split(/:/,$userinput);
         my ($udom,$uname,$ufile)=split(/\//,$fname);
                         my $udir=propath($udom,$uname).'/userfiles';
                         unless (-e $udir) { mkdir($udir,0770); }
                          if (-e $udir) {
                          $ufile=~s/^[\.\~]+//;
                          $ufile=~s/\///g;
                          my $transname=$udir.'/'.$ufile;
                          my $remoteurl='http://'.$clientip.'/userfiles/'.$fname;
                                my $response;
                                 {
                                my $ua=new LWP::UserAgent;
                                my $request=new HTTP::Request('GET',"$remoteurl");
                                $response=$ua->request($request,$transname);
         }
                                if ($response->is_error()) {
    unlink($transname);
                                    my $message=$response->status_line;
                                    &logthis(
                                     "LWP GET: $message for $fname ($remoteurl)");
    print $client "failed\n";
                                } else {
                                    print $client "ok\n";
                                }
                        } else {
                          print $client "not_home\n";
                        } 
   # ------------------------------------------ authenticate access to a user file
                      } elsif ($userinput =~ /^tokenauthuserfile/) {
                          my ($cmd,$fname,$session)=split(/:/,$userinput);
                          chomp($session);
                          $reply='non_auth';
                          if (open(ENVIN,$perlvar{'lonIDsDir'}.'/'.
                                         $session.'.id')) {
                           while ($line=<ENVIN>) {
      if ($line=~/userfile\.$fname\=/) { $reply='ok'; }
                           }
                           close(ENVIN);
                           print $client $reply."\n";
          } else {
    print $client "invalid_token\n";
                          }
 # ----------------------------------------------------------------- unsubscribe  # ----------------------------------------------------------------- unsubscribe
                    } elsif ($userinput =~ /^unsub/) {                     } elsif ($userinput =~ /^unsub/) {
                        my ($cmd,$fname)=split(/:/,$userinput);                         my ($cmd,$fname)=split(/:/,$userinput);
                        if (-e $fname) {                         if (-e $fname) {
                            if (unlink("$fname.$hostid{$clientip}")) {     print $client &unsub($client,$fname,$clientip);
                               print $client "ok\n";  
    } else {  
                               print $client "not_subscribed\n";  
    }  
                        } else {                         } else {
    print $client "not_found\n";     print $client "not_found\n";
                        }                         }
 # ------------------------------------------------------------------- subscribe  # ------------------------------------------------------------------- subscribe
                    } elsif ($userinput =~ /^sub/) {                     } elsif ($userinput =~ /^sub/) {
                        my ($cmd,$fname)=split(/:/,$userinput);         print $client &subscribe($userinput,$clientip);
                        my $ownership=ishome($fname);  
                        if ($ownership eq 'owner') {  
                         if (-e $fname) {  
  if (-d $fname) {  
    print $client "directory\n";  
                          } else {  
                            $now=time;  
                            {   
     my $sh;  
                             if ($sh=  
                              IO::File->new(">$fname.$hostid{$clientip}")) {  
                                print $sh "$clientip:$now\n";  
     }  
    }  
                            unless ($fname=~/\.meta$/) {  
        unlink("$fname.meta.$hostid{$clientip}");  
                            }  
                            $fname=~s/\/home\/httpd\/html\/res/raw/;  
                            $fname="http://$thisserver/".$fname;  
                            print $client "$fname\n";  
          }  
                         } else {  
          print $client "not_found\n";  
                         }  
        } else {  
                         print $client "rejected\n";  
        }  
 # ------------------------------------------------------------------------- log  # ------------------------------------------------------------------------- log
                    } elsif ($userinput =~ /^log/) {                     } elsif ($userinput =~ /^log/) {
                        my ($cmd,$udom,$uname,$what)=split(/:/,$userinput);                         my ($cmd,$udom,$uname,$what)=split(/:/,$userinput);
Line 945  sub make_new_child { Line 1052  sub make_new_child {
                       }                        }
 # -------------------------------------------------------------------- rolesput  # -------------------------------------------------------------------- rolesput
                    } elsif ($userinput =~ /^rolesput/) {                     } elsif ($userinput =~ /^rolesput/) {
          &Debug("rolesput");
     if ($wasenc==1) {      if ($wasenc==1) {
                        my ($cmd,$exedom,$exeuser,$udom,$uname,$what)                         my ($cmd,$exedom,$exeuser,$udom,$uname,$what)
                           =split(/:/,$userinput);                            =split(/:/,$userinput);
          &Debug("cmd = ".$cmd." exedom= ".$exedom.
       "user = ".$exeuser." udom=".$udom.
       "what = ".$what);
                        my $namespace='roles';                         my $namespace='roles';
                        chomp($what);                         chomp($what);
                        my $proname=propath($udom,$uname);                         my $proname=propath($udom,$uname);
Line 964  sub make_new_child { Line 1075  sub make_new_child {
       if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT,0640)) {        if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT,0640)) {
                            foreach $pair (@pairs) {                             foreach $pair (@pairs) {
        ($key,$value)=split(/=/,$pair);         ($key,$value)=split(/=/,$pair);
          &ManagePermissions($key, $udom, $uname,
     &GetAuthType( $udom, 
    $uname));
                                $hash{$key}=$value;                                 $hash{$key}=$value;
          
                            }                             }
    if (untie(%hash)) {     if (untie(%hash)) {
                               print $client "ok\n";                                print $client "ok\n";
Line 1087  sub make_new_child { Line 1202  sub make_new_child {
                        }                         }
 # ------------------------------------------------------------------------ dump  # ------------------------------------------------------------------------ dump
                    } elsif ($userinput =~ /^dump/) {                     } elsif ($userinput =~ /^dump/) {
                        my ($cmd,$udom,$uname,$namespace)                         my ($cmd,$udom,$uname,$namespace,$regexp)
                           =split(/:/,$userinput);                            =split(/:/,$userinput);
                        $namespace=~s/\//\_/g;                         $namespace=~s/\//\_/g;
                        $namespace=~s/\W//g;                         $namespace=~s/\W//g;
                          if (defined($regexp)) {
                             $regexp=&unescape($regexp);
          } else {
                             $regexp='.';
          }
                        my $proname=propath($udom,$uname);                         my $proname=propath($udom,$uname);
                        my $qresult='';                         my $qresult='';
       if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER,0640)) {        if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER,0640)) {
                            foreach $key (keys %hash) {                             foreach $key (keys %hash) {
                                $qresult.="$key=$hash{$key}&";                                 if (eval('$key=~/$regexp/')) {
                                     $qresult.="$key=$hash{$key}&";
          }
                            }                             }
    if (untie(%hash)) {     if (untie(%hash)) {
               $qresult=~s/\&$//;                $qresult=~s/\&$//;
Line 1180  sub make_new_child { Line 1302  sub make_new_child {
                        } else {                         } else {
                            print $client "error:$!\n";                             print $client "error:$!\n";
                        }                         }
   # -------------------------------------------------------------------- chatsend
                      } elsif ($userinput =~ /^chatsend/) {
                          my ($cmd,$cdom,$cnum,$newpost)=split(/\:/,$userinput);
                          &chatadd($cdom,$cnum,$newpost);
                          print $client "ok\n";
   # -------------------------------------------------------------------- chatretr
                      } elsif ($userinput =~ /^chatretr/) {
                          my ($cmd,$cdom,$cnum)=split(/\:/,$userinput);
                          my $reply='';
                          foreach (&getchat($cdom,$cnum)) {
      $reply.=&escape($_).':';
                          }
                          $reply=~s/\:$//;
                          print $client $reply."\n";
 # ------------------------------------------------------------------- querysend  # ------------------------------------------------------------------- querysend
                    } elsif ($userinput =~ /^querysend/) {                     } elsif ($userinput =~ /^querysend/) {
                        my ($cmd,$query,                         my ($cmd,$query,
    $custom,$customshow)=split(/:/,$userinput);     $arg1,$arg2,$arg3)=split(/\:/,$userinput);
        $query=~s/\n*$//g;         $query=~s/\n*$//g;
        unless ($custom or $customshow) {         print $client "".
    print $client "".  
        sqlreply("$hostid{$clientip}\&$query")."\n";  
        }  
        else {  
    print $client "".  
        sqlreply("$hostid{$clientip}\&$query".         sqlreply("$hostid{$clientip}\&$query".
  "\&$custom"."\&$customshow")."\n";   "\&$arg1"."\&$arg2"."\&$arg3")."\n";
        }  
 # ------------------------------------------------------------------ queryreply  # ------------------------------------------------------------------ queryreply
                    } elsif ($userinput =~ /^queryreply/) {                     } elsif ($userinput =~ /^queryreply/) {
                        my ($cmd,$id,$reply)=split(/:/,$userinput);                          my ($cmd,$id,$reply)=split(/:/,$userinput); 
Line 1299  sub make_new_child { Line 1429  sub make_new_child {
                        my $ulsout='';                         my $ulsout='';
                        my $ulsfn;                         my $ulsfn;
                        if (-e $ulsdir) {                         if (-e $ulsdir) {
  if (opendir(LSDIR,$ulsdir)) {                             if(-d $ulsdir) {
                           while ($ulsfn=readdir(LSDIR)) {                                 if (opendir(LSDIR,$ulsdir)) {
      my @ulsstats=stat($ulsdir.'/'.$ulsfn);                                     while ($ulsfn=readdir(LSDIR)) {
                              $ulsout.=$ulsfn.'&'.join('&',@ulsstats).':';                                         my @ulsstats=stat($ulsdir.'/'.$ulsfn);
                           }                                         $ulsout.=$ulsfn.'&'.
                           closedir(LSDIR);                                                  join('&',@ulsstats).':';
         }                                     }
        } else {                                     closedir(LSDIR);
                                  }
                              } else {
                                  my @ulsstats=stat($ulsdir);
                                  $ulsout.=$ulsfn.'&'.join('&',@ulsstats).':';
                              }
                          } else {
                           $ulsout='no_such_dir';                            $ulsout='no_such_dir';
                        }                         }
                        if ($ulsout eq '') { $ulsout='empty'; }                         if ($ulsout eq '') { $ulsout='empty'; }
Line 1325  sub make_new_child { Line 1461  sub make_new_child {
                        print $client "unknown_cmd\n";                         print $client "unknown_cmd\n";
                    }                     }
 # -------------------------------------------------------------------- complete  # -------------------------------------------------------------------- complete
      alarm(0);
                    &status('Listening to '.$hostid{$clientip});                     &status('Listening to '.$hostid{$clientip});
        }         }
 # --------------------------------------------- client unknown or fishy, refuse  # --------------------------------------------- client unknown or fishy, refuse
Line 1333  sub make_new_child { Line 1470  sub make_new_child {
                 $client->close();                  $client->close();
                 &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: "   }              
                     ."Disconnect from $clientip ($hostid{$clientip})</font>");  
 # =============================================================================  # =============================================================================
         }         
        &logthis("<font color=red>CRITICAL: "
    ."Disconnect from $clientip ($hostid{$clientip})</font>");    
         # tidy up gracefully and finish          # tidy up gracefully and finish
           
         $client->close();  
         $server->close();          $server->close();
   
         # this exit is VERY important, otherwise the child will become          # this exit is VERY important, otherwise the child will become
Line 1352  sub make_new_child { Line 1489  sub make_new_child {
 }  }
   
   
   #
   #   Checks to see if the input roleput request was to set
   # an author role.  If so, invokes the lchtmldir script to set
   # up a correct public_html 
   # Parameters:
   #    request   - The request sent to the rolesput subchunk.
   #                We're looking for  /domain/_au
   #    domain    - The domain in which the user is having roles doctored.
   #    user      - Name of the user for which the role is being put.
   #    authtype  - The authentication type associated with the user.
   #
   sub ManagePermissions
   {
       my $request = shift;
       my $domain  = shift;
       my $user    = shift;
       my $authtype= shift;
   
       # See if the request is of the form /$domain/_au
   
       if($request =~ /^(\/$domain\/_au)$/) { # It's an author rolesput...
    my $execdir = $perlvar{'lonDaemons'};
    my $userhome= "/home/$user" ;
    Debug("system $execdir/lchtmldir $userhome $system $authtype");
    system("$execdir/lchtmldir $userhome $user $authtype");
       }
   }
   #
   #   GetAuthType - Determines the authorization type of a user in a domain.
   
   #     Returns the authorization type or nouser if there is no such user.
   #
   sub GetAuthType 
   {
       my $domain = shift;
       my $user   = shift;
   
       Debug("GetAuthType( $domain, $user ) \n");
       my $proname    = &propath($domain, $user); 
       my $passwdfile = "$proname/passwd";
       if( -e $passwdfile ) {
    my $pf = IO::File->new($passwdfile);
    my $realpassword = <$pf>;
    chomp($realpassword);
    Debug("Password info = $realpassword\n");
    my ($authtype, $contentpwd) = split(/:/, $realpassword);
    Debug("Authtype = $authtype, content = $contentpwd\n");
    my $availinfo = '';
    if($authtype eq 'krb4') {
       $availinfo = $contentpwd;
    }
   
    return "$authtype:$availinfo";
       }
       else {
    Debug("Returning nouser");
    return "nouser";
       }
   }
   
   sub addline {
       my ($fname,$hostid,$ip,$newline)=@_;
       my $contents;
       my $found=0;
       my $expr='^'.$hostid.':'.$ip.':';
       $expr =~ s/\./\\\./g;
       if ($sh=IO::File->new("$fname.subscription")) {
    while (my $subline=<$sh>) {
       if ($subline !~ /$expr/) {$contents.= $subline;} else {$found=1;}
    }
    $sh->close();
       }
       $sh=IO::File->new(">$fname.subscription");
       if ($contents) { print $sh $contents; }
       if ($newline) { print $sh $newline; }
       $sh->close();
       return $found;
   }
   
   sub getchat {
       my ($cdom,$cname)=@_;
       my %hash;
       my $proname=&propath($cdom,$cname);
       my @entries=();
       if (tie(%hash,'GDBM_File',"$proname/nohist_chatroom.db",
       &GDBM_READER(),0640)) {
    @entries=map { $_.':'.$hash{$_} } sort keys %hash;
    untie %hash;
       }
       return @entries;
   }
   
   sub chatadd {
       my ($cdom,$cname,$newchat)=@_;
       my %hash;
       my $proname=&propath($cdom,$cname);
       my @entries=();
       if (tie(%hash,'GDBM_File',"$proname/nohist_chatroom.db",
       &GDBM_WRCREAT(),0640)) {
    @entries=map { $_.':'.$hash{$_} } sort keys %hash;
    my $time=time;
    my ($lastid)=($entries[$#entries]=~/^(\w+)\:/);
    my ($thentime,$idnum)=split(/\_/,$lastid);
    my $newid=$time.'_000000';
    if ($thentime==$time) {
       $idnum=~s/^0+//;
       $idnum++;
       $idnum=substr('000000'.$idnum,-6,6);
       $newid=$time.'_'.$idnum;
    }
    $hash{$newid}=$newchat;
    my $expired=$time-3600;
    foreach (keys %hash) {
       my ($thistime)=($_=~/(\d+)\_/);
       if ($thistime<$expired) {
    delete $hash{$_};
       }
    }
    untie %hash;
       }
   }
   
   sub unsub {
       my ($fname,$clientip)=@_;
       my $result;
       if (unlink("$fname.$hostid{$clientip}")) {
    $result="ok\n";
       } else {
    $result="not_subscribed\n";
       }
       if (-e "$fname.subscription") {
    my $found=&addline($fname,$hostid{$clientip},$clientip,'');
    if ($found) { $result="ok\n"; }
       } else {
    if ($result != "ok\n") { $result="not_subscribed\n"; }
       }
       return $result;
   }
   
   sub subscribe {
       my ($userinput,$clientip)=@_;
       my $result;
       my ($cmd,$fname)=split(/:/,$userinput);
       my $ownership=&ishome($fname);
       if ($ownership eq 'owner') {
    if (-e $fname) {
       if (-d $fname) {
    $result="directory\n";
       } else {
    if (-e "$fname.$hostid{$clientip}") {&unsub($fname,$clientip);}
    $now=time;
    my $found=&addline($fname,$hostid{$clientip},$clientip,
      "$hostid{$clientip}:$clientip:$now\n");
    if ($found) { $result="$fname\n"; }
    # if they were subscribed to only meta data, delete that
                   # subscription, when you subscribe to a file you also get
                   # the metadata
    unless ($fname=~/\.meta$/) { &unsub("$fname.meta",$clientip); }
    $fname=~s/\/home\/httpd\/html\/res/raw/;
    $fname="http://$thisserver/".$fname;
    $result="$fname\n";
       }
    } else {
       $result="not_found\n";
    }
       } else {
    $result="rejected\n";
       }
       return $result;
   }
   # ----------------------------------- POD (plain old documentation, CPAN style)
   
   =head1 NAME
   
   lond - "LON Daemon" Server (port "LOND" 5663)
   
   =head1 SYNOPSIS
   
   Usage: B<lond>
   
   Should only be run as user=www.  This is a command-line script which
   is invoked by B<loncron>.  There is no expectation that a typical user
   will manually start B<lond> from the command-line.  (In other words,
   DO NOT START B<lond> YOURSELF.)
   
   =head1 DESCRIPTION
   
   There are two characteristics associated with the running of B<lond>,
   PROCESS MANAGEMENT (starting, stopping, handling child processes)
   and SERVER-SIDE ACTIVITIES (password authentication, user creation,
   subscriptions, etc).  These are described in two large
   sections below.
   
   B<PROCESS MANAGEMENT>
   
   Preforker - server who forks first. Runs as a daemon. HUPs.
   Uses IDEA encryption
   
   B<lond> forks off children processes that correspond to the other servers
   in the network.  Management of these processes can be done at the
   parent process level or the child process level.
   
   B<logs/lond.log> is the location of log messages.
   
   The process management is now explained in terms of linux shell commands,
   subroutines internal to this code, and signal assignments:
   
   =over 4
   
   =item *
   
   PID is stored in B<logs/lond.pid>
   
   This is the process id number of the parent B<lond> process.
   
   =item *
   
   SIGTERM and SIGINT
   
   Parent signal assignment:
    $SIG{INT}  = $SIG{TERM} = \&HUNTSMAN;
   
   Child signal assignment:
    $SIG{INT}  = 'DEFAULT'; (and SIGTERM is DEFAULT also)
   (The child dies and a SIGALRM is sent to parent, awaking parent from slumber
    to restart a new child.)
   
   Command-line invocations:
    B<kill> B<-s> SIGTERM I<PID>
    B<kill> B<-s> SIGINT I<PID>
   
   Subroutine B<HUNTSMAN>:
    This is only invoked for the B<lond> parent I<PID>.
   This kills all the children, and then the parent.
   The B<lonc.pid> file is cleared.
   
   =item *
   
   SIGHUP
   
   Current bug:
    This signal can only be processed the first time
   on the parent process.  Subsequent SIGHUP signals
   have no effect.
   
   Parent signal assignment:
    $SIG{HUP}  = \&HUPSMAN;
   
   Child signal assignment:
    none (nothing happens)
   
   Command-line invocations:
    B<kill> B<-s> SIGHUP I<PID>
   
   Subroutine B<HUPSMAN>:
    This is only invoked for the B<lond> parent I<PID>,
   This kills all the children, and then the parent.
   The B<lond.pid> file is cleared.
   
   =item *
   
   SIGUSR1
   
   Parent signal assignment:
    $SIG{USR1} = \&USRMAN;
   
   Child signal assignment:
    $SIG{USR1}= \&logstatus;
   
   Command-line invocations:
    B<kill> B<-s> SIGUSR1 I<PID>
   
   Subroutine B<USRMAN>:
    When invoked for the B<lond> parent I<PID>,
   SIGUSR1 is sent to all the children, and the status of
   each connection is logged.
   
   =item *
   
   SIGCHLD
   
   Parent signal assignment:
    $SIG{CHLD} = \&REAPER;
   
   Child signal assignment:
    none
   
   Command-line invocations:
    B<kill> B<-s> SIGCHLD I<PID>
   
   Subroutine B<REAPER>:
    This is only invoked for the B<lond> parent I<PID>.
   Information pertaining to the child is removed.
   The socket port is cleaned up.
   
   =back
   
   B<SERVER-SIDE ACTIVITIES>
   
   Server-side information can be accepted in an encrypted or non-encrypted
   method.
   
   =over 4
   
   =item ping
   
   Query a client in the hosts.tab table; "Are you there?"
   
   =item pong
   
   Respond to a ping query.
   
   =item ekey
   
   Read in encrypted key, make cipher.  Respond with a buildkey.
   
   =item load
   
   Respond with CPU load based on a computation upon /proc/loadavg.
   
   =item currentauth
   
   Reply with current authentication information (only over an
   encrypted channel).
   
   =item auth
   
   Only over an encrypted channel, reply as to whether a user's
   authentication information can be validated.
   
   =item passwd
   
   Allow for a password to be set.
   
   =item makeuser
   
   Make a user.
   
   =item passwd
   
   Allow for authentication mechanism and password to be changed.
   
   =item home
   
   Respond to a question "are you the home for a given user?"
   
   =item update
   
   Update contents of a subscribed resource.
   
   =item unsubscribe
   
   The server is unsubscribing from a resource.
   
   =item subscribe
   
   The server is subscribing to a resource.
   
   =item log
   
   Place in B<logs/lond.log>
   
   =item put
   
   stores hash in namespace
   
   =item rolesput
   
   put a role into a user's environment
   
   =item get
   
   returns hash with keys from array
   reference filled in from namespace
   
   =item eget
   
   returns hash with keys from array
   reference filled in from namesp (encrypts the return communication)
   
   =item rolesget
   
   get a role from a user's environment
   
   =item del
   
   deletes keys out of array from namespace
   
   =item keys
   
   returns namespace keys
   
   =item dump
   
   dumps the complete (or key matching regexp) namespace into a hash
   
   =item store
   
   stores hash permanently
   for this url; hashref needs to be given and should be a \%hashname; the
   remaining args aren't required and if they aren't passed or are '' they will
   be derived from the ENV
   
   =item restore
   
   returns a hash for a given url
   
   =item querysend
   
   Tells client about the lonsql process that has been launched in response
   to a sent query.
   
   =item queryreply
   
   Accept information from lonsql and make appropriate storage in temporary
   file space.
   
   =item idput
   
   Defines usernames as corresponding to IDs.  (These "IDs" are unique identifiers
   for each student, defined perhaps by the institutional Registrar.)
   
   =item idget
   
   Returns usernames corresponding to IDs.  (These "IDs" are unique identifiers
   for each student, defined perhaps by the institutional Registrar.)
   
   =item tmpput
   
   Accept and store information in temporary space.
   
   =item tmpget
   
   Send along temporarily stored information.
   
   =item ls
   
   List part of a user's directory.
   
   =item Hanging up (exit or init)
   
   What to do when a client tells the server that they (the client)
   are leaving the network.
   
   =item unknown command
   
   If B<lond> is sent an unknown command (not in the list above),
   it replys to the client "unknown_cmd".
   
   =item UNKNOWN CLIENT
   
   If the anti-spoofing algorithm cannot verify the client,
   the client is rejected (with a "refused" message sent
   to the client, and the connection is closed.
   
   =back
   
   =head1 PREREQUISITES
   
   IO::Socket
   IO::File
   Apache::File
   Symbol
   POSIX
   Crypt::IDEA
   LWP::UserAgent()
   GDBM_File
   Authen::Krb4
   
   =head1 COREQUISITES
   
   =head1 OSNAMES
   
   linux
   
   =head1 SCRIPT CATEGORIES
   
   Server/Process
   
   =cut
Removed from v.1.60  
changed lines
  Added in v.1.89

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