--- loncom/lond 2011/01/20 10:55:02 1.469 +++ loncom/lond 2014/01/03 19:36:47 1.489.2.11 @@ -2,7 +2,7 @@ # The LearningOnline Network # lond "LON Daemon" Server (port "LOND" 5663) # -# $Id: lond,v 1.469 2011/01/20 10:55:02 foxr Exp $ +# $Id: lond,v 1.489.2.11 2014/01/03 19:36:47 raeburn Exp $ # # Copyright Michigan State University Board of Trustees # @@ -34,6 +34,7 @@ use strict; use lib '/home/httpd/lib/perl/'; use LONCAPA; use LONCAPA::Configuration; +use LONCAPA::Lond; use IO::Socket; use IO::File; @@ -53,13 +54,14 @@ use LONCAPA::lonlocal; use LONCAPA::lonssl; use Fcntl qw(:flock); use Apache::lonnet; +use Mail::Send; my $DEBUG = 0; # Non zero to enable debug log entries. my $status=''; my $lastlog=''; -my $VERSION='$Revision: 1.469 $'; #' stupid emacs +my $VERSION='$Revision: 1.489.2.11 $'; #' stupid emacs my $remoteVERSION; my $currenthostid="default"; my $currentdomainid; @@ -91,6 +93,8 @@ my %managers; # Ip -> manager names my %perlvar; # Will have the apache conf defined perl vars. +my $dist; + # # The hash below is used for command dispatching, and is therefore keyed on the request keyword. # Each element of the hash contains a reference to an array that contains: @@ -126,32 +130,13 @@ my @passwderrors = ("ok", "pwchange_failure - lcpasswd Error filename is invalid"); -# 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 Unable to make www member of users's group", - "lcuseradd Unable to su to root", - "lcuseradd Unable to set password", - "lcuseradd Username has invalid characters", - "lcuseradd Password has an invalid character", - "lcuseradd User already exists", - "lcuseradd Could not add user.", - "lcuseradd Password mismatch"); - - # This array are the errors from lcinstallfile: my @installerrors = ("ok", "Initial user id of client not that of www", "Usage error, not enough command line arguments", - "Source file name does not exist", - "Destination file name does not exist", + "Source filename does not exist", + "Destination filename does not exist", "Some file operation failed", "Invalid table filename." ); @@ -420,8 +405,11 @@ sub ReadManagerTable { my $tablename = $perlvar{'lonTabDir'}."/managers.tab"; if (!open (MANAGERS, $tablename)) { - logthis('No manager table. Nobody can manage!!'); - return; + my $hostname = &Apache::lonnet::hostname($perlvar{'lonHostID'}); + if (&Apache::lonnet::is_LC_dns($hostname)) { + &logthis('No manager table. Nobody can manage!!'); + } + return; } while(my $host = ) { chomp($host); @@ -446,7 +434,7 @@ sub ReadManagerTable { } } else { logthis(' existing host'." $host\n"); - $managers{&Apache::lonnet::get_host_ip($host)} = $host; # Use info from cluster tab if clumemeber + $managers{&Apache::lonnet::get_host_ip($host)} = $host; # Use info from cluster tab if cluster memeber } } } @@ -508,7 +496,8 @@ sub AdjustHostContents { my $me = $perlvar{'lonHostID'}; foreach my $line (split(/\n/,$contents)) { - if(!(($line eq "") || ($line =~ /^ *\#/) || ($line =~ /^ *$/))) { + if(!(($line eq "") || ($line =~ /^ *\#/) || ($line =~ /^ *$/) || + ($line =~ /^\s*\^/))) { chomp($line); my ($id,$domain,$role,$name,$ip,$maxcon,$idleto,$mincon)=split(/:/,$line); if ($id eq $me) { @@ -596,11 +585,8 @@ sub InstallFile { # # ConfigFileFromSelector: converts a configuration file selector # into a configuration file pathname. -# It's probably no longer necessary to preserve -# special handling of hosts or domain as those -# files have been superceded by dns_hosts, dns_domain. -# The default action is just to prepend the directory -# and append .tab +# Supports the following file selectors: +# hosts, domain, dns_hosts, dns_domain # # # Parameters: @@ -613,15 +599,11 @@ sub ConfigFileFromSelector { my $tablefile; my $tabledir = $perlvar{'lonTabDir'}.'/'; - if ($selector eq "hosts") { - $tablefile = $tabledir."hosts.tab"; - } elsif ($selector eq "domain") { - $tablefile = $tabledir."domain.tab"; - } else { + if (($selector eq "hosts") || ($selector eq "domain") || + ($selector eq "dns_hosts") || ($selector eq "dns_domain")) { $tablefile = $tabledir.$selector.'.tab'; } return $tablefile; - } # # PushFile: Called to do an administrative push of a file. @@ -647,6 +629,8 @@ sub PushFile { # supported: # hosts.tab ($filename eq host). # domain.tab ($filename eq domain). + # dns_hosts.tab ($filename eq dns_host). + # dns_domain.tab ($filename eq dns_domain). # Construct the destination filename or reject the request. # # lonManage is supposed to ensure this, however this session could be @@ -678,11 +662,31 @@ sub PushFile { return "error:$!"; } else { &logthis(' Installed new '.$tablefile - .""); - + ." - transaction by: $clientname ($clientip)"); + my $adminmail = $perlvar{'lonAdmEMail'}; + my $admindom = &Apache::lonnet::host_domain($perlvar{'lonHostID'}); + if ($admindom ne '') { + my %domconfig = + &Apache::lonnet::get_dom('configuration',['contacts'],$admindom); + if (ref($domconfig{'contacts'}) eq 'HASH') { + if ($domconfig{'contacts'}{'adminemail'} ne '') { + $adminmail = $domconfig{'contacts'}{'adminemail'}; + } + } + } + if ($adminmail =~ /^[^\@]+\@[^\@]+$/) { + my $msg = new Mail::Send; + $msg->to($adminmail); + $msg->subject('LON-CAPA DNS update on '.$perlvar{'lonHostID'}); + $msg->add('Content-type','text/plain; charset=UTF-8'); + if (my $fh = $msg->open()) { + print $fh 'Update to '.$tablefile.' from Cluster Manager '. + "$clientname ($clientip)\n"; + $fh->close; + } + } } - # Indicate success: return "ok"; @@ -1621,6 +1625,80 @@ sub ls3_handler { } ®ister_handler("ls3", \&ls3_handler, 0, 1, 0); +sub read_lonnet_global { + my ($cmd,$tail,$client) = @_; + my $userinput = "$cmd:$tail"; + my $requested = &Apache::lonnet::thaw_unescape($tail); + my $result; + my %packagevars = ( + spareid => \%Apache::lonnet::spareid, + perlvar => \%Apache::lonnet::perlvar, + ); + my %limit_to = ( + perlvar => { + lonOtherAuthen => 1, + lonBalancer => 1, + lonVersion => 1, + lonSysEMail => 1, + lonHostID => 1, + lonRole => 1, + lonDefDomain => 1, + lonLoadLim => 1, + lonUserLoadLim => 1, + } + ); + if (ref($requested) eq 'HASH') { + foreach my $what (keys(%{$requested})) { + my $response; + my $items = {}; + if (exists($packagevars{$what})) { + if (ref($limit_to{$what}) eq 'HASH') { + foreach my $varname (keys(%{$packagevars{$what}})) { + if ($limit_to{$what}{$varname}) { + $items->{$varname} = $packagevars{$what}{$varname}; + } + } + } else { + $items = $packagevars{$what}; + } + if ($what eq 'perlvar') { + if (!exists($packagevars{$what}{'lonBalancer'})) { + if ($dist =~ /^(centos|rhes|fedora|scientific)/) { + my $othervarref=LONCAPA::Configuration::read_conf('httpd.conf'); + if (ref($othervarref) eq 'HASH') { + $items->{'lonBalancer'} = $othervarref->{'lonBalancer'}; + } + } + } + } + $response = &Apache::lonnet::freeze_escape($items); + } + $result .= &escape($what).'='.$response.'&'; + } + } + $result =~ s/\&$//; + &Reply($client,\$result,$userinput); + return 1; +} +®ister_handler("readlonnetglobal", \&read_lonnet_global, 0, 1, 0); + +sub server_devalidatecache_handler { + my ($cmd,$tail,$client) = @_; + my $userinput = "$cmd:$tail"; + my $items = &unescape($tail); + my @cached = split(/\&/,$items); + foreach my $key (@cached) { + if ($key =~ /:/) { + my ($name,$id) = map { &unescape($_); } split(/:/,$key); + &Apache::lonnet::devalidate_cache_new($name,$id); + } + } + my $result = 'ok'; + &Reply($client,\$result,$userinput); + return 1; +} +®ister_handler("devalidatecache", \&server_devalidatecache_handler, 0, 1, 0); + sub server_timezone_handler { my ($cmd,$tail,$client) = @_; my $userinput = "$cmd:$tail"; @@ -1669,6 +1747,15 @@ sub server_homeID_handler { } ®ister_handler("serverhomeID", \&server_homeID_handler, 0, 1, 0); +sub server_distarch_handler { + my ($cmd,$tail,$client) = @_; + my $userinput = "$cmd:$tail"; + my $reply = &distro_and_arch(); + &Reply($client,\$reply,$userinput); + return 1; +} +®ister_handler("serverdistarch", \&server_distarch_handler, 0, 1, 0); + # Process a reinit request. Reinit requests that either # lonc or lond be reinitialized so that an updated # host.tab or domain.tab can be processed. @@ -1974,7 +2061,7 @@ sub add_user_handler { ."makeuser"; } unless ($fperror) { - my $result=&make_passwd_file($uname, $umode,$npass, $passfilename); + my $result=&make_passwd_file($uname,$udom,$umode,$npass, $passfilename); &Reply($client,\$result, $userinput); #BUGBUG - could be fail } else { &Failure($client, \$fperror, $userinput); @@ -2035,10 +2122,9 @@ sub change_authentication_handler { my $passfilename = &password_path($udom, $uname); if ($passfilename) { # Not allowed to create a new user!! # 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). + # passwd since otherwise make_passwd_file will fail as + # creation of unix authenticated users is no longer supported + # except from the command line, when running make_domain_coordinator.pl if(($oldauth =~/^unix/) && ($umode eq "unix")) { my $result = &change_unix_password($uname, $npass); @@ -2049,22 +2135,15 @@ sub change_authentication_handler { &Failure($client, \$result); } } else { - my $result=&make_passwd_file($uname, $umode,$npass,$passfilename); + my $result=&make_passwd_file($uname,$udom,$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); } @@ -2249,7 +2328,10 @@ sub fetch_user_file_handler { my $destname=$udir.'/'.$ufile; my $transname=$udir.'/'.$ufile.'.in.transit'; - my $remoteurl='http://'.$clientip.'/userfiles/'.$fname; + my $clientprotocol=$Apache::lonnet::protocol{$clientname}; + $clientprotocol = 'http' if ($clientprotocol ne 'https'); + my $clienthost = &Apache::lonnet::hostname($clientname); + my $remoteurl=$clientprotocol.'://'.$clienthost.'/userfiles/'.$fname; my $response; Debug("Remote URL : $remoteurl Transfername $transname Destname: $destname"); alarm(120); @@ -2271,6 +2353,24 @@ sub fetch_user_file_handler { unlink($transname); &Failure($client, "failed\n", $userinput); } else { + if ($fname =~ /^default.+\.(page|sequence)$/) { + my ($major,$minor) = split(/\./,$clientversion); + if (($major < 2) || ($major == 2 && $minor < 11)) { + my $now = time; + &Apache::lonnet::do_cache_new('crschange',$udom.'_'.$uname,$now,600); + my $key = &escape('internal.contentchange'); + my $what = "$key=$now"; + my $hashref = &tie_user_hash($udom,$uname,'environment', + &GDBM_WRCREAT(),"P",$what); + if ($hashref) { + $hashref->{$key}=$now; + if (!&untie_user_hash($hashref)) { + &logthis("error: ".($!+0)." untie (GDBM) failed ". + "when updating internal.contentchange"); + } + } + } + } &Reply($client, "ok\n", $userinput); } } @@ -3143,6 +3243,9 @@ sub dump_profile_database { # that is matched against # database keywords to do # selective dumps. +# range - optional range of entries +# e.g., 10-20 would return the +# 10th to 19th items, etc. # $client - Channel open on the client. # Returns: # 1 - Continue processing. @@ -3152,93 +3255,12 @@ sub dump_profile_database { sub dump_with_regexp { my ($cmd, $tail, $client) = @_; + my $res = LONCAPA::Lond::dump_with_regexp($tail, $clientversion); - my $userinput = "$cmd:$tail"; - - my ($udom,$uname,$namespace,$regexp,$range,$extra)=split(/:/,$tail); - if (defined($regexp)) { - $regexp=&unescape($regexp); - } else { - $regexp='.'; - } - my ($start,$end); - if (defined($range)) { - if ($range =~/^(\d+)\-(\d+)$/) { - ($start,$end) = ($1,$2); - } elsif ($range =~/^(\d+)$/) { - ($start,$end) = (0,$1); - } else { - undef($range); - } - } - my $hashref = &tie_user_hash($udom, $uname, $namespace, - &GDBM_READER()); - my $skipcheck; - if ($hashref) { - my $qresult=''; - my $count=0; - if ($extra ne '') { - $extra = &Apache::lonnet::thaw_unescape($extra); - $skipcheck = $extra->{'skipcheck'}; - } - my @ids = &Apache::lonnet::current_machine_ids(); - my (%homecourses,$major,$minor,$now); - if (($namespace eq 'roles') && (!$skipcheck)) { - my $loncaparev = $clientversion; - if ($loncaparev eq '') { - $loncaparev = $Apache::lonnet::loncaparevs{$clientname}; - } - if ($loncaparev =~ /^\'?(\d+)\.(\d+)\.[\w.\-]+\'?/) { - $major = $1; - $minor = $2; - } - $now = time; - } - while (my ($key,$value) = each(%$hashref)) { - if ($namespace eq 'roles') { - if ($key =~ m{^/($LONCAPA::match_domain)/($LONCAPA::match_courseid)(/?[^_]*)_(cc|co|in|ta|ep|ad|st|cr)$}) { - my $cdom = $1; - my $cnum = $2; - unless ($skipcheck) { - my ($role,$end,$start) = split(/\_/,$value); - if (!$end || $end > $now) { - next unless (&releasereqd_check($cnum,$cdom,$key,$value,$major, - $minor,\%homecourses,\@ids)); - } - } - } - } - if ($regexp eq '.') { - $count++; - if (defined($range) && $count >= $end) { last; } - if (defined($range) && $count < $start) { next; } - $qresult.=$key.'='.$value.'&'; - } else { - my $unescapeKey = &unescape($key); - if (eval('$unescapeKey=~/$regexp/')) { - $count++; - if (defined($range) && $count >= $end) { last; } - if (defined($range) && $count < $start) { next; } - $qresult.="$key=$value&"; - } - } - } - if (&untie_user_hash($hashref)) { - if (($namespace eq 'roles') && (!$skipcheck)) { - if (keys(%homecourses) > 0) { - $qresult .= &check_homecourses(\%homecourses,$udom,$regexp,$count, - $range,$start,$end,$major,$minor); - } - } - chop($qresult); - &Reply($client, \$qresult, $userinput); - } else { - &Failure( $client, "error: ".($!+0)." untie(GDBM) Failed ". - "while attempting dump\n", $userinput); - } + if ($res =~ /^error:/) { + &Failure($client, \$res, "$cmd:$tail"); } else { - &Failure($client, "error: ".($!+0)." tie(GDBM) Failed ". - "while attempting dump\n", $userinput); + &Reply($client, \$res, "$cmd:$tail"); } return 1; @@ -3808,7 +3830,9 @@ sub put_course_id_hash_handler { # creationcontext - include courses created in specified context # # domcloner - flag to indicate if user can create CCs in course's domain. -# If so, ability to clone course is automatic. +# If so, ability to clone course is automatic. +# hasuniquecode - filter by courses for which a six character unique code has +# been set. # # $client - The socket open on the client. # Returns: @@ -3822,7 +3846,7 @@ sub dump_course_id_handler { my ($udom,$since,$description,$instcodefilter,$ownerfilter,$coursefilter, $typefilter,$regexp_ok,$rtn_as_hash,$selfenrollonly,$catfilter,$showhidden, $caller,$cloner,$cc_clone_list,$cloneonly,$createdbefore,$createdafter, - $creationcontext,$domcloner) =split(/:/,$tail); + $creationcontext,$domcloner,$hasuniquecode) =split(/:/,$tail); my $now = time; my ($cloneruname,$clonerudom,%cc_clone); if (defined($description)) { @@ -3895,8 +3919,11 @@ sub dump_course_id_handler { } else { $creationcontext = '.'; } + unless ($hasuniquecode) { + $hasuniquecode = '.'; + } my $unpack = 1; - if ($description eq '.' && $instcodefilter eq '.' && $coursefilter eq '.' && + if ($description eq '.' && $instcodefilter eq '.' && $ownerfilter eq '.' && $typefilter eq '.') { $unpack = 0; } @@ -3983,6 +4010,9 @@ sub dump_course_id_handler { $selfenroll_end = $items->{'selfenroll_end_date'}; $created = $items->{'created'}; $context = $items->{'context'}; + if ($hasuniquecode ne '.') { + next unless ($items->{'uniquecode'}); + } if ($selfenrollonly) { next if (!$selfenroll_types); if (($selfenroll_end > 0) && ($selfenroll_end <= $now)) { @@ -4405,6 +4435,49 @@ sub get_id_handler { } ®ister_handler("idget", \&get_id_handler, 0, 1, 0); +# Deletes one or more ids in a domain's id database. +# +# Parameters: +# $cmd - Command keyword (iddel). +# $tail - Command tail. In this case a colon +# separated list containing: +# The domain for which we are deleting the id(s). +# &-separated list of id(s) to delete. +# $client - File open on client socket. +# Returns: +# 1 - Continue processing +# 0 - Exit server. +# +# + +sub del_id_handler { + my ($cmd,$tail,$client) = @_; + + my $userinput = "$cmd:$tail"; + + my ($udom,$what)=split(/:/,$tail); + chomp($what); + my $hashref = &tie_domain_hash($udom, "ids", &GDBM_WRCREAT(), + "D", $what); + if ($hashref) { + my @keys=split(/\&/,$what); + foreach my $key (@keys) { + delete($hashref->{$key}); + } + if (&untie_user_hash($hashref)) { + &Reply($client, "ok\n", $userinput); + } else { + &Failure($client, "error: ".($!+0)." untie(GDBM) Failed ". + "while attempting iddel\n", $userinput); + } + } else { + &Failure( $client, "error: ".($!+0)." tie(GDBM) Failed ". + "while attempting iddel\n", $userinput); + } + return 1; +} +®ister_handler("iddel", \&del_id_handler, 0, 1, 0); + # # Puts broadcast e-mail sent by Domain Coordinator in nohist_dcmail database # @@ -4953,9 +5026,10 @@ sub validate_instcode_handler { my ($dom,$instcode,$owner) = split(/:/, $tail); $instcode = &unescape($instcode); $owner = &unescape($owner); - my ($outcome,$description) = + my ($outcome,$description,$credits) = &localenroll::validate_instcode($dom,$instcode,$owner); - my $result = &escape($outcome).'&'.&escape($description); + my $result = &escape($outcome).'&'.&escape($description).'&'. + &escape($credits); &Reply($client, \$result, $userinput); return 1; @@ -5008,10 +5082,11 @@ sub get_sections_handler { sub validate_course_owner_handler { my ($cmd, $tail, $client) = @_; my $userinput = "$cmd:$tail"; - my ($inst_course_id, $owner, $cdom) = split(/:/, $tail); - + my ($inst_course_id, $owner, $cdom, $coowners) = split(/:/, $tail); + $owner = &unescape($owner); - my $outcome = &localenroll::new_course($inst_course_id,$owner,$cdom); + $coowners = &unescape($coowners); + my $outcome = &localenroll::new_course($inst_course_id,$owner,$cdom,$coowners); &Reply($client, \$outcome, $userinput); @@ -5220,6 +5295,49 @@ sub validate_crsreq_handler { } ®ister_handler("autocrsreqvalidation", \&validate_crsreq_handler, 0, 1, 0); +sub crsreq_update_handler { + my ($cmd, $tail, $client) = @_; + my $userinput = "$cmd:$tail"; + my ($cdom,$cnum,$crstype,$action,$ownername,$ownerdomain,$fullname,$title,$code,$infohashref) = + split(/:/, $tail); + $crstype = &unescape($crstype); + $action = &unescape($action); + $ownername = &unescape($ownername); + $ownerdomain = &unescape($ownerdomain); + $fullname = &unescape($fullname); + $title = &unescape($title); + $code = &unescape($code); + my $incoming = &Apache::lonnet::thaw_unescape($infohashref); + my ($result,$outcome); + eval { + local($SIG{__DIE__})='DEFAULT'; + my %rtnhash; + $outcome = &localenroll::crsreq_updates($cdom,$cnum,$crstype,$action, + $ownername,$ownerdomain,$fullname, + $title,$code,$incoming,\%rtnhash); + if ($outcome eq 'ok') { + my @posskeys = qw(createdweb createdmsg queuedweb queuedmsg formitems reviewweb); + foreach my $key (keys(%rtnhash)) { + if (grep(/^\Q$key\E/,@posskeys)) { + $result .= &escape($key).'='.&Apache::lonnet::freeze_escape($rtnhash{$key}).'&'; + } + } + $result =~ s/\&$//; + } + }; + if (!$@) { + if ($outcome eq 'ok') { + &Reply($client, \$result, $userinput); + } else { + &Reply($client, "format_error\n", $userinput); + } + } else { + &Failure($client,"unknown_cmd\n",$userinput); + } + return 1; +} +®ister_handler("autocrsrequpdate", \&crsreq_update_handler, 0, 1, 0); + # # Read and retrieve institutional code format (for support form). # Formal Parameters: @@ -5927,18 +6045,6 @@ sub lcpasswdstrerror { } } -# -# 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)=@_; @@ -6062,9 +6168,13 @@ sub HUPSMAN { # sig # a setuid perl script that can be root for us to do this job. # sub ReloadApache { - my $execdir = $perlvar{'lonDaemons'}; - my $script = $execdir."/apachereload"; - system($script); +# --------------------------- Handle case of another apachereload process (locking) + if (&LONCAPA::try_to_lock('/tmp/lock_apachereload')) { + my $execdir = $perlvar{'lonDaemons'}; + my $script = $execdir."/apachereload"; + system($script); + unlink('/tmp/lock_apachereload'); # Remove the lock file. + } } # @@ -6328,7 +6438,14 @@ $SIG{USR2} = \&UpdateHosts; &Apache::lonnet::load_hosts_tab(); my %iphost = &Apache::lonnet::get_iphost(1); -my $dist=`$perlvar{'lonDaemons'}/distprobe`; +$dist=`$perlvar{'lonDaemons'}/distprobe`; + +my $arch = `uname -i`; +chomp($arch); +if ($arch eq 'unknown') { + $arch = `uname -m`; + chomp($arch); +} # -------------------------------------------------------------- # Accept connections. When a connection comes in, it is validated @@ -6414,7 +6531,9 @@ sub make_new_child { #---------------------------------------------------- kerberos 5 initialization &Authen::Krb5::init_context(); unless (($dist eq 'fedora5') || ($dist eq 'fedora4') || - ($dist eq 'fedora6') || ($dist eq 'suse9.3')) { + ($dist eq 'fedora6') || ($dist eq 'suse9.3') || + ($dist eq 'suse12.2') || ($dist eq 'suse12.3') || + ($dist eq 'suse13.1')) { &Authen::Krb5::init_ets(); } @@ -6460,6 +6579,12 @@ sub make_new_child { # If the remote is attempting a local init... give that a try: # (my $i, my $inittype, $clientversion) = split(/:/, $remotereq); + # For LON-CAPA 2.9, the client session will have sent its LON-CAPA + # version when initiating the connection. For LON-CAPA 2.8 and older, + # the version is retrieved from the global %loncaparevs in lonnet.pm. + # $clientversion contains path to keyfile if $inittype eq 'local' + # it's overridden below in this case + $clientversion ||= $Apache::lonnet::loncaparevs{$clientname}; # If the connection type is ssl, but I didn't get my # certificate files yet, then I'll drop back to @@ -6603,22 +6728,29 @@ sub is_author { # Author role should show up as a key /domain/_au - my $key = "/$domain/_au"; my $value; - if (defined($hashref)) { - $value = $hashref->{$key}; - } + if ($hashref) { - if(defined($value)) { - &Debug("$user @ $domain is an author"); + my $key = "/$domain/_au"; + if (defined($hashref)) { + $value = $hashref->{$key}; + if(!untie_user_hash($hashref)) { + return 'error: ' . ($!+0)." untie (GDBM) Failed"; + } + } + + if(defined($value)) { + &Debug("$user @ $domain is an author"); + } + } else { + return 'error: '.($!+0)." tie (GDBM) Failed"; } return defined($value); } # # Checks to see if the input roleput request was to set -# an author role. If so, invokes the lchtmldir script to set -# up a correct public_html +# an author role. If so, creates construction space # Parameters: # request - The request sent to the rolesput subchunk. # We're looking for /domain/_au @@ -6628,16 +6760,15 @@ sub is_author { # 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 =~ /^(\/\Q$domain\E\/_au)$/) { # It's an author rolesput... - my $execdir = $perlvar{'lonDaemons'}; - my $userhome= "/home/$user" ; - &logthis("system $execdir/lchtmldir $userhome $user $authtype"); - &Debug("Setting homedir permissions for $userhome"); - system("$execdir/lchtmldir $userhome $user $authtype"); + my $path=$perlvar{'lonDocRoot'}."/priv/$domain"; + unless (-e $path) { + mkdir($path); + } + unless (-e $path.'/'.$user) { + mkdir($path.'/'.$user); + } } } @@ -7126,7 +7257,9 @@ sub subscribe { # the metadata unless ($fname=~/\.meta$/) { &unsub("$fname.meta",$clientip); } $fname=~s/\/home\/httpd\/html\/res/raw/; - $fname="http://".&Apache::lonnet::hostname($perlvar{'lonHostID'})."/".$fname; + my $protocol = $Apache::lonnet::protocol{$perlvar{'lonHostID'}}; + $protocol = 'http' if ($protocol ne 'https'); + $fname=$protocol.'://'.&Apache::lonnet::hostname($perlvar{'lonHostID'})."/".$fname; $result="$fname\n"; } } else { @@ -7168,7 +7301,7 @@ sub change_unix_password { sub make_passwd_file { - my ($uname, $umode,$npass,$passfilename)=@_; + my ($uname,$udom,$umode,$npass,$passfilename)=@_; my $result="ok"; if ($umode eq 'krb4' or $umode eq 'krb5') { { @@ -7202,55 +7335,8 @@ sub make_passwd_file { } } } elsif ($umode eq 'unix') { - { - # - # Don't allow the creation of privileged accounts!!! that would - # be real bad!!! - # - my $uid = getpwnam($uname); - if((defined $uid) && ($uid == 0)) { - &logthis(">>>Attempted to create privilged account blocked"); - return "no_priv_account_error\n"; - } - - my $execpath ="$perlvar{'lonDaemons'}/"."lcuseradd"; - - my $lc_error_file = $execdir."/tmp/lcuseradd".$$.".status"; - { - &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"; - print $se "$lc_error_file\n"; # Status -> unique file. - } - 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"; - } 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"; - } - } + &logthis(">>>Attempt to create unix account blocked -- unix auth not available for new users."); + $result="no_new_unix_accounts"; } elsif ($umode eq 'none') { { my $pf = IO::File->new("> $passfilename"); @@ -7314,166 +7400,9 @@ sub get_usersession_config { return; } -sub releasereqd_check { - my ($cnum,$cdom,$key,$value,$major,$minor,$homecourses,$ids) = @_; - my $home = &Apache::lonnet::homeserver($cnum,$cdom); - return if ($home eq 'no_host'); - my ($reqdmajor,$reqdminor,$displayrole); - if ($cnum =~ /$LONCAPA::match_community/) { - if ($major eq '' && $minor eq '') { - return unless ((ref($ids) eq 'ARRAY') && - (grep(/^\Q$home\E$/,@{$ids}))); - } else { - $reqdmajor = 2; - $reqdminor = 9; - return unless (&useable_role($reqdmajor,$reqdminor,$major,$minor)); - } - } - my $hashid = $cdom.':'.$cnum; - my ($courseinfo,$cached) = - &Apache::lonnet::is_cached_new('courseinfo',$hashid); - if (defined($cached)) { - if (ref($courseinfo) eq 'HASH') { - if (exists($courseinfo->{'releaserequired'})) { - my ($reqdmajor,$reqdminor) = split(/\./,$courseinfo->{'releaserequired'}); - return unless (&useable_role($reqdmajor,$reqdminor,$major,$minor)); - } - } - } else { - if (ref($ids) eq 'ARRAY') { - if (grep(/^\Q$home\E$/,@{$ids})) { - if (ref($homecourses) eq 'HASH') { - if (ref($homecourses->{$hashid}) eq 'ARRAY') { - push(@{$homecourses->{$hashid}},{$key=>$value}); - } else { - $homecourses->{$hashid} = [{$key=>$value}]; - } - } - return; - } - } - my $courseinfo = &get_courseinfo_hash($cnum,$cdom,$home); - if (ref($courseinfo) eq 'HASH') { - if (exists($courseinfo->{'releaserequired'})) { - my ($reqdmajor,$reqdminor) = split(/\./,$courseinfo->{'releaserequired'}); - return unless (&useable_role($reqdmajor,$reqdminor,$major,$minor)); - } - } else { - return; - } - } - return 1; -} -sub get_courseinfo_hash { - my ($cnum,$cdom,$home) = @_; - my %info; - eval { - local($SIG{ALRM}) = sub { die "timeout\n"; }; - local($SIG{__DIE__})='DEFAULT'; - alarm(3); - %info = &Apache::lonnet::courseiddump($cdom,'.',1,'.','.',$cnum,1,[$home],'.'); - alarm(0); - }; - if ($@) { - if ($@ eq "timeout\n") { - &logthis("WARNING courseiddump for $cnum:$cdom from $home timedout"); - } else { - &logthis("WARNING unexpected error during eval of call for courseiddump from $home"); - } - } else { - if (ref($info{$cdom.'_'.$cnum}) eq 'HASH') { - my $hashid = $cdom.':'.$cnum; - return &Apache::lonnet::do_cache_new('courseinfo',$hashid,$info{$cdom.'_'.$cnum},600); - } - } - return; -} - -sub check_homecourses { - my ($homecourses,$udom,$regexp,$count,$range,$start,$end,$major,$minor) = @_; - my ($result,%addtocache); - my $yesterday = time - 24*3600; - if (ref($homecourses) eq 'HASH') { - my (%okcourses,%courseinfo,%recent); - my $hashref = &tie_domain_hash($udom, "nohist_courseids", &GDBM_WRCREAT()); - if ($hashref) { - while (my ($key,$value) = each(%$hashref)) { - my $unesc_key = &unescape($key); - if ($unesc_key =~ /^lasttime:(\w+)$/) { - my $cid = $1; - $cid =~ s/_/:/; - if ($value > $yesterday ) { - $recent{$cid} = 1; - } - next; - } - my $items = &Apache::lonnet::thaw_unescape($value); - if (ref($items) eq 'HASH') { - my $hashid = $unesc_key; - $hashid =~ s/_/:/; - $courseinfo{$hashid} = $items; - if (ref($homecourses->{$hashid}) eq 'ARRAY') { - my ($reqdmajor,$reqdminor) = split(/\./,$items->{'releaserequired'}); - if (&useable_role($reqdmajor,$reqdminor,$major,$minor)) { - $okcourses{$hashid} = 1; - } - } - } - } - unless (&untie_domain_hash($hashref)) { - &logthis('Failed to untie tied hash for nohist_courseids.db'); - } - } else { - &logthis('Failed to tie hash for nohist_courseids.db'); - return; - } - foreach my $hashid (keys(%recent)) { - my ($result,$cached)=&Apache::lonnet::is_cached_new('courseinfo',$hashid); - unless ($cached) { - &Apache::lonnet::do_cache_new('courseinfo',$hashid,$courseinfo{$hashid},600); - } - } - foreach my $hashid (keys(%{$homecourses})) { - next if ($recent{$hashid}); - &Apache::lonnet::do_cache_new('courseinfo',$hashid,$courseinfo{$hashid},600); - } - foreach my $hashid (keys(%okcourses)) { - if (ref($homecourses->{$hashid}) eq 'ARRAY') { - foreach my $role (@{$homecourses->{$hashid}}) { - if (ref($role) eq 'HASH') { - while (my ($key,$value) = each(%{$role})) { - if ($regexp eq '.') { - $count++; - if (defined($range) && $count >= $end) { last; } - if (defined($range) && $count < $start) { next; } - $result.=$key.'='.$value.'&'; - } else { - my $unescapeKey = &unescape($key); - if (eval('$unescapeKey=~/$regexp/')) { - $count++; - if (defined($range) && $count >= $end) { last; } - if (defined($range) && $count < $start) { next; } - $result.="$key=$value&"; - } - } - } - } - } - } - } - } - return $result; -} - -sub useable_role { - my ($reqdmajor,$reqdminor,$major,$minor) = @_; - if ($reqdmajor ne '' && $reqdminor ne '') { - return if (($major eq '' && $minor eq '') || - ($major < $reqdmajor) || - (($major == $reqdmajor) && ($minor < $reqdminor))); - } - return 1; +sub distro_and_arch { + return $dist.':'.$arch; } # ----------------------------------- POD (plain old documentation, CPAN style) @@ -7683,7 +7612,7 @@ Place in B stores hash in namespace -=item rolesputy +=item rolesput put a role into a user's environment