--- loncom/lond 2002/09/03 02:02:50 1.90.2.1 +++ loncom/lond 2003/03/13 21:01:52 1.113 @@ -2,7 +2,7 @@ # The LearningOnline Network # lond "LON Daemon" Server (port "LOND" 5663) # -# $Id: lond,v 1.90.2.1 2002/09/03 02:02:50 albertel Exp $ +# $Id: lond,v 1.113 2003/03/13 21:01:52 albertel Exp $ # # Copyright Michigan State University Board of Trustees # @@ -31,36 +31,27 @@ # 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, # 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 -# 12/05 Scott Harrison # 12/05,12/13,12/29 Gerd Kortemeyer # YEAR=2001 -# Jan 01 Scott Harrison # 02/12 Gerd Kortemeyer -# 03/15 Scott Harrison # 03/24 Gerd Kortemeyer -# 04/02 Scott Harrison # 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 -# 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 +# 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 LONCAPA::Configuration; @@ -74,6 +65,7 @@ use Crypt::IDEA; use LWP::UserAgent(); use GDBM_File; use Authen::Krb4; +use Authen::Krb5; use lib '/home/httpd/lib/perl/'; use localauth; @@ -82,6 +74,68 @@ my $DEBUG = 0; # Non zero to ena my $status=''; my $lastlog=''; +# +# The array below are password error strings." +# +my $lastpwderror = 13; # Largest error number from lcpasswd. +my @passwderrors = ("ok", + "lcpasswd must be run as user 'www'", + "lcpasswd got incorrect number of arguments", + "lcpasswd did not get the right nubmer of input text lines", + "lcpasswd too many simultaneous pwd changes in progress", + "lcpasswd User does not exist.", + "lcpasswd Incorrect current passwd", + "lcpasswd Unable to su to root.", + "lcpasswd Cannot set new passwd.", + "lcpasswd Username has invalid characters", + "lcpasswd Invalid characters in password", + "11", "12", + "lcpasswd Password mismatch"); + + +# The array below are lcuseradd error strings.: + +my $lastadderror = 13; +my @adderrors = ("ok", + "User ID mismatch, lcuseradd must run as user www", + "lcuseradd Incorrect number of command line parameters must be 3", + "lcuseradd Incorrect number of stdinput lines, must be 3", + "lcuseradd Too many other simultaneous pwd changes in progress", + "lcuseradd User does not exist", + "lcuseradd Unabel to mak ewww member of users's group", + "lcuseradd Unable to su to root", + "lcuseradd Unable to set password", + "lcuseradd Usrname has invbalid charcters", + "lcuseradd Password has an invalid character", + "lcuseradd User already exists", + "lcuseradd Could not add user.", + "lcuseradd Password mismatch"); + + +# +# Convert an error return code from lcpasswd to a string value. +# +sub lcpasswdstrerror { + my $ErrorCode = shift; + if(($ErrorCode < 0) || ($ErrorCode > $lastpwderror)) { + return "lcpasswd Unrecognized error return value ".$ErrorCode; + } else { + return $passwderrors[$ErrorCode]; + } +} + +# +# Convert an error return code from lcuseradd to a string value: +# +sub lcuseraddstrerror { + my $ErrorCode = shift; + if(($ErrorCode < 0) || ($ErrorCode > $lastadderror)) { + return "lcuseradd - Unrecognized error code: ".$ErrorCode; + } else { + return $adderrors[$ErrorCode]; + } +} + # grabs exception and records it to log before exiting sub catchexception { my ($error)=@_; @@ -106,9 +160,8 @@ $SIG{'QUIT'}=\&catchexception; $SIG{__DIE__}=\&catchexception; # ---------------------------------- Read loncapa_apache.conf and loncapa.conf -&status("Read loncapa_apache.conf and loncapa.conf"); -my $perlvarref=LONCAPA::Configuration::read_conf('loncapa_apache.conf', - 'loncapa.conf'); +&status("Read loncapa.conf and loncapa_apache.conf"); +my $perlvarref=LONCAPA::Configuration::read_conf('loncapa.conf'); my %perlvar=%{$perlvarref}; undef $perlvarref; @@ -210,17 +263,25 @@ sub checkchildren { } } sleep 5; + $SIG{ALRM} = sub { die "timeout" }; + $SIG{__DIE__} = 'DEFAULT'; foreach (sort keys %children) { unless (-e "$docdir/lon-status/londchld/$_.txt") { + eval { + alarm(300); &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.$_` + $result=`/bin/cp $execdir/logs/lond.log $execdir/logs/lond.log.$_`; + alarm(0); + } } } + $SIG{ALRM} = 'DEFAULT'; + $SIG{__DIE__} = \&cathcexception; } # --------------------------------------------------------------------- Logging @@ -278,6 +339,7 @@ sub status { my $now=time; my $local=localtime($now); $status=$local.': '.$what; + $0='lond: '.$what.' '.$local; } # -------------------------------------------------------- Escape Special Chars @@ -428,37 +490,35 @@ close(PIDSAVE); &logthis("CRITICAL: ---------- Starting ----------"); &status('Starting'); -# ------------------------------------------------------- Now we are on our own - -# Fork off our children. -for (1 .. $PREFORK) { - make_new_child(); -} + # ----------------------------------------------------- Install signal handlers -&status('Forked children'); $SIG{CHLD} = \&REAPER; $SIG{INT} = $SIG{TERM} = \&HUNTSMAN; $SIG{HUP} = \&HUPSMAN; $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) { - &status('Sleeping'); - sleep; # wait for a signal (i.e., child's death) - &logthis('Woke up'); - &status('Woke up'); - for ($i = $children; $i < $PREFORK; $i++) { - make_new_child(); # top up the child pool - } + $client = $server->accept() or next; + make_new_child($client); } sub make_new_child { + my $client; my $pid; my $cipher; my $sigset; + + $client = shift; &logthis("Attempting to start child"); # block signal for fork $sigset = POSIX::SigSet->new(SIGINT); @@ -488,11 +548,10 @@ sub make_new_child { or die "Can't unblock SIGINT for fork: $!\n"; $tmpsnum=0; - - # 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; +#---------------------------------------------------- kerberos 5 initialization + &Authen::Krb5::init_context(); + &Authen::Krb5::init_ets(); + &status('Accepted connection'); # ============================================================================= # do something with the connection @@ -500,7 +559,7 @@ sub make_new_child { $client->sockopt(SO_KEEPALIVE, 1);# Enable monitoring of # connection liveness. # 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 $clientip=inet_ntoa($iaddr); my $clientrec=($hostid{$clientip} ne undef); @@ -630,15 +689,22 @@ sub make_new_child { my ($howpwd,$contentpwd)=split(/:/,$realpasswd); my $pwdcorrect=0; if ($howpwd eq 'internal') { + &Debug("Internal auth"); $pwdcorrect= (crypt($upass,$contentpwd) eq $contentpwd); } elsif ($howpwd eq 'unix') { - $contentpwd=(getpwnam($uname))[1]; - my $pwauth_path="/usr/local/sbin/pwauth"; - unless ($contentpwd eq 'x') { - $pwdcorrect= - (crypt($upass,$contentpwd) eq $contentpwd); - } + &Debug("Unix auth"); + if((getpwnam($uname))[1] eq "") { #no such user! + $pwdcorrect = 0; + } else { + $contentpwd=(getpwnam($uname))[1]; + 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"; @@ -646,14 +712,41 @@ sub make_new_child { close PWAUTH; $pwdcorrect=!$?; } + } } elsif ($howpwd eq 'krb4') { - $null=pack("C",0); - unless ($upass=~/$null/) { - $pwdcorrect=( - Authen::Krb4::get_pw_in_tkt($uname,"", - $contentpwd,'krbtgt',$contentpwd,1, - $upass) == 0); - } else { $pwdcorrect=0; } + $null=pack("C",0); + unless ($upass=~/$null/) { + my $krb4_error = &Authen::Krb4::get_pw_in_tkt + ($uname,"",$contentpwd,'krbtgt', + $contentpwd,1,$upass); + if (!$krb4_error) { + $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') { + $null=pack("C",0); + unless ($upass=~/$null/) { + my $krbclient=&Authen::Krb5::parse_name($uname.'@'.$contentpwd); + my $krbservice="krbtgt/".$contentpwd."\@".$contentpwd; + my $krbserver=&Authen::Krb5::parse_name($krbservice); + my $credentials=&Authen::Krb5::cc_default(); + $credentials->initialize($krbclient); + my $krbreturn = + &Authen::Krb5::get_in_tkt_with_password( + $krbclient,$krbserver,$upass,$credentials); +# unless ($krbreturn) { +# &logthis("Krb5 Error: ". +# &Authen::Krb5::error()); +# } + $pwdcorrect = ($krbreturn == 1); + } else { $pwdcorrect=0; } } elsif ($howpwd eq 'localauth') { $pwdcorrect=&localauth::localauth($uname,$upass, $contentpwd); @@ -677,7 +770,7 @@ sub make_new_child { chomp($npass); $upass=&unescape($upass); $npass=&unescape($npass); - &logthis("Trying to change password for $uname"); + &Debug("Trying to change password for $uname"); my $proname=propath($udom,$uname); my $passfilename="$proname/passwd"; if (-e $passfilename) { @@ -687,6 +780,7 @@ sub make_new_child { chomp($realpasswd); my ($howpwd,$contentpwd)=split(/:/,$realpasswd); if ($howpwd eq 'internal') { + &Debug("internal auth"); if (crypt($upass,$contentpwd) eq $contentpwd) { my $salt=time; $salt=substr($salt,6,2); @@ -703,6 +797,7 @@ sub make_new_child { # one way or another. # First: Make sure the current password is # correct + &Debug("auth is unix"); $contentpwd=(getpwnam($uname))[1]; my $pwdcorrect = "0"; my $pwauth_path="/usr/local/sbin/pwauth"; @@ -714,16 +809,20 @@ sub make_new_child { die "Cannot invoke authentication"; print PWAUTH "$uname\n$upass\n"; close PWAUTH; - $pwdcorrect=!$?; + &Debug("exited pwauth with $? ($uname,$upass) "); + $pwdcorrect=($? == 0); } if ($pwdcorrect) { my $execdir=$perlvar{'lonDaemons'}; - my $pf = IO::File->new("|$execdir/lcpasswd"); + &Debug("Opening lcpasswd pipeline"); + my $pf = IO::File->new("|$execdir/lcpasswd > /home/www/lcpasswd.log"); print $pf "$uname\n$npass\n$npass\n"; close $pf; - my $result = ($?>0 ? 'pwchange_failure' + my $err = $?; + my $result = ($err>0 ? 'pwchange_failure' : 'ok'); - &logthis("Result of password change for $uname: $result"); + &logthis("Result of password change for $uname: ". + &lcpasswdstrerror($?)); print $client "$result\n"; } else { print $client "non_authorized\n"; @@ -739,7 +838,7 @@ sub make_new_child { } # -------------------------------------------------------------------- makeuser } elsif ($userinput =~ /^makeuser/) { - Debug("Make user received"); + &Debug("Make user received"); my $oldumask=umask(0077); if ($wasenc==1) { my @@ -764,58 +863,16 @@ sub make_new_child { $fpnow.='/'.$fpparts[$i]; unless (-e $fpnow) { unless (mkdir($fpnow,0777)) { - $fperror="error:$!"; + $fperror="error: ".($!+0) + ." mkdir failed while attempting " + ."makeuser\n"; } } } unless ($fperror) { - if ($umode eq 'krb4') { - { - my $pf = IO::File->new(">$passfilename"); - print $pf "krb4:$npass\n"; - } - print $client "ok\n"; - } elsif ($umode eq 'internal') { - my $salt=time; - $salt=substr($salt,6,2); - my $ncpass=crypt($npass,$salt); - { - &Debug("Creating internal auth"); - my $pf = IO::File->new(">$passfilename"); - print $pf "internal:$ncpass\n"; - } - print $client "ok\n"; - } elsif ($umode eq 'localauth') { - { - my $pf = IO::File->new(">$passfilename"); - print $pf "localauth:$npass\n"; - } - print $client "ok\n"; - } elsif ($umode eq 'unix') { - { - my $execpath="$perlvar{'lonDaemons'}/". - "lcuseradd"; - { - &Debug("Executing external: ". - $execpath); - my $se = IO::File->new("|$execpath"); - print $se "$uname\n"; - print $se "$npass\n"; - print $se "$npass\n"; - } - my $pf = IO::File->new(">$passfilename"); - print $pf "unix:\n"; - } - print $client "ok\n"; - } elsif ($umode eq 'none') { - { - my $pf = IO::File->new(">$passfilename"); - print $pf "none:\n"; - } - print $client "ok\n"; - } else { - print $client "auth_mode_error\n"; - } + my $result=&make_passwd_file($uname, $umode,$npass, + $passfilename); + print $client $result; } else { print $client "$fperror\n"; } @@ -829,60 +886,19 @@ sub make_new_child { &Debug("Changing authorization"); if ($wasenc==1) { my - ($cmd,$udom,$uname,$umode,$npass)=split(/:/,$userinput); + ($cmd,$udom,$uname,$umode,$npass)=split(/:/,$userinput); chomp($npass); &Debug("cmd = ".$cmd." domain= ".$udom. "uname =".$uname." umode= ".$umode); $npass=&unescape($npass); - my $proname=propath($udom,$uname); + my $proname=&propath($udom,$uname); my $passfilename="$proname/passwd"; if ($udom ne $perlvar{'lonDefDomain'}) { print $client "not_right_domain\n"; } else { - if ($umode eq 'krb4') { - { - my $pf = IO::File->new(">$passfilename"); - print $pf "krb4:$npass\n"; - } - print $client "ok\n"; - } elsif ($umode eq 'internal') { - my $salt=time; - $salt=substr($salt,6,2); - my $ncpass=crypt($npass,$salt); - { - my $pf = IO::File->new(">$passfilename"); - print $pf "internal:$ncpass\n"; - } - print $client "ok\n"; - } elsif ($umode eq 'localauth') { - { - my $pf = IO::File->new(">$passfilename"); - print $pf "localauth:$npass\n"; - } - print $client "ok\n"; - } elsif ($umode eq 'unix') { - { - my $execpath="$perlvar{'lonDaemons'}/". - "lcuseradd"; - { - my $se = IO::File->new("|$execpath"); - print $se "$uname\n"; - print $se "$npass\n"; - print $se "$npass\n"; - } - my $pf = IO::File->new(">$passfilename"); - print $pf "unix:\n"; - } - print $client "ok\n"; - } elsif ($umode eq 'none') { - { - my $pf = IO::File->new(">$passfilename"); - print $pf "none:\n"; - } - print $client "ok\n"; - } else { - print $client "auth_mode_error\n"; - } + my $result=&make_passwd_file($uname, $umode,$npass, + $passfilename); + print $client $result; } } else { print $client "refused\n"; @@ -1004,6 +1020,10 @@ sub make_new_child { # ------------------------------------------------------------------- subscribe } elsif ($userinput =~ /^sub/) { print $client &subscribe($userinput,$clientip); +# ------------------------------------------------------------- current version + } elsif ($userinput =~ /^currentversion/) { + my ($cmd,$fname)=split(/:/,$userinput); + print $client ¤tversion($fname)."\n"; # ------------------------------------------------------------------------- log } elsif ($userinput =~ /^log/) { my ($cmd,$udom,$uname,$what)=split(/:/,$userinput); @@ -1016,7 +1036,9 @@ sub make_new_child { print $hfh "$now:$hostid{$clientip}:$what\n"; print $client "ok\n"; } else { - print $client "error:$!\n"; + print $client "error: ".($!+0) + ." IO::File->new Failed " + ."while attempting log\n"; } } # ------------------------------------------------------------------------- put @@ -1044,10 +1066,14 @@ sub make_new_child { if (untie(%hash)) { print $client "ok\n"; } else { - print $client "error:$!\n"; + print $client "error: ".($!+0) + ." untie(GDBM) failed ". + "while attempting put\n"; } } else { - print $client "error:$!\n"; + print $client "error: ".($!) + ." tie(GDBM) Failed ". + "while attempting put\n"; } } else { print $client "refused\n"; @@ -1086,10 +1112,14 @@ sub make_new_child { if (untie(%hash)) { print $client "ok\n"; } else { - print $client "error:$!\n"; + print $client "error: ".($!+0) + ." untie(GDBM) Failed ". + "while attempting rolesput\n"; } } else { - print $client "error:$!\n"; + print $client "error: ".($!+0) + ." tie(GDBM) Failed ". + "while attempting rolesput\n"; } } else { print $client "refused\n"; @@ -1112,10 +1142,19 @@ sub make_new_child { $qresult=~s/\&$//; print $client "$qresult\n"; } else { - print $client "error:$!\n"; + print $client "error: ".($!+0) + ." untie(GDBM) Failed ". + "while attempting get\n"; } } else { - print $client "error:$!\n"; + if ($!+0 == 2) { + print $client "error:No such file or ". + "GDBM reported bad block error\n"; + } else { + print $client "error: ".($!+0) + ." tie(GDBM) Failed ". + "while attempting get\n"; + } } # ------------------------------------------------------------------------ eget } elsif ($userinput =~ /^eget/) { @@ -1148,10 +1187,14 @@ sub make_new_child { print $client "error:no_key\n"; } } else { - print $client "error:$!\n"; + print $client "error: ".($!+0) + ." untie(GDBM) Failed ". + "while attempting eget\n"; } } else { - print $client "error:$!\n"; + print $client "error: ".($!+0) + ." tie(GDBM) Failed ". + "while attempting eget\n"; } # ------------------------------------------------------------------------- del } elsif ($userinput =~ /^del/) { @@ -1176,10 +1219,14 @@ sub make_new_child { if (untie(%hash)) { print $client "ok\n"; } else { - print $client "error:$!\n"; + print $client "error: ".($!+0) + ." untie(GDBM) Failed ". + "while attempting del\n"; } } else { - print $client "error:$!\n"; + print $client "error: ".($!+0) + ." tie(GDBM) Failed ". + "while attempting del\n"; } # ------------------------------------------------------------------------ keys } elsif ($userinput =~ /^keys/) { @@ -1197,10 +1244,59 @@ sub make_new_child { $qresult=~s/\&$//; print $client "$qresult\n"; } else { - print $client "error:$!\n"; + print $client "error: ".($!+0) + ." untie(GDBM) Failed ". + "while attempting keys\n"; + } + } else { + print $client "error: ".($!+0) + ." tie(GDBM) Failed ". + "while attempting keys\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: ".($!+0) + ." untie(GDBM) Failed ". + "while attempting currentdump\n"; } } else { - print $client "error:$!\n"; + print $client "error: ".($!+0) + ." tie(GDBM) Failed ". + "while attempting currentdump\n"; } # ------------------------------------------------------------------------ dump } elsif ($userinput =~ /^dump/) { @@ -1213,24 +1309,32 @@ sub make_new_child { } else { $regexp='.'; } - my $proname=propath($udom,$uname); my $qresult=''; - if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER,0640)) { + my $proname=propath($udom,$uname); + if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER(),0640)) { study($regexp); - foreach $key (keys %hash) { - my $unescapeKey = &unescape($key); - if (eval('$unescapeKey=~/$regexp/')) { - $qresult.="$key=$hash{$key}&"; - } + while (($key,$value) = each(%hash)) { + if ($regexp eq '.') { + $qresult.=$key.'='.$value.'&'; + } else { + my $unescapeKey = &unescape($key); + if (eval('$unescapeKey=~/$regexp/')) { + $qresult.="$key=$value&"; + } + } } - if (untie(%hash)) { - $qresult=~s/\&$//; - print $client "$qresult\n"; + if (untie(%hash)) { + chop($qresult); + print $client "$qresult\n"; } else { - print $client "error:$!\n"; + print $client "error: ".($!+0) + ." untie(GDBM) Failed ". + "while attempting dump\n"; } } else { - print $client "error:$!\n"; + print $client "error: ".($!+0) + ." tie(GDBM) Failed ". + "while attempting dump\n"; } # ----------------------------------------------------------------------- store } elsif ($userinput =~ /^store/) { @@ -1267,10 +1371,14 @@ sub make_new_child { if (untie(%hash)) { print $client "ok\n"; } else { - print $client "error:$!\n"; + print $client "error: ".($!+0) + ." untie(GDBM) Failed ". + "while attempting store\n"; } } else { - print $client "error:$!\n"; + print $client "error: ".($!+0) + ." tie(GDBM) Failed ". + "while attempting store\n"; } } else { print $client "refused\n"; @@ -1301,10 +1409,14 @@ sub make_new_child { $qresult=~s/\&$//; print $client "$qresult\n"; } else { - print $client "error:$!\n"; + print $client "error: ".($!+0) + ." untie(GDBM) Failed ". + "while attempting restore\n"; } } else { - print $client "error:$!\n"; + print $client "error: ".($!+0) + ." tie(GDBM) Failed ". + "while attempting restore\n"; } # -------------------------------------------------------------------- chatsend } elsif ($userinput =~ /^chatsend/) { @@ -1343,7 +1455,9 @@ sub make_new_child { print $client "ok\n"; } else { - print $client "error:$!\n"; + print $client "error: ".($!+0) + ." IO::File->new Failed ". + "while attempting queryreply\n"; } # ----------------------------------------------------------------------- idput } elsif ($userinput =~ /^idput/) { @@ -1367,10 +1481,14 @@ sub make_new_child { if (untie(%hash)) { print $client "ok\n"; } else { - print $client "error:$!\n"; + print $client "error: ".($!+0) + ." untie(GDBM) Failed ". + "while attempting idput\n"; } } else { - print $client "error:$!\n"; + print $client "error: ".($!+0) + ." tie(GDBM) Failed ". + "while attempting idput\n"; } # ----------------------------------------------------------------------- idget } elsif ($userinput =~ /^idget/) { @@ -1388,10 +1506,14 @@ sub make_new_child { $qresult=~s/\&$//; print $client "$qresult\n"; } else { - print $client "error:$!\n"; + print $client "error: ".($!+0) + ." untie(GDBM) Failed ". + "while attempting idget\n"; } } else { - print $client "error:$!\n"; + print $client "error: ".($!+0) + ." tie(GDBM) Failed ". + "while attempting idget\n"; } # ---------------------------------------------------------------------- tmpput } elsif ($userinput =~ /^tmpput/) { @@ -1408,7 +1530,9 @@ sub make_new_child { print $client "$id\n"; } else { - print $client "error:$!\n"; + print $client "error: ".($!+0) + ."IO::File->new Failed ". + "while attempting tmpput\n"; } # ---------------------------------------------------------------------- tmpget @@ -1424,9 +1548,24 @@ sub make_new_child { close $store; } else { - print $client "error:$!\n"; + print $client "error: ".($!+0) + ."IO::File->new Failed ". + "while attempting tmpget\n"; } +# ---------------------------------------------------------------------- tmpdel + } elsif ($userinput =~ /^tmpdel/) { + my ($cmd,$id)=split(/:/,$userinput); + chomp($id); + $id=~s/\W/\_/g; + my $execdir=$perlvar{'lonDaemons'}; + if (unlink("$execdir/tmp/$id.tmp")) { + print $client "ok\n"; + } else { + print $client "error: ".($!+0) + ."Unlink tmp Failed ". + "while attempting tmpdel\n"; + } # -------------------------------------------------------------------------- ls } elsif ($userinput =~ /^ls/) { my ($cmd,$ulsdir)=split(/:/,$userinput); @@ -1475,21 +1614,19 @@ sub make_new_child { &logthis("WARNING: " ."Rejected client $clientip, closing connection"); } - } + } # ============================================================================= &logthis("CRITICAL: " ."Disconnect from $clientip ($hostid{$clientip})"); - # tidy up gracefully and finish - - $server->close(); + # this exit is VERY important, otherwise the child will become # a producer of more and more children, forking yourself into # process death. exit; - } + } @@ -1541,7 +1678,7 @@ sub GetAuthType my ($authtype, $contentpwd) = split(/:/, $realpassword); Debug("Authtype = $authtype, content = $contentpwd\n"); my $availinfo = ''; - if($authtype eq 'krb4') { + if($authtype eq 'krb4' or $authtype eq 'krb5') { $availinfo = $contentpwd; } @@ -1632,12 +1769,68 @@ sub unsub { return $result; } +sub currentversion { + my $fname=shift; + my $version=-1; + my $ulsdir=''; + if ($fname=~/^(.+)\/[^\/]+$/) { + $ulsdir=$1; + } + $fname=~s/\.\d+\.(\w+(?:\.meta)*)$/\.$1/; + $fname=~s/\.(\w+(?:\.meta)*)$/\.\(\\d\+\)\.$1\$/; + + if (-e $fname) { $version=1; } + if (-e $ulsdir) { + if(-d $ulsdir) { + if (opendir(LSDIR,$ulsdir)) { + while ($ulsfn=readdir(LSDIR)) { +# see if this is a regular file (ignore links produced earlier) + my $thisfile=$ulsdir.'/'.$ulsfn; + unless (-l $thisfile) { + if ($thisfile=~/$fname/) { + if ($1>$version) { $version=$1; } + } + } + } + closedir(LSDIR); + $version++; + } + } + } + return $version; +} + +sub thisversion { + my $fname=shift; + my $version=-1; + if ($fname=~/\.(\d+)\.\w+(?:\.meta)*$/) { + $version=$1; + } + return $version; +} + sub subscribe { my ($userinput,$clientip)=@_; my $result; my ($cmd,$fname)=split(/:/,$userinput); my $ownership=&ishome($fname); if ($ownership eq 'owner') { +# explitly asking for the current version? + unless (-e $fname) { + my $currentversion=¤tversion($fname); + if (&thisversion($fname)==$currentversion) { + if ($fname=~/^(.+)\.\d+\.(\w+(?:\.meta)*)$/) { + my $root=$1; + my $extension=$2; + symlink($root.'.'.$extension, + $root.'.'.$currentversion.'.'.$extension); + unless ($extension=~/\.meta$/) { + symlink($root.'.'.$extension.'.meta', + $root.'.'.$currentversion.'.'.$extension.'.meta'); + } + } + } + } if (-e $fname) { if (-d $fname) { $result="directory\n"; @@ -1663,6 +1856,58 @@ sub subscribe { } return $result; } + +sub make_passwd_file { + my ($uname, $umode,$npass,$passfilename)=@_; + my $result="ok\n"; + if ($umode eq 'krb4' or $umode eq 'krb5') { + { + my $pf = IO::File->new(">$passfilename"); + print $pf "$umode:$npass\n"; + } + } elsif ($umode eq 'internal') { + my $salt=time; + $salt=substr($salt,6,2); + my $ncpass=crypt($npass,$salt); + { + &Debug("Creating internal auth"); + my $pf = IO::File->new(">$passfilename"); + print $pf "internal:$ncpass\n"; + } + } elsif ($umode eq 'localauth') { + { + my $pf = IO::File->new(">$passfilename"); + print $pf "localauth:$npass\n"; + } + } elsif ($umode eq 'unix') { + { + my $execpath="$perlvar{'lonDaemons'}/"."lcuseradd"; + { + &Debug("Executing external: ".$execpath); + &Debug("user = ".$uname.", Password =". $npass); + my $se = IO::File->new("|$execpath > /home/www/lcuseradd.log"); + print $se "$uname\n"; + print $se "$npass\n"; + print $se "$npass\n"; + } + my $useraddok = $?; + if($useraddok > 0) { + &logthis("Failed lcuseradd: ".&lcuseraddstrerror($useraddok)); + } + my $pf = IO::File->new(">$passfilename"); + print $pf "unix:\n"; + } + } elsif ($umode eq 'none') { + { + my $pf = IO::File->new(">$passfilename"); + print $pf "none:\n"; + } + } else { + $result="auth_mode_error\n"; + } + return $result; +} + # ----------------------------------- POD (plain old documentation, CPAN style) =head1 NAME @@ -1961,6 +2206,7 @@ Crypt::IDEA LWP::UserAgent() GDBM_File Authen::Krb4 +Authen::Krb5 =head1 COREQUISITES