--- loncom/lond 2005/03/03 23:21:51 1.280 +++ loncom/lond 2006/05/31 14:46:48 1.305.2.7 @@ -2,7 +2,7 @@ # The LearningOnline Network # lond "LON Daemon" Server (port "LOND" 5663) # -# $Id: lond,v 1.280 2005/03/03 23:21:51 matthew Exp $ +# $Id: lond,v 1.305.2.7 2006/05/31 14:46:48 albertel Exp $ # # Copyright Michigan State University Board of Trustees # @@ -48,17 +48,20 @@ use localauth; use localenroll; use localstudentphoto; use File::Copy; +use File::Find; use LONCAPA::ConfigFileEdit; use LONCAPA::lonlocal; use LONCAPA::lonssl; use Fcntl qw(:flock); +use Symbol; my $DEBUG = 0; # Non zero to enable debug log entries. my $status=''; my $lastlog=''; +my $lond_max_wait_time = 13; -my $VERSION='$Revision: 1.280 $'; #' stupid emacs +my $VERSION='$Revision: 1.305.2.7 $'; #' stupid emacs my $remoteVERSION; my $currenthostid="default"; my $currentdomainid; @@ -112,20 +115,20 @@ my %Dispatcher; # 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", - "lcpasswd User already exists", - "lcpasswd Something went wrong with user addition.", - "lcpasswd Password mismatch", - "lcpasswd Error filename is invalid"); + "pwchange_failure - lcpasswd must be run as user 'www'", + "pwchange_failure - lcpasswd got incorrect number of arguments", + "pwchange_failure - lcpasswd did not get the right nubmer of input text lines", + "pwchange_failure - lcpasswd too many simultaneous pwd changes in progress", + "pwchange_failure - lcpasswd User does not exist.", + "pwchange_failure - lcpasswd Incorrect current passwd", + "pwchange_failure - lcpasswd Unable to su to root.", + "pwchange_failure - lcpasswd Cannot set new passwd.", + "pwchange_failure - lcpasswd Username has invalid characters", + "pwchange_failure - lcpasswd Invalid characters in password", + "pwchange_failure - lcpasswd User already exists", + "pwchange_failure - lcpasswd Something went wrong with user addition.", + "pwchange_failure - lcpasswd Password mismatch", + "pwchange_failure - lcpasswd Error filename is invalid"); # The array below are lcuseradd error strings.: @@ -472,39 +475,11 @@ sub CopyFile { my ($oldfile, $newfile) = @_; - # The file must exist: - - if(-e $oldfile) { - - # Read the old file. - - my $oldfh = IO::File->new("< $oldfile"); - if(!$oldfh) { - return 0; - } - my @contents = <$oldfh>; # Suck in the entire file. - - # write the backup file: - - my $newfh = IO::File->new("> $newfile"); - if(!(defined $newfh)){ - return 0; - } - my $lines = scalar @contents; - for (my $i =0; $i < $lines; $i++) { - print $newfh ($contents[$i]); - } - - $oldfh->close; - $newfh->close; - - chmod(0660, $newfile); - - return 1; - - } else { - return 0; + if (! copy($oldfile,$newfile)) { + return 0; } + chmod(0660, $newfile); + return 1; } # # Host files are passed out with externally visible host IPs. @@ -997,23 +972,13 @@ sub tie_domain_hash { my $user_top_dir = $perlvar{'lonUsersDir'}; my $domain_dir = $user_top_dir."/$domain"; - my $resource_file = $domain_dir."/$namespace.db"; - my %hash; - if(tie(%hash, 'GDBM_File', $resource_file, $how, 0640)) { - if (defined($loghead)) { # Need to log the operation. - my $logFh = IO::File->new(">>$domain_dir/$namespace.hist"); - if($logFh) { - my $timestamp = time; - print $logFh "$loghead:$timestamp:$logtail\n"; - } - $logFh->close; - } - return \%hash; # Return the tied hash. - } else { - return undef; # Tie failed. - } + my $resource_file = $domain_dir."/$namespace"; + return &_locking_hash_tie($resource_file,$namespace,$how,$loghead,$logtail); } +sub untie_domain_hash { + return &_locking_hash_untie(@_); +} # # Ties a user's resource file to a hash. # If necessary, an appropriate history @@ -1039,18 +1004,27 @@ sub tie_user_hash { $namespace=~s/\//\_/g; # / -> _ $namespace=~s/\W//g; # whitespace eliminated. my $proname = propath($domain, $user); - - # Tie the database. - + + my $file_prefix="$proname/$namespace"; + return &_locking_hash_tie($file_prefix,$namespace,$how,$loghead,$what); +} + +sub untie_user_hash { + return &_locking_hash_untie(@_); +} + +# internal routines that handle the actual tieing and untieing process + +sub _do_hash_tie { + my ($file_prefix,$namespace,$how,$loghead,$what) = @_; my %hash; - if(tie(%hash, 'GDBM_File', "$proname/$namespace.db", - $how, 0640)) { + if(tie(%hash, 'GDBM_File', "$file_prefix.db", $how, 0640)) { # If this is a namespace for which a history is kept, # make the history log entry: if (($namespace !~/^nohist\_/) && (defined($loghead))) { my $args = scalar @_; - Debug(" Opening history: $namespace $args"); - my $hfh = IO::File->new(">>$proname/$namespace.hist"); + Debug(" Opening history: $file_prefix $args"); + my $hfh = IO::File->new(">>$file_prefix.hist"); if($hfh) { my $now = time; print $hfh "$loghead:$now:$what\n"; @@ -1061,7 +1035,72 @@ sub tie_user_hash { } else { return undef; } +} + +sub _do_hash_untie { + my ($hashref) = @_; + my $result = untie(%$hashref); + return $result; +} + +{ + my $sym; + + sub _locking_hash_tie { + my ($file_prefix,$namespace,$how,$loghead,$what) = @_; + + my ($lock); + + if ($how eq &GDBM_READER()) { + $lock=LOCK_SH; + $how=$how|&GDBM_NOLOCK(); + #if the db doesn't exist we can't read from it + if (! -e "$file_prefix.db") { + $! = 2; + return undef; + } + } elsif ($how eq &GDBM_WRCREAT()) { + $lock=LOCK_EX; + $how=$how|&GDBM_NOLOCK(); + if (! -e "$file_prefix.db") { + # doesn't exist but we need it to in order to successfully + # lock it so bring it into existance + open(TOUCH,">>$file_prefix.db"); + close(TOUCH); + } + } else { + &logthis("Unknown method $how for $file_prefix"); + die(); + } + $sym=&Symbol::gensym(); + open($sym,"$file_prefix.db"); + my $failed=0; + eval { + local $SIG{__DIE__}='DEFAULT'; + local $SIG{ALRM}=sub { + $failed=1; + die("failed lock"); + }; + alarm($lond_max_wait_time); + flock($sym,$lock); + alarm(0); + }; + if ($failed) { + $! = 100; # throwing error # 100 + return undef; + } + return &_do_hash_tie($file_prefix,$namespace,$how,$loghead,$what); + } + + sub _locking_hash_untie { + my ($hashref) = @_; + my $result = untie(%$hashref); + flock($sym,LOCK_UN); + close($sym); + undef($sym); + return $result; + } } # read_profile @@ -1094,7 +1133,7 @@ sub read_profile { $qresult.="$hashref->{$queries[$i]}&"; # Presumably failure gives empty string. } $qresult=~s/\&$//; # Remove trailing & from last lookup. - if (untie %$hashref) { + if (&untie_user_hash($hashref)) { return $qresult; } else { return "error: ".($!+0)." untie (GDBM) Failed"; @@ -1391,18 +1430,18 @@ sub du_handler { # etc. # if (-d $ududir) { - # And as Shakespeare would say to make - # assurance double sure, - # use execute_command to ensure that the command is not executed in - # a shell that can screw us up. - - my $duout = execute_command("du -ks $ududir"); - $duout=~s/[^\d]//g; #preserve only the numbers - &Reply($client,"$duout\n","$cmd:$ududir"); + my $total_size=0; + my $code=sub { + if ($_=~/\.\d+\./) { return;} + if ($_=~/\.meta$/) { return;} + $total_size+=(stat($_))[7]; + }; + chdir($ududir); + find($code,$ududir); + $total_size=int($total_size/1024); + &Reply($client,"$total_size\n","$cmd:$ududir"); } else { - &Failure($client, "bad_directory:$ududir\n","$cmd:$ududir"); - } return 1; } @@ -1441,14 +1480,15 @@ sub ls_handler { if(-d $ulsdir) { if (opendir(LSDIR,$ulsdir)) { while ($ulsfn=readdir(LSDIR)) { - undef $obs, $rights; + undef($obs); + undef($rights); my @ulsstats=stat($ulsdir.'/'.$ulsfn); #We do some obsolete checking here if(-e $ulsdir.'/'.$ulsfn.".meta") { open(FILE, $ulsdir.'/'.$ulsfn.".meta"); my @obsolete=; foreach my $obsolete (@obsolete) { - if($obsolete =~ m|()(on)|) { $obs = 1; } + if($obsolete =~ m/()(on|1)/) { $obs = 1; } if($obsolete =~ m|()(default)|) { $rights = 1; } } } @@ -1508,14 +1548,15 @@ sub ls2_handler { if(-d $ulsdir) { if (opendir(LSDIR,$ulsdir)) { while ($ulsfn=readdir(LSDIR)) { - undef $obs, $rights; + undef($obs); + undef($rights); my @ulsstats=stat($ulsdir.'/'.$ulsfn); #We do some obsolete checking here if(-e $ulsdir.'/'.$ulsfn.".meta") { open(FILE, $ulsdir.'/'.$ulsfn.".meta"); my @obsolete=; foreach my $obsolete (@obsolete) { - if($obsolete =~ m|()(on)|) { $obs = 1; } + if($obsolete =~ m/()(on|1)/) { $obs = 1; } if($obsolete =~ m|()(default)|) { $rights = 1; } @@ -1729,19 +1770,9 @@ sub change_password_handler { &Failure( $client, "non_authorized\n",$userinput); } } elsif ($howpwd eq 'unix') { - # Unix means we have to access /etc/password - &Debug("auth is unix"); - my $execdir=$perlvar{'lonDaemons'}; - &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 $err = $?; - my $result = ($err>0 ? 'pwchange_failure' : 'ok'); + my $result = &change_unix_password($uname, $npass); &logthis("Result of password change for $uname: ". - &lcpasswdstrerror($?)); + $result); &Reply($client, "$result\n", $userinput); } else { # this just means that the current password mode is not @@ -1840,6 +1871,9 @@ sub add_user_handler { # Implicit inputs: # The authentication systems describe above have their own forms of implicit # input into the authentication process that are described above. +# NOTE: +# This is also used to change the authentication credential values (e.g. passwd). +# # sub change_authentication_handler { @@ -1859,24 +1893,41 @@ sub change_authentication_handler { my $oldauth = &get_auth_type($udom, $uname); # Get old auth info. my $passfilename = &password_path($udom, $uname); if ($passfilename) { # Not allowed to create a new user!! - my $result=&make_passwd_file($uname, $umode,$npass,$passfilename); - # - # If the current auth mode is internal, and the old auth mode was - # unix, or krb*, and the user is an author for this domain, - # re-run manage_permissions for that role in order to be able - # to take ownership of the construction space back to www:www - # - - if( (($oldauth =~ /^unix/) && ($umode eq "internal")) || - (($oldauth =~ /^internal/) && ($umode eq "unix")) ) { - if(&is_author($udom, $uname)) { - &Debug(" Need to manage author permissions..."); - &manage_permissions("/$udom/_au", $udom, $uname, "$umode:"); + # If just changing the unix passwd. need to arrange to run + # passwd since otherwise make_passwd_file will run + # lcuseradd which fails if an account already exists + # (to prevent an unscrupulous LONCAPA admin from stealing + # an existing account by overwriting it as a LonCAPA account). + + if(($oldauth =~/^unix/) && ($umode eq "unix")) { + my $result = &change_unix_password($uname, $npass); + &logthis("Result of password change for $uname: ".$result); + if ($result eq "ok") { + &Reply($client, "$result\n") + } else { + &Failure($client, "$result\n"); } + } else { + my $result=&make_passwd_file($uname, $umode,$npass,$passfilename); + # + # If the current auth mode is internal, and the old auth mode was + # unix, or krb*, and the user is an author for this domain, + # re-run manage_permissions for that role in order to be able + # to take ownership of the construction space back to www:www + # + + + if( (($oldauth =~ /^unix/) && ($umode eq "internal")) || + (($oldauth =~ /^internal/) && ($umode eq "unix")) ) { + if(&is_author($udom, $uname)) { + &Debug(" Need to manage author permissions..."); + &manage_permissions("/$udom/_au", $udom, $uname, "$umode:"); + } + } + &Reply($client, $result, $userinput); } - &Reply($client, $result, $userinput); } else { &Failure($client, "non_authorized\n", $userinput); # Fail the user now. } @@ -1958,6 +2009,7 @@ sub update_resource_handler { my $since=$now-$atime; if ($since>$perlvar{'lonExpire'}) { my $reply=&reply("unsub:$fname","$clientname"); + &devalidate_meta_cache($fname); unlink("$fname"); } else { my $transname="$fname.in.transfer"; @@ -1988,6 +2040,7 @@ sub update_resource_handler { alarm(0); } rename($transname,$fname); + &devalidate_meta_cache($fname); } } &Reply( $client, "ok\n", $userinput); @@ -2001,6 +2054,26 @@ sub update_resource_handler { } ®ister_handler("update", \&update_resource_handler, 0 ,1, 0); +sub devalidate_meta_cache { + my ($url) = @_; + use Cache::Memcached; + my $memcache = new Cache::Memcached({'servers'=>['127.0.0.1:11211']}); + $url = &declutter($url); + $url =~ s-\.meta$--; + my $id = &escape('meta:'.$url); + $memcache->delete($id); +} + +sub declutter { + my $thisfn=shift; + $thisfn=~s/^\Q$perlvar{'lonDocRoot'}\E//; + $thisfn=~s/^\///; + $thisfn=~s|^adm/wrapper/||; + $thisfn=~s|^adm/coursedocs/showdoc/||; + $thisfn=~s/^res\///; + $thisfn=~s/\?.+$//; + return $thisfn; +} # # Fetch a user file from a remote server to the user's home directory # userfiles subdir. @@ -2217,8 +2290,11 @@ sub token_auth_user_file_handler { my $reply="non_auth\n"; if (open(ENVIN,$perlvar{'lonIDsDir'}.'/'. $session.'.id')) { + flock(ENVIN,LOCK_SH); while (my $line=) { - if ($line=~ m|userfile\.\Q$fname\E\=|) { $reply="ok\n"; } + my ($envname)=split(/=/,$line,2); + $envname=&unescape($envname); + if ($envname=~ m|^userfile\.\Q$fname\E|) { $reply="ok\n"; } } close(ENVIN); &Reply($client, $reply, "$cmd:$tail"); @@ -2369,7 +2445,7 @@ sub put_user_profile_entry { my ($key,$value)=split(/=/,$pair); $hashref->{$key}=$value; } - if (untie(%$hashref)) { + if (&untie_user_hash($hashref)) { &Reply( $client, "ok\n", $userinput); } else { &Failure($client, "error: ".($!+0)." untie(GDBM) failed ". @@ -2377,7 +2453,7 @@ sub put_user_profile_entry { $userinput); } } else { - &Failure( $client, "error: ".($!)." tie(GDBM) Failed ". + &Failure( $client, "error: ".($!+0)." tie(GDBM) Failed ". "while attempting put\n", $userinput); } } else { @@ -2388,6 +2464,61 @@ sub put_user_profile_entry { } ®ister_handler("put", \&put_user_profile_entry, 0, 1, 0); +# Put a piece of new data in hash, returns error if entry already exists +# Parameters: +# $cmd - The command that got us here. +# $tail - Tail of the command (remaining parameters). +# $client - File descriptor connected to client. +# Returns +# 0 - Requested to exit, caller should shut down. +# 1 - Continue processing. +# +sub newput_user_profile_entry { + my ($cmd, $tail, $client) = @_; + + my $userinput = "$cmd:$tail"; + + my ($udom,$uname,$namespace,$what) =split(/:/,$tail,4); + if ($namespace eq 'roles') { + &Failure( $client, "refused\n", $userinput); + return 1; + } + + chomp($what); + + my $hashref = &tie_user_hash($udom, $uname, $namespace, + &GDBM_WRCREAT(),"N",$what); + if(!$hashref) { + &Failure( $client, "error: ".($!+0)." tie(GDBM) Failed ". + "while attempting put\n", $userinput); + return 1; + } + + my @pairs=split(/\&/,$what); + foreach my $pair (@pairs) { + my ($key,$value)=split(/=/,$pair); + if (exists($hashref->{$key})) { + &Failure($client, "key_exists: ".$key."\n",$userinput); + return 1; + } + } + + foreach my $pair (@pairs) { + my ($key,$value)=split(/=/,$pair); + $hashref->{$key}=$value; + } + + if (&untie_user_hash($hashref)) { + &Reply( $client, "ok\n", $userinput); + } else { + &Failure($client, "error: ".($!+0)." untie(GDBM) failed ". + "while attempting put\n", + $userinput); + } + return 1; +} +®ister_handler("newput", \&newput_user_profile_entry, 0, 1, 0); + # # Increment a profile entry in the user history file. # The history contains keyword value pairs. In this case, @@ -2418,13 +2549,19 @@ sub increment_user_value_handler { my @pairs=split(/\&/,$what); foreach my $pair (@pairs) { my ($key,$value)=split(/=/,$pair); + $value = &unescape($value); # We could check that we have a number... if (! defined($value) || $value eq '') { $value = 1; } $hashref->{$key}+=$value; + if ($namespace eq 'nohist_resourcetracker') { + if ($hashref->{$key} < 0) { + $hashref->{$key} = 0; + } + } } - if (untie(%$hashref)) { + if (&untie_user_hash($hashref)) { &Reply( $client, "ok\n", $userinput); } else { &Failure($client, "error: ".($!+0)." untie(GDBM) failed ". @@ -2491,7 +2628,7 @@ sub roles_put_handler { $auth_type); $hashref->{$key}=$value; } - if (untie($hashref)) { + if (&untie_user_hash($hashref)) { &Reply($client, "ok\n", $userinput); } else { &Failure( $client, "error: ".($!+0)." untie(GDBM) Failed ". @@ -2542,7 +2679,7 @@ sub roles_delete_handler { foreach my $key (@rolekeys) { delete $hashref->{$key}; } - if (untie(%$hashref)) { + if (&untie_user_hash($hashref)) { &Reply($client, "ok\n", $userinput); } else { &Failure( $client, "error: ".($!+0)." untie(GDBM) Failed ". @@ -2683,7 +2820,7 @@ sub delete_profile_entry { foreach my $key (@keys) { delete($hashref->{$key}); } - if (untie(%$hashref)) { + if (&untie_user_hash($hashref)) { &Reply($client, "ok\n", $userinput); } else { &Failure($client, "error: ".($!+0)." untie(GDBM) Failed ". @@ -2725,7 +2862,7 @@ sub get_profile_keys { foreach my $key (keys %$hashref) { $qresult.="$key&"; } - if (untie(%$hashref)) { + if (&untie_user_hash($hashref)) { $qresult=~s/\&$//; &Reply($client, "$qresult\n", $userinput); } else { @@ -2786,7 +2923,7 @@ sub dump_profile_database { $data{$symb}->{$param}=$value; $data{$symb}->{'v.'.$param}=$v; } - if (untie(%$hashref)) { + if (&untie_user_hash($hashref)) { while (my ($symb,$param_hash) = each(%data)) { while(my ($param,$value) = each (%$param_hash)){ next if ($param =~ /^v\./); # Ignore versions... @@ -2861,7 +2998,7 @@ sub dump_with_regexp { } } } - if (untie(%$hashref)) { + if (&untie_user_hash($hashref)) { chop($qresult); &Reply($client, "$qresult\n", $userinput); } else { @@ -2923,7 +3060,7 @@ sub store_handler { $hashref->{"$version:$rid:timestamp"}=$now; $allkeys.='timestamp'; $hashref->{"$version:keys:$rid"}=$allkeys; - if (untie($hashref)) { + if (&untie_user_hash($hashref)) { &Reply($client, "ok\n", $userinput); } else { &Failure($client, "error: ".($!+0)." untie(GDBM) Failed ". @@ -2975,24 +3112,22 @@ sub restore_handler { $namespace=~s/\//\_/g; $namespace=~s/\W//g; chomp($rid); - my $proname=&propath($udom,$uname); my $qresult=''; - my %hash; - if (tie(%hash,'GDBM_File',"$proname/$namespace.db", - &GDBM_READER(),0640)) { - my $version=$hash{"version:$rid"}; + my $hashref = &tie_user_hash($udom, $uname, $namespace, &GDBM_READER()); + if ($hashref) { + my $version=$hashref->{"version:$rid"}; $qresult.="version=$version&"; my $scope; for ($scope=1;$scope<=$version;$scope++) { - my $vkeys=$hash{"$scope:keys:$rid"}; + my $vkeys=$hashref->{"$scope:keys:$rid"}; my @keys=split(/:/,$vkeys); my $key; $qresult.="$scope:keys=$vkeys&"; foreach $key (@keys) { - $qresult.="$scope:$key=".$hash{"$scope:$rid:$key"}."&"; + $qresult.="$scope:$key=".$hashref->{"$scope:$rid:$key"}."&"; } } - if (untie(%hash)) { + if (&untie_user_hash($hashref)) { $qresult=~s/\&$//; &Reply( $client, "$qresult\n", $userinput); } else { @@ -3225,7 +3360,7 @@ sub put_course_id_handler { } $hashref->{$key}=$courseinfo.':'.$now; } - if (untie(%$hashref)) { + if (&untie_domain_hash($hashref)) { &Reply( $client, "ok\n", $userinput); } else { &Failure($client, "error: ".($!+0) @@ -3280,7 +3415,7 @@ sub dump_course_id_handler { my $userinput = "$cmd:$tail"; - my ($udom,$since,$description,$instcodefilter,$ownerfilter) =split(/:/,$tail); + my ($udom,$since,$description,$instcodefilter,$ownerfilter,$coursefilter) =split(/:/,$tail); if (defined($description)) { $description=&unescape($description); } else { @@ -3296,6 +3431,11 @@ sub dump_course_id_handler { } else { $ownerfilter='.'; } + if (defined($coursefilter)) { + $coursefilter=&unescape($coursefilter); + } else { + $coursefilter='.'; + } unless (defined($since)) { $since=0; } my $qresult=''; @@ -3326,11 +3466,17 @@ sub dump_course_id_handler { $match = 0; } } + unless ($coursefilter eq '.' || !defined($coursefilter)) { + my $unescapeCourse = &unescape($key); + unless (eval('$unescapeCourse=~/^$udom(_)\Q$coursefilter\E$/')) { + $match = 0; + } + } if ($match == 1) { $qresult.=$key.'='.$descr.':'.$inst_code.':'.$owner.'&'; } } - if (untie(%$hashref)) { + if (&untie_domain_hash($hashref)) { chop($qresult); &Reply($client, "$qresult\n", $userinput); } else { @@ -3379,7 +3525,7 @@ sub put_id_handler { my ($key,$value)=split(/=/,$pair); $hashref->{$key}=$value; } - if (untie(%$hashref)) { + if (&untie_domain_hash($hashref)) { &Reply($client, "ok\n", $userinput); } else { &Failure($client, "error: ".($!+0)." untie(GDBM) Failed ". @@ -3428,7 +3574,7 @@ sub get_id_handler { for (my $i=0;$i<=$#queries;$i++) { $qresult.="$hashref->{$queries[$i]}&"; } - if (untie(%$hashref)) { + if (&untie_domain_hash($hashref)) { $qresult=~s/\&$//; &Reply($client, "$qresult\n", $userinput); } else { @@ -3445,6 +3591,258 @@ sub get_id_handler { ®ister_handler("idget", \&get_id_handler, 0, 1, 0); # +# Puts broadcast e-mail sent by Domain Coordinator in nohist_dcmail database +# +# Parameters +# $cmd - Command keyword that caused us to be dispatched. +# $tail - Tail of the command. Consists of a colon separated: +# domain - the domain whose dcmail we are recording +# email Consists of key=value pair +# where key is unique msgid +# and value is message (in XML) +# $client - Socket open on the client. +# +# Returns: +# 1 - indicating processing should continue. +# Side effects +# reply is written to $client. +# +sub put_dcmail_handler { + my ($cmd,$tail,$client) = @_; + my $userinput = "$cmd:$tail"; + + my ($udom,$what)=split(/:/,$tail); + chomp($what); + my $hashref = &tie_domain_hash($udom, "nohist_dcmail", &GDBM_WRCREAT()); + if ($hashref) { + my ($key,$value)=split(/=/,$what); + $hashref->{$key}=$value; + } + if (&untie_domain_hash($hashref)) { + &Reply($client, "ok\n", $userinput); + } else { + &Failure($client, "error: ".($!+0)." untie(GDBM) Failed ". + "while attempting dcmailput\n", $userinput); + } + return 1; +} +®ister_handler("dcmailput", \&put_dcmail_handler, 0, 1, 0); + +# +# Retrieves broadcast e-mail from nohist_dcmail database +# Returns to client an & separated list of key=value pairs, +# where key is msgid and value is message information. +# +# Parameters +# $cmd - Command keyword that caused us to be dispatched. +# $tail - Tail of the command. Consists of a colon separated: +# domain - the domain whose dcmail table we dump +# startfilter - beginning of time window +# endfilter - end of time window +# sendersfilter - & separated list of username:domain +# for senders to search for. +# $client - Socket open on the client. +# +# Returns: +# 1 - indicating processing should continue. +# Side effects +# reply (& separated list of msgid=messageinfo pairs) is +# written to $client. +# +sub dump_dcmail_handler { + my ($cmd, $tail, $client) = @_; + + my $userinput = "$cmd:$tail"; + my ($udom,$startfilter,$endfilter,$sendersfilter) = split(/:/,$tail); + chomp($sendersfilter); + my @senders = (); + if (defined($startfilter)) { + $startfilter=&unescape($startfilter); + } else { + $startfilter='.'; + } + if (defined($endfilter)) { + $endfilter=&unescape($endfilter); + } else { + $endfilter='.'; + } + if (defined($sendersfilter)) { + $sendersfilter=&unescape($sendersfilter); + @senders = map { &unescape($_) } split(/\&/,$sendersfilter); + } + + my $qresult=''; + my $hashref = &tie_domain_hash($udom, "nohist_dcmail", &GDBM_WRCREAT()); + if ($hashref) { + while (my ($key,$value) = each(%$hashref)) { + my $match = 1; + my ($timestamp,$subj,$uname,$udom) = + split(/:/,&unescape(&unescape($key)),5); # yes, twice really + $subj = &unescape($subj); + unless ($startfilter eq '.' || !defined($startfilter)) { + if ($timestamp < $startfilter) { + $match = 0; + } + } + unless ($endfilter eq '.' || !defined($endfilter)) { + if ($timestamp > $endfilter) { + $match = 0; + } + } + unless (@senders < 1) { + unless (grep/^$uname:$udom$/,@senders) { + $match = 0; + } + } + if ($match == 1) { + $qresult.=$key.'='.$value.'&'; + } + } + if (&untie_domain_hash($hashref)) { + chop($qresult); + &Reply($client, "$qresult\n", $userinput); + } else { + &Failure($client, "error: ".($!+0)." untie(GDBM) Failed ". + "while attempting dcmaildump\n", $userinput); + } + } else { + &Failure($client, "error: ".($!+0)." tie(GDBM) Failed ". + "while attempting dcmaildump\n", $userinput); + } + return 1; +} + +®ister_handler("dcmaildump", \&dump_dcmail_handler, 0, 1, 0); + +# +# Puts domain roles in nohist_domainroles database +# +# Parameters +# $cmd - Command keyword that caused us to be dispatched. +# $tail - Tail of the command. Consists of a colon separated: +# domain - the domain whose roles we are recording +# role - Consists of key=value pair +# where key is unique role +# and value is start/end date information +# $client - Socket open on the client. +# +# Returns: +# 1 - indicating processing should continue. +# Side effects +# reply is written to $client. +# + +sub put_domainroles_handler { + my ($cmd,$tail,$client) = @_; + + my $userinput = "$cmd:$tail"; + my ($udom,$what)=split(/:/,$tail); + chomp($what); + my @pairs=split(/\&/,$what); + my $hashref = &tie_domain_hash($udom, "nohist_domainroles", &GDBM_WRCREAT()); + if ($hashref) { + foreach my $pair (@pairs) { + my ($key,$value)=split(/=/,$pair); + $hashref->{$key}=$value; + } + if (&untie_domain_hash($hashref)) { + &Reply($client, "ok\n", $userinput); + } else { + &Failure($client, "error: ".($!+0)." untie(GDBM) Failed ". + "while attempting domroleput\n", $userinput); + } + } else { + &Failure( $client, "error: ".($!+0)." tie(GDBM) Failed ". + "while attempting domroleput\n", $userinput); + } + + return 1; +} + +®ister_handler("domroleput", \&put_domainroles_handler, 0, 1, 0); + +# +# Retrieves domain roles from nohist_domainroles database +# Returns to client an & separated list of key=value pairs, +# where key is role and value is start and end date information. +# +# Parameters +# $cmd - Command keyword that caused us to be dispatched. +# $tail - Tail of the command. Consists of a colon separated: +# domain - the domain whose domain roles table we dump +# $client - Socket open on the client. +# +# Returns: +# 1 - indicating processing should continue. +# Side effects +# reply (& separated list of role=start/end info pairs) is +# written to $client. +# +sub dump_domainroles_handler { + my ($cmd, $tail, $client) = @_; + + my $userinput = "$cmd:$tail"; + my ($udom,$startfilter,$endfilter,$rolesfilter) = split(/:/,$tail); + chomp($rolesfilter); + my @roles = (); + if (defined($startfilter)) { + $startfilter=&unescape($startfilter); + } else { + $startfilter='.'; + } + if (defined($endfilter)) { + $endfilter=&unescape($endfilter); + } else { + $endfilter='.'; + } + if (defined($rolesfilter)) { + $rolesfilter=&unescape($rolesfilter); + @roles = split(/\&/,$rolesfilter); + } + + my $hashref = &tie_domain_hash($udom, "nohist_domainroles", &GDBM_WRCREAT()); + if ($hashref) { + my $qresult = ''; + while (my ($key,$value) = each(%$hashref)) { + my $match = 1; + my ($start,$end) = split(/:/,&unescape($value)); + my ($trole,$uname,$udom,$runame,$rudom,$rsec) = split(/:/,&unescape($key)); + unless ($startfilter eq '.' || !defined($startfilter)) { + if ($start >= $startfilter) { + $match = 0; + } + } + unless ($endfilter eq '.' || !defined($endfilter)) { + if ($end <= $endfilter) { + $match = 0; + } + } + unless (@roles < 1) { + unless (grep/^$trole$/,@roles) { + $match = 0; + } + } + if ($match == 1) { + $qresult.=$key.'='.$value.'&'; + } + } + if (&untie_domain_hash($hashref)) { + chop($qresult); + &Reply($client, "$qresult\n", $userinput); + } else { + &Failure($client, "error: ".($!+0)." untie(GDBM) Failed ". + "while attempting domrolesdump\n", $userinput); + } + } else { + &Failure($client, "error: ".($!+0)." tie(GDBM) Failed ". + "while attempting domrolesdump\n", $userinput); + } + return 1; +} + +®ister_handler("domrolesdump", \&dump_domainroles_handler, 0, 1, 0); + + # Process the tmpput command I'm not sure what this does.. Seems to # create a file in the lonDaemons/tmp directory of the form $id.tmp # where Id is the client's ip concatenated with a sequence number. @@ -3923,6 +4321,83 @@ sub get_institutional_code_format_handle ®ister_handler("autoinstcodeformat", \&get_institutional_code_format_handler,0,1,0); +# Get domain specific conditions for import of student photographs to a course +# +# Retrieves information from photo_permission subroutine in localenroll. +# Returns outcome (ok) if no processing errors, and whether course owner is +# required to accept conditions of use (yes/no). +# +# +sub photo_permission_handler { + my ($cmd, $tail, $client) = @_; + my $userinput = "$cmd:$tail"; + my $cdom = $tail; + my ($perm_reqd,$conditions); + my $outcome; + eval { + local($SIG{__DIE__})='DEFAULT'; + $outcome = &localenroll::photo_permission($cdom,\$perm_reqd, + \$conditions); + }; + if (!$@) { + &Reply($client, &escape($outcome.':'.$perm_reqd.':'. $conditions)."\n", + $userinput); + } else { + &Failure($client,"unknown_cmd\n",$userinput); + } + return 1; +} +®ister_handler("autophotopermission",\&photo_permission_handler,0,1,0); + +# +# Checks if student photo is available for a user in the domain, in the user's +# directory (in /userfiles/internal/studentphoto.jpg). +# Uses localstudentphoto:fetch() to ensure there is an up to date copy of +# the student's photo. + +sub photo_check_handler { + my ($cmd, $tail, $client) = @_; + my $userinput = "$cmd:$tail"; + my ($udom,$uname,$pid) = split(/:/,$tail); + $udom = &unescape($udom); + $uname = &unescape($uname); + $pid = &unescape($pid); + my $path=&propath($udom,$uname).'/userfiles/internal/'; + if (!-e $path) { + &mkpath($path); + } + my $response; + my $result = &localstudentphoto::fetch($udom,$uname,$pid,\$response); + $result .= ':'.$response; + &Reply($client, &escape($result)."\n",$userinput); + return 1; +} +®ister_handler("autophotocheck",\&photo_check_handler,0,1,0); + +# +# Retrieve information from localenroll about whether to provide a button +# for users who have enbled import of student photos to initiate an +# update of photo files for registered students. Also include +# comment to display alongside button. + +sub photo_choice_handler { + my ($cmd, $tail, $client) = @_; + my $userinput = "$cmd:$tail"; + my $cdom = &unescape($tail); + my ($update,$comment); + eval { + local($SIG{__DIE__})='DEFAULT'; + ($update,$comment) = &localenroll::manager_photo_update($cdom); + }; + if (!$@) { + &Reply($client,&escape($update).':'.&escape($comment)."\n",$userinput); + } else { + &Failure($client,"unknown_cmd\n",$userinput); + } + return 1; +} +®ister_handler("autophotochoice",\&photo_choice_handler,0,1,0); + # # Gets a student's photo to exist (in the correct image type) in the user's # directory. @@ -3935,24 +4410,36 @@ sub get_institutional_code_format_handle # $client - The socket open on the client. # Returns: # 1 - continue processing. + sub student_photo_handler { my ($cmd, $tail, $client) = @_; - my ($domain,$uname,$type) = split(/:/, $tail); + my ($domain,$uname,$ext,$type) = split(/:/, $tail); - my $path=&propath($domain,$uname). - '/userfiles/internal/studentphoto.'.$type; - if (-e $path) { + my $path=&propath($domain,$uname). '/userfiles/internal/'; + my $filename = 'studentphoto.'.$ext; + if ($type eq 'thumbnail') { + $filename = 'studentphoto_tn.'.$ext; + } + if (-e $path.$filename) { &Reply($client,"ok\n","$cmd:$tail"); return 1; } &mkpath($path); - my $file=&localstudentphoto::fetch($domain,$uname); + my $file; + if ($type eq 'thumbnail') { + eval { + local($SIG{__DIE__})='DEFAULT'; + $file=&localstudentphoto::fetch_thumbnail($domain,$uname); + }; + } else { + $file=&localstudentphoto::fetch($domain,$uname); + } if (!$file) { &Failure($client,"unavailable\n","$cmd:$tail"); return 1; } - if (!-e $path) { &convert_photo($file,$path); } - if (-e $path) { + if (!-e $path.$filename) { &convert_photo($file,$path.$filename); } + if (-e $path.$filename) { &Reply($client,"ok\n","$cmd:$tail"); return 1; } @@ -4348,16 +4835,23 @@ sub ReadHostTable { open (CONFIG,"$perlvar{'lonTabDir'}/hosts.tab") || die "Can't read host file"; my $myloncapaname = $perlvar{'lonHostID'}; Debug("My loncapa name is : $myloncapaname"); + my %name_to_ip; while (my $configline=) { if ($configline !~ /^\s*\#/ && $configline !~ /^\s*$/ ) { my ($id,$domain,$role,$name)=split(/:/,$configline); $name=~s/\s//g; - my $ip = gethostbyname($name); - if (length($ip) ne 4) { - &logthis("Skipping host $id name $name no IP $ip found\n"); - next; + my $ip; + if (!exists($name_to_ip{$name})) { + $ip = gethostbyname($name); + if (!$ip || length($ip) ne 4) { + &logthis("Skipping host $id name $name no IP found\n"); + next; + } + $ip=inet_ntoa($ip); + $name_to_ip{$name} = $ip; + } else { + $ip = $name_to_ip{$name}; } - $ip=inet_ntoa($ip); $hostid{$ip}=$id; # LonCAPA name of host by IP. $hostdom{$id}=$domain; # LonCAPA domain name of host. $hostip{$id}=$ip; # IP address of host. @@ -4497,8 +4991,6 @@ sub Reply { Debug("Request was $request Reply was $reply"); $Transactions++; - - } @@ -4660,7 +5152,7 @@ sub sub_sql_reply { Type => SOCK_STREAM, Timeout => 10) or return "con_lost"; - print $sclient "$cmd\n"; + print $sclient "$cmd:$currentdomainid\n"; my $answer=<$sclient>; chomp($answer); if (!$answer) { $answer="con_lost"; } @@ -4726,6 +5218,8 @@ $SIG{USR2} = \&UpdateHosts; ReadHostTable; +my $dist=`$perlvar{'lonDaemons'}/distprobe`; + # -------------------------------------------------------------- # Accept connections. When a connection comes in, it is validated # and if good, a child process is created to process transactions @@ -4801,7 +5295,9 @@ sub make_new_child { # my $tmpsnum=0; # Now global #---------------------------------------------------- kerberos 5 initialization &Authen::Krb5::init_context(); - &Authen::Krb5::init_ets(); + unless (($dist eq 'fedora4') || ($dist eq 'suse9.3')) { + &Authen::Krb5::init_ets(); + } &status('Accepted connection'); # ============================================================================= @@ -5011,16 +5507,13 @@ sub is_author { # user - Name of the user for which the role is being put. # authtype - The authentication type associated with the user. # -sub manage_permissions -{ - - +sub manage_permissions { my ($request, $domain, $user, $authtype) = @_; &Debug("manage_permissions: $request $domain $user $authtype"); # See if the request is of the form /$domain/_au - if($request =~ /^(\/$domain\/_au)$/) { # It's an author rolesput... + if($request =~ /^(\/\Q$domain\E\/_au)$/) { # It's an author rolesput... my $execdir = $perlvar{'lonDaemons'}; my $userhome= "/home/$user" ; &logthis("system $execdir/lchtmldir $userhome $user $authtype"); @@ -5269,38 +5762,38 @@ sub addline { sub get_chat { 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 $hashref = &tie_user_hash($cdom, $cname, 'nohist_chatroom', + &GDBM_READER()); + if ($hashref) { + @entries=map { $_.':'.$hashref->{$_} } sort(keys(%$hashref)); + &untie_user_hash($hashref); } my @participants=(); my $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:'.$_; + $hashref = &tie_user_hash($cdom, $cname, 'nohist_inchatroom', + &GDBM_WRCREAT()); + if ($hashref) { + $hashref->{$uname.':'.$udom}=time; + foreach my $user (sort(keys(%$hashref))) { + if ($hashref->{$user}>$cutoff) { + push(@participants, 'active_participant:'.$user); } } - untie %hash; + &untie_user_hash($hashref); } return (@participants,@entries); } sub chat_add { my ($cdom,$cname,$newchat)=@_; - my %hash; - my $proname=&propath($cdom,$cname); my @entries=(); my $time=time; - if (tie(%hash,'GDBM_File',"$proname/nohist_chatroom.db", - &GDBM_WRCREAT(),0640)) { - @entries=map { $_.':'.$hash{$_} } sort keys %hash; + my $hashref = &tie_user_hash($cdom, $cname, 'nohist_chatroom', + &GDBM_WRCREAT()); + if ($hashref) { + @entries=map { $_.':'.$hashref->{$_} } sort(keys(%$hashref)); my ($lastid)=($entries[$#entries]=~/^(\w+)\:/); my ($thentime,$idnum)=split(/\_/,$lastid); my $newid=$time.'_000000'; @@ -5310,21 +5803,22 @@ sub chat_add { $idnum=substr('000000'.$idnum,-6,6); $newid=$time.'_'.$idnum; } - $hash{$newid}=$newchat; + $hashref->{$newid}=$newchat; my $expired=$time-3600; - foreach (keys %hash) { - my ($thistime)=($_=~/(\d+)\_/); + foreach my $comment (keys(%$hashref)) { + my ($thistime) = ($comment=~/(\d+)\_/); if ($thistime<$expired) { - delete $hash{$_}; + delete $hashref->{$comment}; } } - untie %hash; - } - { - my $hfh; - if ($hfh=IO::File->new(">>$proname/chatroom.log")) { - print $hfh "$time:".&unescape($newchat)."\n"; + { + my $proname=&propath($cdom,$cname); + if (open(CHATLOG,">>$proname/chatroom.log")) { + print CHATLOG ("$time:".&unescape($newchat)."\n"); + } + close(CHATLOG); } + &untie_user_hash($hashref); } } @@ -5413,7 +5907,7 @@ sub thisversion { sub subscribe { my ($userinput,$clientip)=@_; my $result; - my ($cmd,$fname)=split(/:/,$userinput); + my ($cmd,$fname)=split(/:/,$userinput,2); my $ownership=&ishome($fname); if ($ownership eq 'owner') { # explitly asking for the current version? @@ -5457,6 +5951,35 @@ sub subscribe { } return $result; } +# Change the passwd of a unix user. The caller must have +# first verified that the user is a loncapa user. +# +# Parameters: +# user - Unix user name to change. +# pass - New password for the user. +# Returns: +# ok - if success +# other - Some meaningfule error message string. +# NOTE: +# invokes a setuid script to change the passwd. +sub change_unix_password { + my ($user, $pass) = @_; + + &Debug("change_unix_password"); + my $execdir=$perlvar{'lonDaemons'}; + &Debug("Opening lcpasswd pipeline"); + my $pf = IO::File->new("|$execdir/lcpasswd > " + ."$perlvar{'lonDaemons'}" + ."/logs/lcpasswd.log"); + print $pf "$user\n$pass\n$pass\n"; + close $pf; + my $err = $?; + return ($err < @passwderrors) ? $passwderrors[$err] : + "pwchange_falure - unknown error"; + + +} + sub make_passwd_file { my ($uname, $umode,$npass,$passfilename)=@_; @@ -5516,24 +6039,30 @@ sub make_passwd_file { print $se "$npass\n"; print $se "$lc_error_file\n"; # Status -> unique file. } - my $error = IO::File->new("< $lc_error_file"); - my $useraddok = <$error>; - $error->close; - unlink($lc_error_file); - - chomp $useraddok; - - if($useraddok > 0) { - my $error_text = &lcuseraddstrerror($useraddok); - &logthis("Failed lcuseradd: $error_text"); - $result = "lcuseradd_failed:$error_text\n"; - } else { - my $pf = IO::File->new(">$passfilename"); - if($pf) { - print $pf "unix:\n"; - } else { - $result = "pass_file_failed_error"; + if (-r $lc_error_file) { + &Debug("Opening error file: $lc_error_file"); + my $error = IO::File->new("< $lc_error_file"); + my $useraddok = <$error>; + $error->close; + unlink($lc_error_file); + + chomp $useraddok; + + if($useraddok > 0) { + my $error_text = &lcuseraddstrerror($useraddok); + &logthis("Failed lcuseradd: $error_text"); + $result = "lcuseradd_failed:$error_text\n"; + } else { + my $pf = IO::File->new(">$passfilename"); + if($pf) { + print $pf "unix:\n"; + } else { + $result = "pass_file_failed_error"; + } } + } else { + &Debug("Could not locate lcuseradd error: $lc_error_file"); + $result="bug_lcuseradd_no_output_file"; } } } elsif ($umode eq 'none') { 500 Internal Server Error

Internal Server Error

The server encountered an internal error or misconfiguration and was unable to complete your request.

Please contact the server administrator at root@localhost to inform them of the time this error occurred, and the actions you performed just before this error.

More information about this error may be available in the server error log.