version 1.1457, 2021/06/06 23:18:59
|
version 1.1462, 2021/08/01 19:28:11
|
Line 468 sub reply {
|
Line 468 sub reply {
|
my $subcmd = $1; |
my $subcmd = $1; |
if (($subcmd eq 'auth') || ($subcmd eq 'passwd') || |
if (($subcmd eq 'auth') || ($subcmd eq 'passwd') || |
($subcmd eq 'changeuserauth') || ($subcmd eq 'makeuser') || |
($subcmd eq 'changeuserauth') || ($subcmd eq 'makeuser') || |
($subcmd eq 'putdom') || ($subcmd eq 'autoexportgrades')) { |
($subcmd eq 'putdom') || ($subcmd eq 'autoexportgrades') || |
|
($subcmd eq 'put')) { |
(undef,undef,my @rest) = split(/:/,$cmd); |
(undef,undef,my @rest) = split(/:/,$cmd); |
if (($subcmd eq 'auth') || ($subcmd eq 'putdom')) { |
if (($subcmd eq 'auth') || ($subcmd eq 'putdom')) { |
splice(@rest,2,1,'Hidden'); |
splice(@rest,2,1,'Hidden'); |
} elsif ($subcmd eq 'passwd') { |
} elsif ($subcmd eq 'passwd') { |
splice(@rest,2,2,('Hidden','Hidden')); |
splice(@rest,2,2,('Hidden','Hidden')); |
} elsif (($subcmd eq 'changeuserauth') || ($subcmd eq 'makeuser') || |
} elsif (($subcmd eq 'changeuserauth') || ($subcmd eq 'makeuser') || |
($subcmd eq 'autoexportgrades')) { |
($subcmd eq 'autoexportgrades') || ($subcmd eq 'put')) { |
splice(@rest,3,1,'Hidden'); |
splice(@rest,3,1,'Hidden'); |
} |
} |
$logged = join(':',('encrypt:'.$subcmd,@rest)); |
$logged = join(':',('encrypt:'.$subcmd,@rest)); |
Line 2146 sub dump_dom {
|
Line 2147 sub dump_dom {
|
# ------------------------------------------ get items from domain db files |
# ------------------------------------------ get items from domain db files |
|
|
sub get_dom { |
sub get_dom { |
my ($namespace,$storearr,$udom,$uhome)=@_; |
my ($namespace,$storearr,$udom,$uhome,$encrypt)=@_; |
return if ($udom eq 'public'); |
return if ($udom eq 'public'); |
my $items=''; |
my $items=''; |
foreach my $item (@$storearr) { |
foreach my $item (@$storearr) { |
Line 2172 sub get_dom {
|
Line 2173 sub get_dom {
|
my $rep; |
my $rep; |
if (grep { $_ eq $uhome } ¤t_machine_ids()) { |
if (grep { $_ eq $uhome } ¤t_machine_ids()) { |
# domain information is hosted on this machine |
# domain information is hosted on this machine |
my $cmd = 'getdom'; |
$rep = &LONCAPA::Lond::get_dom("getdom:$udom:$namespace:$items"); |
if ($namespace =~ /^enc/) { |
|
$cmd = 'egetdom'; |
|
} |
|
$rep = &LONCAPA::Lond::get_dom("$cmd:$udom:$namespace:$items"); |
|
} else { |
} else { |
if ($namespace =~ /^enc/) { |
if ($encrypt) { |
$rep=&reply("encrypt:egetdom:$udom:$namespace:$items",$uhome); |
$rep=&reply("encrypt:egetdom:$udom:$namespace:$items",$uhome); |
} else { |
} else { |
$rep=&reply("getdom:$udom:$namespace:$items",$uhome); |
$rep=&reply("getdom:$udom:$namespace:$items",$uhome); |
Line 2206 sub get_dom {
|
Line 2203 sub get_dom {
|
# -------------------------------------------- put items in domain db files |
# -------------------------------------------- put items in domain db files |
|
|
sub put_dom { |
sub put_dom { |
my ($namespace,$storehash,$udom,$uhome)=@_; |
my ($namespace,$storehash,$udom,$uhome,$encrypt)=@_; |
if (!$udom) { |
if (!$udom) { |
$udom=$env{'user.domain'}; |
$udom=$env{'user.domain'}; |
if (defined(&domain($udom,'primary'))) { |
if (defined(&domain($udom,'primary'))) { |
Line 2227 sub put_dom {
|
Line 2224 sub put_dom {
|
$items.=&escape($item).'='.&freeze_escape($$storehash{$item}).'&'; |
$items.=&escape($item).'='.&freeze_escape($$storehash{$item}).'&'; |
} |
} |
$items=~s/\&$//; |
$items=~s/\&$//; |
if ($namespace =~ /^enc/) { |
if ($encrypt) { |
return &reply("encrypt:putdom:$udom:$namespace:$items",$uhome); |
return &reply("encrypt:putdom:$udom:$namespace:$items",$uhome); |
} else { |
} else { |
return &reply("putdom:$udom:$namespace:$items",$uhome); |
return &reply("putdom:$udom:$namespace:$items",$uhome); |
Line 7117 sub unserialize {
|
Line 7114 sub unserialize {
|
# see Lond::dump_with_regexp |
# see Lond::dump_with_regexp |
# if $escapedkeys hash keys won't get unescaped. |
# if $escapedkeys hash keys won't get unescaped. |
sub dump { |
sub dump { |
my ($namespace,$udomain,$uname,$regexp,$range,$escapedkeys)=@_; |
my ($namespace,$udomain,$uname,$regexp,$range,$escapedkeys,$encrypt)=@_; |
if (!$udomain) { $udomain=$env{'user.domain'}; } |
if (!$udomain) { $udomain=$env{'user.domain'}; } |
if (!$uname) { $uname=$env{'user.name'}; } |
if (!$uname) { $uname=$env{'user.name'}; } |
my $uhome=&homeserver($uname,$udomain); |
my $uhome=&homeserver($uname,$udomain); |
Line 7133 sub dump {
|
Line 7130 sub dump {
|
$uname, $namespace, $regexp, $range)), $perlvar{'lonVersion'}); |
$uname, $namespace, $regexp, $range)), $perlvar{'lonVersion'}); |
return %{unserialize($reply, $escapedkeys)}; |
return %{unserialize($reply, $escapedkeys)}; |
} |
} |
my $rep=&reply("dump:$udomain:$uname:$namespace:$regexp:$range",$uhome); |
my $rep; |
|
if ($encrypt) { |
|
$rep=&reply("encrypt:edump:$udomain:$uname:$namespace:$regexp:$range",$uhome); |
|
} else { |
|
$rep=&reply("dump:$udomain:$uname:$namespace:$regexp:$range",$uhome); |
|
} |
my @pairs=split(/\&/,$rep); |
my @pairs=split(/\&/,$rep); |
my %returnhash=(); |
my %returnhash=(); |
if (!($rep =~ /^error/ )) { |
if (!($rep =~ /^error/ )) { |
Line 7280 sub inc {
|
Line 7282 sub inc {
|
# --------------------------------------------------------------- put interface |
# --------------------------------------------------------------- put interface |
|
|
sub put { |
sub put { |
my ($namespace,$storehash,$udomain,$uname)=@_; |
my ($namespace,$storehash,$udomain,$uname,$encrypt)=@_; |
if (!$udomain) { $udomain=$env{'user.domain'}; } |
if (!$udomain) { $udomain=$env{'user.domain'}; } |
if (!$uname) { $uname=$env{'user.name'}; } |
if (!$uname) { $uname=$env{'user.name'}; } |
my $uhome=&homeserver($uname,$udomain); |
my $uhome=&homeserver($uname,$udomain); |
Line 7289 sub put {
|
Line 7291 sub put {
|
$items.=&escape($item).'='.&freeze_escape($$storehash{$item}).'&'; |
$items.=&escape($item).'='.&freeze_escape($$storehash{$item}).'&'; |
} |
} |
$items=~s/\&$//; |
$items=~s/\&$//; |
return &reply("put:$udomain:$uname:$namespace:$items",$uhome); |
if ($encrypt) { |
|
return &reply("encrypt:put:$udomain:$uname:$namespace:$items",$uhome); |
|
} else { |
|
return &reply("put:$udomain:$uname:$namespace:$items",$uhome); |
|
} |
} |
} |
|
|
# ------------------------------------------------------------ newput interface |
# ------------------------------------------------------------ newput interface |
Line 8117 sub customaccess {
|
Line 8123 sub customaccess {
|
# ------------------------------------------------- Check for a user privilege |
# ------------------------------------------------- Check for a user privilege |
|
|
sub allowed { |
sub allowed { |
my ($priv,$uri,$symb,$role,$clientip,$noblockcheck,$ignorecache)=@_; |
my ($priv,$uri,$symb,$role,$clientip,$noblockcheck,$ignorecache,$nodeeplinkcheck,$nodeeplinkout)=@_; |
my $ver_orguri=$uri; |
my $ver_orguri=$uri; |
$uri=&deversion($uri); |
$uri=&deversion($uri); |
my $orguri=$uri; |
my $orguri=$uri; |
Line 8342 sub allowed {
|
Line 8348 sub allowed {
|
if ($env{'user.priv.'.$env{'request.role'}.'./'} |
if ($env{'user.priv.'.$env{'request.role'}.'./'} |
=~/\Q$priv\E\&([^\:]*)/) { |
=~/\Q$priv\E\&([^\:]*)/) { |
my $value = $1; |
my $value = $1; |
my $deeplinkblock = &deeplink_check($priv,$symb,$uri); |
my $deeplinkblock; |
|
unless ($nodeeplinkcheck) { |
|
$deeplinkblock = &deeplink_check($priv,$symb,$uri); |
|
} |
if ($deeplinkblock) { |
if ($deeplinkblock) { |
$thisallowed='D'; |
$thisallowed='D'; |
} elsif ($noblockcheck) { |
} elsif ($noblockcheck) { |
Line 8365 sub allowed {
|
Line 8374 sub allowed {
|
$refuri=&declutter($refuri); |
$refuri=&declutter($refuri); |
my ($match) = &is_on_map($refuri); |
my ($match) = &is_on_map($refuri); |
if ($match) { |
if ($match) { |
my $deeplinkblock = &deeplink_check($priv,$symb,$refuri); |
my $deeplinkblock; |
|
unless ($nodeeplinkcheck) { |
|
$deeplinkblock = &deeplink_check($priv,$symb,$refuri); |
|
} |
if ($deeplinkblock) { |
if ($deeplinkblock) { |
$thisallowed='D'; |
$thisallowed='D'; |
} elsif ($noblockcheck) { |
} elsif ($noblockcheck) { |
Line 8441 sub allowed {
|
Line 8453 sub allowed {
|
=~/\Q$priv\E\&([^\:]*)/) { |
=~/\Q$priv\E\&([^\:]*)/) { |
my $value = $1; |
my $value = $1; |
if ($priv eq 'bre') { |
if ($priv eq 'bre') { |
if ($noblockcheck) { |
my $deeplinkblock; |
|
unless ($nodeeplinkcheck) { |
|
$deeplinkblock = &deeplink_check($priv,$symb,$uri); |
|
} |
|
if ($deeplinkblock) { |
|
$thisallowed = 'D'; |
|
} elsif ($noblockcheck) { |
$thisallowed.=$value; |
$thisallowed.=$value; |
} else { |
} else { |
my @blockers = &has_comm_blocking($priv,$symb,$uri,$ignorecache); |
my @blockers = &has_comm_blocking($priv,$symb,$uri,$ignorecache); |
Line 8483 sub allowed {
|
Line 8501 sub allowed {
|
=~/\Q$priv\E\&([^\:]*)/) { |
=~/\Q$priv\E\&([^\:]*)/) { |
my $value = $1; |
my $value = $1; |
if ($priv eq 'bre') { |
if ($priv eq 'bre') { |
my $deeplinkblock = &deeplink_check($priv,$symb,$refuri); |
my $deeplinkblock; |
|
unless ($nodeeplinkcheck) { |
|
$deeplinkblock = &deeplink_check($priv,$symb,$refuri); |
|
} |
if ($deeplinkblock) { |
if ($deeplinkblock) { |
$thisallowed = 'D'; |
$thisallowed = 'D'; |
} elsif ($noblockcheck) { |
} elsif ($noblockcheck) { |
Line 8666 sub allowed {
|
Line 8687 sub allowed {
|
} |
} |
} |
} |
|
|
|
# Restricted for deeplinked session? |
|
|
|
if ($env{'request.deeplink.login'}) { |
|
if ($env{'acc.deeplinkout'} && !$nodeeplinkout) { |
|
if (!$symb) { $symb=&symbread($uri,1); } |
|
if (($symb) && ($env{'acc.deeplinkout'}=~/\&\Q$symb\E\&/)) { |
|
return ''; |
|
} |
|
} |
|
} |
|
|
# Restricted by state or randomout? |
# Restricted by state or randomout? |
|
|
if ($thisallowed=~/X/) { |
if ($thisallowed=~/X/) { |
Line 9023 sub deeplink_check {
|
Line 9055 sub deeplink_check {
|
@symbs = keys(%possibles); |
@symbs = keys(%possibles); |
} |
} |
|
|
my ($login,$switchrole,$allow); |
my ($deeplink_symb,$allow); |
if ($env{'request.deeplink.login'} =~ m{^\Q/tiny/$cdom/\E(\w+)$}) { |
if ($env{'request.deeplink.login'}) { |
my $key = $1; |
$deeplink_symb = &Apache::loncommon::deeplink_login_symb($cnum,$cdom); |
my $tinyurl; |
|
my ($result,$cached)=&Apache::lonnet::is_cached_new('tiny',$cdom."\0".$key); |
|
if (defined($cached)) { |
|
$tinyurl = $result; |
|
} else { |
|
my $configuname = &Apache::lonnet::get_domainconfiguser($cdom); |
|
my %currtiny = &Apache::lonnet::get('tiny',[$key],$cdom,$configuname); |
|
if ($currtiny{$key} ne '') { |
|
$tinyurl = $currtiny{$key}; |
|
&Apache::lonnet::do_cache_new('tiny',$cdom."\0".$key,$currtiny{$key},600); |
|
} |
|
} |
|
if ($tinyurl ne '') { |
|
my ($cnumreq,$posslogin) = split(/\&/,$tinyurl); |
|
if ($cnumreq eq $cnum) { |
|
$login = $posslogin; |
|
} else { |
|
$switchrole = 1; |
|
} |
|
} |
|
} |
} |
foreach my $symb (@symbs) { |
foreach my $symb (@symbs) { |
last if ($allow); |
last if ($allow); |
Line 9056 sub deeplink_check {
|
Line 9068 sub deeplink_check {
|
my ($listed,$scope,$access) = split(/,/,$deeplink); |
my ($listed,$scope,$access) = split(/,/,$deeplink); |
if ($access eq 'any') { |
if ($access eq 'any') { |
$allow = 1; |
$allow = 1; |
} elsif ($login) { |
} elsif ($deeplink_symb) { |
if ($access eq 'only') { |
if ($access eq 'only') { |
if ($scope eq 'res') { |
if ($scope eq 'res') { |
if ($symb eq $login) { |
if ($symb eq $deeplink_symb) { |
$allow = 1; |
$allow = 1; |
} |
} |
} elsif ($scope eq 'map') { |
} elsif (($scope eq 'map') || ($scope eq 'rec')) { |
#FIXME Compare map for $env{'request.deeplink.login'} with map for $symb |
my ($map_from_symb,$map_from_login); |
} elsif ($scope eq 'rec') { |
$map_from_symb = &deversion((&decode_symb($symb))[0]); |
#FIXME Recurse up for $env{'request.deeplink.login'} with map for $symb |
if ($deeplink_symb =~ /\.(page|sequence)$/) { |
|
$map_from_login = &deversion((&decode_symb($deeplink_symb))[2]); |
|
} else { |
|
$map_from_login = &deversion((&decode_symb($deeplink_symb))[0]); |
|
} |
|
if (($map_from_symb) && ($map_from_login)) { |
|
if ($map_from_symb eq $map_from_login) { |
|
$allow = 1; |
|
} elsif ($scope eq 'rec') { |
|
my @recurseup = &get_map_hierarchy($map_from_symb,$env{'request.course.id'}); |
|
if (grep(/^\Q$map_from_login\E$/,@recurseup)) { |
|
$allow = 1; |
|
} |
|
} |
|
} |
} |
} |
} else { |
} else { |
my ($acctype,$item) = split(/:/,$access); |
my ($acctype,$item) = split(/:/,$access); |
Line 9776 sub auto_validate_class_sec {
|
Line 9802 sub auto_validate_class_sec {
|
return $response; |
return $response; |
} |
} |
|
|
|
sub auto_instsec_reformat { |
|
my ($cdom,$action,$instsecref) = @_; |
|
return unless(($action eq 'clutter') || ($action eq 'declutter')); |
|
my @homeservers; |
|
if (defined(&domain($cdom,'primary'))) { |
|
push(@homeservers,&domain($cdom,'primary')); |
|
} else { |
|
my %servers = &get_servers($cdom,'library'); |
|
foreach my $tryserver (keys(%servers)) { |
|
if (!grep(/^\Q$tryserver\E$/,@homeservers)) { |
|
push(@homeservers,$tryserver); |
|
} |
|
} |
|
} |
|
my $response; |
|
my %reformatted = %{$instsecref}; |
|
foreach my $server (@homeservers) { |
|
if (ref($instsecref) eq 'HASH') { |
|
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)/); |
|
my @items = split(/&/,$response); |
|
foreach my $item (@items) { |
|
my ($key,$value) = split(/=/,$item); |
|
$reformatted{&unescape($key)} = &thaw_unescape($value); |
|
} |
|
} |
|
} |
|
return %reformatted; |
|
} |
|
|
sub auto_validate_instclasses { |
sub auto_validate_instclasses { |
my ($cdom,$cnum,$owners,$classesref) = @_; |
my ($cdom,$cnum,$owners,$classesref) = @_; |
my ($homeserver,%validations); |
my ($homeserver,%validations); |
Line 12140 sub get_domain_lti {
|
Line 12198 sub get_domain_lti {
|
my %domconfig = &get_dom('configuration',[$name],$cdom); |
my %domconfig = &get_dom('configuration',[$name],$cdom); |
if (ref($domconfig{$name}) eq 'HASH') { |
if (ref($domconfig{$name}) eq 'HASH') { |
%lti = %{$domconfig{$name}}; |
%lti = %{$domconfig{$name}}; |
my %encdomconfig = &get_dom('encconfig',[$name],$cdom); |
my %encdomconfig = &get_dom('encconfig',[$name],$cdom,undef,1); |
if (ref($encdomconfig{$name}) eq 'HASH') { |
if (ref($encdomconfig{$name}) eq 'HASH') { |
foreach my $id (keys(%lti)) { |
foreach my $id (keys(%lti)) { |
if (ref($encdomconfig{$name}{$id}) eq 'HASH') { |
if (ref($encdomconfig{$name}{$id}) eq 'HASH') { |
Line 12216 sub EXT_cache_set {
|
Line 12274 sub EXT_cache_set {
|
# --------------------------------------------------------- Value of a Variable |
# --------------------------------------------------------- Value of a Variable |
sub EXT { |
sub EXT { |
|
|
my ($varname,$symbparm,$udom,$uname,$usection,$recurse,$cid)=@_; |
my ($varname,$symbparm,$udom,$uname,$usection,$recurse,$cid,$recurseupref)=@_; |
unless ($varname) { return ''; } |
unless ($varname) { return ''; } |
#get real user name/domain, courseid and symb |
#get real user name/domain, courseid and symb |
my $courseid; |
my $courseid; |
Line 12370 sub EXT {
|
Line 12428 sub EXT {
|
} |
} |
|
|
my ($section, $group, @groups, @recurseup, $recursed); |
my ($section, $group, @groups, @recurseup, $recursed); |
|
if (ref($recurseupref) eq 'ARRAY') { |
|
@recurseup = @{$recurseupref}; |
|
$recursed = 1; |
|
} |
my ($courselevelm,$courseleveli,$courselevel,$mapp); |
my ($courselevelm,$courseleveli,$courselevel,$mapp); |
if (($courseid eq '') && ($cid)) { |
if (($courseid eq '') && ($cid)) { |
$courseid = $cid; |
$courseid = $cid; |