--- loncom/lonnet/perl/lonnet.pm 2004/06/29 14:56:32 1.516 +++ loncom/lonnet/perl/lonnet.pm 2004/08/25 16:03:17 1.532 @@ -1,7 +1,7 @@ # The LearningOnline Network # TCP networking package # -# $Id: lonnet.pm,v 1.516 2004/06/29 14:56:32 raeburn Exp $ +# $Id: lonnet.pm,v 1.532 2004/08/25 16:03:17 albertel Exp $ # # Copyright Michigan State University Board of Trustees # @@ -1047,6 +1047,7 @@ sub currentversion { sub subscribe { my $fname=shift; if ($fname=~/\/(aboutme|syllabus|bulletinboard|smppg)$/) { return ''; } + $fname=~s/[\n\r]//g; my $author=$fname; $author=~s/\/home\/httpd\/html\/res\/([^\/]*)\/([^\/]*).*/$1\/$2/; my ($udom,$uname)=split(/\//,$author); @@ -1067,6 +1068,7 @@ sub repcopy { my $filename=shift; $filename=~s/\/+/\//g; if ($filename=~/^\/home\/httpd\/html\/adm\//) { return OK; } + $filename=~s/[\n\r]//g; my $transname="$filename.in.transfer"; if ((-e $filename) || (-e $transname)) { return OK; } my $remoteurl=subscribe($filename); @@ -1131,10 +1133,10 @@ sub ssi_body { my ($filelink,%form)=@_; my $output=($filelink=~/^http\:/?&externalssi($filelink): &ssi($filelink,%form)); - $output=~s/^.*?\]*\>//si; - $output=~s/(.*)\<\/body\s*\>.*?$/$1/si; $output=~ s/\/\/ BEGIN LON\-CAPA Internal.+\/\/ END LON\-CAPA Internal\s//gs; + $output=~s/^.*?\]*\>//si; + $output=~s/(.*)\<\/body\s*\>.*?$/$1/si; return $output; } @@ -1267,10 +1269,8 @@ sub process_coursefile { # input: name of form element, coursedoc=1 means this is for the course # output: url of file in userspace -sub userfileupload { - my ($formname,$coursedoc,$subdir)=@_; - if (!defined($subdir)) { $subdir='unknown'; } - my $fname=$ENV{'form.'.$formname.'.filename'}; +sub clean_filename { + my ($fname)=@_; # Replace Windows backslashes by forward slashes $fname=~s/\\/\//g; # Get rid of everything but the actual filename @@ -1279,9 +1279,33 @@ sub userfileupload { $fname=~s/\s+/\_/g; # Replace all other weird characters by nothing $fname=~s/[^\w\.\-]//g; + return $fname; +} + +sub userfileupload { + my ($formname,$coursedoc,$subdir)=@_; + if (!defined($subdir)) { $subdir='unknown'; } + my $fname=$ENV{'form.'.$formname.'.filename'}; + $fname=&clean_filename($fname); # See if there is anything left unless ($fname) { return 'error: no uploaded file'; } chop($ENV{'form.'.$formname}); + if (($formname eq 'screenshot') && ($subdir eq 'helprequests')) { #files uploaded to help request form are handled differently + my $now = time; + my $filepath = 'tmp/helprequests/'.$now; + my @parts=split(/\//,$filepath); + my $fullpath = $perlvar{'lonDaemons'}; + for (my $i=0;$i<@parts;$i++) { + $fullpath .= '/'.$parts[$i]; + if ((-e $fullpath)!=1) { + mkdir($fullpath,0777); + } + } + open(my $fh,'>'.$fullpath.'/'.$fname); + print $fh $ENV{'form.'.$formname}; + close($fh); + return $fullpath.'/'.$fname; + } # Create the directory if not present my $docuname=''; my $docudom=''; @@ -1356,6 +1380,19 @@ sub removeuserfile { return &reply("removeuserfile:$docudom/$docuname/$fname",$home); } +sub mkdiruserfile { + my ($docuname,$docudom,$dir)=@_; + my $home=&homeserver($docuname,$docudom); + return &reply("mkdiruserfile:".&escape("$docudom/$docuname/$dir"),$home); +} + +sub renameuserfile { + my ($docuname,$docudom,$old,$new)=@_; + my $home=&homeserver($docuname,$docudom); + return &reply("renameuserfile:$docudom:$docuname:".&escape("$old").':'. + &escape("$new"),$home); +} + # ------------------------------------------------------------------------- Log sub log { @@ -1600,7 +1637,7 @@ sub getannounce { if ($announcement=~/\w/) { return ''. - '
'.$announcement.'
'; + ''.$announcement.''; } else { return ''; } @@ -2575,6 +2612,30 @@ sub put { return &reply("put:$udomain:$uname:$namespace:$items",$uhome); } +# ---------------------------------------------------------- putstore interface + +sub putstore { + my ($namespace,$storehash,$udomain,$uname)=@_; + if (!$udomain) { $udomain=$ENV{'user.domain'}; } + if (!$uname) { $uname=$ENV{'user.name'}; } + my $uhome=&homeserver($uname,$udomain); + my $items=''; + my %allitems = (); + foreach (keys %$storehash) { + if ($_ =~ m/^([^\:]+):([^\:]+):([^\:]+)$/) { + my $key = $1.':keys:'.$2; + $allitems{$key} .= $3.':'; + } + $items.=$_.'='.&escape($$storehash{$_}).'&'; + } + foreach (keys %allitems) { + $allitems{$_} =~ s/\:$//; + $items.= $_.'='.$allitems{$_}.'&'; + } + $items=~s/\&$//; + return &reply("put:$udomain:$uname:$namespace:$items",$uhome); +} + # ------------------------------------------------------ critical put interface sub cput { @@ -2657,8 +2718,8 @@ sub allowed { if (defined($ENV{'allowed.'.$priv})) { return $ENV{'allowed.'.$priv}; } # Free bre access to adm and meta resources - - if ((($uri=~/^adm\//) || ($uri=~/\.meta$/)) && ($priv eq 'bre')) { + if (((($uri=~/^adm\//) && ($uri !~ m|/bulletinboard$|)) + || ($uri=~/\.meta$/)) && ($priv eq 'bre')) { return 'F'; } @@ -3077,9 +3138,14 @@ sub fetch_enrollment_query { $cmd = &escape($cmd); my $query = 'fetchenrollment'; my $queryid=&reply("querysend:".$query.':'.$dom.':'.$ENV{'user.name'}.':'.$cmd,$homeserver); - unless ($queryid=~/^\Q$host\E\_/) { return 'error: '.$queryid; } + unless ($queryid=~/^\Q$host\E\_/) { + &logthis('fetch_enrollment_query: invalid queryid: '.$queryid.' for host: '.$host.' and homeserver: '.$homeserver.' context: '.$context.' '.$cnum); + return 'error: '.$queryid; + } my $reply = &get_query_reply($queryid); - unless ( ($reply =~/^timeout/) || ($reply =~/^error/) ) { + if ( ($reply =~/^timeout/) || ($reply =~/^error/) ) { + &logthis('fetch_enrollment_query error: '.$reply.' for '.$dom.' '.$ENV{'user.name'}.' for '.$queryid.' context: '.$context.' '.$cnum); + } else { my @responses = split/:/,$reply; if ($homeserver eq $perlvar{'lonHostID'}) { foreach (@responses) { @@ -3096,10 +3162,14 @@ sub fetch_enrollment_query { my $filename = $dom.'_'.$key.'_'.$_.'_classlist.xml'; my $destname = $pathname.'/'.$filename; my $xml_classlist = &reply("autoretrieve:".$filename,$homeserver); - unless ($xml_classlist =~ /^error/) { + if ($xml_classlist =~ /^error/) { + &logthis('fetch_enrollment_query - autoretrieve error: '.$xml_classlist.' for '.$filename.' from server: '.$homeserver.' '.$context.' '.$cnum); + } else { if ( open(FILE,">$destname") ) { print FILE &unescape($xml_classlist); close(FILE); + } else { + &logthis('fetch_enrollment_query - error opening classlist file '.$destname.' '.$context.' '.$cnum); } } } @@ -3203,6 +3273,32 @@ sub auto_create_password { return ($authparam,$create_passwd,$authchk); } +sub auto_instcode_format { + my ($caller,$codedom,$instcodes,$codes,$codetitles,$cat_titles,$cat_order) = @_; + my $courses = ''; + my $homeserver; + if ($caller eq 'global') { + $homeserver = $perlvar{'lonHostID'}; + } else { + $homeserver = &homeserver($caller,$codedom); + } + my $host=$hostname{$homeserver}; + foreach (keys %{$instcodes}) { + $courses .= &escape($_).'='.&escape($$instcodes{$_}).'&'; + } + chop($courses); + my $response=&reply('autoinstcodeformat:'.$codedom.':'.$courses,$homeserver); + unless ($response =~ /(con_lost|error|no_such_host|refused)/) { + my ($codes_str,$codetitles_str,$cat_titles_str,$cat_order_str) = split/:/,$response; + %{$codes} = &str2hash($codes_str); + @{$codetitles} = &str2array($codetitles_str); + %{$cat_titles} = &str2hash($cat_titles_str); + %{$cat_order} = &str2hash($cat_order_str); + return 'ok'; + } + return $response; +} + # ------------------------------------------------------------------ Plain Text sub plaintext { @@ -3585,16 +3681,19 @@ sub revokecustomrole { # ------------------------------------------------------------ Portfolio Director Lister +# returns listing of contents of user's /userfiles/portfolio/ directory +# + sub portfoliolist { -#FIXME us the ls: command instead please -#FIXME uhome should never be an argument to any lonnet functions - # returns listing of contents of user's /userfiles/portfolio/ directory - # - my ($udom,$uname,$uhome); + my ($currentPath, $currentFile) = @_; + my ($udom, $uname, $portfolioRoot); $uname=$ENV{'user.name'}; $udom=$ENV{'user.domain'}; - $uhome=$ENV{'user.home'}; - my $listing = &reply('portls:'.$uname.':'.$udom, $uhome); + # really should interrogate the system for home directory information, but . . . + $portfolioRoot = '/home/httpd/lonUsers/'.$udom.'/'; + $uname =~ /^(.?)(.?)(.?)/; + $portfolioRoot = $portfolioRoot.$1.'/'.$2.'/'.$3.'/'.$uname.'/userfiles/portfolio'; + my $listing = &reply('ls:'.$portfolioRoot.$currentPath, &homeserver($uname,$udom)); return $listing; } @@ -4119,7 +4218,9 @@ sub metadata { my ($uri,$what,$liburi,$prefix,$depthcount)=@_; $uri=&declutter($uri); # if it is a non metadata possible uri return quickly - if (($uri eq '') || (($uri =~ m|^/*adm/|) && ($uri !~ m|^adm/includes|)) || + if (($uri eq '') || + (($uri =~ m|^/*adm/|) && + ($uri !~ m|^adm/includes|) && ($uri !~ m|/bulletinboard$|)) || ($uri =~ m|/$|) || ($uri =~ m|/.meta$|) || ($uri =~ /^~/) || ($uri =~ m|home/[^/]+/public_html/|)) { return undef; @@ -4879,6 +4980,14 @@ sub getfile { if ($rtncode eq '404') { unlink($localfile); } + #my $ua=new LWP::UserAgent; + #my $request=new HTTP::Request('GET',&tokenwrapper($file)); + #my $response=$ua->request($request); + #if ($response->is_success()) { + # return $response->content; + # } else { + # return -1; + # } return -1; } if ($info < $fileinfo[9]) { @@ -4892,12 +5001,19 @@ sub getfile { } else { $lwpresp = &getuploaded('GET',$file,$cdom,$cnum,\$info,\$rtncode); if ($lwpresp ne 'ok') { - return -1; + my $ua=new LWP::UserAgent; + my $request=new HTTP::Request('GET',&tokenwrapper($file)); + my $response=$ua->request($request); + if ($response->is_success()) { + return $response->content; + } else { + return -1; + } } my @parts = ($cdom,$cnum); if ($filename =~ m|^(.+)/[^/]+$|) { push @parts, split(/\//,$1); - } + } foreach my $part (@parts) { $path .= '/'.$part; if (!-e $path) { @@ -4914,6 +5030,22 @@ sub getfile { return $info; } +sub tokenwrapper { + my $uri=shift; + $uri=~s/^http\:\/\/([^\/]+)//; + $uri=~s/^\///; + $ENV{'user.environment'}=~/\/([^\/]+)\.id/; + my $token=$1; + if ($uri=~/^uploaded\/([^\/]+)\/([^\/]+)\/([^\/]+)(\?\.*)*$/) { + &appenv('userfile.'.$1.'/'.$2.'/'.$3 => $ENV{'request.course.id'}); + return 'http://'.$hostname{ &homeserver($2,$1)}.'/'.$uri. + (($uri=~/\?/)?'&':'?').'token='.$token. + '&tokenissued='.$perlvar{'lonHostID'}; + } else { + return '/adm/notfound.html'; + } +} + sub getuploaded { my ($reqtype,$uri,$cdom,$cnum,$info,$rtncode) = @_; $uri=~s/^\///; @@ -4951,7 +5083,21 @@ sub filelocation { $location = $file; $location =~ s:/~(.*?)/(.*):/home/$1/public_html/$2:; } elsif ($file=~/^\/*uploaded/) { # is an uploaded file - $location=$file; + if ($file=~/^\/uploaded\/([^\/]+)\/([^\/]+)\/(\/)?simplepage\/([^\/]+)$/) { + $location=&Apache::loncommon::propath($1,$2).'/userfiles/simplepage/'.$4; + if (not -e $location) { + $file=~/^\/uploaded\/(.*)$/; + $location=$Apache::lonnet::perlvar{'lonDocRoot'}.'/userfiles/'.$1; + } + } elsif ($file=~/^\/uploaded\/([^\/]+)\/([^\/]+)\/aboutme\/([^\/]+)$/) { + $location=&Apache::loncommon::propath($1,$2).'/userfiles/aboutme/'.$3; + if (not -e $location) { + $file=~/^\/uploaded\/(.*)$/; + $location=$Apache::lonnet::perlvar{'lonDocRoot'}.'/userfiles/'.$1; + } + } else { + $location=$file; + } } else { $file=~s/^\Q$perlvar{'lonDocRoot'}\E//; $file=~s:^/res/:/:; @@ -5842,6 +5988,17 @@ put($namespace,$storehash,$udom,$uname) =item * +putstore($namespace,$storehash,$udomain,$uname) : stores hash in namesp +keys used in storehash include version information (e.g., 1:$symb:message etc.) as +used in records written by &store and retrieved by &restore. This function +was created for use in editing discussion posts, without incrementing the +version number included in the key for a particular post. The colon +separated list of attribute names (e.g., the value associated with the key +1:keys:$symb) is also generated and passed in the ampersand separated +items sent to lonnet::reply(). + +=item * + cput($namespace,$storehash,$udom,$uname) : critical put ($udom and $uname are optional)