--- loncom/lonnet/perl/lonnet.pm 2008/07/17 21:22:51 1.963 +++ loncom/lonnet/perl/lonnet.pm 2009/10/09 12:42:36 1.976.2.10 @@ -1,7 +1,7 @@ # The LearningOnline Network # TCP networking package # -# $Id: lonnet.pm,v 1.963 2008/07/17 21:22:51 raeburn Exp $ +# $Id: lonnet.pm,v 1.976.2.10 2009/10/09 12:42:36 raeburn Exp $ # # Copyright Michigan State University Board of Trustees # @@ -27,6 +27,47 @@ # ### +=pod + +=head1 NAME + +Apache::lonnet.pm + +=head1 SYNOPSIS + +This file is an interface to the lonc processes of +the LON-CAPA network as well as set of elaborated functions for handling information +necessary for navigating through a given cluster of LON-CAPA machines within a +domain. There are over 40 specialized functions in this module which handle the +reading and transmission of metadata, user information (ids, names, environments, roles, +logs), file information (storage, reading, directories, extensions, replication, embedded +styles and descriptors), educational resources (course descriptions, section names and +numbers), url hashing (to assign roles on a url basis), and translating abbreviated symbols to +and from more descriptive phrases or explanations. + +This is part of the LearningOnline Network with CAPA project +described at http://www.lon-capa.org. + +=head1 Package Variables + +These are largely undocumented, so if you decipher one please note it here. + +=over 4 + +=item $processmarker + +Contains the time this process was started and this servers host id. + +=item $dumpcount + +Counts the number of times a message log flush has been attempted (regardless +of success) by this process. Used as part of the filename when messages are +delayed. + +=back + +=cut + package Apache::lonnet; use strict; @@ -34,7 +75,7 @@ use LWP::UserAgent(); use HTTP::Date; # use Date::Parse; use vars qw(%perlvar %spareid %pr %prp $memcache %packagetab $tmpdir - $_64bit %env); + $_64bit %env %protocol); my (%badServerCache, $memcache, %courselogs, %accesshash, %domainrolehash, %userrolehash, $processmarker, $dumpcount, %coursedombuf, @@ -61,28 +102,6 @@ require Exporter; our @ISA = qw (Exporter); our @EXPORT = qw(%env); -=pod - -=head1 Package Variables - -These are largely undocumented, so if you decipher one please note it here. - -=over 4 - -=item $processmarker - -Contains the time this process was started and this servers host id. - -=item $dumpcount - -Counts the number of times a message log flush has been attempted (regardless -of success) by this process. Used as part of the filename when messages are -delayed. - -=back - -=cut - # --------------------------------------------------------------------- Logging { @@ -158,6 +177,20 @@ sub create_connection { return 0; } +sub get_server_timezone { + my ($cnum,$cdom) = @_; + my $home=&homeserver($cnum,$cdom); + if ($home ne 'no_host') { + my $cachetime = 24*3600; + my ($timezone,$cached)=&is_cached_new('servertimezone',$home); + if (defined($cached)) { + return $timezone; + } else { + my $timezone = &reply('servertimezone',$home); + return &do_cache_new('servertimezone',$home,$timezone,$cachetime); + } + } +} # -------------------------------------------------- Non-critical communication sub subreply { @@ -489,7 +522,7 @@ sub appenv { # ----------------------------------------------------- Delete from Environment sub delenv { - my $delthis=shift; + my ($delthis,$regexp) = @_; if (($delthis=~/user\.role/) || ($delthis=~/user\.priv/)) { &logthis("WARNING: ". "Attempt to delete from environment ".$delthis); @@ -502,10 +535,17 @@ sub delenv { tie(my %disk_env,'GDBM_File',$env{'user.environment'}, (&GDBM_WRITER()|&GDBM_NOLOCK()),0640)) { foreach my $key (keys(%disk_env)) { - if ($key=~/^$delthis/) { - delete($env{$key}); - delete($disk_env{$key}); - } + if ($regexp) { + if ($key=~/^$delthis/) { + delete($env{$key}); + delete($disk_env{$key}); + } + } else { + if ($key=~/^\Q$delthis\E/) { + delete($env{$key}); + delete($disk_env{$key}); + } + } } untie(%disk_env); } @@ -643,7 +683,11 @@ sub spareserver { } if (!$want_server_name) { - $spare_server="http://".&hostname($spare_server); + my $protocol = 'http'; + if ($protocol{$spare_server} eq 'https') { + $protocol = $protocol{$spare_server}; + } + $spare_server = $protocol.'://'.&hostname($spare_server); } return $spare_server; } @@ -704,7 +748,8 @@ sub changepass { my ($uname,$udom,$currentpass,$newpass,$server,$context)=@_; $currentpass = &escape($currentpass); $newpass = &escape($newpass); - my $answer = reply("encrypt:passwd:$udom:$uname:$currentpass:$newpass:$context", + my $lonhost = $perlvar{'lonHostID'}; + my $answer = reply("encrypt:passwd:$udom:$uname:$currentpass:$newpass:$context:$lonhost", $server); if (! $answer) { &logthis("No reply on password change request to $server ". @@ -729,6 +774,9 @@ sub changepass { } elsif ($answer =~ "^refused") { &logthis("$server refused to change $uname in $udom password because ". "it was sent an unencrypted request to change the password."); + } 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."); } return $answer; } @@ -1199,12 +1247,11 @@ sub inst_userrules { return (\%ruleshash,\@ruleorder); } -# ------------------------- Get Authentication and Language Defaults for Domain +# ------------- Get Authentication, Language and User Tools Defaults for Domain sub get_domain_defaults { my ($domain) = @_; my $cachetime = 60*60*24; - my ($defauthtype,$defautharg,$deflang); my ($result,$cached)=&is_cached_new('domdefaults',$domain); if (defined($cached)) { if (ref($result) eq 'HASH') { @@ -1213,16 +1260,31 @@ sub get_domain_defaults { } my %domdefaults; my %domconfig = - &Apache::lonnet::get_dom('configuration',['defaults'],$domain); + &Apache::lonnet::get_dom('configuration',['defaults','quotas'],$domain); if (ref($domconfig{'defaults'}) eq 'HASH') { $domdefaults{'lang_def'} = $domconfig{'defaults'}{'lang_def'}; $domdefaults{'auth_def'} = $domconfig{'defaults'}{'auth_def'}; $domdefaults{'auth_arg_def'} = $domconfig{'defaults'}{'auth_arg_def'}; + $domdefaults{'timezone_def'} = $domconfig{'defaults'}{'timezone_def'}; + $domdefaults{'datelocale_def'} = $domconfig{'defaults'}{'datelocale_def'}; } else { $domdefaults{'lang_def'} = &domain($domain,'lang_def'); $domdefaults{'auth_def'} = &domain($domain,'auth_def'); $domdefaults{'auth_arg_def'} = &domain($domain,'auth_arg_def'); } + if (ref($domconfig{'quotas'}) eq 'HASH') { + if (ref($domconfig{'quotas'}{'defaultquota'}) eq 'HASH') { + $domdefaults{'defaultquota'} = $domconfig{'quotas'}{'defaultquota'}; + } else { + $domdefaults{'defaultquota'} = $domconfig{'quotas'}; + } + my @usertools = ('aboutme','blog','portfolio'); + foreach my $item (@usertools) { + if (ref($domconfig{'quotas'}{$item}) eq 'HASH') { + $domdefaults{$item} = $domconfig{'quotas'}{$item}; + } + } + } &Apache::lonnet::do_cache_new('domdefaults',$domain,\%domdefaults, $cachetime); return %domdefaults; @@ -1547,9 +1609,14 @@ sub purge_remembered { sub userenvironment { my ($udom,$unam,@what)=@_; + my $items; + foreach my $item (@what) { + $items.=&escape($item).'&'; + } + $items=~s/\&$//; my %returnhash=(); my @answer=split(/\&/, - &reply('get:'.$udom.':'.$unam.':environment:'.join('&',@what), + &reply('get:'.$udom.':'.$unam.':environment:'.$items, &homeserver($unam,$udom))); my $i; for ($i=0;$i<=$#what;$i++) { @@ -1746,7 +1813,7 @@ sub ssi_body { } my $output=''; my $response; - if ($filelink=~/^http\:/) { + if ($filelink=~/^https?\:/) { ($output,$response)=&externalssi($filelink); } else { ($output,$response)=&ssi($filelink,%form); @@ -2466,7 +2533,12 @@ sub courseacclog { # FIXME: Probably ought to escape things.... foreach my $key (keys(%env)) { if ($key=~/^form\.(.*)/) { - $what.=':'.$1.'='.$env{$key}; + my $formitem = $1; + if ($formitem =~ /^HWFILE(?:SIZE|TOOBIG)/) { + $what.=':'.$formitem.'='.$env{$key}; + } elsif ($formitem !~ /^HWFILE(?:[^.]+)$/) { + $what.=':'.$formitem.'='.$env{$key}; + } } } } elsif ($fnsymb =~ m:^/adm/searchcat:) { @@ -2556,6 +2628,9 @@ sub courserolelog { $storehash{'section'} = $sec; } &instructor_log($namespace,\%storehash,$delflag,$username,$domain,$cnum,$cdom); + if (($trole ne 'st') || ($sec ne '')) { + &devalidate_cache_new('getcourseroles',$cdom.'_'.$cnum); + } } } return; @@ -2577,6 +2652,7 @@ sub get_course_adv_roles { my %dumphash= &dump('nohist_userroles',$coursehash{'domain'},$coursehash{'num'}); my $now=time; + my %privileged; foreach my $entry (keys %dumphash) { my ($tend,$tstart)=split(/\:/,$dumphash{$entry}); if (($tstart) && ($tstart<0)) { next; } @@ -2584,8 +2660,21 @@ sub get_course_adv_roles { if (($tstart) && ($now<$tstart)) { next; } my ($role,$username,$domain,$section)=split(/\:/,$entry); if ($username eq '' || $domain eq '') { next; } - if ((&privileged($username,$domain)) && - (!$nothide{$username.':'.$domain})) { next; } + unless (ref($privileged{$domain}) eq 'HASH') { + my %dompersonnel = + &Apache::lonnet::get_domain_roles($domain,['dc'],$now,$now); + $privileged{$domain} = {}; + foreach my $server (keys(%dompersonnel)) { + if (ref($dompersonnel{$server}) eq 'HASH') { + foreach my $user (keys(%{$dompersonnel{$server}})) { + my ($trole,$uname,$udom) = split(/:/,$user); + $privileged{$udom}{$uname} = 1; + } + } + } + } + if ((exists($privileged{$domain}{$username})) && + (!$nothide{$username.':'.$domain})) { next; } if ($role eq 'cr') { next; } if ($codes) { if ($section) { $role .= ':'.$section; } @@ -2596,7 +2685,7 @@ sub get_course_adv_roles { } } else { my $key=&plaintext($role); - if ($section) { $key.=' (Section '.$section.')'; } + if ($section) { $key.=' ('.&Apache::lonlocal::mt('Section [_1]',$section).')'; } if ($returnhash{$key}) { $returnhash{$key}.=','.$username.':'.$domain; } else { @@ -2630,6 +2719,7 @@ sub get_my_roles { } my %returnhash=(); my $now=time; + my %privileged; foreach my $entry (keys(%dumphash)) { my ($role,$tend,$tstart); if ($context eq 'userroles') { @@ -2678,9 +2768,32 @@ sub get_my_roles { } } if ($hidepriv) { - if ((&privileged($username,$domain)) && - (!$nothide{$username.':'.$domain})) { - next; + if ($context eq 'userroles') { + if ((&privileged($username,$domain)) && + (!$nothide{$username.':'.$domain})) { + next; + } + } else { + unless (ref($privileged{$domain}) eq 'HASH') { + my %dompersonnel = + &Apache::lonnet::get_domain_roles($domain,['dc'],$now,$now); + $privileged{$domain} = {}; + if (keys(%dompersonnel)) { + foreach my $server (keys(%dompersonnel)) { + if (ref($dompersonnel{$server}) eq 'HASH') { + foreach my $user (keys(%{$dompersonnel{$server}})) { + my ($trole,$uname,$udom) = split(/:/,$user); + $privileged{$udom}{$uname} = $trole; + } + } + } + } + } + if (exists($privileged{$domain}{$username})) { + if (!$nothide{$username.':'.$domain}) { + next; + } + } } } if ($withsec) { @@ -3561,12 +3674,13 @@ sub privileged { sub rolesinit { my ($domain,$username,$authhost)=@_; + my %userroles; my $rolesdump=reply("dump:$domain:$username:roles",$authhost); - if (($rolesdump eq 'con_lost') || ($rolesdump eq '')) { return ''; } + if (($rolesdump eq 'con_lost') || ($rolesdump eq '')) { return \%userroles; } my %allroles=(); my %allgroups=(); my $now=time; - my %userroles = ('user.login.time' => $now); + %userroles = ('user.login.time' => $now); my $group_privs; if ($rolesdump ne '') { @@ -4327,6 +4441,129 @@ sub is_portfolio_file { return; } +sub usertools_access { + my ($uname,$udom,$tool,$action) = @_; + my $access; + my %tools = ( + aboutme => 1, + blog => 1, + portfolio => 1, + ); + return if (!defined($tools{$tool})); + + if ((!defined($udom)) || (!defined($uname))) { + $udom = $env{'user.domain'}; + $uname = $env{'user.name'}; + } + + if (($udom eq $env{'user.domain'}) && ($uname eq $env{'user.name'})) { + if ($action ne 'reload') { + return $env{'environment.availabletools.'.$tool}; + } + } + + my ($toolstatus,$inststatus); + + if (($udom eq $env{'user.domain'}) && ($uname eq $env{'user.name'})) { + $toolstatus = $env{'environment.tools.'.$tool}; + $inststatus = $env{'environment.inststatus'}; + } else { + my %userenv = &userenvironment($udom,$uname,'tools.'.$tool); + $toolstatus = $userenv{'tools.'.$tool}; + $inststatus = $userenv{'inststatus'}; + } + + if ($toolstatus ne '') { + if ($toolstatus) { + $access = 1; + } else { + $access = 0; + } + return $access; + } + + my $is_adv = &is_advanced_user($udom,$uname); + my %domdef = &get_domain_defaults($udom); + if (ref($domdef{$tool}) eq 'HASH') { + if ($is_adv) { + if ($domdef{$tool}{'_LC_adv'} ne '') { + if ($domdef{$tool}{'_LC_adv'}) { + $access = 1; + } else { + $access = 0; + } + return $access; + } + } + if ($inststatus ne '') { + my ($hasaccess,$hasnoaccess); + foreach my $affiliation (split(/:/,$inststatus)) { + if ($domdef{$tool}{$affiliation} ne '') { + if ($domdef{$tool}{$affiliation}) { + $hasaccess = 1; + } else { + $hasnoaccess = 1; + } + } + } + if ($hasaccess || $hasnoaccess) { + if ($hasaccess) { + $access = 1; + } elsif ($hasnoaccess) { + $access = 0; + } + return $access; + } + } else { + if ($domdef{$tool}{'default'} ne '') { + if ($domdef{$tool}{'default'}) { + $access = 1; + } elsif ($domdef{$tool}{'default'} == 0) { + $access = 0; + } + return $access; + } + } + } else { + $access = 1; + return $access; + } +} + +sub is_advanced_user { + my ($udom,$uname) = @_; + my %roleshash = &get_my_roles($uname,$udom,'userroles',undef,undef,undef,1); + my %allroles; + my $is_adv; + foreach my $role (keys(%roleshash)) { + my ($trest,$tdomain,$trole,$sec) = split(/:/,$role); + my $area = '/'.$tdomain.'/'.$trest; + if ($sec ne '') { + $area .= '/'.$sec; + } + if (($area ne '') && ($trole ne '')) { + my $spec=$trole.'.'.$area; + if ($trole =~ /^cr\//) { + &custom_roleprivs(\%allroles,$trole,$tdomain,$trest,$spec,$area); + } elsif ($trole ne 'gr') { + &standard_roleprivs(\%allroles,$trole,$tdomain,$spec,$trest,$area); + } + } + } + foreach my $role (keys(%allroles)) { + last if ($is_adv); + foreach my $item (split(/:/,$allroles{$role})) { + if ($item ne '') { + my ($privilege,$restrictions)=split(/&/,$item); + if ($privilege eq 'adv') { + $is_adv = 1; + last; + } + } + } + } + return $is_adv; +} # ---------------------------------------------- Custom access rule evaluation @@ -4891,6 +5128,9 @@ sub log_query { sub update_portfolio_table { my ($uname,$udom,$file_name,$query,$group,$action) = @_; + if ($group ne '') { + $file_name =~s /^\Q$group\E//; + } my $homeserver = &homeserver($uname,$udom); my $queryid= &reply("querysend:".$query.':'.&escape($uname.':'.$udom.':'.$group). @@ -5879,7 +6119,7 @@ sub assigncustomrole { sub revokerole { my ($udom,$uname,$url,$role,$deleteflag,$selfenroll,$context)=@_; my $now=time; - return &assignrole($udom,$uname,$url,$role,$now,$deleteflag,$selfenroll,$context); + return &assignrole($udom,$uname,$url,$role,$now,undef,$deleteflag,$selfenroll,$context); } # ---------------------------------------------------------- Revoke Custom Role @@ -6144,20 +6384,18 @@ sub modify_access_controls { } } } + my ($group); + if (&is_course($domain,$user)) { + ($group,my $file) = split(/\//,$file_name,2); + } $deloutcome = &del('file_permissions',\@deletions,$domain,$user); $new_values{$file_name."\0".'accesscontrol'} = \%new_control; $outcome = &put('file_permissions',\%new_values,$domain,$user); # remove lock my @del_lock = ($file_name."\0".'locked_access_records'); my $dellockoutcome = &del('file_permissions',\@del_lock,$domain,$user); - my ($file,$group); - if (&is_course($domain,$user)) { - ($group,$file) = split(/\//,$file_name,2); - } else { - $file = $file_name; - } my $sqlresult = - &update_portfolio_table($user,$domain,$file,'portfolio_access', + &update_portfolio_table($user,$domain,$file_name,'portfolio_access', $group); } else { $outcome = "error: could not obtain lockfile\n"; @@ -8130,7 +8368,10 @@ sub repcopy_userfile { if (-e $transferfile) { return 'ok'; } my $request; $uri=~s/^\///; - $request=new HTTP::Request('GET','http://'.&hostname(&homeserver($cnum,$cdom)).'/raw/'.$uri); + my $homeserver = &homeserver($cnum,$cdom); + my $protocol = $protocol{$homeserver}; + $protocol = 'http' if ($protocol ne 'https'); + $request=new HTTP::Request('GET',$protocol.'://'.&hostname($homeserver).'/raw/'.$uri); my $response=$ua->request($request,$transferfile); # did it work? if ($response->is_error()) { @@ -8145,7 +8386,7 @@ sub repcopy_userfile { sub tokenwrapper { my $uri=shift; - $uri=~s|^http\://([^/]+)||; + $uri=~s|^https?\://([^/]+)||; $uri=~s|^/||; $env{'user.environment'}=~/\/([^\/]+)\.id/; my $token=$1; @@ -8153,7 +8394,10 @@ sub tokenwrapper { if ($udom && $uname && $file) { $file=~s|(\?\.*)*$||; &appenv({"userfile.$udom/$uname/$file" => $env{'request.course.id'}}); - return 'http://'.&hostname(&homeserver($uname,$udom)).'/'.$uri. + my $homeserver = &homeserver($uname,$udom); + my $protocol = $protocol{$homeserver}; + $protocol = 'http' if ($protocol ne 'https'); + return $protocol.'://'.&hostname($homeserver).'/'.$uri. (($uri=~/\?/)?'&':'?').'token='.$token. '&tokenissued='.$perlvar{'lonHostID'}; } else { @@ -8168,7 +8412,10 @@ sub tokenwrapper { sub getuploaded { my ($reqtype,$uri,$cdom,$cnum,$info,$rtncode) = @_; $uri=~s/^\///; - $uri = 'http://'.&hostname(&homeserver($cnum,$cdom)).'/raw/'.$uri; + my $homeserver = &homeserver($cnum,$cdom); + my $protocol = $protocol{$homeserver}; + $protocol = 'http' if ($protocol ne 'https'); + $uri = $protocol.'://'.&hostname($homeserver).'/raw/'.$uri; my $ua=new LWP::UserAgent; my $request=new HTTP::Request($reqtype,$uri); my $response=$ua->request($request); @@ -8250,7 +8497,7 @@ sub filelocation { sub hreflocation { my ($dir,$file)=@_; - unless (($file=~m-^http://-i) || ($file=~m-^/-)) { + unless (($file=~m-^https?\://-i) || ($file=~m-^/-)) { $file=filelocation($dir,$file); } elsif ($file=~m-^/adm/-) { $file=~s-^/adm/wrapper/-/-; @@ -8446,14 +8693,19 @@ sub get_dns { open(my $config,"<$perlvar{'lonTabDir'}/hosts.tab"); foreach my $dns (<$config>) { next if ($dns !~ /^\^(\S*)/x); - $alldns{$1} = 1; + my $line = $1; + my ($host,$protocol) = split(/:/,$line); + if ($protocol ne 'https') { + $protocol = 'http'; + } + $alldns{$host} = $protocol; } while (%alldns) { my ($dns) = keys(%alldns); - delete($alldns{$dns}); my $ua=new LWP::UserAgent; - my $request=new HTTP::Request('GET',"http://$dns$url"); + my $request=new HTTP::Request('GET',"$alldns{$dns}://$dns$url"); my $response=$ua->request($request); + delete($alldns{$dns}); next if ($response->is_error()); my @content = split("\n",$response->content); &Apache::lonnet::do_cache_new('dns',$url,\@content,30*24*60*60); @@ -8518,6 +8770,12 @@ sub get_dns { } return $domain{$name}{$what}; } + + sub domain_info { + &load_domain_tab() if (!$loaded); + return %domain; + } + } @@ -8535,13 +8793,22 @@ sub get_dns { next if ($configline =~ /^(\#|\s*$ )/x); next if ($configline =~ /^\^/); chomp($configline); - my ($id,$domain,$role,$name)=split(/:/,$configline); + my ($id,$domain,$role,$name,$protocol)=split(/:/,$configline); $name=~s/\s//g; if ($id && $domain && $role && $name) { $hostname{$id}=$name; push(@{$name_to_host{$name}}, $id); $hostdom{$id}=$domain; if ($role eq 'library') { $libserv{$id}=$name; } + if (defined($protocol)) { + if ($protocol eq 'https') { + $protocol{$id} = $protocol; + } else { + $protocol{$id} = 'http'; + } + } else { + $protocol{$id} = 'http'; + } } } } @@ -8586,6 +8853,11 @@ sub get_dns { return %name_to_host; } + sub all_host_domain { + &load_hosts_tab() if (!$loaded); + return %hostdom; + } + sub is_library { &load_hosts_tab() if (!$loaded); @@ -8984,7 +9256,7 @@ when the connection is brought back up =item * B: unable to contact remote host and unable to save message for later delivery -=item * B: an error a occured, a description of the error follows the : +=item * B: an error a occurred, a description of the error follows the : =item * B: unable to fund a host associated with the user/domain that was requested @@ -9008,9 +9280,11 @@ in the user's environment.db and in %env =item * X -B: removes all items from the session -environment file that matches the regular expression in $regexp. The -values are also delted from the current processes %env. +B: removes all items from the session +environment file that begin with $delthis. If the +optional second arg - $regexp - is true, $delthis is treated as a +regular expression, otherwise \Q$delthis\E is used. +The values are also deleted from the current processes %env. =item * get_env_multiple($name) @@ -9175,7 +9449,7 @@ Inputs: =item B<$uname> Student's loncapa login name -=item B<$uid> Student's id/student number +=item B<$uid> Student/Employee ID =item B<$umode> Student's authentication mode @@ -9564,7 +9838,7 @@ Returns: 'key_exists: ' -> failed to anything out of $storehash, as at least already existed in the db (other requested keys may also already exist) - 'error: ' -> unable to tie the DB or other erorr occured + 'error: ' -> unable to tie the DB or other error occurred 'con_lost' -> unable to contact request server 'refused' -> action was not allowed by remote machine