--- loncom/lonnet/perl/lonnet.pm 2008/12/08 23:00:47 1.976 +++ loncom/lonnet/perl/lonnet.pm 2009/02/10 11:15:16 1.986 @@ -1,7 +1,7 @@ # The LearningOnline Network # TCP networking package # -# $Id: lonnet.pm,v 1.976 2008/12/08 23:00:47 raeburn Exp $ +# $Id: lonnet.pm,v 1.986 2009/02/10 11:15:16 foxr Exp $ # # Copyright Michigan State University Board of Trustees # @@ -73,6 +73,9 @@ package Apache::lonnet; use strict; use LWP::UserAgent(); use HTTP::Date; +use Image::Magick; +use IO::Socket; + # use Date::Parse; use vars qw(%perlvar %spareid %pr %prp $memcache %packagetab $tmpdir $_64bit %env %protocol); @@ -97,6 +100,8 @@ 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); @@ -146,7 +151,8 @@ sub logthis { my $now=time; my $local=localtime($now); if (open(my $fh,">>$execdir/logs/lonnet.log")) { - print $fh "$local ($$): $message\n"; + my $logstring = $local. " ($$): ".$message."\n"; # Keep any \'s in string. + print $fh $logstring; close($fh); } return 1; @@ -177,6 +183,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 { @@ -521,7 +541,7 @@ 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/) { + if ($key=~/^\Q$delthis\E/) { delete($env{$key}); delete($disk_env{$key}); } @@ -1227,7 +1247,6 @@ sub inst_userrules { sub get_domain_defaults { my ($domain) = @_; my $cachetime = 60*60*24; - my ($defauthtype,$defautharg,$deflang,%deftools); my ($result,$cached)=&is_cached_new('domdefaults',$domain); if (defined($cached)) { if (ref($result) eq 'HASH') { @@ -1241,6 +1260,8 @@ sub get_domain_defaults { $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'); @@ -1259,6 +1280,11 @@ sub get_domain_defaults { } } } + if (ref($domconfig{'requestcourses'}) eq 'HASH') { + foreach my $item ('official','unofficial') { + $domdefaults{$item} = $domconfig{'requestcourses'}{$item}; + } + } &Apache::lonnet::do_cache_new('domdefaults',$domain,\%domdefaults, $cachetime); return %domdefaults; @@ -1787,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); @@ -2010,6 +2036,32 @@ sub clean_filename { $fname=~s/\.(\d+)(?=\.)/_$1/g; return $fname; } +#This Function check if a Image max 400px width and height 500px. If not then scale the image down +sub resizeImage { + my($img_url) = @_; + my $ima = Image::Magick->new; + $ima->Read($img_url); + if($ima->Get('width') > 400) + { + my $factor = $ima->Get('width')/400; + $ima->Scale( width=>400, height=>$ima->Get('height')/$factor ); + } + if($ima->Get('height') > 500) + { + my $factor = $ima->Get('height')/500; + $ima->Scale( width=>$ima->Get('width')/$factor, height=>500); + } + + $ima->Write($img_url); +} + +#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"} @@ -2110,6 +2162,7 @@ sub finishuserfileupload { $thumbwidth,$thumbheight) = @_; my $path=$docudom.'/'.$docuname.'/'; my $filepath=$perlvar{'lonDocRoot'}; + my ($fnamepath,$file,$fetchthumb); $file=$fname; if ($fname=~m|/|) { @@ -2124,6 +2177,7 @@ sub finishuserfileupload { mkdir($filepath,0777); } } + # Save the file { if (!open(FH,'>'.$filepath.'/'.$file)) { @@ -2137,6 +2191,11 @@ sub finishuserfileupload { return '/adm/notfound.html'; } close(FH); + if($upload_photo_form==1) + { + resizeImage($filepath.'/'.$file); + $upload_photo_form = 0; + } } if ($parser eq 'parse') { my $parse_result = &extract_embedded_items($filepath.'/'.$file,$allfiles, @@ -2158,7 +2217,7 @@ sub finishuserfileupload { # Notify homeserver to grep it # - my $docuhome=&homeserver($docuname,$docudom); + my $docuhome=&homeserver($docuname,$docudom); my $fetchresult= &reply('fetchuserfile:'.$path.$file,$docuhome); if ($fetchresult eq 'ok') { if ($fetchthumb) { @@ -2290,21 +2349,21 @@ sub add_filetype { } sub removeuploadedurl { - my ($url)=@_; - my (undef,undef,$udom,$uname,$fname)=split('/',$url,5); + my ($url)=@_; + my (undef,undef,$udom,$uname,$fname)=split('/',$url,5); return &removeuserfile($uname,$udom,$fname); } sub removeuserfile { my ($docuname,$docudom,$fname)=@_; - my $home=&homeserver($docuname,$docudom); + my $home=&homeserver($docuname,$docudom); my $result = &reply("removeuserfile:$docudom/$docuname/$fname",$home); - if ($result eq 'ok') { + if ($result eq 'ok') { if (($fname !~ /\.meta$/) && (&is_portfolio_file($fname))) { my $metafile = $fname.'.meta'; my $metaresult = &removeuserfile($docuname,$docudom,$metafile); my $url = "/uploaded/$docudom/$docuname/$fname"; - my ($file,$group) = (&parse_portfolio_url($url))[3,4]; + my ($file,$group) = (&parse_portfolio_url($url))[3,4]; my $sqlresult = &update_portfolio_table($docuname,$docudom,$file, 'portfolio_metadata',$group, @@ -3810,11 +3869,11 @@ sub del { foreach my $item (@$storearr) { $items.=&escape($item).'&'; } + $items=~s/\&$//; if (!$udomain) { $udomain=$env{'user.domain'}; } if (!$uname) { $uname=$env{'user.name'}; } my $uhome=&homeserver($uname,$udomain); - return &reply("del:$udomain:$uname:$namespace:$items",$uhome); } @@ -4375,13 +4434,23 @@ sub is_portfolio_file { } sub usertools_access { - my ($uname,$udom,$tool) = @_; - my $access; - my %tools = ( - aboutme => 1, - blog => 1, - portfolio => 1, - ); + my ($uname,$udom,$tool,$action,$context) = @_; + my ($access,%tools); + if ($context eq '') { + $context = 'tools'; + } + if ($context eq 'requestcourses') { + %tools = ( + official => 1, + unofficial => 1, + ); + } else { + %tools = ( + aboutme => 1, + blog => 1, + portfolio => 1, + ); + } return if (!defined($tools{$tool})); if ((!defined($udom)) || (!defined($uname))) { @@ -4389,20 +4458,25 @@ sub usertools_access { $uname = $env{'user.name'}; } - my $hashid=$uname.':'.$udom; - my ($result,$cached) = &is_cached_new('usertools.'.$tool,$hashid); - if (defined($cached)) { - return $result; + if (($udom eq $env{'user.domain'}) && ($uname eq $env{'user.name'})) { + if ($action ne 'reload') { + if ($context eq 'requestcourses') { + return $env{'environment.canrequest.'.$tool}; + } else { + return $env{'environment.availabletools.'.$tool}; + } + } } my ($toolstatus,$inststatus); - if (($udom eq $env{'user.domain'}) && ($uname eq $env{'user.name'})) { - $toolstatus = $env{'environment.tools.'.$tool}; + if (($udom eq $env{'user.domain'}) && ($uname eq $env{'user.name'}) && + ($action ne 'reload')) { + $toolstatus = $env{'environment.'.$context.'.'.$tool}; $inststatus = $env{'environment.inststatus'}; } else { - my %userenv = &userenvironment($udom,$uname,'tools.'.$tool); - $toolstatus = $userenv{'tools.'.$tool}; + my %userenv = &userenvironment($udom,$uname,$context.'.'.$tool); + $toolstatus = $userenv{$context.'.'.$tool}; $inststatus = $userenv{'inststatus'}; } @@ -4412,7 +4486,6 @@ sub usertools_access { } else { $access = 0; } - &do_cache_new('usertools.'.$tool,$hashid,$access,600); return $access; } @@ -4426,7 +4499,6 @@ sub usertools_access { } else { $access = 0; } - &do_cache_new('usertools.'.$tool,$hashid,$access,600); return $access; } } @@ -4447,7 +4519,6 @@ sub usertools_access { } elsif ($hasnoaccess) { $access = 0; } - &do_cache_new('usertools.'.$tool,$hashid,$access,600); return $access; } } else { @@ -4457,13 +4528,15 @@ sub usertools_access { } elsif ($domdef{$tool}{'default'} == 0) { $access = 0; } - &do_cache_new('usertools.'.$tool,$hashid,$access,600); return $access; } } } else { - $access = 1; - &do_cache_new('usertools.'.$tool,$hashid,$access,600); + if ($context eq 'tools') { + $access = 1; + } else { + $access = 0; + } return $access; } } @@ -8306,7 +8379,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()) { @@ -8321,7 +8397,7 @@ sub repcopy_userfile { sub tokenwrapper { my $uri=shift; - $uri=~s|^http\://([^/]+)||; + $uri=~s|^https?\://([^/]+)||; $uri=~s|^/||; $env{'user.environment'}=~/\/([^\/]+)\.id/; my $token=$1; @@ -8329,7 +8405,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 { @@ -8344,7 +8423,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); @@ -8426,7 +8508,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/-/-; @@ -8622,14 +8704,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); @@ -8925,6 +9012,23 @@ sub get_dns { } } +# +# Given a DNS returns the loncapa host name for that DNS +# +sub host_from_dns { + my ($dns) = @_; + my @hosts; + my $ip; + + $ip = gethostbyname($dns); # Initial translation to IP is in net order. + if (length($ip) == 4) { + $ip = &IO::Socket::inet_ntoa($ip); + @hosts = get_hosts_from_ip($ip); + return $hosts[0]; + } + return undef; +} + BEGIN { # ----------------------------------- Read loncapa.conf and loncapa_apache.conf @@ -9814,8 +9918,15 @@ dirlist($uri) : return directory list ba spareserver() : find server with least workload from spare.tab + +=item * + +host_from_dns($dns) : Returns the loncapa hostname corresponding to a DNS name or undef +if there is no corresponding loncapa host. + =back + =head2 Apache Request =over 4