--- loncom/lonnet/perl/lonnet.pm 2008/07/17 21:22:51 1.963 +++ loncom/lonnet/perl/lonnet.pm 2008/12/19 17:04:57 1.979 @@ -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.979 2008/12/19 17:04:57 raeburn Exp $ # # Copyright Michigan State University Board of Trustees # @@ -27,14 +27,57 @@ # ### +=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; use LWP::UserAgent(); use HTTP::Date; +use Image::Magick; + # 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, @@ -56,33 +99,13 @@ use LONCAPA::Configuration; my $readit; my $max_connection_retries = 10; # Or some such value. +my $upload_photo_form = 0; #Variable to check when user upload a photo 0=not 1=true + 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 { @@ -643,7 +666,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; } @@ -1199,12 +1226,12 @@ 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 ($defauthtype,$defautharg,$deflang,%deftools); my ($result,$cached)=&is_cached_new('domdefaults',$domain); if (defined($cached)) { if (ref($result) eq 'HASH') { @@ -1213,7 +1240,7 @@ 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'}; @@ -1223,6 +1250,19 @@ sub get_domain_defaults { $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 +1587,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++) { @@ -1970,6 +2015,14 @@ sub clean_filename { return $fname; } +#Wrapper function for userphotoupload +sub userphotoupload +{ + my($formname,$subdir) = @_; + $upload_photo_form = 1; + return &userfileupload($formname,undef,$subdir); +} + # --------------- Take an uploaded file and put it into the userfiles directory # input: $formname - the contents of the file are in $env{"form.$formname"} # the desired filenam is in $env{"form.$formname.filename"} @@ -2096,6 +2149,25 @@ sub finishuserfileupload { return '/adm/notfound.html'; } close(FH); + if($upload_photo_form==1) + { + my $ima = Image::Magick->new; + $ima->Read($filepath.'/'.$file); + if($ima->Get('width') > 300) + { + my $factor = $ima->Get('width')/300; + $ima->Scale( width=>300, height=>$ima->Get('height')/$factor ); + } + if($ima->Get('height') > 400) + { + my $factor = $ima->Get('height')/400; + $ima->Scale( width=>$ima->Get('width')/$factor, height=>400); + } + + + $ima->Write($filepath.'/'.$file); + $upload_photo_form = 0; + } } if ($parser eq 'parse') { my $parse_result = &extract_embedded_items($filepath.'/'.$file,$allfiles, @@ -2466,7 +2538,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:) { @@ -2596,7 +2673,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 { @@ -3561,12 +3638,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 +4405,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 +5092,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 +6083,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 +6348,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"; @@ -8446,14 +8648,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 +8725,12 @@ sub get_dns { } return $domain{$name}{$what}; } + + sub domain_info { + &load_domain_tab() if (!$loaded); + return %domain; + } + } @@ -8535,13 +8748,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 +8808,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 +9211,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 @@ -9175,7 +9402,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 +9791,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