--- loncom/lonnet/perl/lonnet.pm 2023/12/23 02:17:39 1.1520
+++ loncom/lonnet/perl/lonnet.pm 2025/01/05 21:53:43 1.1533
@@ -1,7 +1,7 @@
# The LearningOnline Network
# TCP networking package
#
-# $Id: lonnet.pm,v 1.1520 2023/12/23 02:17:39 raeburn Exp $
+# $Id: lonnet.pm,v 1.1533 2025/01/05 21:53:43 raeburn Exp $
#
# Copyright Michigan State University Board of Trustees
#
@@ -188,7 +188,11 @@ sub create_connection {
Type => SOCK_STREAM,
Timeout => 10);
return 0 if (!$client);
- print $client (join(':',$hostname,$lonid,&machine_ids($hostname),$loncaparevs{$lonid})."\n");
+ if ($loncaparevs{$lonid} =~ /^(\d+\.\d+\.[\w.]+)-\d+$/) {
+ print $client (join(':',$hostname,$lonid,$1,&machine_ids($hostname))."\n");
+ } else {
+ print $client (join(':',$hostname,$lonid,&machine_ids($hostname))."\n");
+ }
my $result = <$client>;
chomp($result);
return 1 if ($result eq 'done');
@@ -224,7 +228,7 @@ sub get_server_distarch {
}
}
my $rep = &reply('serverdistarch',$lonhost);
- unless ($rep eq 'unknown_command' || $rep eq 'no_such_host' ||
+ unless ($rep eq 'unknown_cmd' || $rep eq 'no_such_host' ||
$rep eq 'con_lost' || $rep eq 'rejected' || $rep eq 'refused' ||
$rep eq '') {
return &do_cache_new('serverdistarch',$lonhost,$rep,$cachetime);
@@ -2783,7 +2787,7 @@ sub get_domain_defaults {
} else {
$domdefaults{'defaultquota'} = $domconfig{'quotas'};
}
- my @usertools = ('aboutme','blog','webdav','portfolio');
+ my @usertools = ('aboutme','blog','webdav','portfolio','portaccess');
foreach my $item (@usertools) {
if (ref($domconfig{'quotas'}{$item}) eq 'HASH') {
$domdefaults{$item} = $domconfig{'quotas'}{$item};
@@ -2802,7 +2806,7 @@ sub get_domain_defaults {
$domdefaults{'requestauthor'} = $domconfig{'requestauthor'};
}
if (ref($domconfig{'authordefaults'}) eq 'HASH') {
- foreach my $item ('nocodemirror','copyright','sourceavail','domcoordacc','editors') {
+ foreach my $item ('nocodemirror','copyright','sourceavail','domcoordacc','editors','archive') {
if ($item eq 'editors') {
if (ref($domconfig{'authordefaults'}{'editors'}) eq 'ARRAY') {
$domdefaults{$item} = join(',',@{$domconfig{'authordefaults'}{'editors'}});
@@ -2825,6 +2829,9 @@ sub get_domain_defaults {
if (ref($domconfig{'coursedefaults'}{'postsubmit'}) eq 'HASH') {
$domdefaults{'postsubmit'} = $domconfig{'coursedefaults'}{'postsubmit'}{'client'};
}
+ if (ref($domconfig{'coursedefaults'}{'crseditors'}) eq 'ARRAY') {
+ $domdefaults{'crseditors'}=join(',',@{$domconfig{'coursedefaults'}{'crseditors'}});
+ }
foreach my $type (@coursetypes) {
if (ref($domconfig{'coursedefaults'}{'coursecredits'}) eq 'HASH') {
unless ($type eq 'community') {
@@ -2975,6 +2982,17 @@ sub get_domain_defaults {
$domdefaults{'ltiprivhosts'} = $domconfig{'ltisec'}{'private'}{'keys'};
}
}
+ if (ref($domconfig{'ltisec'}{'suggested'}) eq 'HASH') {
+ my %suggestions = %{$domconfig{'ltisec'}{'suggested'}};
+ foreach my $item (keys(%{$domconfig{'ltisec'}{'suggested'}})) {
+ unless (ref($domconfig{'ltisec'}{'suggested'}{$item}) eq 'HASH') {
+ delete($suggestions{$item});
+ }
+ }
+ if (keys(%suggestions)) {
+ $domdefaults{'linkprotsuggested'} = \%suggestions;
+ }
+ }
}
if (ref($domconfig{'toolsec'}) eq 'HASH') {
if (ref($domconfig{'toolsec'}{'encrypt'}) eq 'HASH') {
@@ -5609,6 +5627,39 @@ sub coauthorrolelog {
return;
}
+sub authorarchivelog {
+ my ($hashref,$size,$filesdest,$action) = @_;
+ my $lonprtdir = $Apache::lonnet::perlvar{'lonPrtDir'};
+ my $londocroot = $Apache::lonnet::perlvar{'lonDocRoot'};
+ $filesdest =~ s{^\Q$lonprtdir/\E}{};
+ if ($filesdest =~ m{^($match_username)_($match_domain)_archive_(\d+_\d+_\d+(|[.\w]+))$}) {
+ my ($auname,$audom,$id) = ($1,$2,$3);
+ if (ref($hashref) eq 'HASH') {
+ my $namespace = 'archivelog';
+ my $dir;
+ if ($hashref->{dir} =~ m{^\Q$londocroot/priv/$audom/$auname\E(.*)$}) {
+ $dir = $1;
+ }
+ my $delflag = 0;
+ my %storehash = (
+ id => $id,
+ dir => $dir,
+ files => $hashref->{numfiles},
+ subdirs => $hashref->{numdirs},
+ bytes => $hashref->{bytes},
+ size => $size,
+ action => $action,
+ );
+ if ($action eq 'delete') {
+ $delflag = 1;
+ }
+ &write_log('author',$namespace,\%storehash,$delflag,$auname,
+ $audom,$auname,$audom);
+ }
+ }
+ return;
+}
+
sub get_course_adv_roles {
my ($cid,$codes) = @_;
$cid=$env{'request.course.id'} unless (defined($cid));
@@ -6116,7 +6167,7 @@ sub courselastaccess {
sub extract_lastaccess {
my ($returnhash,$rep) = @_;
if (ref($returnhash) eq 'HASH') {
- unless ($rep eq 'unknown_command' || $rep eq 'no_such_host' ||
+ unless ($rep eq 'unknown_cmd' || $rep eq 'no_such_host' ||
$rep eq 'con_lost' || $rep eq 'rejected' || $rep eq 'refused' ||
$rep eq '') {
my @pairs=split(/\&/,$rep);
@@ -6703,13 +6754,17 @@ sub cstore {
if ($stuname) { $home=&homeserver($stuname,$domain); }
- $symb=&symbclean($symb);
+ unless (($symb eq '_feedback') || ($symb eq '_discussion')) {
+ $symb=&symbclean($symb);
+ }
if (!$symb) { unless ($symb=&symbread()) { return ''; } }
if (!$domain) { $domain=$env{'user.domain'}; }
if (!$stuname) { $stuname=$env{'user.name'}; }
- &devalidate($symb,$stuname,$domain);
+ unless (($symb eq '_feedback') || ($symb eq '_discussion')) {
+ &devalidate($symb,$stuname,$domain);
+ }
$symb=escape($symb);
if (!$namespace) {
@@ -6719,7 +6774,7 @@ sub cstore {
}
if (!$home) { $home=$env{'user.home'}; }
- $$storehash{'ip'}=&get_requestor_ip();
+ $$storehash{'ip'} = &get_requestor_ip();
$$storehash{'host'}=$perlvar{'lonHostID'};
my $namevalue='';
@@ -6998,6 +7053,7 @@ sub rolesinit {
my %allroles=();
my %allgroups=();
my %gotcoauconfig=();
+ my %domdefaults=();
for my $area (grep { ! /^rolesdef_/ } keys(%rolesdump)) {
my $role = $rolesdump{$area};
@@ -7060,6 +7116,20 @@ sub rolesinit {
my $name = $item;
if ($item eq 'authoreditors') {
$name = 'editors';
+ unless ($info{'authoreditors'}) {
+ my %domdefs;
+ if (ref($domdefaults{$audom}) eq 'HASH') {
+ %domdefs = %{$domdefaults{$audom}};
+ } else {
+ %domdefs = &get_domain_defaults($audom);
+ $domdefaults{$audom} = \%domdefs;
+ }
+ if ($domdefs{$name} ne '') {
+ $info{'authoreditors'} = $domdefs{$name};
+ } else {
+ $info{'authoreditors'} = 'edit,xml';
+ }
+ }
}
$coauthorenv{"environment.internal.$name.$area"} = $info{$item};
}
@@ -7988,7 +8058,7 @@ sub portfolio_access {
}
sub get_portfolio_access {
- my ($udom,$unum,$file_name,$group,$clientip,$access_hash) = @_;
+ my ($udom,$unum,$file_name,$group,$clientip,$access_hash,$portaccessref) = @_;
if (!ref($access_hash)) {
my $current_perms = &get_portfile_permissions($udom,$unum);
@@ -7997,11 +8067,19 @@ sub get_portfolio_access {
$access_hash = $access_controls{$file_name};
}
- my ($public,$guest,@domains,@users,@courses,@groups,@ips);
+ my $portaccess;
+ if (ref($portaccess) eq 'SCALAR') {
+ $portaccess = $$portaccessref;
+ } else {
+ $portaccess = &usertools_access($unum,$udom,'portaccess',undef,'tools');
+ }
+
+ my ($public,$guest,@domains,@users,@courses,@groups,@ips,@userips);
my $now = time;
if (ref($access_hash) eq 'HASH') {
foreach my $key (keys(%{$access_hash})) {
my ($num,$scope,$end,$start) = ($key =~ /^([^:]+):([a-z]+)_(\d*)_?(\d*)$/);
+ next if (($scope ne 'ip') && ($portaccess == 0));
if ($start > $now) {
next;
}
@@ -8023,6 +8101,8 @@ sub get_portfolio_access {
push(@groups,$key);
} elsif ($scope eq 'ip') {
push(@ips,$key);
+ } elsif ($scope eq 'userip') {
+ push(@userips,$key);
}
}
if ($public) {
@@ -8040,6 +8120,19 @@ sub get_portfolio_access {
if ($allowed) {
return 'ok';
}
+ } elsif (@userips > 0) {
+ my $allowed;
+ foreach my $useripkey (@userips) {
+ if (ref($access_hash->{$useripkey}{'ip'}) eq 'ARRAY') {
+ if (&Apache::loncommon::check_ip_acc(join(',',@{$access_hash->{$useripkey}{'ip'}}),$clientip)) {
+ $allowed = 1;
+ last;
+ }
+ }
+ }
+ if ($allowed) {
+ return 'ok';
+ }
}
if ($env{'user.name'} eq 'public' && $env{'user.domain'} eq 'public') {
if ($guest) {
@@ -8253,6 +8346,7 @@ sub usertools_access {
%tools = (
aboutme => 1,
blog => 1,
+ webdav => 1,
portfolio => 1,
portaccess => 1,
timezone => 1,
@@ -10315,7 +10409,7 @@ sub auto_instsec_reformat {
my $info = &freeze_escape($instsecref);
my $response=&reply('autoinstsecreformat:'.$cdom.':'.
$action.':'.$info,$server);
- next if ($response =~ /(con_lost|error|no_such_host|refused|unknown_command)/);
+ next if ($response =~ /(con_lost|error|no_such_host|refused|unknown_cmd)/);
my @items = split(/&/,$response);
foreach my $item (@items) {
my ($key,$value) = split(/=/,$item);
@@ -10397,7 +10491,7 @@ sub auto_export_grades {
my $grades = &freeze_escape($gradesref);
my $response=&reply('encrypt:autoexportgrades:'.$cdom.':'.$cnum.':'.
$info.':'.$grades,$homeserver);
- unless ($response =~ /(con_lost|error|no_such_host|refused|unknown_command)/) {
+ unless ($response =~ /(con_lost|error|no_such_host|refused|unknown_cmd)/) {
my @items = split(/&/,$response);
foreach my $item (@items) {
my ($key,$value) = split('=',$item);
@@ -11590,7 +11684,7 @@ sub is_course {
}
sub store_userdata {
- my ($storehash,$datakey,$namespace,$udom,$uname) = @_;
+ my ($storehash,$datakey,$namespace,$udom,$uname,$ip) = @_;
my $result;
if ($datakey ne '') {
if (ref($storehash) eq 'HASH') {
@@ -11602,7 +11696,11 @@ sub store_userdata {
if (($uhome eq '') || ($uhome eq 'no_host')) {
$result = 'error: no_host';
} else {
- $storehash->{'ip'} = &get_requestor_ip();
+ if ($ip ne '') {
+ $storehash->{'ip'} = $ip;
+ } else {
+ $storehash->{'ip'} = &get_requestor_ip();
+ }
$storehash->{'host'} = $perlvar{'lonHostID'};
my $namevalue='';
@@ -12457,6 +12555,8 @@ sub stat_file {
# $relpath - Current path (relative to top level).
# $dirhashref - reference to hash to populate with URLs of directories (Required)
# $filehashref - reference to hash to populate with URLs of files (Optional)
+# $getlastmod - if true, will set value for each key in innerhash in $filehashref
+# to last modification time of file; value set to 1 otherwise.
#
# Returns: nothing
#
@@ -12469,7 +12569,8 @@ sub stat_file {
#
sub recursedirs {
- my ($is_home,$recurse,$include,$exclude,$nonemptydir,$addtopdir,$toppath,$relpath,$dirhashref,$filehashref) = @_;
+ my ($is_home,$recurse,$include,$exclude,$nonemptydir,$addtopdir,$toppath,
+ $relpath,$dirhashref,$filehashref,$getlastmod) = @_;
return unless (ref($dirhashref) eq 'HASH');
my $docroot = $perlvar{'lonDocRoot'};
my $currpath = $docroot.$toppath;
@@ -12477,7 +12578,7 @@ sub recursedirs {
$currpath .= "/$relpath";
}
my ($savefile,$checkinc,$checkexc);
- if (ref($filehashref)) {
+ if (ref($filehashref) eq 'HASH') {
$savefile = 1;
}
if (ref($include) eq 'HASH') {
@@ -12500,7 +12601,8 @@ sub recursedirs {
}
$dirhashref->{&Apache::lonlocal::js_escape($newpath)} = 1;
if ($recurse) {
- &recursedirs($is_home,$recurse,$include,$exclude,$nonemptydir,$addtopdir,$toppath,$newpath,$dirhashref,$filehashref);
+ &recursedirs($is_home,$recurse,$include,$exclude,$nonemptydir,$addtopdir,
+ $toppath,$newpath,$dirhashref,$filehashref,$getlastmod);
}
} elsif (($savefile) || ($relpath eq '')) {
next if ($nonemptydir && $filecount);
@@ -12517,10 +12619,16 @@ sub recursedirs {
$dirhashref->{'/'} = 1;
}
if ($savefile) {
+ my $value;
+ if ($getlastmod) {
+ ($value) = (stat("$currpath/$item"))[9];
+ } else {
+ $value = 1;
+ }
if ($relpath eq '') {
- $filehashref->{'/'}{$item} = 1;
+ $filehashref->{'/'}{$item} = $value
} else {
- $filehashref->{&Apache::lonlocal::js_escape($relpath)}{$item} = 1;
+ $filehashref->{&Apache::lonlocal::js_escape($relpath)}{$item} = $value;
}
}
$filecount ++;
@@ -12529,8 +12637,11 @@ sub recursedirs {
closedir($dirh);
}
} else {
- my ($dirlistref,$listerror) =
- &dirlist($toppath.$relpath);
+ my $url = $toppath;
+ if ($relpath ne '') {
+ $url = $toppath.'/'.$relpath;
+ }
+ my ($dirlistref,$listerror) = &dirlist($url);
my @dir_lines;
my $dirptr=16384;
if (ref($dirlistref) eq 'ARRAY') {
@@ -12554,12 +12665,13 @@ sub recursedirs {
}
$dirhashref->{&Apache::lonlocal::js_escape($newpath)} = 1;
if ($recurse) {
- &recursedirs($is_home,$recurse,$include,$exclude,$nonemptydir,$addtopdir,$toppath,$newpath,$dirhashref,$filehashref);
+ &recursedirs($is_home,$recurse,$include,$exclude,$nonemptydir,$addtopdir,
+ $toppath,$newpath,$dirhashref,$filehashref,$getlastmod);
}
} elsif (($savefile) || ($relpath eq '')) {
next if ($nonemptydir && $filecount);
if ($checkinc || $checkexc) {
- my $extension;
+ my ($extension) = ($item =~ /\.(\w+)$/);
if ($checkinc) {
next unless ($extension && $include->{$extension});
}
@@ -12571,10 +12683,16 @@ sub recursedirs {
$dirhashref->{'/'} = 1;
}
if ($savefile) {
+ my $value;
+ if ($getlastmod) {
+ $value = $mtime;
+ } else {
+ $value = 1;
+ }
if ($relpath eq '') {
- $filehashref->{'/'}{$item} = 1;
+ $filehashref->{'/'}{$item} = $value;
} else {
- $filehashref->{&Apache::lonlocal::js_escape($relpath)}{$item} = 1;
+ $filehashref->{&Apache::lonlocal::js_escape($relpath)}{$item} = $value;
}
}
$filecount ++;
@@ -12601,6 +12719,14 @@ sub priv_exclude {
};
}
+sub res_exclude {
+ return {
+ meta => 1,
+ subscription => 1,
+ rights => 1,
+ };
+}
+
# -------------------------------------------------------- Value of a Condition
# gets the value of a specific preevaluated condition
@@ -15070,6 +15196,49 @@ sub repcopy_userfile {
return 'ok';
}
+sub repcopy_crsprivfile {
+ my ($src,$dest) = @_;
+ my $result;
+ if ($src =~ m{^/priv/($match_domain)/($match_courseid)/(.+)$}) {
+ my ($cdom,$cnum,$filepath) = ($1,$2,$3);
+ $filepath =~ s/\.{2,}//g;
+ my $chome = &homeserver($cnum,$cdom);
+ unless ($chome eq 'no_host') {
+ my @ids=¤t_machine_ids();
+ unless (grep(/^\Q$chome\E$/,@ids)) {
+ if (&is_course($cdom,$cnum)) {
+ my $londocroot = $perlvar{'lonDocRoot'};
+ if ($dest =~ m{^\Q$londocroot/priv/\E$match_domain/$match_username/.*\Q$filepath\E$}) {
+ my $cmd = 'crsfilefrompriv:'.&escape($filepath).':'.&escape($cnum).':'.&escape($cdom);
+ $result = &reply($cmd,$chome);
+ unless (($result eq 'unknown_cmd') || ($result =~ /^error:/)) {
+ my $url = &unescape($result);
+ if ($url =~ m{^https?://[^/]+\Q/userfiles/$cdom/$cnum/priv/$filepath\E$}) {
+ my $request=new HTTP::Request('GET',$url);
+ my $response=&LONCAPA::LWPReq::makerequest($chome,$request,'',\%perlvar,1200,1);
+ if ($response->is_error()) {
+ $result = 'error: '.$response->status_line;
+ } else {
+ if (open(my $fh,'>',$dest)) {
+ print $fh $response->content;
+ close($fh);
+ $result = 'ok';
+ } else {
+ $result = 'error: nowrite';
+ }
+ }
+ } else {
+ $result = 'error: invalidurl';
+ }
+ }
+ }
+ }
+ }
+ }
+ }
+ return $result;
+}
+
sub tokenwrapper {
my $uri=shift;
$uri=~s|^https?\://([^/]+)||;