--- loncom/lond 2002/07/17 19:06:30 1.83 +++ loncom/lond 2003/08/22 16:26:11 1.132.2.1 @@ -2,7 +2,7 @@ # The LearningOnline Network # lond "LON Daemon" Server (port "LOND" 5663) # -# $Id: lond,v 1.83 2002/07/17 19:06:30 stredwic Exp $ +# $Id: lond,v 1.132.2.1 2003/08/22 16:26:11 albertel Exp $ # # Copyright Michigan State University Board of Trustees # @@ -31,49 +31,40 @@ # 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; use IO::Socket; use IO::File; -use Apache::File; +#use Apache::File; use Symbol; use POSIX; 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 +73,72 @@ my $DEBUG = 0; # Non zero to ena my $status=''; my $lastlog=''; +my $VERSION='$Revision: 1.132.2.1 $'; #' stupid emacs +my $remoteVERSION; +my $currenthostid; +my $currentdomainid; +# +# 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 +163,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; @@ -116,7 +172,7 @@ undef $perlvarref; my $wwwid=getpwnam('www'); if ($wwwid!=$<) { $emailto="$perlvar{'lonAdmEMail'},$perlvar{'lonSysEMail'}"; - $subj="LON: $perlvar{'lonHostID'} User ID mismatch"; + $subj="LON: $currenthostid User ID mismatch"; system("echo 'User ID mismatch. lond must be run as user www.' |\ mailto $emailto -s '$subj' > /dev/null"); exit 1; @@ -143,6 +199,8 @@ while ($configline=) { my ($id,$domain,$role,$name,$ip)=split(/:/,$configline); chomp($ip); $ip=~s/\D+$//; $hostid{$ip}=$id; + $hostdom{$id}=$domain; + $hostip{$id}=$ip; if ($id eq $perlvar{'lonHostID'}) { $thisserver=$name; } $PREFORK++; } @@ -210,17 +268,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.$_` + #$emailto="$perlvar{'lonAdmEMail'},$perlvar{'lonSysEMail'}"; + #$subj="LON: $currenthostid 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.$_`; + alarm(0); + } } } + $SIG{ALRM} = 'DEFAULT'; + $SIG{__DIE__} = \&cathcexception; } # --------------------------------------------------------------------- Logging @@ -248,7 +314,7 @@ sub logstatus { my $docdir=$perlvar{'lonDocRoot'}; { my $fh=IO::File->new(">>$docdir/lon-status/londstatus.txt"); - print $fh $$."\t".$status."\t".$lastlog."\n"; + print $fh $$."\t".$currenthostid."\t".$status."\t".$lastlog."\n"; $fh->close(); } { @@ -278,6 +344,7 @@ sub status { my $now=time; my $local=localtime($now); $status=$local.': '.$what; + $0='lond: '.$what.' '.$local; } # -------------------------------------------------------- Escape Special Chars @@ -308,13 +375,6 @@ sub reconlonc { if (kill 0 => $loncpid) { &logthis("lonc at pid $loncpid responding, sending USR1"); kill USR1 => $loncpid; - sleep 5; - if (-e "$peerfile") { return; } - &logthis("$peerfile still not there, give it another try"); - sleep 10; - if (-e "$peerfile") { return; } - &logthis( - "WARNING: $peerfile still not there, giving up"); } else { &logthis( "CRITICAL: " @@ -344,12 +404,12 @@ sub subreply { sub reply { my ($cmd,$server)=@_; my $answer; - if ($server ne $perlvar{'lonHostID'}) { + if ($server ne $currenthostid) { $answer=subreply($cmd,$server); if ($answer eq 'con_lost') { $answer=subreply("ping",$server); if ($answer ne $server) { - &logthis("sub reply: answer != server"); + &logthis("sub reply: answer != server answer is $answer, server is $server"); &reconlonc("$perlvar{'lonSockDir'}/$server"); } $answer=subreply($cmd,$server); @@ -428,37 +488,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); @@ -478,6 +536,8 @@ sub make_new_child { } else { # Child can *not* return from this subroutine. $SIG{INT} = 'DEFAULT'; # make SIGINT kill us as it did before + $SIG{CHLD} = 'DEFAULT'; #make this default so that pwauth returns + #don't get intercepted $SIG{USR1}= \&logstatus; $SIG{ALRM}= \&timeout; $lastlog='Forked '; @@ -488,30 +548,32 @@ 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 # ----------------------------------------------------------------------------- + $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); &logthis( -"INFO: Connection $i, $clientip ($hostid{$clientip})" +"INFO: Connection, $clientip ($hostid{$clientip})" ); &status("Connecting $clientip ($hostid{$clientip})"); my $clientok; if ($clientrec) { &status("Waiting for init from $clientip ($hostid{$clientip})"); my $remotereq=<$client>; - $remotereq=~s/\W//g; - if ($remotereq eq 'init') { + $remotereq=~s/[^\w:]//g; + if ($remotereq =~ /^init/) { + &sethost("sethost:$perlvar{'lonHostID'}"); my $challenge="$$".time; print $client "$challenge\n"; &status( @@ -540,9 +602,15 @@ sub make_new_child { if ($clientok) { # ---------------- New known client connecting, could mean machine online again - &reconlonc("$perlvar{'lonSockDir'}/$hostid{$clientip}"); - &logthis( - "Established connection: $hostid{$clientip}"); + foreach my $id (keys(%hostip)) { + if ($hostip{$id} ne $clientip || + $hostip{$currenthostid} eq $clientip) { + # no need to try to do recon's to myself + next; + } + &reconlonc("$perlvar{'lonSockDir'}/$id"); + } + &logthis("Established connection: $hostid{$clientip}"); &status('Will listen to '.$hostid{$clientip}); # ------------------------------------------------------------ Process requests while (my $userinput=<$client>) { @@ -570,17 +638,17 @@ sub make_new_child { # ------------------------------------------------------------- Normal commands # ------------------------------------------------------------------------ ping if ($userinput =~ /^ping/) { - print $client "$perlvar{'lonHostID'}\n"; + print $client "$currenthostid\n"; # ------------------------------------------------------------------------ pong } elsif ($userinput =~ /^pong/) { $reply=reply("ping",$hostid{$clientip}); - print $client "$perlvar{'lonHostID'}:$reply\n"; + print $client "$currenthostid:$reply\n"; # ------------------------------------------------------------------------ ekey } elsif ($userinput =~ /^ekey/) { my $buildkey=time.$$.int(rand 100000); $buildkey=~tr/1-6/A-F/; $buildkey=int(rand 100000).$buildkey.int(rand 100000); - my $key=$perlvar{'lonHostID'}.$hostid{$clientip}; + my $key=$currenthostid.$hostid{$clientip}; $key=~tr/a-z/A-Z/; $key=~tr/G-P/0-9/; $key=~tr/Q-Z/0-9/; @@ -597,8 +665,12 @@ sub make_new_child { $loadavg=<$loadfile>; } $loadavg =~ s/\s.*//g; - my $loadpercent=100*$loadavg/$perlvar{'lonLoadLim'}; + my $loadpercent=100*$loadavg/$perlvar{'lonLoadLim'}; print $client "$loadpercent\n"; +# -------------------------------------------------------------------- userload + } elsif ($userinput =~ /^userload/) { + my $userloadpercent=&userload(); + print $client "$userloadpercent\n"; # ----------------------------------------------------------------- currentauth } elsif ($userinput =~ /^currentauth/) { if ($wasenc==1) { @@ -628,15 +700,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"; @@ -644,14 +723,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); @@ -675,7 +781,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) { @@ -685,6 +791,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); @@ -701,6 +808,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"; @@ -712,16 +820,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 > $perlvar{'lonDaemons'}/logs/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"; @@ -737,7 +849,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 @@ -752,7 +864,7 @@ sub make_new_child { $passfilename); if (-e $passfilename) { print $client "already_exists\n"; - } elsif ($udom ne $perlvar{'lonDefDomain'}) { + } elsif ($udom ne $currentdomainid) { print $client "not_right_domain\n"; } else { @fpparts=split(/\//,$proname); @@ -762,58 +874,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"; } @@ -827,60 +897,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'}) { + if ($udom ne $currentdomainid) { 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"; @@ -947,48 +976,65 @@ sub make_new_child { } else { 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=) { + if ($line=~/userfile\.$fname\=/) { $reply='ok'; } + } + close(ENVIN); + print $client $reply."\n"; + } else { + print $client "invalid_token\n"; + } # ----------------------------------------------------------------- unsubscribe } elsif ($userinput =~ /^unsub/) { my ($cmd,$fname)=split(/:/,$userinput); if (-e $fname) { - if (unlink("$fname.$hostid{$clientip}")) { - print $client "ok\n"; - } else { - print $client "not_subscribed\n"; - } + print $client &unsub($client,$fname,$clientip); } else { print $client "not_found\n"; } # ------------------------------------------------------------------- subscribe } elsif ($userinput =~ /^sub/) { + print $client &subscribe($userinput,$clientip); +# ------------------------------------------------------------- current version + } elsif ($userinput =~ /^currentversion/) { my ($cmd,$fname)=split(/:/,$userinput); - 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"; - } + print $client ¤tversion($fname)."\n"; # ------------------------------------------------------------------------- log } elsif ($userinput =~ /^log/) { my ($cmd,$udom,$uname,$what)=split(/:/,$userinput); @@ -1001,7 +1047,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 @@ -1021,7 +1069,7 @@ sub make_new_child { ) { print $hfh "P:$now:$what\n"; } } my @pairs=split(/\&/,$what); - 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) { ($key,$value)=split(/=/,$pair); $hash{$key}=$value; @@ -1029,10 +1077,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"; @@ -1059,7 +1111,7 @@ sub make_new_child { } } my @pairs=split(/\&/,$what); - 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) { ($key,$value)=split(/=/,$pair); &ManagePermissions($key, $udom, $uname, @@ -1071,10 +1123,56 @@ 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"; + } +# -------------------------------------------------------------------- rolesdel + } elsif ($userinput =~ /^rolesdel/) { + &Debug("rolesdel"); + if ($wasenc==1) { + my ($cmd,$exedom,$exeuser,$udom,$uname,$what) + =split(/:/,$userinput); + &Debug("cmd = ".$cmd." exedom= ".$exedom. + "user = ".$exeuser." udom=".$udom. + "what = ".$what); + my $namespace='roles'; + chomp($what); + my $proname=propath($udom,$uname); + my $now=time; + { + my $hfh; + if ( + $hfh=IO::File->new(">>$proname/$namespace.hist") + ) { + print $hfh "D:$now:$exedom:$exeuser:$what\n"; + } + } + my @rolekeys=split(/\&/,$what); + if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT(),0640)) { + foreach $key (@rolekeys) { + delete $hash{$key}; + + } + if (untie(%hash)) { + print $client "ok\n"; + } else { + print $client "error: ".($!+0) + ." untie(GDBM) Failed ". + "while attempting rolesdel\n"; + } + } else { + print $client "error: ".($!+0) + ." tie(GDBM) Failed ". + "while attempting rolesdel\n"; } } else { print $client "refused\n"; @@ -1089,7 +1187,7 @@ sub make_new_child { my @queries=split(/\&/,$what); my $proname=propath($udom,$uname); my $qresult=''; - if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER,0640)) { + if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER(),0640)) { for ($i=0;$i<=$#queries;$i++) { $qresult.="$hash{$queries[$i]}&"; } @@ -1097,10 +1195,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/) { @@ -1112,7 +1219,7 @@ sub make_new_child { my @queries=split(/\&/,$what); my $proname=propath($udom,$uname); my $qresult=''; - if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER,0640)) { + if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER(),0640)) { for ($i=0;$i<=$#queries;$i++) { $qresult.="$hash{$queries[$i]}&"; } @@ -1133,10 +1240,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/) { @@ -1154,17 +1265,21 @@ sub make_new_child { ) { print $hfh "D:$now:$what\n"; } } my @keys=split(/\&/,$what); - if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT,0640)) { + if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT(),0640)) { foreach $key (@keys) { delete($hash{$key}); } 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/) { @@ -1174,7 +1289,7 @@ sub make_new_child { $namespace=~s/\W//g; my $proname=propath($udom,$uname); 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) { $qresult.="$key&"; } @@ -1182,10 +1297,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:$!\n"; + 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: ".($!+0) + ." tie(GDBM) Failed ". + "while attempting currentdump\n"; } # ------------------------------------------------------------------------ dump } elsif ($userinput =~ /^dump/) { @@ -1198,22 +1362,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)) { - foreach $key (keys %hash) { - if (eval('$key=~/$regexp/')) { - $qresult.="$key=$hash{$key}&"; - } + my $proname=propath($udom,$uname); + if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER(),0640)) { + study($regexp); + 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/) { @@ -1233,7 +1407,7 @@ sub make_new_child { } my @pairs=split(/\&/,$what); - if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT,0640)) { + if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT(),0640)) { my @previouskeys=split(/&/,$hash{"keys:$rid"}); my $key; $hash{"version:$rid"}++; @@ -1250,10 +1424,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"; @@ -1267,7 +1445,7 @@ sub make_new_child { chomp($rid); my $proname=propath($udom,$uname); my $qresult=''; - if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER,0640)) { + if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER(),0640)) { my $version=$hash{"version:$rid"}; $qresult.="version=$version&"; my $scope; @@ -1284,11 +1462,30 @@ 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/) { + my ($cmd,$cdom,$cnum,$newpost)=split(/\:/,$userinput); + &chatadd($cdom,$cnum,$newpost); + print $client "ok\n"; +# -------------------------------------------------------------------- chatretr + } elsif ($userinput =~ /^chatretr/) { + my + ($cmd,$cdom,$cnum,$udom,$uname)=split(/\:/,$userinput); + my $reply=''; + foreach (&getchat($cdom,$cnum,$udom,$uname)) { + $reply.=&escape($_).':'; + } + $reply=~s/\:$//; + print $client $reply."\n"; # ------------------------------------------------------------------- querysend } elsif ($userinput =~ /^querysend/) { my ($cmd,$query, @@ -1312,8 +1509,75 @@ 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"; } +# ----------------------------------------------------------------- courseidput + } elsif ($userinput =~ /^courseidput/) { + my ($cmd,$udom,$what)=split(/:/,$userinput); + chomp($what); + $udom=~s/\W//g; + my $proname= + "$perlvar{'lonUsersDir'}/$udom/nohist_courseids"; + my $now=time; + my @pairs=split(/\&/,$what); + if (tie(%hash,'GDBM_File',"$proname.db",&GDBM_WRCREAT(),0640)) { + foreach $pair (@pairs) { + ($key,$value)=split(/=/,$pair); + $hash{$key}=$value.':'.$now; + } + if (untie(%hash)) { + print $client "ok\n"; + } else { + print $client "error: ".($!+0) + ." untie(GDBM) Failed ". + "while attempting courseidput\n"; + } + } else { + print $client "error: ".($!+0) + ." tie(GDBM) Failed ". + "while attempting courseidput\n"; + } +# ---------------------------------------------------------------- courseiddump + } elsif ($userinput =~ /^courseiddump/) { + my ($cmd,$udom,$since,$description) + =split(/:/,$userinput); + if (defined($description)) { + $description=&unescape($description); + } else { + $description='.'; + } + unless (defined($since)) { $since=0; } + my $qresult=''; + my $proname= + "$perlvar{'lonUsersDir'}/$udom/nohist_courseids"; + if (tie(%hash,'GDBM_File',"$proname.db",&GDBM_READER(),0640)) { + while (($key,$value) = each(%hash)) { + my ($descr,$lasttime)=split(/\:/,$value); + if ($lasttime<$since) { next; } + if ($regexp eq '.') { + $qresult.=$key.'='.$descr.'&'; + } else { + my $unescapeVal = &unescape($descr); + if (eval('$unescapeVal=~/$description/i')) { + $qresult.="$key=$descr&"; + } + } + } + if (untie(%hash)) { + chop($qresult); + print $client "$qresult\n"; + } else { + print $client "error: ".($!+0) + ." untie(GDBM) Failed ". + "while attempting courseiddump\n"; + } + } else { + print $client "error: ".($!+0) + ." tie(GDBM) Failed ". + "while attempting courseiddump\n"; + } # ----------------------------------------------------------------------- idput } elsif ($userinput =~ /^idput/) { my ($cmd,$udom,$what)=split(/:/,$userinput); @@ -1328,7 +1592,7 @@ sub make_new_child { ) { print $hfh "P:$now:$what\n"; } } my @pairs=split(/\&/,$what); - if (tie(%hash,'GDBM_File',"$proname.db",&GDBM_WRCREAT,0640)) { + if (tie(%hash,'GDBM_File',"$proname.db",&GDBM_WRCREAT(),0640)) { foreach $pair (@pairs) { ($key,$value)=split(/=/,$pair); $hash{$key}=$value; @@ -1336,10 +1600,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/) { @@ -1349,7 +1617,7 @@ sub make_new_child { my $proname="$perlvar{'lonUsersDir'}/$udom/ids"; my @queries=split(/\&/,$what); my $qresult=''; - if (tie(%hash,'GDBM_File',"$proname.db",&GDBM_READER,0640)) { + if (tie(%hash,'GDBM_File',"$proname.db",&GDBM_READER(),0640)) { for ($i=0;$i<=$#queries;$i++) { $qresult.="$hash{$queries[$i]}&"; } @@ -1357,10 +1625,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/) { @@ -1377,7 +1649,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 @@ -1393,9 +1667,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); @@ -1429,6 +1718,10 @@ sub make_new_child { $client->close(); last; # ------------------------------------------------------------- unknown command + } elsif ($userinput =~ /^sethost:/) { + print $client &sethost($userinput)."\n"; + } elsif ($userinput =~/^version:/) { + print $client &version($userinput)."\n"; } else { # unknown command print $client "unknown_cmd\n"; @@ -1444,21 +1737,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; - } + } @@ -1510,7 +1801,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; } @@ -1520,7 +1811,287 @@ sub GetAuthType 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,$udom,$uname)=@_; + 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; + } + my @participants=(); + $cutoff=time-60; + if (tie(%hash,'GDBM_File',"$proname/nohist_inchatroom.db", + &GDBM_WRCREAT(),0640)) { + $hash{$uname.':'.$udom}=time; + foreach (sort keys %hash) { + if ($hash{$_}>$cutoff) { + $participants[$#participants+1]='active_participant:'.$_; + } + } + untie %hash; + } + return (@participants,@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 currentversion { + my $fname=shift; + my $version=-1; + my $ulsdir=''; + if ($fname=~/^(.+)\/[^\/]+$/) { + $ulsdir=$1; + } + my ($fnamere1,$fnamere2); + # remove version if already specified + $fname=~s/\.\d+\.(\w+(?:\.meta)*)$/\.$1/; + # get the bits that go before and after the version number + if ( $fname=~/^(.*\.)(\w+(?:\.meta)*)$/ ) { + $fnamere1=$1; + $fnamere2='.'.$2; + } + 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=~/\Q$fnamere1\E(\d+)\Q$fnamere2\E/) { + 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"; + } 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; +} + +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 > $perlvar{'lonDaemons'}/logs/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; +} + +sub sethost { + my ($remotereq) = @_; + my (undef,$hostid)=split(/:/,$remotereq); + if (!defined($hostid)) { $hostid=$perlvar{'lonHostID'}; } + if ($hostip{$perlvar{'lonHostID'}} eq $hostip{$hostid}) { + $currenthostid=$hostid; + $currentdomainid=$hostdom{$hostid}; + &logthis("Setting hostid to $hostid, and domain to $currentdomainid"); + } else { + &logthis("Requested host id $hostid not an alias of ". + $perlvar{'lonHostID'}." refusing connection"); + return 'unable_to_set'; + } + return 'ok'; +} + +sub version { + my ($userinput)=@_; + $remoteVERSION=(split(/:/,$userinput))[1]; + return "version:$VERSION"; +} + +#There is a copy of this in lonnet.pm +sub userload { + my $numusers=0; + { + opendir(LONIDS,$perlvar{'lonIDsDir'}); + my $filename; + my $curtime=time; + while ($filename=readdir(LONIDS)) { + if ($filename eq '.' || $filename eq '..') {next;} + my ($mtime)=(stat($perlvar{'lonIDsDir'}.'/'.$filename))[9]; + if ($curtime-$mtime < 3600) { $numusers++; } + } + closedir(LONIDS); + } + my $userloadpercent=0; + my $maxuserload=$perlvar{'lonUserLoadLim'}; + if ($maxuserload) { + $userloadpercent=100*$numusers/$maxuserload; + } + $userloadpercent=sprintf("%.2f",$userloadpercent); + return $userloadpercent; } # ----------------------------------- POD (plain old documentation, CPAN style) @@ -1821,6 +2392,7 @@ Crypt::IDEA LWP::UserAgent() GDBM_File Authen::Krb4 +Authen::Krb5 =head1 COREQUISITES