--- loncom/lonnet/perl/lonnet.pm 2007/04/03 17:51:50 1.858 +++ loncom/lonnet/perl/lonnet.pm 2007/05/17 09:25:31 1.878 @@ -1,7 +1,7 @@ # The LearningOnline Network # TCP networking package # -# $Id: lonnet.pm,v 1.858 2007/04/03 17:51:50 raeburn Exp $ +# $Id: lonnet.pm,v 1.878 2007/05/17 09:25:31 foxr Exp $ # # Copyright Michigan State University Board of Trustees # @@ -31,22 +31,21 @@ package Apache::lonnet; use strict; use LWP::UserAgent(); -use HTTP::Headers; use HTTP::Date; # use Date::Parse; -use vars -qw(%perlvar %badServerCache %spareid - %pr %prp $memcache %packagetab - %courselogs %accesshash %userrolehash %domainrolehash $processmarker $dumpcount - %coursedombuf %coursenumbuf %coursehombuf %coursedescrbuf %courseinstcodebuf %courseownerbuf %coursetypebuf - $tmpdir $_64bit %env); +use vars qw(%perlvar %spareid %pr %prp $memcache %packagetab $tmpdir + $_64bit %env); + +my (%badServerCache, $memcache, %courselogs, %accesshash, %domainrolehash, + %userrolehash, $processmarker, $dumpcount, %coursedombuf, + %coursenumbuf, %coursehombuf, %coursedescrbuf, %courseinstcodebuf, + %courseownerbuf, %coursetypebuf); use IO::Socket; use GDBM_File; use HTML::LCParser; -use HTML::Parser; use Fcntl qw(:flock); -use Storable qw(lock_store lock_nstore lock_retrieve freeze thaw nfreeze); +use Storable qw(thaw nfreeze); use Time::HiRes qw( gettimeofday tv_interval ); use Cache::Memcached; use Digest::MD5; @@ -182,7 +181,7 @@ sub subreply { $client=IO::Socket::UNIX->new(Peer =>"$peerfile", Type => SOCK_STREAM, Timeout => 10); - if($client) { + if ($client) { last; # Connected! } else { &create_connection(&hostname($server),$server); @@ -734,21 +733,36 @@ sub idput { # ------------------------------------------- get items from domain db files sub get_dom { - my ($namespace,$storearr,$udom)=@_; + my ($namespace,$storearr,$udom,$uhome)=@_; my $items=''; foreach my $item (@$storearr) { $items.=&escape($item).'&'; } $items=~s/\&$//; - if (!$udom) { $udom=$env{'user.domain'}; } - if (defined(&domain($udom,'primary'))) { - my $uhome=&domain($udom,'primary'); + if (!$udom) { + $udom=$env{'user.domain'}; + if (defined(&domain($udom,'primary'))) { + $uhome=&domain($udom,'primary'); + } else { + undef($uhome); + } + } else { + if (!$uhome) { + if (defined(&domain($udom,'primary'))) { + $uhome=&domain($udom,'primary'); + } + } + } + if ($udom && $uhome && ($uhome ne 'no_host')) { my $rep=&reply("getdom:$udom:$namespace:$items",$uhome); + my %returnhash; + if ($rep eq '' || $rep =~ /^error: 2 /) { + return %returnhash; + } my @pairs=split(/\&/,$rep); if ( $#pairs==0 && $pairs[0] =~ /^(con_lost|error|no_such_host)/i) { return @pairs; } - my %returnhash=(); my $i=0; foreach my $item (@$storearr) { $returnhash{$item}=&thaw_unescape($pairs[$i]); @@ -756,17 +770,29 @@ sub get_dom { } return %returnhash; } else { - &logthis("get_dom failed - no primary domain server for $udom"); + &logthis("get_dom failed - no homeserver and/or domain"); } } # -------------------------------------------- put items in domain db files sub put_dom { - my ($namespace,$storehash,$udom)=@_; - if (!$udom) { $udom=$env{'user.domain'}; } - if (defined(&domain($udom,'primary'))) { - my $uhome=&domain($udom,'primary'); + my ($namespace,$storehash,$udom,$uhome)=@_; + if (!$udom) { + $udom=$env{'user.domain'}; + if (defined(&domain($udom,'primary'))) { + $uhome=&domain($udom,'primary'); + } else { + undef($uhome); + } + } else { + if (!$uhome) { + if (defined(&domain($udom,'primary'))) { + $uhome=&domain($udom,'primary'); + } + } + } + if ($udom && $uhome && ($uhome ne 'no_host')) { my $items=''; foreach my $item (keys(%$storehash)) { $items.=&escape($item).'='.&freeze_escape($$storehash{$item}).'&'; @@ -774,7 +800,7 @@ sub put_dom { $items=~s/\&$//; return &reply("putdom:$udom:$namespace:$items",$uhome); } else { - &logthis("put_dom failed - no primary domain server for $udom"); + &logthis("put_dom failed - no homeserver and/or domain"); } } @@ -802,6 +828,16 @@ sub retrieve_inst_usertypes { return (\%returnhash,\@order); } +sub is_domainimage { + my ($url) = @_; + if ($url=~m-^/+res/+($match_domain)/+\1\-domainconfig/+(img|logo|domlogo)/+-) { + if (&domain($1) ne '') { + return '1'; + } + } + return; +} + # --------------------------------------------------- Assign a key to a student sub assign_access_key { @@ -1028,7 +1064,10 @@ my $kicks=0; my $hits=0; sub make_key { my ($name,$id) = @_; - if (length($id) > 200) { $id=length($id).':'.&Digest::MD5::md5_hex($id); } + if (length($id) > 65 + && length(&escape($id)) > 200) { + $id=length($id).':'.&Digest::MD5::md5_hex($id); + } return &escape($name.':'.$id); } @@ -1075,7 +1114,9 @@ sub do_cache_new { $time=600; } if ($debug) { &Apache::lonnet::logthis("Setting $id to $value"); } - $memcache->set($id,$setvalue,$time); + if (!($memcache->set($id,$setvalue,$time))) { + &logthis("caching of id -> $id failed"); + } # need to make a copy of $value #&make_room($id,$value,$debug); return $value; @@ -1521,13 +1562,16 @@ sub clean_filename { # $codebase - reference to hash for codebase of java objects # $desuname - username for permanent storage of uploaded file # $dsetudom - domain for permanaent storage of uploaded file +# $thumbwidth - width (pixels) of thumbnail to make for uploaded image +# $thumbheight - height (pixels) of thumbnail to make for uploaded image # # output: url of file in userspace, or error: # or /adm/notfound.html if failure to upload occurse sub userfileupload { - my ($formname,$coursedoc,$subdir,$parser,$allfiles,$codebase,$destuname,$destudom)=@_; + my ($formname,$coursedoc,$subdir,$parser,$allfiles,$codebase,$destuname, + $destudom,$thumbwidth,$thumbheight)=@_; if (!defined($subdir)) { $subdir='unknown'; } my $fname=$env{'form.'.$formname.'.filename'}; $fname=&clean_filename($fname); @@ -1574,7 +1618,7 @@ sub userfileupload { if ($env{'form.folder'} =~ m/^(default|supplemental)/) { return &finishuserfileupload($docuname,$docudom, $formname,$fname,$parser,$allfiles, - $codebase); + $codebase,$thumbwidth,$thumbheight); } else { $fname=$env{'form.folder'}.'/'.$fname; return &process_coursefile('uploaddoc',$docuname,$docudom, @@ -1584,8 +1628,9 @@ sub userfileupload { } elsif (defined($destuname)) { my $docuname=$destuname; my $docudom=$destudom; - return &finishuserfileupload($docuname,$docudom,$formname, - $fname,$parser,$allfiles,$codebase); + return &finishuserfileupload($docuname,$docudom,$formname,$fname, + $parser,$allfiles,$codebase, + $thumbwidth,$thumbheight); } else { my $docuname=$env{'user.name'}; @@ -1594,16 +1639,18 @@ sub userfileupload { $docuname=$env{'course.'.$env{'request.course.id'}.'.num'}; $docudom=$env{'course.'.$env{'request.course.id'}.'.domain'}; } - return &finishuserfileupload($docuname,$docudom,$formname, - $fname,$parser,$allfiles,$codebase); + return &finishuserfileupload($docuname,$docudom,$formname,$fname, + $parser,$allfiles,$codebase, + $thumbwidth,$thumbheight); } } sub finishuserfileupload { - my ($docuname,$docudom,$formname,$fname,$parser,$allfiles,$codebase) = @_; + my ($docuname,$docudom,$formname,$fname,$parser,$allfiles,$codebase, + $thumbwidth,$thumbheight) = @_; my $path=$docudom.'/'.$docuname.'/'; my $filepath=$perlvar{'lonDocRoot'}; - my ($fnamepath,$file); + my ($fnamepath,$file,$fetchthumb); $file=$fname; if ($fname=~m|/|) { ($fnamepath,$file) = ($fname =~ m|^(.*)/([^/]+)$|); @@ -1639,12 +1686,28 @@ sub finishuserfileupload { ' for embedded media: '.$parse_result); } } + if (($thumbwidth =~ /^\d+$/) && ($thumbheight =~ /^\d+$/)) { + my $input = $filepath.'/'.$file; + my $output = $filepath.'/'.'tn-'.$file; + my $thumbsize = $thumbwidth.'x'.$thumbheight; + system("convert -sample $thumbsize $input $output"); + if (-e $filepath.'/'.'tn-'.$file) { + $fetchthumb = 1; + } + } # Notify homeserver to grep it # my $docuhome=&homeserver($docuname,$docudom); my $fetchresult= &reply('fetchuserfile:'.$path.$file,$docuhome); if ($fetchresult eq 'ok') { + if ($fetchthumb) { + my $thumbresult= &reply('fetchuserfile:'.$path.'tn-'.$file,$docuhome); + if ($thumbresult ne 'ok') { + &logthis('Failed to transfer '.$path.'tn-'.$file.' to host '. + $docuhome.': '.$thumbresult); + } + } # # Return the URL to it return '/uploaded/'.$path.$file; @@ -2087,7 +2150,12 @@ sub get_my_roles { my %returnhash=(); my $now=time; foreach my $entry (keys(%dumphash)) { - my ($tend,$tstart)=split(/\:/,$dumphash{$entry}); + my ($role,$tend,$tstart); + if ($context eq 'userroles') { + ($role,$tend,$tstart)=split(/_/,$dumphash{$entry}); + } else { + ($tend,$tstart)=split(/\:/,$dumphash{$entry}); + } if (($tstart) && ($tstart<0)) { next; } my $status = 'active'; if (($tend) && ($tend<$now)) { @@ -2105,7 +2173,13 @@ sub get_my_roles { next; } } - my ($role,$username,$domain,$section)=split(/\:/,$entry); + my ($rolecode,$username,$domain,$section,$area); + if ($context eq 'userroles') { + ($area,$rolecode) = split(/_/,$entry); + (undef,$domain,$username,$section) = split(/\//,$area); + } else { + ($role,$username,$domain,$section) = split(/\:/,$entry); + } if (ref($roledoms) eq 'ARRAY') { if (!grep(/^\Q$domain\E$/,@{$roledoms})) { next; @@ -2115,7 +2189,7 @@ sub get_my_roles { if (!grep(/^\Q$role\E$/,@{$roles})) { next; } - } + } $returnhash{$username.':'.$domain.':'.$role}=$tstart.':'.$tend; } return %returnhash; @@ -3540,9 +3614,16 @@ sub get_portfolio_access { } if (@users > 0) { foreach my $userkey (@users) { - if (exists($access_hash->{$userkey}{'users'}{$env{'user.name'}.':'.$env{'user.domain'}})) { - return 'ok'; - } + if (ref($access_hash->{$userkey}{'users'}) eq 'ARRAY') { + foreach my $item (@{$access_hash->{$userkey}{'users'}}) { + if (ref($item) eq 'HASH') { + if (($item->{'uname'} eq $env{'user.name'}) && + ($item->{'udom'} eq $env{'user.domain'})) { + return 'ok'; + } + } + } + } } } my %roleshash; @@ -4373,8 +4454,18 @@ sub userlog_query { sub auto_run { my ($cnum,$cdom) = @_; - my $homeserver = &homeserver($cnum,$cdom); - my $response = &reply('autorun:'.$cdom,$homeserver); + my $response = 0; + my $settings; + my %domconfig = &get_dom('configuration',['autoenroll'],$cdom); + if (ref($domconfig{'autoenroll'}) eq 'HASH') { + $settings = $domconfig{'autoenroll'}; + if ($settings->{'run'} eq '1') { + $response = 1; + } + } else { + my $homeserver = &homeserver($cnum,$cdom); + $response = &reply('autorun:'.$cdom,$homeserver); + } return $response; } @@ -4404,15 +4495,27 @@ sub auto_validate_courseID { } sub auto_create_password { - my ($cnum,$cdom,$authparam) = @_; - my $homeserver = &homeserver($cnum,$cdom); + my ($cnum,$cdom,$authparam,$udom) = @_; + my ($homeserver,$response); my $create_passwd = 0; my $authchk = ''; - my $response=&unescape(&reply('autocreatepassword:'.$authparam.':'.$cdom,$homeserver)); - if ($response eq 'refused') { - $authchk = 'refused'; + if ($udom =~ /^$match_domain$/) { + $homeserver = &domain($udom,'primary'); + } + if ($homeserver eq '') { + if (($cdom =~ /^$match_domain$/) && ($cnum =~ /^$match_courseid$/)) { + $homeserver = &homeserver($cnum,$cdom); + } + } + if ($homeserver eq '') { + $authchk = 'nodomain'; } else { - ($authparam,$create_passwd,$authchk) = split/:/,$response; + $response=&unescape(&reply('autocreatepassword:'.$authparam.':'.$cdom,$homeserver)); + if ($response eq 'refused') { + $authchk = 'refused'; + } else { + ($authparam,$create_passwd,$authchk) = split/:/,$response; + } } return ($authparam,$create_passwd,$authchk); } @@ -5217,7 +5320,7 @@ sub save_selected_files { my ($user, $path, @files) = @_; my $filename = $user."savedfiles"; my @other_files = &files_not_in_path($user, $path); - open (OUT, '>'.$Apache::lonnet::perlvar{'lonDaemons'}.'/tmp/'.$filename); + open (OUT, '>'.$tmpdir.$filename); foreach my $file (@files) { print (OUT $env{'form.currentpath'}.$file."\n"); } @@ -5809,6 +5912,13 @@ sub devalidatecourseresdata { # --------------------------------------------------- Course Resourcedata Query +# +# Parameters: +# $coursenum - Number of the course. +# $coursedomain - Domain at which the course was created. +# Returns: +# A hash of the course parameters along (I think) with timestamps +# and version info. sub get_courseresdata { my ($coursenum,$coursedomain)=@_; @@ -7585,47 +7695,60 @@ sub correct_line_ends { sub goodbye { &logthis("Starting Shut down"); #not converted to using infrastruture and probably shouldn't be - &logthis(sprintf("%-20s is %s",'%badServerCache',length(&freeze(\%badServerCache)))); + &logthis(sprintf("%-20s is %s",'%badServerCache',length(&nfreeze(\%badServerCache)))); #converted # &logthis(sprintf("%-20s is %s",'%metacache',scalar(%metacache))); - &logthis(sprintf("%-20s is %s",'%homecache',length(&freeze(\%homecache)))); -# &logthis(sprintf("%-20s is %s",'%titlecache',length(&freeze(\%titlecache)))); -# &logthis(sprintf("%-20s is %s",'%courseresdatacache',length(&freeze(\%courseresdatacache)))); + &logthis(sprintf("%-20s is %s",'%homecache',length(&nfreeze(\%homecache)))); +# &logthis(sprintf("%-20s is %s",'%titlecache',length(&nfreeze(\%titlecache)))); +# &logthis(sprintf("%-20s is %s",'%courseresdatacache',length(&nfreeze(\%courseresdatacache)))); #1.1 only -# &logthis(sprintf("%-20s is %s",'%userresdatacache',length(&freeze(\%userresdatacache)))); -# &logthis(sprintf("%-20s is %s",'%getsectioncache',length(&freeze(\%getsectioncache)))); -# &logthis(sprintf("%-20s is %s",'%courseresversioncache',length(&freeze(\%courseresversioncache)))); -# &logthis(sprintf("%-20s is %s",'%resversioncache',length(&freeze(\%resversioncache)))); - &logthis(sprintf("%-20s is %s",'%remembered',length(&freeze(\%remembered)))); +# &logthis(sprintf("%-20s is %s",'%userresdatacache',length(&nfreeze(\%userresdatacache)))); +# &logthis(sprintf("%-20s is %s",'%getsectioncache',length(&nfreeze(\%getsectioncache)))); +# &logthis(sprintf("%-20s is %s",'%courseresversioncache',length(&nfreeze(\%courseresversioncache)))); +# &logthis(sprintf("%-20s is %s",'%resversioncache',length(&nfreeze(\%resversioncache)))); + &logthis(sprintf("%-20s is %s",'%remembered',length(&nfreeze(\%remembered)))); &logthis(sprintf("%-20s is %s",'kicks',$kicks)); &logthis(sprintf("%-20s is %s",'hits',$hits)); &flushcourselogs(); &logthis("Shutting down"); } -BEGIN { - -# ----------------------------------- Read loncapa.conf and loncapa_apache.conf - unless ($readit) { -{ - my $configvars = LONCAPA::Configuration::read_conf('loncapa.conf'); - %perlvar = (%perlvar,%{$configvars}); -} - sub get_dns { - my ($url,$func) = @_; + my ($url,$func,$ignore_cache) = @_; + if (!$ignore_cache) { + my ($content,$cached)= + &Apache::lonnet::is_cached_new('dns',$url); + if ($cached) { + &$func($content); + return; + } + } + + my %alldns; open(my $config,"<$perlvar{'lonTabDir'}/hosts.tab"); foreach my $dns (<$config>) { next if ($dns !~ /^\^(\S*)/x); - $dns = $1; + $alldns{$1} = 1; + } + while (%alldns) { + my ($dns) = keys(%alldns); + delete($alldns{$dns}); my $ua=new LWP::UserAgent; my $request=new HTTP::Request('GET',"http://$dns$url"); my $response=$ua->request($request); next if ($response->is_error()); my @content = split("\n",$response->content); + &Apache::lonnet::do_cache_new('dns',$url,\@content,30*24*60*60); &$func(\@content); + return; } close($config); + my $which = (split('/',$url))[3]; + &logthis("unable to contact DNS defaulting to on disk file dns_$which.tab\n"); + open($config,"<$perlvar{'lonTabDir'}/dns_$which.tab"); + my @content = <$config>; + &$func(\@content); + return; } # ------------------------------------------------------------ Read domain file { @@ -7646,12 +7769,17 @@ sub get_dns { $this_domain{$field} = shift(@elements); } $domain{$name} = \%this_domain; - &logthis("Domain.tab: $name ".$domain{$name}{'description'} ); } } - + + sub reset_domain_info { + undef($loaded); + undef(%domain); + } + sub load_domain_tab { - &get_dns('/adm/dns/domain',\&parse_domain_tab); + my ($ignore_cache) = @_; + &get_dns('/adm/dns/domain',\&parse_domain_tab,$ignore_cache); my $fh; if (open($fh,"<".$perlvar{'lonTabDir'}.'/domain.tab')) { my @lines = <$fh>; @@ -7695,12 +7823,21 @@ sub get_dns { $hostdom{$id}=$domain; if ($role eq 'library') { $libserv{$id}=$name; } } - &logthis("Hosts.tab: $name ".$id ); } } + + sub reset_hosts_info { + &reset_domain_info(); + &reset_hosts_ip_info(); + undef(%hostname); + undef(%hostdom); + undef(%libserv); + undef($loaded); + } sub load_hosts_tab { - &get_dns('/adm/dns/hosts',\&parse_hosts_tab); + my ($ignore_cache) = @_; + &get_dns('/adm/dns/hosts',\&parse_hosts_tab,$ignore_cache); open(my $config,"<$perlvar{'lonTabDir'}/hosts.tab"); my @config = <$config>; &parse_hosts_tab(\@config); @@ -7708,9 +7845,6 @@ sub get_dns { $loaded=1; } - # FIXME: dev server don't want this, production servers _do_ want this - #&get_iphost(); - sub hostname { &load_hosts_tab() if (!$loaded); @@ -7779,6 +7913,25 @@ sub get_dns { my %iphost; my %name_to_ip; my %lonid_to_ip; + + my %valid_ip; + sub valid_ip { + my ($ip) = @_; + if (exists($iphost{$ip}) || exists($valid_ip{$ip})) { + return 1; + } + my $name = gethostbyip($ip); + my $lonid = &hostname($name); + if (defined($lonid)) { + $valid_ip{$ip} = $lonid; + return 1; + } + my %iphosts = &get_iphost(); + if (ref($iphost{$ip})) { + return 1; + } + } + sub get_hosts_from_ip { my ($ip) = @_; my %iphosts = &get_iphost(); @@ -7787,6 +7940,12 @@ sub get_dns { } return; } + + sub reset_hosts_ip_info { + undef(%iphost); + undef(%name_to_ip); + undef(%lonid_to_ip); + } sub get_host_ip { my ($lonid) = @_; @@ -7803,10 +7962,23 @@ sub get_dns { } sub get_iphost { - if (%iphost) { return %iphost; } + my ($ignore_cache) = @_; + if (!$ignore_cache) { + if (%iphost) { + return %iphost; + } + my ($ip_info,$cached)= + &Apache::lonnet::is_cached_new('iphost','iphost'); + if ($cached) { + %iphost = %{$ip_info->[0]}; + %name_to_ip = %{$ip_info->[1]}; + %lonid_to_ip = %{$ip_info->[2]}; + return %iphost; + } + } my %hostname = &all_hostnames(); foreach my $id (keys(%hostname)) { - my $name=$hostname{$id}; + my $name=&hostname($id); my $ip; if (!exists($name_to_ip{$name})) { $ip = gethostbyname($name); @@ -7822,10 +7994,24 @@ sub get_dns { $lonid_to_ip{$id} = $ip; push(@{$iphost{$ip}},$id); } + &Apache::lonnet::do_cache_new('iphost','iphost', + [\%iphost,\%name_to_ip,\%lonid_to_ip], + 24*60*60); + return %iphost; } } +BEGIN { + +# ----------------------------------- Read loncapa.conf and loncapa_apache.conf + unless ($readit) { +{ + my $configvars = LONCAPA::Configuration::read_conf('loncapa.conf'); + %perlvar = (%perlvar,%{$configvars}); +} + + # ------------------------------------------------------ Read spare server file { open(my $config,"<$perlvar{'lonTabDir'}/spare.tab"); @@ -8159,7 +8345,13 @@ passed in @what from the requested user' =item * X -B: retrieves data from a user's activity.log file. %filters defines filters applied when parsing the log file. These can be start or end timestamps, or the type of action - log to look for Login or Logout events, check for Checkin or Checkout, role for role selection. The response is in the form timestamp1:hostid1:event1×tamp2:hostid2:event2 where events are escaped strings of the action recorded in the activity.log file. +B: retrieves data from a user's +activity.log file. %filters defines filters applied when parsing the +log file. These can be start or end timestamps, or the type of action +- log to look for Login or Logout events, check for Checkin or +Checkout, role for role selection. The response is in the form +timestamp1:hostid1:event1×tamp2:hostid2:event2 where events are +escaped strings of the action recorded in the activity.log file. =back @@ -8345,6 +8537,14 @@ setting for a specific $type, where $typ @what should be a list of parameters to ask about. This routine caches answers for 5 minutes. +=item * + +get_courseresdata($courseid, $domain) : dump the entire course resource +data base, returning a hash that is keyed by the resource name and has +values that are the resource value. I believe that the timestamps and +versions are also returned. + + =back =head2 Course Modification @@ -8626,12 +8826,15 @@ critical subroutine =item * -get_dom($namespace,$storearr,$udomain) : returns hash with keys from array -reference filled in from namespace found in domain level on primary domain server ($udomain is optional) +get_dom($namespace,$storearr,$udom,$uhome) : returns hash with keys from +array reference filled in from namespace found in domain level on either +specified domain server ($uhome) or primary domain server ($udom and $uhome are optional). =item * -put_dom($namespace,$storehash,$udomain) : stores hash in namespace at domain level on primary domain server ($udomain is optional) +put_dom($namespace,$storehash,$udom,$uhome) : stores hash in namespace at +domain level either on specified domain server ($uhome) or primary domain +server ($udom and $uhome are optional) =back @@ -9024,3 +9227,4 @@ symblist($mapname,%newhash) : update sym =back =cut +