--- loncom/lonnet/perl/lonnet.pm 2018/12/05 21:36:18 1.1393 +++ loncom/lonnet/perl/lonnet.pm 2021/05/03 15:27:45 1.1450 @@ -1,7 +1,7 @@ # The LearningOnline Network # TCP networking package # -# $Id: lonnet.pm,v 1.1393 2018/12/05 21:36:18 raeburn Exp $ +# $Id: lonnet.pm,v 1.1450 2021/05/03 15:27:45 raeburn Exp $ # # Copyright Michigan State University Board of Trustees # @@ -77,9 +77,9 @@ use CGI::Cookie; use Encode; -use vars qw(%perlvar %spareid %pr %prp $memcache %packagetab $tmpdir +use vars qw(%perlvar %spareid %pr %prp $memcache %packagetab $tmpdir $deftex $_64bit %env %protocol %loncaparevs %serverhomeIDs %needsrelease - %managerstab); + %managerstab $passwdmin); my (%badServerCache, $memcache, %courselogs, %accesshash, %domainrolehash, %userrolehash, $processmarker, $dumpcount, %coursedombuf, @@ -96,11 +96,13 @@ use Cache::Memcached; use Digest::MD5; use Math::Random; use File::MMagic; +use Net::CIDR; use LONCAPA qw(:DEFAULT :match); use LONCAPA::Configuration; use LONCAPA::lonmetadata; use LONCAPA::Lond; use LONCAPA::LWPReq; +use LONCAPA::transliterate; use File::Copy; @@ -127,12 +129,13 @@ our @EXPORT = qw(%env); $logid ++; my $now = time(); my $id=$now.'00000'.$$.'00000'.$logid; + my $ip = &get_requestor_ip(); my $logentry = { $id => { 'exe_uname' => $env{'user.name'}, 'exe_udom' => $env{'user.domain'}, 'exe_time' => $now, - 'exe_ip' => $ENV{'REMOTE_ADDR'}, + 'exe_ip' => $ip, 'delflag' => $delflag, 'logentry' => $storehash, 'uname' => $uname, @@ -184,7 +187,7 @@ sub create_connection { Type => SOCK_STREAM, Timeout => 10); return 0 if (!$client); - print $client (join(':',$hostname,$lonid,&machine_ids($hostname))."\n"); + print $client (join(':',$hostname,$lonid,&machine_ids($hostname),$loncaparevs{$lonid})."\n"); my $result = <$client>; chomp($result); return 1 if ($result eq 'done'); @@ -311,9 +314,10 @@ sub get_server_loncaparev { $answer = &reply('serverloncaparev',$lonhost); if (($answer eq 'unknown_cmd') || ($answer eq 'con_lost')) { if ($caller eq 'loncron') { + my $hostname = &hostname($lonhost); my $protocol = $protocol{$lonhost}; $protocol = 'http' if ($protocol ne 'https'); - my $url = $protocol.'://'.&hostname($lonhost).'/adm/about.html'; + my $url = $protocol.'://'.$hostname.'/adm/about.html'; my $request=new HTTP::Request('GET',$url); my $response=&LONCAPA::LWPReq::makerequest($lonhost,$request,'',\%perlvar,4,1); unless ($response->is_error()) { @@ -458,8 +462,26 @@ sub reply { unless (defined(&hostname($server))) { return 'no_such_host'; } my $answer=subreply($cmd,$server); if (($answer=~/^refused/) || ($answer=~/^rejected/)) { - &logthis("WARNING:". - " $cmd to $server returned $answer"); + my $logged = $cmd; + if ($cmd =~ /^encrypt:([^:]+):/) { + my $subcmd = $1; + if (($subcmd eq 'auth') || ($subcmd eq 'passwd') || + ($subcmd eq 'changeuserauth') || ($subcmd eq 'makeuser') || + ($subcmd eq 'putdom') || ($subcmd eq 'autoexportgrades')) { + (undef,undef,my @rest) = split(/:/,$cmd); + if (($subcmd eq 'auth') || ($subcmd eq 'putdom')) { + splice(@rest,2,1,'Hidden'); + } elsif ($subcmd eq 'passwd') { + splice(@rest,2,2,('Hidden','Hidden')); + } elsif (($subcmd eq 'changeuserauth') || ($subcmd eq 'makeuser') || + ($subcmd eq 'autoexportgrades')) { + splice(@rest,3,1,'Hidden'); + } + $logged = join(':',('encrypt:'.$subcmd,@rest)); + } + } + &logthis("WARNING:". + " $logged to $server returned $answer"); } return $answer; } @@ -671,7 +693,7 @@ sub check_for_valid_session { $lonid=$cookies{$secure}; } elsif (exists($cookies{$name})) { $lonid=$cookies{$name}; - } elsif (exists($cookies{$linkname})) { + } elsif ((exists($cookies{$linkname})) && ($ENV{'SERVER_PORT'} != 443)) { $lonid=$cookies{$linkname}; } elsif (exists($cookies{$pubname})) { $lonid=$cookies{$pubname}; @@ -711,18 +733,23 @@ sub check_for_valid_session { if (!defined($disk_env{'user.name'}) || !defined($disk_env{'user.domain'})) { + untie(%disk_env); return undef; } if (ref($userhashref) eq 'HASH') { $userhashref->{'name'} = $disk_env{'user.name'}; $userhashref->{'domain'} = $disk_env{'user.domain'}; + if ($disk_env{'request.role'}) { + $userhashref->{'role'} = $disk_env{'request.role'}; + } $userhashref->{'lti'} = $disk_env{'request.lti.login'}; if ($userhashref->{'lti'}) { $userhashref->{'ltitarget'} = $disk_env{'request.lti.target'}; $userhashref->{'ltiuri'} = $disk_env{'request.lti.uri'}; } } + untie(%disk_env); return $handle; } @@ -987,13 +1014,13 @@ sub spareserver { } if (!$want_server_name) { - my $protocol = 'http'; - if ($protocol{$spare_server} eq 'https') { - $protocol = $protocol{$spare_server}; - } if (defined($spare_server)) { my $hostname = &hostname($spare_server); if (defined($hostname)) { + my $protocol = 'http'; + if ($protocol{$spare_server} eq 'https') { + $protocol = $protocol{$spare_server}; + } $spare_server = $protocol.'://'.$hostname; } } @@ -1060,6 +1087,19 @@ sub find_existing_session { return; } +sub delusersession { + my ($lonid,$udom,$uname) = @_; + my $uprimary_id = &domain($udom,'primary'); + my $uintdom = &internet_dom($uprimary_id); + my $intdom = &internet_dom($lonid); + my $serverhomedom = &host_domain($lonid); + if (($uintdom ne '') && ($uintdom eq $intdom)) { + return &reply(join(':','delusersession', + map {&escape($_)} ($udom,$uname)),$lonid); + } + return; +} + # check if user's browser sent load balancer cookie and server still has session # and is not overloaded. sub check_for_balancer_cookie { @@ -1115,6 +1155,21 @@ sub check_for_balancer_cookie { return ($otherserver,$cookie); } +sub updatebalcookie { + my ($cookie,$balancer,$lastentry)=@_; + if ($cookie =~ /^($match_domain)\_($match_username)\_[a-f0-9]{32}$/) { + my ($udom,$uname) = ($1,$2); + my $uprimary_id = &domain($udom,'primary'); + my $uintdom = &internet_dom($uprimary_id); + my $intdom = &internet_dom($balancer); + my $serverhomedom = &host_domain($balancer); + if (($uintdom ne '') && ($uintdom eq $intdom)) { + return &reply('updatebalcookie:'.&escape($cookie).':'.&escape($lastentry),$balancer); + } + } + return; +} + sub delbalcookie { my ($cookie,$balancer) =@_; if ($cookie =~ /^($match_domain)\_($match_username)\_[a-f0-9]{32}$/) { @@ -1124,7 +1179,7 @@ sub delbalcookie { my $intdom = &internet_dom($balancer); my $serverhomedom = &host_domain($balancer); if (($uintdom ne '') && ($uintdom eq $intdom)) { - return &reply("delbalcookie:$cookie",$balancer); + return &reply('delbalcookie:'.&escape($cookie),$balancer); } } } @@ -1195,6 +1250,28 @@ sub choose_server { return ($login_host,$hostname,$portal_path,$isredirect,$lowest_load); } +sub get_course_sessions { + my ($cnum,$cdom,$lastactivity) = @_; + my %servers = &internet_dom_servers($cdom); + my %returnhash; + foreach my $server (sort(keys(%servers))) { + my $rep = &reply("coursesessions:$cdom:$cnum:$lastactivity",$server); + my @pairs=split(/\&/,$rep); + unless (($rep eq 'unknown_cmd') || ($rep =~ /^error/)) { + foreach my $item (@pairs) { + my ($key,$value)=split(/=/,$item,2); + $key = &unescape($key); + next if ($key =~ /^error: 2 /); + if (exists($returnhash{$key})) { + next if ($value < $returnhash{$key}); + } + $returnhash{$key}=$value; + } + } + } + return %returnhash; +} + # --------------------------------------------- Try to change a user's password sub changepass { @@ -1230,6 +1307,9 @@ sub changepass { } elsif ($answer =~ "invalid_client") { &logthis("$server refused to change $uname in $udom password because ". "it was a reset by e-mail originating from an invalid server."); + } elsif ($answer =~ "^prioruse") { + &logthis("$server refused to change $uname in $udom password because ". + "the password had been used before"); } return $answer; } @@ -1368,6 +1448,15 @@ sub spare_can_host { $canhost = 0; } } + if ($canhost) { + if (ref($defdomdefaults{'offloadoth'}) eq 'HASH') { + if ($defdomdefaults{'offloadoth'}{$try_server}) { + unless (&shared_institution($udom,$try_server)) { + $canhost = 0; + } + } + } + } if (($canhost) && ($uint_dom)) { my @intdoms; my $internet_names = &get_internet_names($try_server); @@ -1586,7 +1675,7 @@ sub check_loadbalancing { if ($domneedscache) { &do_cache_new('loadbalancing',$domneedscache,$is_balancer,$cachetime); } - if ($is_balancer) { + if (($is_balancer) && ($caller ne 'switchserver')) { my $lowest_load = 30000; if (ref($offloadto) eq 'HASH') { if (ref($offloadto->{'primary'}) eq 'ARRAY') { @@ -1626,9 +1715,9 @@ sub check_loadbalancing { } } } - unless ($homeintdom) { - undef($setcookie); - } + } + if (($is_balancer) && (!$homeintdom)) { + undef($setcookie); } return ($is_balancer,$otherserver,$setcookie,$offloadto,$dom_balancers); } @@ -1739,7 +1828,7 @@ sub trusted_domains { if (&domain($calldom) eq '') { return ($trusted,$untrusted); } - unless ($cmdtype =~ /^(content|shared|enroll|coaurem|domroles|catalog|reqcrs|msg)$/) { + unless ($cmdtype =~ /^(content|shared|enroll|coaurem|othcoau|domroles|catalog|reqcrs|msg)$/) { return ($trusted,$untrusted); } my $callprimary = &domain($calldom,'primary'); @@ -1761,6 +1850,7 @@ sub trusted_domains { map { $possexc{$_} = 1; } @{$trustconfig->{$cmdtype}->{'exc'}}; } if (ref($trustconfig->{$cmdtype}->{'inc'}) eq 'ARRAY') { + $possinc{$intcalldom} = 1; map { $possinc{$_} = 1; } @{$trustconfig->{$cmdtype}->{'inc'}}; } } @@ -1795,12 +1885,12 @@ sub trusted_domains { } foreach my $exc (@allexc) { if (ref($doms_by_intdom{$exc}) eq 'ARRAY') { - $untrusted = $doms_by_intdom{$exc}; + push(@{$untrusted},@{$doms_by_intdom{$exc}}); } } foreach my $inc (@allinc) { if (ref($doms_by_intdom{$inc}) eq 'ARRAY') { - $trusted = $doms_by_intdom{$inc}; + push(@{$trusted},@{$doms_by_intdom{$inc}}); } } } @@ -2077,10 +2167,19 @@ sub get_dom { } if ($udom && $uhome && ($uhome ne 'no_host')) { my $rep; - if ($namespace =~ /^enc/) { - $rep=&reply("encrypt:egetdom:$udom:$namespace:$items",$uhome); + if (grep { $_ eq $uhome } ¤t_machine_ids()) { + # domain information is hosted on this machine + my $cmd = 'getdom'; + if ($namespace =~ /^enc/) { + $cmd = 'egetdom'; + } + $rep = &LONCAPA::Lond::get_dom("$cmd:$udom:$namespace:$items"); } else { - $rep=&reply("getdom:$udom:$namespace:$items",$uhome); + if ($namespace =~ /^enc/) { + $rep=&reply("encrypt:egetdom:$udom:$namespace:$items",$uhome); + } else { + $rep=&reply("getdom:$udom:$namespace:$items",$uhome); + } } my %returnhash; if ($rep eq '' || $rep =~ /^error: 2 /) { @@ -2222,7 +2321,7 @@ sub inst_directory_query { if ($homeserver ne '') { unless ($homeserver eq $perlvar{'lonHostID'}) { if ($srch->{'srchby'} eq 'email') { - my $lcrev = &get_server_loncaparev(undef,$homeserver); + my $lcrev = &get_server_loncaparev($udom,$homeserver); my ($major,$minor) = ($lcrev =~ /^\'?(\d+)\.(\d+)\.[\w.\-]+\'?$/); if (($major eq '' && $minor eq '') || ($major < 2) || (($major == 2) && ($minor < 12))) { @@ -2273,7 +2372,7 @@ sub usersearch { if (&host_domain($tryserver) eq $dom) { unless ($tryserver eq $perlvar{'lonHostID'}) { if ($srch->{'srchby'} eq 'email') { - my $lcrev = &get_server_loncaparev(undef,$tryserver); + my $lcrev = &get_server_loncaparev($dom,$tryserver); my ($major,$minor) = ($lcrev =~ /^\'?(\d+)\.(\d+)\.[\w.\-]+\'?$/); next if (($major eq '' && $minor eq '') || ($major < 2) || (($major == 2) && ($minor < 12))); @@ -2518,7 +2617,7 @@ sub get_domain_defaults { 'coursedefaults','usersessions', 'requestauthor','selfenrollment', 'coursecategories','ssl','autoenroll', - 'trust','helpsettings'],$domain); + 'trust','helpsettings','wafproxy'],$domain); my @coursetypes = ('official','unofficial','community','textbook','placement'); if (ref($domconfig{'defaults'}) eq 'HASH') { $domdefaults{'lang_def'} = $domconfig{'defaults'}{'lang_def'}; @@ -2611,6 +2710,9 @@ sub get_domain_defaults { if (ref($domconfig{'usersessions'}{'offloadnow'}) eq 'HASH') { $domdefaults{'offloadnow'} = $domconfig{'usersessions'}{'offloadnow'}; } + if (ref($domconfig{'usersessions'}{'offloadoth'}) eq 'HASH') { + $domdefaults{'offloadoth'} = $domconfig{'usersessions'}{'offloadoth'}; + } } if (ref($domconfig{'selfenrollment'}) eq 'HASH') { if (ref($domconfig{'selfenrollment'}{'admin'}) eq 'HASH') { @@ -2643,7 +2745,7 @@ sub get_domain_defaults { if (ref($domconfig{'coursecategories'}) eq 'HASH') { $domdefaults{'catauth'} = 'std'; $domdefaults{'catunauth'} = 'std'; - if ($domconfig{'coursecategories'}{'auth'}) { + if ($domconfig{'coursecategories'}{'auth'}) { $domdefaults{'catauth'} = $domconfig{'coursecategories'}{'auth'}; } if ($domconfig{'coursecategories'}{'unauth'}) { @@ -2678,10 +2780,76 @@ sub get_domain_defaults { $domdefaults{'adhocroles'} = $domconfig{'helpsettings'}{'adhoc'}; } } + if (ref($domconfig{'wafproxy'}) eq 'HASH') { + foreach my $item ('ipheader','trusted','vpnint','vpnext','sslopt') { + if ($domconfig{'wafproxy'}{$item}) { + $domdefaults{'waf_'.$item} = $domconfig{'wafproxy'}{$item}; + } + } + } &do_cache_new('domdefaults',$domain,\%domdefaults,$cachetime); return %domdefaults; } +sub get_dom_cats { + my ($dom) = @_; + return unless (&domain($dom)); + my ($cats,$cached)=&is_cached_new('cats',$dom); + unless (defined($cached)) { + my %domconfig = &get_dom('configuration',['coursecategories'],$dom); + if (ref($domconfig{'coursecategories'}) eq 'HASH') { + if (ref($domconfig{'coursecategories'}{'cats'}) eq 'HASH') { + %{$cats} = %{$domconfig{'coursecategories'}{'cats'}}; + } else { + $cats = {}; + } + } else { + $cats = {}; + } + &Apache::lonnet::do_cache_new('cats',$dom,$cats,3600); + } + return $cats; +} + +sub get_dom_instcats { + my ($dom) = @_; + return unless (&domain($dom)); + my ($instcats,$cached)=&is_cached_new('instcats',$dom); + unless (defined($cached)) { + my (%coursecodes,%codes,@codetitles,%cat_titles,%cat_order); + my $totcodes = &retrieve_instcodes(\%coursecodes,$dom); + if ($totcodes > 0) { + my $caller = 'global'; + if (&auto_instcode_format($caller,$dom,\%coursecodes,\%codes, + \@codetitles,\%cat_titles,\%cat_order) eq 'ok') { + $instcats = { + codes => \%codes, + codetitles => \@codetitles, + cat_titles => \%cat_titles, + cat_order => \%cat_order, + }; + &do_cache_new('instcats',$dom,$instcats,3600); + } + } + } + return $instcats; +} + +sub retrieve_instcodes { + my ($coursecodes,$dom) = @_; + my $totcodes; + my %courses = &courseiddump($dom,'.',1,'.','.','.',undef,undef,'Course'); + foreach my $course (keys(%courses)) { + if (ref($courses{$course}) eq 'HASH') { + if ($courses{$course}{'inst_code'} ne '') { + $$coursecodes{$course} = $courses{$course}{'inst_code'}; + $totcodes ++; + } + } + } + return $totcodes; +} + sub course_portal_url { my ($cnum,$cdom) = @_; my $chome = &homeserver($cnum,$cdom); @@ -2698,6 +2866,29 @@ sub course_portal_url { return $firsturl; } +# --------------------------------------------- Get domain config for passwords + +sub get_passwdconf { + my ($dom) = @_; + my (%passwdconf,$gotconf,$lookup); + my ($result,$cached)=&is_cached_new('passwdconf',$dom); + if (defined($cached)) { + if (ref($result) eq 'HASH') { + %passwdconf = %{$result}; + $gotconf = 1; + } + } + unless ($gotconf) { + my %domconfig = &get_dom('configuration',['passwords'],$dom); + if (ref($domconfig{'passwords'}) eq 'HASH') { + %passwdconf = %{$domconfig{'passwords'}}; + } + my $cachetime = 24*60*60; + &do_cache_new('passwdconf',$dom,\%passwdconf,$cachetime); + } + return %passwdconf; +} + # --------------------------------------------------- Assign a key to a student sub assign_access_key { @@ -3240,6 +3431,32 @@ sub repcopy { } } +# ------------------------------------------------- Unsubscribe from a resource + +sub unsubscribe { + my ($fname) = @_; + my $answer; + if ($fname=~/\/(aboutme|syllabus|bulletinboard|smppg)$/) { return $answer; } + $fname=~s/[\n\r]//g; + my $author=$fname; + $author=~s/\/home\/httpd\/html\/res\/([^\/]*)\/([^\/]*).*/$1\/$2/; + my ($udom,$uname)=split(/\//,$author); + my $home=homeserver($uname,$udom); + if ($home eq 'no_host') { + $answer = 'no_host'; + } elsif (grep { $_ eq $home } ¤t_machine_ids()) { + $answer = 'home'; + } else { + my $defdom = $perlvar{'lonDefDomain'}; + if (&will_trust('content',$defdom,$udom)) { + $answer = reply("unsub:$fname",$home); + } else { + $answer = 'untrusted'; + } + } + return $answer; +} + # ------------------------------------------------ Get server side include body sub ssi_body { my ($filelink,%form)=@_; @@ -3268,11 +3485,29 @@ sub ssi_body { # --------------------------------------------------------- Server Side Include sub absolute_url { - my ($host_name) = @_; + my ($host_name,$unalias,$keep_proto) = @_; my $protocol = ($ENV{'SERVER_PORT'} == 443?'https://':'http://'); if ($host_name eq '') { $host_name = $ENV{'SERVER_NAME'}; } + if ($unalias) { + my $alias = &get_proxy_alias(); + if ($alias eq $host_name) { + my $lonhost = $perlvar{'lonHostID'}; + my $hostname = &hostname($lonhost); + my $lcproto; + if (($keep_proto) || ($hostname eq '')) { + $lcproto = $protocol; + } else { + $lcproto = $protocol{$lonhost}; + $lcproto = 'http' if ($lcproto ne 'https'); + $lcproto .= '://'; + } + unless ($hostname eq '') { + return $lcproto.$hostname; + } + } + } return $protocol.$host_name; } @@ -3289,12 +3524,13 @@ sub absolute_url { sub ssi { my ($fn,%form)=@_; - my $request; + my ($host,$request,$response); + $host = &absolute_url('',1); $form{'no_update_last_known'}=1; &Apache::lonenc::check_encrypt(\$fn); if (%form) { - $request=new HTTP::Request('POST',&absolute_url().$fn); + $request=new HTTP::Request('POST',$host.$fn); $request->content(join('&',map { my $name = escape($_); "$name=" . ( ref($form{$_}) eq 'ARRAY' @@ -3302,7 +3538,7 @@ sub ssi { : &escape($form{$_}) ); } keys(%form))); } else { - $request=new HTTP::Request('GET',&absolute_url().$fn); + $request=new HTTP::Request('GET',$host.$fn); } $request->header(Cookie => $ENV{'HTTP_COOKIE'}); @@ -3316,8 +3552,8 @@ sub ssi { ($env{'request.course.sec'}?'/'.$env{'request.course.sec'}:'')))) { $islocal = 1; } - my $response= &LONCAPA::LWPReq::makerequest($lonhost,$request,'',\%perlvar, - '','','',$islocal); + $response= &LONCAPA::LWPReq::makerequest($lonhost,$request,'',\%perlvar, + '','','',$islocal); if (wantarray) { return ($response->content, $response); @@ -3355,10 +3591,10 @@ sub remove_stale_resfile { (grep { $_ eq $homeserver } ¤t_machine_ids())) { my $fname = &filelocation('',$url); if (-e $fname) { - my $protocol = $protocol{$homeserver}; - $protocol = 'http' if ($protocol ne 'https'); my $hostname = &hostname($homeserver); if ($hostname) { + my $protocol = $protocol{$homeserver}; + $protocol = 'http' if ($protocol ne 'https'); my $uri = &declutter($url); my $request=new HTTP::Request('HEAD',$protocol.'://'.$hostname.'/raw/'.$uri); my $response = &LONCAPA::LWPReq::makerequest($homeserver,$request,'',\%perlvar,5,0,1); @@ -3385,12 +3621,18 @@ sub remove_stale_resfile { $stale = 1; } if ($stale) { - unlink($fname); - if ($uri!~/\.meta$/) { - unlink($fname.'.meta'); + if (unlink($fname)) { + if ($uri!~/\.meta$/) { + if (-e $fname.'.meta') { + unlink($fname.'.meta'); + } + } + my $unsubresult = &unsubscribe($fname); + unless ($unsubresult eq 'ok') { + &logthis("no unsub of $fname from $homeserver, reason: $unsubresult"); + } + $removed = 1; } - &reply("unsub:$fname",$homeserver); - $removed = 1; } } } @@ -3540,6 +3782,18 @@ sub can_edit_resource { $forceedit = 1; } $cfile = $resurl; + } elsif (($resurl =~ m{^/ext/}) && ($symb ne '')) { + my ($map,$id,$res) = &decode_symb($symb); + if ($map =~ /\.page$/) { + $incourse = 1; + if ($env{'form.forceedit'}) { + $forceview = 1; + $cfile = $map; + } else { + $forceedit = 1; + $cfile = '/adm/wrapper'.$resurl; + } + } } elsif ($resurl =~ m{^/adm/wrapper/adm/$cdom/$cnum/\d+/ext\.tool$}) { $incourse = 1; if ($env{'form.forceedit'}) { @@ -3565,13 +3819,13 @@ sub can_edit_resource { $cfile = $template; } } elsif (($resurl =~ m{^/adm/wrapper/ext/}) && ($env{'form.folderpath'} =~ /^supplemental/)) { - $incourse = 1; - if ($env{'form.forceedit'}) { - $forceview = 1; - } else { - $forceedit = 1; - } - $cfile = $resurl; + $incourse = 1; + if ($env{'form.forceedit'}) { + $forceview = 1; + } else { + $forceedit = 1; + } + $cfile = $resurl; } elsif (($resurl =~ m{^/adm/wrapper/adm/$cdom/$cnum/\d+/ext\.tool$}) && ($env{'form.folderpath'} =~ /^supplemental/)) { $incourse = 1; if ($env{'form.forceedit'}) { @@ -3834,13 +4088,21 @@ sub clean_filename { } # Replace spaces by underscores $fname=~s/\s+/\_/g; +# Transliterate non-ascii text to ascii + my $lang = &Apache::lonlocal::current_language(); + $fname = &LONCAPA::transliterate::fname_to_ascii($fname,$lang); # Replace all other weird characters by nothing $fname=~s{[^/\w\.\-]}{}g; # Replace all .\d. sequences with _\d. so they no longer look like version # numbers $fname=~s/\.(\d+)(?=\.)/_$1/g; +# Replace three or more adjacent underscores with one for consistency +# with loncfile::filename_check() so complete url can be extracted by +# lonnet::decode_symb() + $fname=~s/_{3,}/_/g; return $fname; } + # This Function checks if an Image's dimensions exceed either $resizewidth (width) # or $resizeheight (height) - both pixels. If so, the image is scaled to produce an # image with the same aspect ratio as the original, but with dimensions which do @@ -3883,13 +4145,16 @@ sub resizeImage { # input: $formname - the contents of the file are in $env{"form.$formname"} # the desired filename is in $env{"form.$formname.filename"} # $context - possible values: coursedoc, existingfile, overwrite, -# canceloverwrite, or ''. +# canceloverwrite, scantron or ''. # if 'coursedoc': upload to the current course # if 'existingfile': write file to tmp/overwrites directory # if 'canceloverwrite': delete file written to tmp/overwrites directory # $context is passed as argument to &finishuserfileupload # $subdir - directory in userfile to store the file into -# $parser - instruction to parse file for objects ($parser = parse) +# $parser - instruction to parse file for objects ($parser = parse) or +# if context is 'scantron', $parser is hashref of csv column mapping +# (e.g.,{ PaperID => 0, LastName => 1, FirstName => 2, ID => 3, +# Section => 4, CODE => 5, FirstQuestion => 9 }). # $allfiles - reference to hash for embedded objects # $codebase - reference to hash for codebase of java objects # $desuname - username for permanent storage of uploaded file @@ -3912,6 +4177,14 @@ sub userfileupload { $fname=&clean_filename($fname); # See if there is anything left unless ($fname) { return 'error: no uploaded file'; } + # If filename now begins with a . prepend unix timestamp _ milliseconds + if ($fname =~ /^\./) { + my ($s,$usec) = &gettimeofday(); + while (length($usec) < 6) { + $usec = '0'.$usec; + } + $fname = $s.'_'.substr($usec,0,3).$fname; + } # Files uploaded to help request form, or uploaded to "create course" page are handled differently if ((($formname eq 'screenshot') && ($subdir eq 'helprequests')) || (($formname eq 'coursecreatorxml') && ($subdir eq 'batchupload')) || @@ -4079,7 +4352,7 @@ sub finishuserfileupload { } } } - if ($parser eq 'parse') { + if (($context ne 'scantron') && ($parser eq 'parse')) { if ((ref($mimetype)) && ($$mimetype eq 'text/html')) { my $parse_result = &extract_embedded_items($filepath.'/'.$file, $allfiles,$codebase); @@ -4088,6 +4361,9 @@ sub finishuserfileupload { ' for embedded media: '.$parse_result); } } + } elsif (($context eq 'scantron') && (ref($parser) eq 'HASH')) { + my $format = $env{'form.scantron_format'}; + &bubblesheet_converter($docudom,$filepath.'/'.$file,$parser,$format); } if (($thumbwidth =~ /^\d+$/) && ($thumbheight =~ /^\d+$/)) { my $input = $filepath.'/'.$file; @@ -4328,6 +4604,246 @@ sub embedded_dependency { return; } +sub bubblesheet_converter { + my ($cdom,$fullpath,$config,$format) = @_; + if ((&domain($cdom) ne '') && + ($fullpath =~ m{^\Q$perlvar{'lonDocRoot'}/userfiles/$cdom/\E$match_courseid/scantron_orig}) && + (-e $fullpath) && (ref($config) eq 'HASH') && ($format ne '')) { + my (%csvcols,%csvoptions); + if (ref($config->{'fields'}) eq 'HASH') { + %csvcols = %{$config->{'fields'}}; + } + if (ref($config->{'options'}) eq 'HASH') { + %csvoptions = %{$config->{'options'}}; + } + my %csvbynum = reverse(%csvcols); + my %scantronconf = &get_scantron_config($format,$cdom); + if (keys(%scantronconf)) { + my %bynum = ( + $scantronconf{CODEstart} => 'CODEstart', + $scantronconf{IDstart} => 'IDstart', + $scantronconf{PaperID} => 'PaperID', + $scantronconf{FirstName} => 'FirstName', + $scantronconf{LastName} => 'LastName', + $scantronconf{Qstart} => 'Qstart', + ); + my @ordered; + foreach my $item (sort { $a <=> $b } keys(%bynum)) { + push(@ordered,$bynum{$item}); + } + my %mapstart = ( + CODEstart => 'CODE', + IDstart => 'ID', + PaperID => 'PaperID', + FirstName => 'FirstName', + LastName => 'LastName', + Qstart => 'FirstQuestion', + ); + my %maplength = ( + CODEstart => 'CODElength', + IDstart => 'IDlength', + PaperID => 'PaperIDlength', + FirstName => 'FirstNamelength', + LastName => 'LastNamelength', + ); + if (open(my $fh,'<',$fullpath)) { + my $output; + my %lettdig = &letter_to_digits(); + my %diglett = reverse(%lettdig); + my $numletts = scalar(keys(%lettdig)); + my $num = 0; + while (my $line=<$fh>) { + $num ++; + next if (($num == 1) && ($csvoptions{'hdr'} == 1)); + $line =~ s{[\r\n]+$}{}; + my %found; + my @values = split(/,/,$line); + my ($qstart,$record); + for (my $i=0; $i<@values; $i++) { + if ((($qstart ne '') && ($i > $qstart)) || + ($csvbynum{$i} eq 'FirstQuestion')) { + if ($values[$i] eq '') { + $values[$i] = $scantronconf{'Qoff'}; + } elsif ($scantronconf{'Qon'} eq 'number') { + if ($values[$i] =~ /^[A-Ja-j]$/) { + $values[$i] = $lettdig{uc($values[$i])}; + } + } elsif ($scantronconf{'Qon'} eq 'letter') { + if ($values[$i] =~ /^[0-9]$/) { + $values[$i] = $diglett{$values[$i]}; + } + } else { + if ($values[$i] =~ /^[0-9A-Ja-j]$/) { + my $digit; + if ($values[$i] =~ /^[A-Ja-j]$/) { + $digit = $lettdig{uc($values[$i])}-1; + if ($values[$i] eq 'J') { + $digit += $numletts; + } + } elsif ($values[$i] =~ /^[0-9]$/) { + $digit = $values[$i]-1; + if ($values[$i] eq '0') { + $digit += $numletts; + } + } + my $qval=''; + for (my $j=0; $j<$scantronconf{'Qlength'}; $j++) { + if ($j == $digit) { + $qval .= $scantronconf{'Qon'}; + } else { + $qval .= $scantronconf{'Qoff'}; + } + } + $values[$i] = $qval; + } + } + if (length($values[$i]) > $scantronconf{'Qlength'}) { + $values[$i] = substr($values[$i],0,$scantronconf{'Qlength'}); + } + my $numblank = $scantronconf{'Qlength'} - length($values[$i]); + if ($numblank > 0) { + $values[$i] .= ($scantronconf{'Qoff'} x $numblank); + } + if ($csvbynum{$i} eq 'FirstQuestion') { + $qstart = $i; + $found{$csvbynum{$i}} = $values[$i]; + } else { + $found{'FirstQuestion'} .= $values[$i]; + } + } elsif (exists($csvbynum{$i})) { + if ($csvoptions{'rem'}) { + $values[$i] =~ s/^\s+//; + } + if (($csvbynum{$i} eq 'PaperID') && ($csvoptions{'pad'})) { + while (length($values[$i]) < $scantronconf{$maplength{$csvbynum{$i}}}) { + $values[$i] = '0'.$values[$i]; + } + } + $found{$csvbynum{$i}} = $values[$i]; + } + } + foreach my $item (@ordered) { + my $currlength = 1+length($record); + my $numspaces = $scantronconf{$item} - $currlength; + if ($numspaces > 0) { + $record .= (' ' x $numspaces); + } + if (($mapstart{$item} ne '') && (exists($found{$mapstart{$item}}))) { + unless ($item eq 'Qstart') { + if (length($found{$mapstart{$item}}) > $scantronconf{$maplength{$item}}) { + $found{$mapstart{$item}} = substr($found{$mapstart{$item}},0,$scantronconf{$maplength{$item}}); + } + } + $record .= $found{$mapstart{$item}}; + } + } + $output .= "$record\n"; + } + close($fh); + if ($output) { + if (open(my $fh,'>',$fullpath)) { + print $fh $output; + close($fh); + } + } + } + } + return; + } +} + +sub letter_to_digits { + my %lettdig = ( + A => 1, + B => 2, + C => 3, + D => 4, + E => 5, + F => 6, + G => 7, + H => 8, + I => 9, + J => 0, + ); + return %lettdig; +} + +sub get_scantron_config { + my ($which,$cdom) = @_; + my @lines = &get_scantronformat_file($cdom); + my %config; + #FIXME probably should move to XML it has already gotten a bit much now + foreach my $line (@lines) { + my ($name,$descrip)=split(/:/,$line); + if ($name ne $which ) { next; } + chomp($line); + my @config=split(/:/,$line); + $config{'name'}=$config[0]; + $config{'description'}=$config[1]; + $config{'CODElocation'}=$config[2]; + $config{'CODEstart'}=$config[3]; + $config{'CODElength'}=$config[4]; + $config{'IDstart'}=$config[5]; + $config{'IDlength'}=$config[6]; + $config{'Qstart'}=$config[7]; + $config{'Qlength'}=$config[8]; + $config{'Qoff'}=$config[9]; + $config{'Qon'}=$config[10]; + $config{'PaperID'}=$config[11]; + $config{'PaperIDlength'}=$config[12]; + $config{'FirstName'}=$config[13]; + $config{'FirstNamelength'}=$config[14]; + $config{'LastName'}=$config[15]; + $config{'LastNamelength'}=$config[16]; + $config{'BubblesPerRow'}=$config[17]; + last; + } + return %config; +} + +sub get_scantronformat_file { + my ($cdom) = @_; + if ($cdom eq '') { + $cdom= $env{'course.'.$env{'request.course.id'}.'.domain'}; + } + my %domconfig = &get_dom('configuration',['scantron'],$cdom); + my $gottab = 0; + my @lines; + if (ref($domconfig{'scantron'}) eq 'HASH') { + if ($domconfig{'scantron'}{'scantronformat'} ne '') { + my $formatfile = &getfile($perlvar{'lonDocRoot'}.$domconfig{'scantron'}{'scantronformat'}); + if ($formatfile ne '-1') { + @lines = split("\n",$formatfile,-1); + $gottab = 1; + } + } + } + if (!$gottab) { + my $confname = $cdom.'-domainconfig'; + my $default = $perlvar{'lonDocRoot'}.'/res/'.$cdom.'/'.$confname.'/default.tab'; + my $formatfile = &getfile($default); + if ($formatfile ne '-1') { + @lines = split("\n",$formatfile,-1); + $gottab = 1; + } + } + if (!$gottab) { + my @domains = ¤t_machine_domains(); + if (grep(/^\Q$cdom\E$/,@domains)) { + if (open(my $fh,'<',$perlvar{'lonTabDir'}.'/scantronformat.tab')) { + @lines = <$fh>; + close($fh); + } + } else { + if (open(my $fh,'<',$perlvar{'lonTabDir'}.'/default_scantronformat.tab')) { + @lines = <$fh>; + close($fh); + } + } + } + return @lines; +} + sub removeuploadedurl { my ($url)=@_; my (undef,undef,$udom,$uname,$fname)=split('/',$url,5); @@ -4554,7 +5070,11 @@ sub courseacclog { if ($formitem =~ /^HWFILE(?:SIZE|TOOBIG)/) { $what.=':'.$formitem.'='.$env{$key}; } elsif ($formitem !~ /^HWFILE(?:[^.]+)$/) { - $what.=':'.$formitem.'='.$env{$key}; + if ($formitem eq 'proctorpassword') { + $what.=':'.$formitem.'=' . '*' x length($env{$key}); + } else { + $what.=':'.$formitem.'='.$env{$key}; + } } } } @@ -5636,7 +6156,7 @@ sub tmpreset { if (!$domain) { $domain=$env{'user.domain'}; } if (!$stuname) { $stuname=$env{'user.name'}; } if ($domain eq 'public' && $stuname eq 'public') { - $stuname=$ENV{'REMOTE_ADDR'}; + $stuname=&get_requestor_ip(); } my $path=LONCAPA::tempdir(); my %hash; @@ -5673,7 +6193,7 @@ sub tmpstore { if (!$domain) { $domain=$env{'user.domain'}; } if (!$stuname) { $stuname=$env{'user.name'}; } if ($domain eq 'public' && $stuname eq 'public') { - $stuname=$ENV{'REMOTE_ADDR'}; + $stuname=&get_requestor_ip(); } my $now=time; my %hash; @@ -5717,7 +6237,7 @@ sub tmprestore { if (!$domain) { $domain=$env{'user.domain'}; } if (!$stuname) { $stuname=$env{'user.name'}; } if ($domain eq 'public' && $stuname eq 'public') { - $stuname=$ENV{'REMOTE_ADDR'}; + $stuname=&get_requestor_ip(); } my %returnhash; $namespace=~s/\//\_/g; @@ -5773,7 +6293,7 @@ sub store { } if (!$home) { $home=$env{'user.home'}; } - $$storehash{'ip'}=$ENV{'REMOTE_ADDR'}; + $$storehash{'ip'}=&get_requestor_ip(); $$storehash{'host'}=$perlvar{'lonHostID'}; my $namevalue=''; @@ -5809,7 +6329,7 @@ sub cstore { } if (!$home) { $home=$env{'user.home'}; } - $$storehash{'ip'}=$ENV{'REMOTE_ADDR'}; + $$storehash{'ip'}=&get_requestor_ip(); $$storehash{'host'}=$perlvar{'lonHostID'}; my $namevalue=''; @@ -6515,7 +7035,8 @@ sub set_adhoc_privileges { my ($author,$adv,$rar)= &set_userprivs(\%userroles,\%rolehash); &appenv(\%userroles,[$role,'cm']); &log($env{'user.domain'},$env{'user.name'},$env{'user.home'},"Role ".$spec); - unless ($caller eq 'constructaccess' && $env{'request.course.id'}) { + unless (($caller eq 'constructaccess' && $env{'request.course.id'}) || + ($caller eq 'tiny')) { &appenv( {'request.role' => $spec, 'request.role.domain' => $dcdom, 'request.course.sec' => $sec, @@ -6803,7 +7324,8 @@ sub putstore { foreach my $key (keys(%{$storehash})) { $namevalue.=&escape($key).'='.&freeze_escape($storehash->{$key}).'&'; } - $namevalue .= 'ip='.&escape($ENV{'REMOTE_ADDR'}). + my $ip = &get_requestor_ip(); + $namevalue .= 'ip='.&escape($ip). '&host='.&escape($perlvar{'lonHostID'}). '&version='.$esc_v. '&by='.&escape($env{'user.name'}.':'.$env{'user.domain'}); @@ -7590,7 +8112,7 @@ sub customaccess { # ------------------------------------------------- Check for a user privilege sub allowed { - my ($priv,$uri,$symb,$role,$clientip,$noblockcheck)=@_; + my ($priv,$uri,$symb,$role,$clientip,$noblockcheck,$ignorecache)=@_; my $ver_orguri=$uri; $uri=&deversion($uri); my $orguri=$uri; @@ -7607,7 +8129,7 @@ sub allowed { if (defined($env{'allowed.'.$priv})) { return $env{'allowed.'.$priv}; } # Free bre access to adm and meta resources - if (((($uri=~/^adm\//) && ($uri !~ m{/(?:smppg|bulletinboard|ext\.tool)$})) + if (((($uri=~/^adm\//) && ($uri !~ m{/(?:smppg|bulletinboard|viewclasslist|aboutme|ext\.tool)$})) || (($uri=~/\.meta$/) && ($uri!~m|^uploaded/|) )) && ($priv eq 'bre')) { return 'F'; @@ -7775,8 +8297,34 @@ sub allowed { if ($env{'user.priv.'.$env{'request.role'}.'.'.$courseuri} =~/\Q$priv\E\&([^\:]*)/) { - unless (($priv eq 'bro') && (!$ownaccess)) { - $thisallowed.=$1; + if ($priv eq 'mip') { + my $rem = $1; + if (($uri ne '') && ($env{'request.course.id'} eq $uri) && + ($env{'course.'.$env{'request.course.id'}.'.internal.courseowner'} eq $env{'user.name'}.':'.$env{'user.domain'})) { + my $cdom = $env{'course.'.$env{'request.course.id'}.'.domain'}; + if ($cdom ne '') { + my %passwdconf = &get_passwdconf($cdom); + if (ref($passwdconf{'crsownerchg'}) eq 'HASH') { + if (ref($passwdconf{'crsownerchg'}{'by'}) eq 'ARRAY') { + if (@{$passwdconf{'crsownerchg'}{'by'}}) { + my @inststatuses = split(':',$env{'environment.inststatus'}); + unless (@inststatuses) { + @inststatuses = ('default'); + } + foreach my $status (@inststatuses) { + if (grep(/^\Q$status\E$/,@{$passwdconf{'crsownerchg'}{'by'}})) { + $thisallowed.=$rem; + } + } + } + } + } + } + } + } else { + unless (($priv eq 'bro') && (!$ownaccess)) { + $thisallowed.=$1; + } } } @@ -7789,10 +8337,13 @@ sub allowed { if ($env{'user.priv.'.$env{'request.role'}.'./'} =~/\Q$priv\E\&([^\:]*)/) { my $value = $1; - if ($noblockcheck) { + my $deeplinkblock = &deeplink_check($priv,$symb,$uri); + if ($deeplinkblock) { + $thisallowed='D'; + } elsif ($noblockcheck) { $thisallowed.=$value; } else { - my @blockers = &has_comm_blocking($priv,$symb,$uri); + my @blockers = &has_comm_blocking($priv,$symb,$uri,$ignorecache); if (@blockers > 0) { $thisallowed = 'B'; } else { @@ -7809,10 +8360,13 @@ sub allowed { $refuri=&declutter($refuri); my ($match) = &is_on_map($refuri); if ($match) { - if ($noblockcheck) { + my $deeplinkblock = &deeplink_check($priv,$symb,$refuri); + if ($deeplinkblock) { + $thisallowed='D'; + } elsif ($noblockcheck) { $thisallowed='F'; } else { - my @blockers = &has_comm_blocking($priv,$symb,$refuri); + my @blockers = &has_comm_blocking($priv,'',$refuri,'',1); if (@blockers > 0) { $thisallowed = 'B'; } else { @@ -7859,6 +8413,16 @@ sub allowed { if ($env{'request.course.id'}) { +# If this is modifying password (internal auth) domains must match for user and user's role. + + if ($priv eq 'mip') { + if ($env{'user.domain'} eq $env{'request.role.domain'}) { + return $thisallowed; + } else { + return ''; + } + } + $courseprivid=$env{'request.course.id'}; if ($env{'request.course.sec'}) { $courseprivid.='/'.$env{'request.course.sec'}; @@ -7875,7 +8439,7 @@ sub allowed { if ($noblockcheck) { $thisallowed.=$value; } else { - my @blockers = &has_comm_blocking($priv,$symb,$uri); + my @blockers = &has_comm_blocking($priv,$symb,$uri,$ignorecache); if (@blockers > 0) { $thisallowed = 'B'; } else { @@ -7888,7 +8452,7 @@ sub allowed { $checkreferer=0; } } - + if ($checkreferer) { my $refuri=$env{'httpref.'.$orguri}; unless ($refuri) { @@ -7914,10 +8478,13 @@ sub allowed { =~/\Q$priv\E\&([^\:]*)/) { my $value = $1; if ($priv eq 'bre') { - if ($noblockcheck) { + my $deeplinkblock = &deeplink_check($priv,$symb,$refuri); + if ($deeplinkblock) { + $thisallowed = 'D'; + } elsif ($noblockcheck) { $thisallowed.=$value; } else { - my @blockers = &has_comm_blocking($priv,$symb,$refuri); + my @blockers = &has_comm_blocking($priv,'',$refuri,'',1); if (@blockers > 0) { $thisallowed = 'B'; } else { @@ -8003,7 +8570,7 @@ sub allowed { } } } - + # # Rest of the restrictions depend on selected course # @@ -8082,6 +8649,8 @@ sub allowed { return 'A'; } elsif ($thisallowed eq 'B') { return 'B'; + } elsif ($thisallowed eq 'D') { + return 'D'; } return 'F'; } @@ -8170,22 +8739,27 @@ sub constructaccess { # # User for whom data are being temporarily cached. my $cacheduser=''; +# Course for which data are being temporarily cached. +my $cachedcid=''; # Cached blockers for this user (a hash of blocking items). my %cachedblockers=(); # When the data were last cached. my $cachedlast=''; sub load_all_blockers { - my ($uname,$udom,$blocks)=@_; + my ($uname,$udom)=@_; if (($uname ne '') && ($udom ne '')) { if (($cacheduser eq $uname.':'.$udom) && + ($cachedcid eq $env{'request.course.id'}) && (abs($cachedlast-time)<5)) { return; } } $cachedlast=time; $cacheduser=$uname.':'.$udom; - %cachedblockers = &get_commblock_resources($blocks); + $cachedcid=$env{'request.course.id'}; + %cachedblockers = &get_commblock_resources(); + return; } sub get_comm_blocks { @@ -8265,14 +8839,23 @@ sub get_commblock_resources { if ($mapsymb) { if (ref($navmap)) { my $mapres = $navmap->getBySymb($mapsymb); - @to_test = $mapres->retrieveResources($mapres,undef,0,0,0,1); - foreach my $res (@to_test) { - my $symb = $res->symb(); - next if ($symb eq $mapsymb); - if ($symb ne '') { - @interval=&EXT("resource.0.interval",$symb); - if ($interval[1] eq 'map') { - last; + if (ref($mapres)) { + my $first = $mapres->map_start(); + my $finish = $mapres->map_finish(); + my $it = $navmap->getIterator($first,$finish,undef,0,0); + if (ref($it)) { + my $res; + while ($res = $it->next(undef,1)) { + next unless (ref($res)); + my $symb = $res->symb(); + next if (($symb eq $mapsymb) || ($symb eq '')); + @interval=&EXT("resource.0.interval",$symb); + if ($interval[1] eq 'map') { + if ($res->answerable()) { + push(@to_test,$res); + last; + } + } } } } @@ -8323,17 +8906,23 @@ sub get_commblock_resources { } sub has_comm_blocking { - my ($priv,$symb,$uri,$blocks) = @_; + my ($priv,$symb,$uri,$ignoresymbdb,$noenccheck,$blocked,$blocks) = @_; my @blockers; return unless ($env{'request.course.id'}); return unless ($priv eq 'bre'); return if ($env{'user.priv.'.$env{'request.role'}} =~/evb\&([^\:]*)/); return if ($env{'request.state'} eq 'construct'); - &load_all_blockers($env{'user.name'},$env{'user.domain'},$blocks); - return unless (keys(%cachedblockers) > 0); + my %blockinfo; + if (ref($blocks) eq 'HASH') { + %blockinfo = &get_commblock_resources($blocks); + } else { + &load_all_blockers($env{'user.name'},$env{'user.domain'}); + %blockinfo = %cachedblockers; + } + return unless (keys(%blockinfo) > 0); my (%possibles,@symbs); if (!$symb) { - $symb = &symbread($uri,1,1,1,\%possibles); + $symb = &symbread($uri,1,1,1,\%possibles,$ignoresymbdb,$noenccheck); } if ($symb) { @symbs = ($symb); @@ -8344,37 +8933,128 @@ sub has_comm_blocking { foreach my $symb (@symbs) { last if ($noblock); my ($map,$resid,$resurl)=&decode_symb($symb); - foreach my $block (keys(%cachedblockers)) { + foreach my $block (keys(%blockinfo)) { if ($block =~ /^firstaccess____(.+)$/) { my $item = $1; - if (($item eq $map) || ($item eq $symb)) { - $noblock = 1; - last; + unless ($blocked) { + if (($item eq $map) || ($item eq $symb)) { + $noblock = 1; + last; + } } } - if (ref($cachedblockers{$block}) eq 'HASH') { - if (ref($cachedblockers{$block}{'resources'}) eq 'HASH') { - if ($cachedblockers{$block}{'resources'}{$symb}) { + if (ref($blockinfo{$block}) eq 'HASH') { + if (ref($blockinfo{$block}{'resources'}) eq 'HASH') { + if ($blockinfo{$block}{'resources'}{$symb}) { unless (grep(/^\Q$block\E$/,@blockers)) { push(@blockers,$block); } } } - } - if (ref($cachedblockers{$block}{'maps'}) eq 'HASH') { - if ($cachedblockers{$block}{'maps'}{$map}) { - unless (grep(/^\Q$block\E$/,@blockers)) { - push(@blockers,$block); + if (ref($blockinfo{$block}{'maps'}) eq 'HASH') { + if ($blockinfo{$block}{'maps'}{$map}) { + unless (grep(/^\Q$block\E$/,@blockers)) { + push(@blockers,$block); + } } } } } } - return if ($noblock); - return @blockers; + unless ($noblock) { + return @blockers; + } + return; } } +sub deeplink_check { + my ($priv,$symb,$uri) = @_; + return unless ($env{'request.course.id'}); + return unless ($priv eq 'bre'); + return if ($env{'request.state'} eq 'construct'); + return if ($env{'request.role.adv'}); + my $cdom = $env{'course.'.$env{'request.course.id'}.'.domain'}; + my $cnum = $env{'course.'.$env{'request.course.id'}.'.num'}; + my (%possibles,@symbs); + if (!$symb) { + $symb = &symbread($uri,1,1,1,\%possibles); + } + if ($symb) { + @symbs = ($symb); + } elsif (keys(%possibles)) { + @symbs = keys(%possibles); + } + + my ($login,$switchrole,$allow); + if ($env{'request.deeplink.login'} =~ m{^\Q/tiny/$cdom/\E(\w+)$}) { + my $key = $1; + 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) { + last if ($allow); + my $deeplink = &EXT("resource.0.deeplink",$symb); + if ($deeplink eq '') { + $allow = 1; + } else { + my ($listed,$scope,$access) = split(/,/,$deeplink); + if ($access eq 'any') { + $allow = 1; + } elsif ($login) { + if ($access eq 'only') { + if ($scope eq 'res') { + if ($symb eq $login) { + $allow = 1; + } + } elsif ($scope eq 'map') { +#FIXME Compare map for $env{'request.deeplink.login'} with map for $symb + } elsif ($scope eq 'rec') { +#FIXME Recurse up for $env{'request.deeplink.login'} with map for $symb + } + } else { + my ($acctype,$item) = split(/:/,$access); + if (($acctype eq 'lti') && ($env{'user.linkprotector'})) { + if (grep(/^\Q$item\E$/,split(/,/,$env{'user.linkprotector'}))) { + my %tinyurls = &get('tiny',[$symb],$cdom,$cnum); + if (grep(/\Q$tinyurls{$symb}\E$/,split(/,/,$env{'user.linkproturis'}))) { + $allow = 1; + } + } + } elsif (($acctype eq 'key') && ($env{'user.deeplinkkey'})) { + if (grep(/^\Q$item\E$/,split(/,/,$env{'user.deeplinkkey'}))) { + my %tinyurls = &get('tiny',[$symb],$cdom,$cnum); + if (grep(/\Q$tinyurls{$symb}\E$/,split(/,/,$env{'user.keyedlinkuri'}))) { + $allow = 1; + } + } + } + } + } + } + } + return if ($allow); + return 1; +} + # -------------------------------- Deversion and split uri into path an filename # @@ -8769,6 +9449,25 @@ sub auto_validate_instcode { return ($outcome,$description,$defaultcredits); } +sub auto_validate_inst_crosslist { + my ($cnum,$cdom,$instcode,$inst_xlist,$coowner) = @_; + my ($homeserver,$response); + if (($cdom =~ /^$match_domain$/) && ($cnum =~ /^$match_courseid$/)) { + $homeserver = &homeserver($cnum,$cdom); + } + if (!defined($homeserver)) { + if ($cdom =~ /^$match_domain$/) { + $homeserver = &domain($cdom,'primary'); + } + } + unless (($homeserver eq '') || ($homeserver eq 'no_host')) { + $response=&reply('autovalidateinstcrosslist:'.$cdom.':'. + &escape($instcode).':'.&escape($inst_xlist).':'. + &escape($coowner),$homeserver); + } + return $response; +} + sub auto_create_password { my ($cnum,$cdom,$authparam,$udom) = @_; my ($homeserver,$response); @@ -9590,11 +10289,23 @@ sub autoupdate_coowners { if ($domdesign{$cdom.'.autoassign.co-owners'}) { my %coursehash = &coursedescription($cdom.'_'.$cnum); my $instcode = $coursehash{'internal.coursecode'}; + my $xlists = $coursehash{'internal.crosslistings'}; if ($instcode ne '') { if (($start && $start <= $now) && ($end == 0) || ($end > $now)) { unless ($coursehash{'internal.courseowner'} eq $uname.':'.$udom) { my ($delcoowners,@newcoowners,$putresult,$delresult,$coowners); my ($result,$desc) = &auto_validate_instcode($cnum,$cdom,$instcode,$uname.':'.$udom); + unless ($result eq 'valid') { + if ($xlists ne '') { + foreach my $xlist (split(',',$xlists)) { + my ($inst_crosslist,$lcsec) = split(':',$xlist); + $result = + &auto_validate_inst_crosslist($cnum,$cdom,$instcode, + $inst_crosslist,$uname.':'.$udom); + last if ($result eq 'valid'); + } + } + } if ($result eq 'valid') { if ($coursehash{'internal.co-owners'}) { foreach my $coowner (split(',',$coursehash{'internal.co-owners'})) { @@ -9607,18 +10318,16 @@ sub autoupdate_coowners { } else { push(@newcoowners,$uname.':'.$udom); } - } else { - if ($coursehash{'internal.co-owners'}) { - foreach my $coowner (split(',',$coursehash{'internal.co-owners'})) { - unless ($coowner eq $uname.':'.$udom) { - push(@newcoowners,$coowner); - } - } - unless (@newcoowners > 0) { - $delcoowners = 1; - $coowners = ''; + } elsif ($coursehash{'internal.co-owners'}) { + foreach my $coowner (split(',',$coursehash{'internal.co-owners'})) { + unless ($coowner eq $uname.':'.$udom) { + push(@newcoowners,$coowner); } } + unless (@newcoowners > 0) { + $delcoowners = 1; + $coowners = ''; + } } if (@newcoowners || $delcoowners) { &store_coowners($cdom,$cnum,$coursehash{'home'}, @@ -9671,19 +10380,35 @@ sub store_coowners { sub modifyuserauth { my ($udom,$uname,$umode,$upass)=@_; my $uhome=&homeserver($uname,$udom); - unless (&allowed('mau',$udom)) { return 'refused'; } + my $allowed; + if (&allowed('mau',$udom)) { + $allowed = 1; + } elsif (($umode eq 'internal') && ($udom eq $env{'user.domain'}) && + ($env{'request.course.id'}) && (&allowed('mip',$env{'request.course.id'})) && + (!$env{'course.'.$env{'request.course.id'}.'.internal.nopasswdchg'})) { + my $cdom = $env{'course.'.$env{'request.course.id'}.'.domain'}; + my $cnum = $env{'course.'.$env{'request.course.id'}.'.num'}; + if (($cdom ne '') && ($cnum ne '')) { + my $is_owner = &is_course_owner($cdom,$cnum); + if ($is_owner) { + $allowed = 1; + } + } + } + unless ($allowed) { return 'refused'; } &logthis('Call to modify user authentication '.$udom.', '.$uname.', '. $umode.' by '.$env{'user.name'}.' at '.$env{'user.domain'}. ' in domain '.$env{'request.role.domain'}); my $reply=&reply('encrypt:changeuserauth:'.$udom.':'.$uname.':'.$umode.':'. &escape($upass),$uhome); + my $ip = &get_requestor_ip(); &log($env{'user.domain'},$env{'user.name'},$env{'user.home'}, 'Authentication changed for '.$udom.', '.$uname.', '.$umode. - '(Remote '.$ENV{'REMOTE_ADDR'}.'): '.$reply); + '(Remote '.$ip.'): '.$reply); &log($udom,,$uname,$uhome, 'Authentication changed by '.$env{'user.domain'}.', '. $env{'user.name'}.', '.$umode. - '(Remote '.$ENV{'REMOTE_ADDR'}.'): '.$reply); + '(Remote '.$ip.'): '.$reply); unless ($reply eq 'ok') { &logthis('Authentication mode error: '.$reply); return 'error: '.$reply; @@ -10012,14 +10737,19 @@ sub writecoursepref { sub createcourse { my ($udom,$description,$url,$course_server,$nonstandard,$inst_code, - $course_owner,$crstype,$cnum,$context,$category)=@_; + $course_owner,$crstype,$cnum,$context,$category,$callercontext)=@_; $url=&declutter($url); my $cid=''; if ($context eq 'requestcourses') { my $can_create = 0; my ($ownername,$ownerdom) = split(':',$course_owner); if ($udom eq $ownerdom) { - if (&usertools_access($ownername,$ownerdom,$category,undef, + my $reload; + if (($callercontext eq 'auto') && + ($ownerdom eq $env{'user.domain'}) && ($ownername eq $env{'user.name'})) { + $reload = 'reload'; + } + if (&usertools_access($ownername,$ownerdom,$category,$reload, $context)) { $can_create = 1; } @@ -10204,7 +10934,7 @@ sub store_userdata { if (($uhome eq '') || ($uhome eq 'no_host')) { $result = 'error: no_host'; } else { - $storehash->{'ip'} = $ENV{'REMOTE_ADDR'}; + $storehash->{'ip'} = &get_requestor_ip(); $storehash->{'host'} = $perlvar{'lonHostID'}; my $namevalue=''; @@ -11751,6 +12481,10 @@ sub EXT { if ($space eq 'name') { return $ENV{'SERVER_NAME'}; } + } elsif ($realm eq 'client') { + if ($space eq 'remote_addr') { + return &get_requestor_ip(); + } } return ''; } @@ -12579,18 +13313,16 @@ sub symbverify { if (tie(%bighash,'GDBM_File',$env{'request.course.fn'}.'.db', &GDBM_READER(),0640)) { - my $noclutter; if (($thisurl =~ m{^/adm/wrapper/ext/}) || ($thisurl =~ m{^ext/})) { $thisurl =~ s/\?.+$//; if ($map =~ m{^uploaded/.+\.page$}) { $thisurl =~ s{^(/adm/wrapper|)/ext/}{http://}; $thisurl =~ s{^\Qhttp://https://\E}{https://}; - $noclutter = 1; } } my $ids; - if ($noclutter) { - $ids=$bighash{'ids_'.$thisurl}; + if ($map =~ m{^uploaded/.+\.page$}) { + $ids=$bighash{'ids_'.&clutter_with_no_wrapper($thisurl)}; } else { $ids=$bighash{'ids_'.&clutter($thisurl)}; } @@ -12690,19 +13422,22 @@ sub deversion { # ------------------------------------------------------ Return symb list entry sub symbread { - my ($thisfn,$donotrecurse,$ignorecachednull,$checkforblock,$possibles)=@_; + my ($thisfn,$donotrecurse,$ignorecachednull,$checkforblock,$possibles, + $ignoresymbdb,$noenccheck)=@_; my $cache_str='request.symbread.cached.'.$thisfn; if (defined($env{$cache_str})) { - if ($ignorecachednull) { - return $env{$cache_str} unless ($env{$cache_str} eq ''); - } else { - return $env{$cache_str}; + unless (ref($possibles) eq 'HASH') { + if ($ignorecachednull) { + return $env{$cache_str} unless ($env{$cache_str} eq ''); + } else { + return $env{$cache_str}; + } } } # no filename provided? try from environment unless ($thisfn) { if ($env{'request.symb'}) { - return $env{$cache_str}=&symbclean($env{'request.symb'}); + return $env{$cache_str}=&symbclean($env{'request.symb'}); } $thisfn=$env{'request.filename'}; } @@ -12725,10 +13460,18 @@ sub symbread { if ($targetfn =~ m|^adm/wrapper/(ext/.*)|) { $targetfn=$1; } - if (tie(%hash,'GDBM_File',$env{'request.course.fn'}.'_symb.db', - &GDBM_READER(),0640)) { - $syval=$hash{$targetfn}; - untie(%hash); + unless ($ignoresymbdb) { + if (tie(%hash,'GDBM_File',$env{'request.course.fn'}.'_symb.db', + &GDBM_READER(),0640)) { + $syval=$hash{$targetfn}; + untie(%hash); + } + if ($syval && $checkforblock) { + my @blockers = &has_comm_blocking('bre',$syval,$thisfn,$ignoresymbdb,$noenccheck); + if (@blockers) { + $syval=''; + } + } } # ---------------------------------------------------------- There was an entry if ($syval) { @@ -12761,13 +13504,18 @@ sub symbread { $syval=&encode_symb($bighash{'map_id_'.$mapid}, $resid,$thisfn); if (ref($possibles) eq 'HASH') { - $possibles->{$syval} = 1; + unless ($bighash{'randomout_'.$ids} || $env{'request.role.adv'}) { + $possibles->{$syval} = 1; + } } if ($checkforblock) { - my @blockers = &has_comm_blocking('bre',$syval,$bighash{'src_'.$ids}); - if (@blockers) { - $syval = ''; - return; + unless ($bighash{'randomout_'.$ids} || $env{'request.role.adv'}) { + my @blockers = &has_comm_blocking('bre',$syval,$bighash{'src_'.$ids},'',$noenccheck); + if (@blockers) { + $syval = ''; + untie(%bighash); + return $env{$cache_str}=''; + } } } } elsif ((!$donotrecurse) || ($checkforblock) || (ref($possibles) eq 'HASH')) { @@ -12786,12 +13534,13 @@ sub symbread { if ($bighash{'map_type_'.$mapid} ne 'page') { my $poss_syval=&encode_symb($bighash{'map_id_'.$mapid}, $resid,$thisfn); - if (ref($possibles) eq 'HASH') { - $possibles->{$syval} = 1; - } + next if ($bighash{'randomout_'.$id} && !$env{'request.role.adv'}); + next unless (($noenccheck) || ($bighash{'encrypted_'.$id} eq $env{'request.enc'})); if ($checkforblock) { - my @blockers = &has_comm_blocking('bre',$poss_syval,$file); - unless (@blockers > 0) { + my @blockers = &has_comm_blocking('bre',$poss_syval,$file,'',$noenccheck); + if (@blockers > 0) { + $syval = ''; + } else { $syval = $poss_syval; $realpossible++; } @@ -12799,6 +13548,11 @@ sub symbread { $syval = $poss_syval; $realpossible++; } + if ($syval) { + if (ref($possibles) eq 'HASH') { + $possibles->{$syval} = 1; + } + } } } } @@ -13336,9 +14090,10 @@ sub repcopy_userfile { my $request; $uri=~s/^\///; my $homeserver = &homeserver($cnum,$cdom); + my $hostname = &hostname($homeserver); my $protocol = $protocol{$homeserver}; $protocol = 'http' if ($protocol ne 'https'); - $request=new HTTP::Request('GET',$protocol.'://'.&hostname($homeserver).'/raw/'.$uri); + $request=new HTTP::Request('GET',$protocol.'://'.$hostname.'/raw/'.$uri); my $response = &LONCAPA::LWPReq::makerequest($homeserver,$request,$transferfile,\%perlvar,'',0,1); # did it work? if ($response->is_error()) { @@ -13362,9 +14117,10 @@ sub tokenwrapper { $file=~s|(\?\.*)*$||; &appenv({"userfile.$udom/$uname/$file" => $env{'request.course.id'}}); my $homeserver = &homeserver($uname,$udom); + my $hostname = &hostname($homeserver); my $protocol = $protocol{$homeserver}; $protocol = 'http' if ($protocol ne 'https'); - return $protocol.'://'.&hostname($homeserver).'/'.$uri. + return $protocol.'://'.$hostname.'/'.$uri. (($uri=~/\?/)?'&':'?').'token='.$token. '&tokenissued='.$perlvar{'lonHostID'}; } else { @@ -13380,9 +14136,10 @@ sub getuploaded { my ($reqtype,$uri,$cdom,$cnum,$info,$rtncode) = @_; $uri=~s/^\///; my $homeserver = &homeserver($cnum,$cdom); + my $hostname = &hostname($homeserver); my $protocol = $protocol{$homeserver}; $protocol = 'http' if ($protocol ne 'https'); - $uri = $protocol.'://'.&hostname($homeserver).'/raw/'.$uri; + $uri = $protocol.'://'.$hostname.'/raw/'.$uri; my $request=new HTTP::Request($reqtype,$uri); my $response=&LONCAPA::LWPReq::makerequest($homeserver,$request,'',\%perlvar,'',0,1); $$rtncode = $response->code; @@ -13535,6 +14292,218 @@ sub default_login_domain { return $domain; } +sub shared_institution { + my ($dom,$lonhost) = @_; + if ($lonhost eq '') { + $lonhost = $perlvar{'lonHostID'}; + } + my $same_intdom; + my $hostintdom = &internet_dom($lonhost); + if ($hostintdom ne '') { + my %iphost = &get_iphost(); + my $primary_id = &domain($dom,'primary'); + my $primary_ip = &get_host_ip($primary_id); + if (ref($iphost{$primary_ip}) eq 'ARRAY') { + foreach my $id (@{$iphost{$primary_ip}}) { + my $intdom = &internet_dom($id); + if ($intdom eq $hostintdom) { + $same_intdom = 1; + last; + } + } + } + } + return $same_intdom; +} + +sub uses_sts { + my ($ignore_cache) = @_; + my $lonhost = $perlvar{'lonHostID'}; + my $hostname = &hostname($lonhost); + my $sts_on; + if ($protocol{$lonhost} eq 'https') { + my $cachetime = 12*3600; + if (!$ignore_cache) { + ($sts_on,my $cached)=&is_cached_new('stspolicy',$lonhost); + if (defined($cached)) { + return $sts_on; + } + } + my $url = $protocol{$lonhost}.'://'.$hostname.'/index.html'; + my $request=new HTTP::Request('HEAD',$url); + my $response=&LONCAPA::LWPReq::makerequest($lonhost,$request,'',\%perlvar,'','','',1); + if ($response->is_success) { + my $has_sts = $response->header('Strict-Transport-Security'); + if ($has_sts eq '') { + $sts_on = 0; + } else { + if ($has_sts =~ /\Qmax-age=\E(\d+)/) { + my $maxage = $1; + if ($maxage) { + $sts_on = 1; + } else { + $sts_on = 0; + } + } else { + $sts_on = 0; + } + } + return &do_cache_new('stspolicy',$lonhost,$sts_on,$cachetime); + } + } + return; +} + +sub waf_allssl { + my ($host_name) = @_; + my $alias = &get_proxy_alias(); + if ($host_name eq '') { + $host_name = $ENV{'SERVER_NAME'}; + } + if (($host_name ne '') && ($alias eq $host_name)) { + my $serverhomedom = &host_domain($perlvar{'lonHostID'}); + my %defdomdefaults = &get_domain_defaults($serverhomedom); + if ($defdomdefaults{'waf_sslopt'}) { + return $defdomdefaults{'waf_sslopt'}; + } + } + return; +} + +sub get_requestor_ip { + my ($r,$nolookup,$noproxy) = @_; + my $from_ip; + if (ref($r)) { + if ($r->can('useragent_ip')) { + if ($noproxy && $r->can('client_ip')) { + $from_ip = $r->client_ip(); + } else { + $from_ip = $r->useragent_ip(); + } + } elsif ($r->connection->can('remote_ip')) { + $from_ip = $r->connection->remote_ip(); + } else { + $from_ip = $r->get_remote_host($nolookup); + } + } else { + $from_ip = $ENV{'REMOTE_ADDR'}; + } + return $from_ip if ($noproxy); + # Who controls proxy settings for server + my $dom_in_use = $Apache::lonnet::perlvar{'lonDefDomain'}; + my $proxyinfo = &get_proxy_settings($dom_in_use); + if ((ref($proxyinfo) eq 'HASH') && ($from_ip)) { + if ($proxyinfo->{'vpnint'}) { + if (&ip_match($from_ip,$proxyinfo->{'vpnint'})) { + return $from_ip; + } + } + if ($proxyinfo->{'trusted'}) { + if (&ip_match($from_ip,$proxyinfo->{'trusted'})) { + my $ipheader = $proxyinfo->{'ipheader'}; + my ($ip,$xfor); + if (ref($r)) { + if ($ipheader) { + $ip = $r->headers_in->{$ipheader}; + } + $xfor = $r->headers_in->{'X-Forwarded-For'}; + } else { + if ($ipheader) { + $ip = $ENV{'HTTP_'.uc($ipheader)}; + } + $xfor = $ENV{'HTTP_X_FORWARDED_FOR'}; + } + if (($ip eq '') && ($xfor ne '')) { + foreach my $poss_ip (reverse(split(/\s*,\s*/,$xfor))) { + unless (&ip_match($poss_ip,$proxyinfo->{'trusted'})) { + $ip = $poss_ip; + last; + } + } + } + if ($ip ne '') { + return $ip; + } + } + } + } + return $from_ip; +} + +sub get_proxy_settings { + my ($dom_in_use) = @_; + my %domdefaults = &Apache::lonnet::get_domain_defaults($dom_in_use); + my $proxyinfo = { + ipheader => $domdefaults{'waf_ipheader'}, + trusted => $domdefaults{'waf_trusted'}, + vpnint => $domdefaults{'waf_vpnint'}, + vpnext => $domdefaults{'waf_vpnext'}, + sslopt => $domdefaults{'waf_sslopt'}, + }; + return $proxyinfo; +} + +sub ip_match { + my ($ip,$pattern_str) = @_; + $ip=Net::CIDR::cidrvalidate($ip); + if ($ip) { + return Net::CIDR::cidrlookup($ip,split(/\s*,\s*/,$pattern_str)); + } + return; +} + +sub get_proxy_alias { + my ($lonid) = @_; + if ($lonid eq '') { + $lonid = $perlvar{'lonHostID'}; + } + if (!defined(&hostname($lonid))) { + return; + } + if ($lonid ne '') { + my ($alias,$cached) = &is_cached_new('proxyalias',$lonid); + if ($cached) { + return $alias; + } + my $dom = &Apache::lonnet::host_domain($lonid); + if ($dom ne '') { + my $cachetime = 60*60*24; + my %domconfig = + &Apache::lonnet::get_dom('configuration',['wafproxy'],$dom); + my $alias; + if (ref($domconfig{'wafproxy'}) eq 'HASH') { + if (ref($domconfig{'wafproxy'}{'alias'}) eq 'HASH') { + $alias = $domconfig{'wafproxy'}{'alias'}{$lonid}; + } + } + return &do_cache_new('proxyalias',$lonid,$alias,$cachetime); + } + } + return; +} + +sub use_proxy_alias { + my ($r,$lonid) = @_; + my $alias = &get_proxy_alias($lonid); + if ($alias) { + my $dom = &host_domain($lonid); + if ($dom ne '') { + my $proxyinfo = &get_proxy_settings($dom ); + my ($vpnint,$remote_ip); + if (ref($proxyinfo) eq 'HASH') { + $vpnint = $proxyinfo->{'vpnint'}; + if ($vpnint) { + $remote_ip = &get_requestor_ip($r,1,1); + } + } + unless ($vpnint && &ip_match($remote_ip,$vpnint)) { + return $alias; + } + } + } + return; +} + # ------------------------------------------------------------- Declutters URLs sub declutter { @@ -14403,6 +15372,16 @@ BEGIN { } +# ------------- set default texengine (domain default overrides this) +{ + $deftex = LONCAPA::texengine(); +} + +# ------------- set default minimum length for passwords for internal auth users +{ + $passwdmin = LONCAPA::passwd_min(); +} + $memcache=new Cache::Memcached({'servers' => ['127.0.0.1:11211'], 'compress_threshold'=> 20_000, }); @@ -14742,6 +15721,7 @@ prevents recursive calls to &allowed. 2: browse allowed A: passphrase authentication needed B: access temporarily blocked because of a blocking event in a course. + D: access blocked because access is required via session initiated via deep-link =item * @@ -15072,6 +16052,88 @@ Returns: =back +=head2 Bubblesheet Configuration + +=over 4 + +=item * + +get_scantron_config($which) + +$which - the name of the configuration to parse from the file. + +Parses and returns the bubblesheet configuration line selected as a +hash of configuration file fields. + + +Returns: + If the named configuration is not in the file, an empty + hash is returned. + + a hash with the fields + name - internal name for the this configuration setup + description - text to display to operator that describes this config + CODElocation - if 0 or the string 'none' + - no CODE exists for this config + if -1 || the string 'letter' + - a CODE exists for this config and is + a string of letters + Unsupported value (but planned for future support) + if a positive integer + - The CODE exists as the first n items from + the question section of the form + if the string 'number' + - The CODE exists for this config and is + a string of numbers + CODEstart - (only matter if a CODE exists) column in the line where + the CODE starts + CODElength - length of the CODE + IDstart - column where the student/employee ID starts + IDlength - length of the student/employee ID info + Qstart - column where the information from the bubbled + 'questions' start + Qlength - number of columns comprising a single bubble line from + the sheet. (usually either 1 or 10) + Qon - either a single character representing the character used + to signal a bubble was chosen in the positional setup, or + the string 'letter' if the letter of the chosen bubble is + in the final, or 'number' if a number representing the + chosen bubble is in the file (1->A 0->J) + Qoff - the character used to represent that a bubble was + left blank + PaperID - if the scanning process generates a unique number for each + sheet scanned the column that this ID number starts in + PaperIDlength - number of columns that comprise the unique ID number + for the sheet of paper + FirstName - column that the first name starts in + FirstNameLength - number of columns that the first name spans + LastName - column that the last name starts in + LastNameLength - number of columns that the last name spans + BubblesPerRow - number of bubbles available in each row used to + bubble an answer. (If not specified, 10 assumed). + + +=item * + +get_scantronformat_file($cdom) + +$cdom - the course's domain (optional); if not supplied, uses +domain for current $env{'request.course.id'}. + +Returns an array containing lines from the scantron format file for +the domain of the course. + +If a url for a custom.tab file is listed in domain's configuration.db, +lines are from this file. + +Otherwise, if a default.tab has been published in RES space by the +domainconfig user, lines are from this file. + +Otherwise, fall back to getting lines from the legacy file on the +local server: /home/httpd/lonTabs/default_scantronformat.tab + +=back + =head2 Resource Subroutines =over 4 @@ -15769,6 +16831,7 @@ userspace, probably shouldn't be called formname: same as for userfileupload() fname: filename (including subdirectories) for the file parser: if 'parse', will parse (html) file to extract references to objects, links etc. + if hashref, and context is scantron, will convert csv format to standard format allfiles: reference to hash used to store objects found by parser codebase: reference to hash used for codebases of java objects found by parser thumbwidth: width (pixels) of thumbnail to be created for uploaded image