Annotation of loncom/lonnet/perl/lonnet.pm, revision 1.833
1.1 albertel 1: # The LearningOnline Network
2: # TCP networking package
1.12 www 3: #
1.833 ! albertel 4: # $Id: lonnet.pm,v 1.832 2007/02/16 01:04:19 raeburn Exp $
1.178 www 5: #
6: # Copyright Michigan State University Board of Trustees
7: #
8: # This file is part of the LearningOnline Network with CAPA (LON-CAPA).
9: #
10: # LON-CAPA is free software; you can redistribute it and/or modify
11: # it under the terms of the GNU General Public License as published by
12: # the Free Software Foundation; either version 2 of the License, or
13: # (at your option) any later version.
14: #
15: # LON-CAPA is distributed in the hope that it will be useful,
16: # but WITHOUT ANY WARRANTY; without even the implied warranty of
17: # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
18: # GNU General Public License for more details.
19: #
20: # You should have received a copy of the GNU General Public License
21: # along with LON-CAPA; if not, write to the Free Software
22: # Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
23: #
24: # /home/httpd/html/adm/gpl.txt
25: #
26: # http://www.lon-capa.org/
27: #
1.169 harris41 28: ###
29:
1.1 albertel 30: package Apache::lonnet;
31:
32: use strict;
1.8 www 33: use LWP::UserAgent();
1.15 www 34: use HTTP::Headers;
1.486 www 35: use HTTP::Date;
36: # use Date::Parse;
1.11 www 37: use vars
1.599 albertel 38: qw(%perlvar %hostname %badServerCache %iphost %spareid %hostdom
39: %libserv %pr %prp $memcache %packagetab
1.662 raeburn 40: %courselogs %accesshash %userrolehash %domainrolehash $processmarker $dumpcount
1.741 raeburn 41: %coursedombuf %coursenumbuf %coursehombuf %coursedescrbuf %courseinstcodebuf %courseownerbuf %coursetypebuf
1.599 albertel 42: %domaindescription %domain_auth_def %domain_auth_arg_def
1.685 raeburn 43: %domain_lang_def %domain_city %domain_longi %domain_lati %domain_primary
44: $tmpdir $_64bit %env);
1.403 www 45:
1.1 albertel 46: use IO::Socket;
1.31 www 47: use GDBM_File;
1.208 albertel 48: use HTML::LCParser;
1.637 raeburn 49: use HTML::Parser;
1.88 www 50: use Fcntl qw(:flock);
1.557 albertel 51: use Storable qw(lock_store lock_nstore lock_retrieve freeze thaw nfreeze);
1.539 albertel 52: use Time::HiRes qw( gettimeofday tv_interval );
1.599 albertel 53: use Cache::Memcached;
1.676 albertel 54: use Digest::MD5;
1.790 albertel 55: use Math::Random;
1.807 albertel 56: use LONCAPA qw(:DEFAULT :match);
1.740 www 57: use LONCAPA::Configuration;
1.676 albertel 58:
1.195 www 59: my $readit;
1.550 foxr 60: my $max_connection_retries = 10; # Or some such value.
1.1 albertel 61:
1.619 albertel 62: require Exporter;
63:
64: our @ISA = qw (Exporter);
65: our @EXPORT = qw(%env);
66:
1.449 matthew 67: =pod
68:
69: =head1 Package Variables
70:
71: These are largely undocumented, so if you decipher one please note it here.
72:
73: =over 4
74:
75: =item $processmarker
76:
77: Contains the time this process was started and this servers host id.
78:
79: =item $dumpcount
80:
81: Counts the number of times a message log flush has been attempted (regardless
82: of success) by this process. Used as part of the filename when messages are
83: delayed.
84:
85: =back
86:
87: =cut
88:
89:
1.1 albertel 90: # --------------------------------------------------------------------- Logging
1.729 www 91: {
92: my $logid;
93: sub instructor_log {
94: my ($hash_name,$storehash,$delflag,$uname,$udom)=@_;
95: $logid++;
96: my $id=time().'00000'.$$.'00000'.$logid;
97: return &Apache::lonnet::put('nohist_'.$hash_name,
1.730 www 98: { $id => {
99: 'exe_uname' => $env{'user.name'},
100: 'exe_udom' => $env{'user.domain'},
101: 'exe_time' => time(),
102: 'exe_ip' => $ENV{'REMOTE_ADDR'},
103: 'delflag' => $delflag,
104: 'logentry' => $storehash,
105: 'uname' => $uname,
106: 'udom' => $udom,
107: }
108: },
1.729 www 109: $env{'course.'.$env{'request.course.id'}.'.domain'},
110: $env{'course.'.$env{'request.course.id'}.'.num'}
111: );
112: }
113: }
1.1 albertel 114:
1.163 harris41 115: sub logtouch {
116: my $execdir=$perlvar{'lonDaemons'};
1.448 albertel 117: unless (-e "$execdir/logs/lonnet.log") {
118: open(my $fh,">>$execdir/logs/lonnet.log");
1.163 harris41 119: close $fh;
120: }
121: my ($wwwuid,$wwwgid)=(getpwnam('www'))[2,3];
122: chown($wwwuid,$wwwgid,$execdir.'/logs/lonnet.log');
123: }
124:
1.1 albertel 125: sub logthis {
126: my $message=shift;
127: my $execdir=$perlvar{'lonDaemons'};
128: my $now=time;
129: my $local=localtime($now);
1.448 albertel 130: if (open(my $fh,">>$execdir/logs/lonnet.log")) {
131: print $fh "$local ($$): $message\n";
132: close($fh);
133: }
1.1 albertel 134: return 1;
135: }
136:
137: sub logperm {
138: my $message=shift;
139: my $execdir=$perlvar{'lonDaemons'};
140: my $now=time;
141: my $local=localtime($now);
1.448 albertel 142: if (open(my $fh,">>$execdir/logs/lonnet.perm.log")) {
143: print $fh "$now:$message:$local\n";
144: close($fh);
145: }
1.1 albertel 146: return 1;
147: }
148:
149: # -------------------------------------------------- Non-critical communication
150: sub subreply {
151: my ($cmd,$server)=@_;
1.704 albertel 152: my $peerfile="$perlvar{'lonSockDir'}/".$hostname{$server};
1.549 foxr 153: #
154: # With loncnew process trimming, there's a timing hole between lonc server
155: # process exit and the master server picking up the listen on the AF_UNIX
156: # socket. In that time interval, a lock file will exist:
157:
158: my $lockfile=$peerfile.".lock";
159: while (-e $lockfile) { # Need to wait for the lockfile to disappear.
160: sleep(1);
161: }
162: # At this point, either a loncnew parent is listening or an old lonc
1.550 foxr 163: # or loncnew child is listening so we can connect or everything's dead.
1.549 foxr 164: #
1.550 foxr 165: # We'll give the connection a few tries before abandoning it. If
166: # connection is not possible, we'll con_lost back to the client.
167: #
168: my $client;
169: for (my $retries = 0; $retries < $max_connection_retries; $retries++) {
170: $client=IO::Socket::UNIX->new(Peer =>"$peerfile",
171: Type => SOCK_STREAM,
172: Timeout => 10);
173: if($client) {
174: last; # Connected!
175: }
176: sleep(1); # Try again later if failed connection.
177: }
178: my $answer;
179: if ($client) {
1.704 albertel 180: print $client "sethost:$server:$cmd\n";
1.550 foxr 181: $answer=<$client>;
182: if (!$answer) { $answer="con_lost"; }
183: chomp($answer);
184: } else {
185: $answer = 'con_lost'; # Failed connection.
186: }
1.1 albertel 187: return $answer;
188: }
189:
190: sub reply {
191: my ($cmd,$server)=@_;
1.205 www 192: unless (defined($hostname{$server})) { return 'no_such_host'; }
1.1 albertel 193: my $answer=subreply($cmd,$server);
1.65 www 194: if (($answer=~/^refused/) || ($answer=~/^rejected/)) {
1.672 albertel 195: &logthis("<font color=\"blue\">WARNING:".
1.12 www 196: " $cmd to $server returned $answer</font>");
197: }
1.1 albertel 198: return $answer;
199: }
200:
201: # ----------------------------------------------------------- Send USR1 to lonc
202:
203: sub reconlonc {
204: my $peerfile=shift;
205: &logthis("Trying to reconnect for $peerfile");
206: my $loncfile="$perlvar{'lonDaemons'}/logs/lonc.pid";
1.448 albertel 207: if (open(my $fh,"<$loncfile")) {
1.1 albertel 208: my $loncpid=<$fh>;
209: chomp($loncpid);
210: if (kill 0 => $loncpid) {
211: &logthis("lonc at pid $loncpid responding, sending USR1");
212: kill USR1 => $loncpid;
213: sleep 1;
214: if (-e "$peerfile") { return; }
215: &logthis("$peerfile still not there, give it another try");
216: sleep 5;
217: if (-e "$peerfile") { return; }
1.12 www 218: &logthis(
1.672 albertel 219: "<font color=\"blue\">WARNING: $peerfile still not there, giving up</font>");
1.1 albertel 220: } else {
1.12 www 221: &logthis(
1.672 albertel 222: "<font color=\"blue\">WARNING:".
1.12 www 223: " lonc at pid $loncpid not responding, giving up</font>");
1.1 albertel 224: }
225: } else {
1.672 albertel 226: &logthis('<font color="blue">WARNING: lonc not running, giving up</font>');
1.1 albertel 227: }
228: }
229:
230: # ------------------------------------------------------ Critical communication
1.12 www 231:
1.1 albertel 232: sub critical {
233: my ($cmd,$server)=@_;
1.89 www 234: unless ($hostname{$server}) {
1.672 albertel 235: &logthis("<font color=\"blue\">WARNING:".
1.89 www 236: " Critical message to unknown server ($server)</font>");
237: return 'no_such_host';
238: }
1.1 albertel 239: my $answer=reply($cmd,$server);
240: if ($answer eq 'con_lost') {
241: &reconlonc("$perlvar{'lonSockDir'}/$server");
1.589 albertel 242: my $answer=reply($cmd,$server);
1.1 albertel 243: if ($answer eq 'con_lost') {
244: my $now=time;
245: my $middlename=$cmd;
1.5 www 246: $middlename=substr($middlename,0,16);
1.1 albertel 247: $middlename=~s/\W//g;
248: my $dfilename=
1.305 www 249: "$perlvar{'lonSockDir'}/delayed/$now.$dumpcount.$$.$middlename.$server";
250: $dumpcount++;
1.1 albertel 251: {
1.448 albertel 252: my $dfh;
253: if (open($dfh,">$dfilename")) {
254: print $dfh "$cmd\n";
255: close($dfh);
256: }
1.1 albertel 257: }
258: sleep 2;
259: my $wcmd='';
260: {
1.448 albertel 261: my $dfh;
262: if (open($dfh,"<$dfilename")) {
263: $wcmd=<$dfh>;
264: close($dfh);
265: }
1.1 albertel 266: }
267: chomp($wcmd);
1.7 www 268: if ($wcmd eq $cmd) {
1.672 albertel 269: &logthis("<font color=\"blue\">WARNING: ".
1.12 www 270: "Connection buffer $dfilename: $cmd</font>");
1.1 albertel 271: &logperm("D:$server:$cmd");
272: return 'con_delayed';
273: } else {
1.672 albertel 274: &logthis("<font color=\"red\">CRITICAL:"
1.12 www 275: ." Critical connection failed: $server $cmd</font>");
1.1 albertel 276: &logperm("F:$server:$cmd");
277: return 'con_failed';
278: }
279: }
280: }
281: return $answer;
1.405 albertel 282: }
283:
1.755 albertel 284: # ------------------------------------------- check if return value is an error
285:
286: sub error {
287: my ($result) = @_;
1.756 albertel 288: if ($result =~ /^(con_lost|no_such_host|error: (\d+) (.*))/) {
1.755 albertel 289: if ($2 == 2) { return undef; }
290: return $1;
291: }
292: return undef;
293: }
294:
1.783 albertel 295: sub convert_and_load_session_env {
296: my ($lonidsdir,$handle)=@_;
297: my @profile;
298: {
299: open(my $idf,"$lonidsdir/$handle.id");
300: flock($idf,LOCK_SH);
301: @profile=<$idf>;
302: close($idf);
303: }
304: my %temp_env;
305: foreach my $line (@profile) {
1.786 albertel 306: if ($line !~ m/=/) {
307: return 0;
308: }
1.783 albertel 309: chomp($line);
310: my ($envname,$envvalue)=split(/=/,$line,2);
311: $temp_env{&unescape($envname)} = &unescape($envvalue);
312: }
313: unlink("$lonidsdir/$handle.id");
314: if (tie(my %disk_env,'GDBM_File',"$lonidsdir/$handle.id",&GDBM_WRCREAT(),
315: 0640)) {
316: %disk_env = %temp_env;
317: @env{keys(%temp_env)} = @disk_env{keys(%temp_env)};
318: untie(%disk_env);
319: }
1.786 albertel 320: return 1;
1.783 albertel 321: }
322:
1.374 www 323: # ------------------------------------------- Transfer profile into environment
1.780 albertel 324: my $env_loaded;
325: sub transfer_profile_to_env {
1.788 albertel 326: my ($lonidsdir,$handle,$force_transfer) = @_;
327: if (!$force_transfer && $env_loaded) { return; }
1.374 www 328:
1.720 albertel 329: if (!defined($lonidsdir)) {
330: $lonidsdir = $perlvar{'lonIDsDir'};
331: }
332: if (!defined($handle)) {
333: ($handle) = ($env{'user.environment'} =~m|/([^/]+)\.id$| );
334: }
335:
1.786 albertel 336: my $convert;
337: {
338: open(my $idf,"$lonidsdir/$handle.id");
339: flock($idf,LOCK_SH);
340: if (tie(my %disk_env,'GDBM_File',"$lonidsdir/$handle.id",
341: &GDBM_READER(),0640)) {
342: @env{keys(%disk_env)} = @disk_env{keys(%disk_env)};
343: untie(%disk_env);
344: } else {
345: $convert = 1;
346: }
347: }
348: if ($convert) {
349: if (!&convert_and_load_session_env($lonidsdir,$handle)) {
350: &logthis("Failed to load session, or convert session.");
351: }
1.374 www 352: }
1.783 albertel 353:
1.786 albertel 354: my %remove;
1.783 albertel 355: while ( my $envname = each(%env) ) {
1.433 matthew 356: if (my ($key,$time) = ($envname =~ /^(cgi\.(\d+)_\d+\.)/)) {
357: if ($time < time-300) {
1.783 albertel 358: $remove{$key}++;
1.433 matthew 359: }
360: }
361: }
1.783 albertel 362:
1.619 albertel 363: $env{'user.environment'} = "$lonidsdir/$handle.id";
1.780 albertel 364: $env_loaded=1;
1.783 albertel 365: foreach my $expired_key (keys(%remove)) {
1.433 matthew 366: &delenv($expired_key);
1.374 www 367: }
1.1 albertel 368: }
369:
1.830 albertel 370: sub timed_flock {
371: my ($file,$lock_type) = @_;
372: my $failed=0;
373: eval {
374: local $SIG{__DIE__}='DEFAULT';
375: local $SIG{ALRM}=sub {
376: $failed=1;
377: die("failed lock");
378: };
379: alarm(13);
380: flock($file,$lock_type);
381: alarm(0);
382: };
383: if ($failed) {
384: return undef;
385: } else {
386: return 1;
387: }
388: }
389:
1.5 www 390: # ---------------------------------------------------------- Append Environment
391:
392: sub appenv {
1.6 www 393: my %newenv=@_;
1.692 albertel 394: foreach my $key (keys(%newenv)) {
395: if (($newenv{$key}=~/^user\.role/) || ($newenv{$key}=~/^user\.priv/)) {
1.672 albertel 396: &logthis("<font color=\"blue\">WARNING: ".
1.692 albertel 397: "Attempt to modify environment ".$key." to ".$newenv{$key}
1.151 www 398: .'</font>');
1.692 albertel 399: delete($newenv{$key});
1.35 www 400: } else {
1.692 albertel 401: $env{$key}=$newenv{$key};
1.35 www 402: }
1.191 harris41 403: }
1.830 albertel 404: open(my $env_file,$env{'user.environment'});
405: if (&timed_flock($env_file,LOCK_EX)
406: &&
407: tie(my %disk_env,'GDBM_File',$env{'user.environment'},
408: (&GDBM_WRITER()|&GDBM_NOLOCK()),0640)) {
1.783 albertel 409: while (my ($key,$value) = each(%newenv)) {
410: $disk_env{$key} = $value;
1.448 albertel 411: }
1.783 albertel 412: untie(%disk_env);
1.56 www 413: }
414: return 'ok';
415: }
416: # ----------------------------------------------------- Delete from Environment
417:
418: sub delenv {
419: my $delthis=shift;
420: if (($delthis=~/user\.role/) || ($delthis=~/user\.priv/)) {
1.672 albertel 421: &logthis("<font color=\"blue\">WARNING: ".
1.56 www 422: "Attempt to delete from environment ".$delthis);
423: return 'error';
424: }
1.830 albertel 425: open(my $env_file,$env{'user.environment'});
426: if (&timed_flock($env_file,LOCK_EX)
427: &&
428: tie(my %disk_env,'GDBM_File',$env{'user.environment'},
429: (&GDBM_WRITER()|&GDBM_NOLOCK()),0640)) {
1.783 albertel 430: foreach my $key (keys(%disk_env)) {
431: if ($key=~/^$delthis/) {
1.619 albertel 432: delete($env{$key});
1.783 albertel 433: delete($disk_env{$key});
1.473 matthew 434: }
1.448 albertel 435: }
1.783 albertel 436: untie(%disk_env);
1.5 www 437: }
438: return 'ok';
1.369 albertel 439: }
440:
1.790 albertel 441: sub get_env_multiple {
442: my ($name) = @_;
443: my @values;
444: if (defined($env{$name})) {
445: # exists is it an array
446: if (ref($env{$name})) {
447: @values=@{ $env{$name} };
448: } else {
449: $values[0]=$env{$name};
450: }
451: }
452: return(@values);
453: }
454:
1.369 albertel 455: # ------------------------------------------ Find out current server userload
456: # there is a copy in lond
457: sub userload {
458: my $numusers=0;
459: {
460: opendir(LONIDS,$perlvar{'lonIDsDir'});
461: my $filename;
462: my $curtime=time;
463: while ($filename=readdir(LONIDS)) {
464: if ($filename eq '.' || $filename eq '..') {next;}
1.404 albertel 465: my ($mtime)=(stat($perlvar{'lonIDsDir'}.'/'.$filename))[9];
1.437 albertel 466: if ($curtime-$mtime < 1800) { $numusers++; }
1.369 albertel 467: }
468: closedir(LONIDS);
469: }
470: my $userloadpercent=0;
471: my $maxuserload=$perlvar{'lonUserLoadLim'};
472: if ($maxuserload) {
1.371 albertel 473: $userloadpercent=100*$numusers/$maxuserload;
1.369 albertel 474: }
1.372 albertel 475: $userloadpercent=sprintf("%.2f",$userloadpercent);
1.369 albertel 476: return $userloadpercent;
1.283 www 477: }
478:
479: # ------------------------------------------ Fight off request when overloaded
480:
481: sub overloaderror {
482: my ($r,$checkserver)=@_;
483: unless ($checkserver) { $checkserver=$perlvar{'lonHostID'}; }
484: my $loadavg;
485: if ($checkserver eq $perlvar{'lonHostID'}) {
1.448 albertel 486: open(my $loadfile,'/proc/loadavg');
1.283 www 487: $loadavg=<$loadfile>;
488: $loadavg =~ s/\s.*//g;
1.285 matthew 489: $loadavg = 100*$loadavg/$perlvar{'lonLoadLim'};
1.448 albertel 490: close($loadfile);
1.283 www 491: } else {
492: $loadavg=&reply('load',$checkserver);
493: }
1.285 matthew 494: my $overload=$loadavg-100;
1.283 www 495: if ($overload>0) {
1.285 matthew 496: $r->err_headers_out->{'Retry-After'}=$overload;
1.283 www 497: $r->log_error('Overload of '.$overload.' on '.$checkserver);
1.554 www 498: return 413;
1.283 www 499: }
500: return '';
1.5 www 501: }
1.1 albertel 502:
503: # ------------------------------ Find server with least workload from spare.tab
1.11 www 504:
1.1 albertel 505: sub spareserver {
1.670 albertel 506: my ($loadpercent,$userloadpercent,$want_server_name) = @_;
1.784 albertel 507: my $spare_server;
1.370 albertel 508: if ($userloadpercent !~ /\d/) { $userloadpercent=0; }
1.784 albertel 509: my $lowest_load=($loadpercent > $userloadpercent) ? $loadpercent
510: : $userloadpercent;
511:
512: foreach my $try_server (@{ $spareid{'primary'} }) {
513: ($spare_server, $lowest_load) =
514: &compare_server_load($try_server, $spare_server, $lowest_load);
515: }
516:
517: my $found_server = ($spare_server ne '' && $lowest_load < 100);
518:
519: if (!$found_server) {
520: foreach my $try_server (@{ $spareid{'default'} }) {
521: ($spare_server, $lowest_load) =
522: &compare_server_load($try_server, $spare_server, $lowest_load);
523: }
524: }
525:
526: if (!$want_server_name) {
527: $spare_server="http://$hostname{$spare_server}";
528: }
529: return $spare_server;
530: }
531:
532: sub compare_server_load {
533: my ($try_server, $spare_server, $lowest_load) = @_;
534:
535: my $loadans = &reply('load', $try_server);
536: my $userloadans = &reply('userload',$try_server);
537:
538: if ($loadans !~ /\d/ && $userloadans !~ /\d/) {
539: next; #didn't get a number from the server
540: }
541:
542: my $load;
543: if ($loadans =~ /\d/) {
544: if ($userloadans =~ /\d/) {
545: #both are numbers, pick the bigger one
546: $load = ($loadans > $userloadans) ? $loadans
547: : $userloadans;
1.411 albertel 548: } else {
1.784 albertel 549: $load = $loadans;
1.411 albertel 550: }
1.784 albertel 551: } else {
552: $load = $userloadans;
553: }
554:
555: if (($load =~ /\d/) && ($load < $lowest_load)) {
556: $spare_server = $try_server;
557: $lowest_load = $load;
1.370 albertel 558: }
1.784 albertel 559: return ($spare_server,$lowest_load);
1.202 matthew 560: }
561: # --------------------------------------------- Try to change a user's password
562:
563: sub changepass {
1.799 raeburn 564: my ($uname,$udom,$currentpass,$newpass,$server,$context)=@_;
1.202 matthew 565: $currentpass = &escape($currentpass);
566: $newpass = &escape($newpass);
1.799 raeburn 567: my $answer = reply("encrypt:passwd:$udom:$uname:$currentpass:$newpass:$context",
1.202 matthew 568: $server);
569: if (! $answer) {
570: &logthis("No reply on password change request to $server ".
571: "by $uname in domain $udom.");
572: } elsif ($answer =~ "^ok") {
573: &logthis("$uname in $udom successfully changed their password ".
574: "on $server.");
575: } elsif ($answer =~ "^pwchange_failure") {
576: &logthis("$uname in $udom was unable to change their password ".
577: "on $server. The action was blocked by either lcpasswd ".
578: "or pwchange");
579: } elsif ($answer =~ "^non_authorized") {
580: &logthis("$uname in $udom did not get their password correct when ".
581: "attempting to change it on $server.");
582: } elsif ($answer =~ "^auth_mode_error") {
583: &logthis("$uname in $udom attempted to change their password despite ".
584: "not being locally or internally authenticated on $server.");
585: } elsif ($answer =~ "^unknown_user") {
586: &logthis("$uname in $udom attempted to change their password ".
587: "on $server but were unable to because $server is not ".
588: "their home server.");
589: } elsif ($answer =~ "^refused") {
590: &logthis("$server refused to change $uname in $udom password because ".
591: "it was sent an unencrypted request to change the password.");
592: }
593: return $answer;
1.1 albertel 594: }
595:
1.169 harris41 596: # ----------------------- Try to determine user's current authentication scheme
597:
598: sub queryauthenticate {
599: my ($uname,$udom)=@_;
1.456 albertel 600: my $uhome=&homeserver($uname,$udom);
601: if (!$uhome) {
602: &logthis("User $uname at $udom is unknown when looking for authentication mechanism");
603: return 'no_host';
604: }
605: my $answer=reply("encrypt:currentauth:$udom:$uname",$uhome);
606: if ($answer =~ /^(unknown_user|refused|con_lost)/) {
607: &logthis("User $uname at $udom threw error $answer when checking authentication mechanism");
1.169 harris41 608: }
1.456 albertel 609: return $answer;
1.169 harris41 610: }
611:
1.1 albertel 612: # --------- Try to authenticate user from domain's lib servers (first this one)
1.11 www 613:
1.1 albertel 614: sub authenticate {
615: my ($uname,$upass,$udom)=@_;
1.807 albertel 616: $upass=&escape($upass);
617: $uname= &LONCAPA::clean_username($uname);
1.471 albertel 618: my $uhome=&homeserver($uname,$udom);
619: if (!$uhome) {
620: &logthis("User $uname at $udom is unknown in authenticate");
621: return 'no_host';
1.1 albertel 622: }
1.471 albertel 623: my $answer=reply("encrypt:auth:$udom:$uname:$upass",$uhome);
624: if ($answer eq 'authorized') {
625: &logthis("User $uname at $udom authorized by $uhome");
626: return $uhome;
627: }
628: if ($answer eq 'non_authorized') {
629: &logthis("User $uname at $udom rejected by $uhome");
630: return 'no_host';
1.9 www 631: }
1.471 albertel 632: &logthis("User $uname at $udom threw error $answer when checking authentication mechanism");
1.1 albertel 633: return 'no_host';
634: }
635:
636: # ---------------------- Find the homebase for a user from domain's lib servers
1.11 www 637:
1.599 albertel 638: my %homecache;
1.1 albertel 639: sub homeserver {
1.230 stredwic 640: my ($uname,$udom,$ignoreBadCache)=@_;
1.1 albertel 641: my $index="$uname:$udom";
1.426 albertel 642:
1.599 albertel 643: if (exists($homecache{$index})) { return $homecache{$index}; }
1.1 albertel 644: my $tryserver;
645: foreach $tryserver (keys %libserv) {
1.230 stredwic 646: next if ($ignoreBadCache ne 'true' &&
1.231 stredwic 647: exists($badServerCache{$tryserver}));
1.1 albertel 648: if ($hostdom{$tryserver} eq $udom) {
649: my $answer=reply("home:$udom:$uname",$tryserver);
650: if ($answer eq 'found') {
1.599 albertel 651: return $homecache{$index}=$tryserver;
1.231 stredwic 652: } elsif ($answer eq 'no_host') {
653: $badServerCache{$tryserver}=1;
1.221 matthew 654: }
1.1 albertel 655: }
656: }
657: return 'no_host';
1.70 www 658: }
659:
660: # ------------------------------------- Find the usernames behind a list of IDs
661:
662: sub idget {
663: my ($udom,@ids)=@_;
664: my %returnhash=();
665:
666: my $tryserver;
667: foreach $tryserver (keys %libserv) {
668: if ($hostdom{$tryserver} eq $udom) {
669: my $idlist=join('&',@ids);
670: $idlist=~tr/A-Z/a-z/;
671: my $reply=&reply("idget:$udom:".$idlist,$tryserver);
672: my @answer=();
1.76 www 673: if (($reply ne 'con_lost') && ($reply!~/^error\:/)) {
1.70 www 674: @answer=split(/\&/,$reply);
675: } ;
676: my $i;
677: for ($i=0;$i<=$#ids;$i++) {
678: if ($answer[$i]) {
679: $returnhash{$ids[$i]}=$answer[$i];
680: }
681: }
682: }
683: }
684: return %returnhash;
685: }
686:
687: # ------------------------------------- Find the IDs behind a list of usernames
688:
689: sub idrget {
690: my ($udom,@unames)=@_;
691: my %returnhash=();
1.800 albertel 692: foreach my $uname (@unames) {
693: $returnhash{$uname}=(&userenvironment($udom,$uname,'id'))[1];
1.191 harris41 694: }
1.70 www 695: return %returnhash;
696: }
697:
698: # ------------------------------- Store away a list of names and associated IDs
699:
700: sub idput {
701: my ($udom,%ids)=@_;
702: my %servers=();
1.800 albertel 703: foreach my $uname (keys(%ids)) {
704: &cput('environment',{'id'=>$ids{$uname}},$udom,$uname);
705: my $uhom=&homeserver($uname,$udom);
1.70 www 706: if ($uhom ne 'no_host') {
1.800 albertel 707: my $id=&escape($ids{$uname});
1.70 www 708: $id=~tr/A-Z/a-z/;
1.800 albertel 709: my $esc_unam=&escape($uname);
1.70 www 710: if ($servers{$uhom}) {
1.800 albertel 711: $servers{$uhom}.='&'.$id.'='.$esc_unam;
1.70 www 712: } else {
1.800 albertel 713: $servers{$uhom}=$id.'='.$esc_unam;
1.70 www 714: }
715: }
1.191 harris41 716: }
1.800 albertel 717: foreach my $server (keys(%servers)) {
718: &critical('idput:'.$udom.':'.$servers{$server},$server);
1.191 harris41 719: }
1.344 www 720: }
721:
1.806 raeburn 722: # ------------------------------------------- get items from domain db files
723:
724: sub get_dom {
725: my ($namespace,$storearr,$udom)=@_;
726: my $items='';
727: foreach my $item (@$storearr) {
728: $items.=&escape($item).'&';
729: }
730: $items=~s/\&$//;
731: if (!$udom) { $udom=$env{'user.domain'}; }
732: if (exists($domain_primary{$udom})) {
733: my $uhome=$domain_primary{$udom};
734: my $rep=&reply("getdom:$udom:$namespace:$items",$uhome);
735: my @pairs=split(/\&/,$rep);
736: if ( $#pairs==0 && $pairs[0] =~ /^(con_lost|error|no_such_host)/i) {
737: return @pairs;
738: }
739: my %returnhash=();
740: my $i=0;
741: foreach my $item (@$storearr) {
742: $returnhash{$item}=&thaw_unescape($pairs[$i]);
743: $i++;
744: }
745: return %returnhash;
746: } else {
747: &logthis("get_dom failed - no primary domain server for $udom");
748: }
749: }
750:
751: # -------------------------------------------- put items in domain db files
752:
753: sub put_dom {
754: my ($namespace,$storehash,$udom)=@_;
755: if (!$udom) { $udom=$env{'user.domain'}; }
756: if (exists($domain_primary{$udom})) {
757: my $uhome=$domain_primary{$udom};
758: my $items='';
759: foreach my $item (keys(%$storehash)) {
760: $items.=&escape($item).'='.&freeze_escape($$storehash{$item}).'&';
761: }
762: $items=~s/\&$//;
763: return &reply("putdom:$udom:$namespace:$items",$uhome);
764: } else {
765: &logthis("put_dom failed - no primary domain server for $udom");
766: }
767: }
768:
1.344 www 769: # --------------------------------------------------- Assign a key to a student
770:
771: sub assign_access_key {
1.364 www 772: #
773: # a valid key looks like uname:udom#comments
774: # comments are being appended
775: #
1.498 www 776: my ($ckey,$kdom,$knum,$cdom,$cnum,$udom,$uname,$logentry)=@_;
777: $kdom=
1.620 albertel 778: $env{'course.'.$env{'request.course.id'}.'.domain'} unless (defined($kdom));
1.498 www 779: $knum=
1.620 albertel 780: $env{'course.'.$env{'request.course.id'}.'.num'} unless (defined($knum));
1.344 www 781: $cdom=
1.620 albertel 782: $env{'course.'.$env{'request.course.id'}.'.domain'} unless (defined($cdom));
1.344 www 783: $cnum=
1.620 albertel 784: $env{'course.'.$env{'request.course.id'}.'.num'} unless (defined($cnum));
785: $udom=$env{'user.name'} unless (defined($udom));
786: $uname=$env{'user.domain'} unless (defined($uname));
1.498 www 787: my %existing=&get('accesskeys',[$ckey],$kdom,$knum);
1.364 www 788: if (($existing{$ckey}=~/^\#(.*)$/) || # - new key
1.479 albertel 789: ($existing{$ckey}=~/^\Q$uname\E\:\Q$udom\E\#(.*)$/)) {
1.364 www 790: # assigned to this person
791: # - this should not happen,
1.345 www 792: # unless something went wrong
793: # the first time around
794: # ready to assign
1.364 www 795: $logentry=$1.'; '.$logentry;
1.496 www 796: if (&put('accesskeys',{$ckey=>$uname.':'.$udom.'#'.$logentry},
1.498 www 797: $kdom,$knum) eq 'ok') {
1.345 www 798: # key now belongs to user
1.346 www 799: my $envkey='key.'.$cdom.'_'.$cnum;
1.345 www 800: if (&put('environment',{$envkey => $ckey}) eq 'ok') {
801: &appenv('environment.'.$envkey => $ckey);
802: return 'ok';
803: } else {
804: return
805: 'error: Count not permanently assign key, will need to be re-entered later.';
806: }
807: } else {
808: return 'error: Could not assign key, try again later.';
809: }
1.364 www 810: } elsif (!$existing{$ckey}) {
1.345 www 811: # the key does not exist
812: return 'error: The key does not exist';
813: } else {
814: # the key is somebody else's
815: return 'error: The key is already in use';
816: }
1.344 www 817: }
818:
1.364 www 819: # ------------------------------------------ put an additional comment on a key
820:
821: sub comment_access_key {
822: #
823: # a valid key looks like uname:udom#comments
824: # comments are being appended
825: #
826: my ($ckey,$cdom,$cnum,$logentry)=@_;
827: $cdom=
1.620 albertel 828: $env{'course.'.$env{'request.course.id'}.'.domain'} unless (defined($cdom));
1.364 www 829: $cnum=
1.620 albertel 830: $env{'course.'.$env{'request.course.id'}.'.num'} unless (defined($cnum));
1.364 www 831: my %existing=&get('accesskeys',[$ckey],$cdom,$cnum);
832: if ($existing{$ckey}) {
833: $existing{$ckey}.='; '.$logentry;
834: # ready to assign
1.367 www 835: if (&put('accesskeys',{$ckey=>$existing{$ckey}},
1.364 www 836: $cdom,$cnum) eq 'ok') {
837: return 'ok';
838: } else {
839: return 'error: Count not store comment.';
840: }
841: } else {
842: # the key does not exist
843: return 'error: The key does not exist';
844: }
845: }
846:
1.344 www 847: # ------------------------------------------------------ Generate a set of keys
848:
849: sub generate_access_keys {
1.364 www 850: my ($number,$cdom,$cnum,$logentry)=@_;
1.344 www 851: $cdom=
1.620 albertel 852: $env{'course.'.$env{'request.course.id'}.'.domain'} unless (defined($cdom));
1.344 www 853: $cnum=
1.620 albertel 854: $env{'course.'.$env{'request.course.id'}.'.num'} unless (defined($cnum));
1.361 www 855: unless (&allowed('mky',$cdom)) { return 0; }
1.344 www 856: unless (($cdom) && ($cnum)) { return 0; }
857: if ($number>10000) { return 0; }
858: sleep(2); # make sure don't get same seed twice
859: srand(time()^($$+($$<<15))); # from "Programming Perl"
860: my $total=0;
861: for (my $i=1;$i<=$number;$i++) {
862: my $newkey=sprintf("%lx",int(100000*rand)).'-'.
863: sprintf("%lx",int(100000*rand)).'-'.
864: sprintf("%lx",int(100000*rand));
865: $newkey=~s/1/g/g; # folks mix up 1 and l
866: $newkey=~s/0/h/g; # and also 0 and O
867: my %existing=&get('accesskeys',[$newkey],$cdom,$cnum);
868: if ($existing{$newkey}) {
869: $i--;
870: } else {
1.364 www 871: if (&put('accesskeys',
872: { $newkey => '# generated '.localtime().
1.620 albertel 873: ' by '.$env{'user.name'}.'@'.$env{'user.domain'}.
1.364 www 874: '; '.$logentry },
875: $cdom,$cnum) eq 'ok') {
1.344 www 876: $total++;
877: }
878: }
879: }
1.620 albertel 880: &log($env{'user.domain'},$env{'user.name'},$env{'user.home'},
1.344 www 881: 'Generated '.$total.' keys for '.$cnum.' at '.$cdom);
882: return $total;
883: }
884:
885: # ------------------------------------------------------- Validate an accesskey
886:
887: sub validate_access_key {
888: my ($ckey,$cdom,$cnum,$udom,$uname)=@_;
889: $cdom=
1.620 albertel 890: $env{'course.'.$env{'request.course.id'}.'.domain'} unless (defined($cdom));
1.344 www 891: $cnum=
1.620 albertel 892: $env{'course.'.$env{'request.course.id'}.'.num'} unless (defined($cnum));
893: $udom=$env{'user.domain'} unless (defined($udom));
894: $uname=$env{'user.name'} unless (defined($uname));
1.345 www 895: my %existing=&get('accesskeys',[$ckey],$cdom,$cnum);
1.479 albertel 896: return ($existing{$ckey}=~/^\Q$uname\E\:\Q$udom\E\#/);
1.70 www 897: }
898:
899: # ------------------------------------- Find the section of student in a course
1.652 albertel 900: sub devalidate_getsection_cache {
901: my ($udom,$unam,$courseid)=@_;
902: my $hashid="$udom:$unam:$courseid";
903: &devalidate_cache_new('getsection',$hashid);
904: }
1.298 matthew 905:
1.815 albertel 906: sub courseid_to_courseurl {
907: my ($courseid) = @_;
908: #already url style courseid
909: return $courseid if ($courseid =~ m{^/});
910:
911: if (exists($env{'course.'.$courseid.'.num'})) {
912: my $cnum = $env{'course.'.$courseid.'.num'};
913: my $cdom = $env{'course.'.$courseid.'.domain'};
914: return "/$cdom/$cnum";
915: }
916:
917: my %courseinfo=&Apache::lonnet::coursedescription($courseid);
918: if (exists($courseinfo{'num'})) {
919: return "/$courseinfo{'domain'}/$courseinfo{'num'}";
920: }
921:
922: return undef;
923: }
924:
1.298 matthew 925: sub getsection {
926: my ($udom,$unam,$courseid)=@_;
1.599 albertel 927: my $cachetime=1800;
1.551 albertel 928:
929: my $hashid="$udom:$unam:$courseid";
1.599 albertel 930: my ($result,$cached)=&is_cached_new('getsection',$hashid);
1.551 albertel 931: if (defined($cached)) { return $result; }
932:
1.298 matthew 933: my %Pending;
934: my %Expired;
935: #
936: # Each role can either have not started yet (pending), be active,
937: # or have expired.
938: #
939: # If there is an active role, we are done.
940: #
941: # If there is more than one role which has not started yet,
942: # choose the one which will start sooner
943: # If there is one role which has not started yet, return it.
944: #
945: # If there is more than one expired role, choose the one which ended last.
946: # If there is a role which has expired, return it.
947: #
1.815 albertel 948: $courseid = &courseid_to_courseurl($courseid);
1.817 raeburn 949: my %roleshash = &dump('roles',$udom,$unam,$courseid);
950: foreach my $key (keys(%roleshash)) {
1.479 albertel 951: next if ($key !~/^\Q$courseid\E(?:\/)*(\w+)*\_st$/);
1.298 matthew 952: my $section=$1;
953: if ($key eq $courseid.'_st') { $section=''; }
1.817 raeburn 954: my ($dummy,$end,$start)=split(/\_/,&unescape($roleshash{$key}));
1.298 matthew 955: my $now=time;
1.548 albertel 956: if (defined($end) && $end && ($now > $end)) {
1.298 matthew 957: $Expired{$end}=$section;
958: next;
959: }
1.548 albertel 960: if (defined($start) && $start && ($now < $start)) {
1.298 matthew 961: $Pending{$start}=$section;
962: next;
963: }
1.599 albertel 964: return &do_cache_new('getsection',$hashid,$section,$cachetime);
1.298 matthew 965: }
966: #
967: # Presumedly there will be few matching roles from the above
968: # loop and the sorting time will be negligible.
969: if (scalar(keys(%Pending))) {
970: my ($time) = sort {$a <=> $b} keys(%Pending);
1.599 albertel 971: return &do_cache_new('getsection',$hashid,$Pending{$time},$cachetime);
1.298 matthew 972: }
973: if (scalar(keys(%Expired))) {
974: my @sorted = sort {$a <=> $b} keys(%Expired);
975: my $time = pop(@sorted);
1.599 albertel 976: return &do_cache_new('getsection',$hashid,$Expired{$time},$cachetime);
1.298 matthew 977: }
1.599 albertel 978: return &do_cache_new('getsection',$hashid,'-1',$cachetime);
1.298 matthew 979: }
1.70 www 980:
1.599 albertel 981: sub save_cache {
982: &purge_remembered();
1.722 albertel 983: #&Apache::loncommon::validate_page();
1.620 albertel 984: undef(%env);
1.780 albertel 985: undef($env_loaded);
1.599 albertel 986: }
1.452 albertel 987:
1.599 albertel 988: my $to_remember=-1;
989: my %remembered;
990: my %accessed;
991: my $kicks=0;
992: my $hits=0;
993: sub devalidate_cache_new {
994: my ($name,$id,$debug) = @_;
995: if ($debug) { &Apache::lonnet::logthis("deleting $name:$id"); }
996: $id=&escape($name.':'.$id);
997: $memcache->delete($id);
998: delete($remembered{$id});
999: delete($accessed{$id});
1000: }
1001:
1002: sub is_cached_new {
1003: my ($name,$id,$debug) = @_;
1004: $id=&escape($name.':'.$id);
1005: if (exists($remembered{$id})) {
1006: if ($debug) { &Apache::lonnet::logthis("Earyl return $id of $remembered{$id} "); }
1007: $accessed{$id}=[&gettimeofday()];
1008: $hits++;
1009: return ($remembered{$id},1);
1010: }
1011: my $value = $memcache->get($id);
1012: if (!(defined($value))) {
1013: if ($debug) { &Apache::lonnet::logthis("getting $id is not defined"); }
1.417 albertel 1014: return (undef,undef);
1.416 albertel 1015: }
1.599 albertel 1016: if ($value eq '__undef__') {
1017: if ($debug) { &Apache::lonnet::logthis("getting $id is __undef__"); }
1018: $value=undef;
1019: }
1020: &make_room($id,$value,$debug);
1021: if ($debug) { &Apache::lonnet::logthis("getting $id is $value"); }
1022: return ($value,1);
1023: }
1024:
1025: sub do_cache_new {
1026: my ($name,$id,$value,$time,$debug) = @_;
1027: $id=&escape($name.':'.$id);
1028: my $setvalue=$value;
1029: if (!defined($setvalue)) {
1030: $setvalue='__undef__';
1031: }
1.623 albertel 1032: if (!defined($time) ) {
1033: $time=600;
1034: }
1.599 albertel 1035: if ($debug) { &Apache::lonnet::logthis("Setting $id to $value"); }
1.600 albertel 1036: $memcache->set($id,$setvalue,$time);
1037: # need to make a copy of $value
1038: #&make_room($id,$value,$debug);
1.599 albertel 1039: return $value;
1040: }
1041:
1042: sub make_room {
1043: my ($id,$value,$debug)=@_;
1044: $remembered{$id}=$value;
1045: if ($to_remember<0) { return; }
1046: $accessed{$id}=[&gettimeofday()];
1047: if (scalar(keys(%remembered)) <= $to_remember) { return; }
1048: my $to_kick;
1049: my $max_time=0;
1050: foreach my $other (keys(%accessed)) {
1051: if (&tv_interval($accessed{$other}) > $max_time) {
1052: $to_kick=$other;
1053: $max_time=&tv_interval($accessed{$other});
1054: }
1055: }
1056: delete($remembered{$to_kick});
1057: delete($accessed{$to_kick});
1058: $kicks++;
1059: if ($debug) { &logthis("kicking $to_kick $max_time $kicks\n"); }
1.541 albertel 1060: return;
1061: }
1062:
1.599 albertel 1063: sub purge_remembered {
1.604 albertel 1064: #&logthis("Tossing ".scalar(keys(%remembered)));
1065: #&logthis(sprintf("%-20s is %s",'%remembered',length(&freeze(\%remembered))));
1.599 albertel 1066: undef(%remembered);
1067: undef(%accessed);
1.428 albertel 1068: }
1.70 www 1069: # ------------------------------------- Read an entry from a user's environment
1070:
1071: sub userenvironment {
1072: my ($udom,$unam,@what)=@_;
1073: my %returnhash=();
1074: my @answer=split(/\&/,
1075: &reply('get:'.$udom.':'.$unam.':environment:'.join('&',@what),
1076: &homeserver($unam,$udom)));
1077: my $i;
1078: for ($i=0;$i<=$#what;$i++) {
1079: $returnhash{$what[$i]}=&unescape($answer[$i]);
1080: }
1081: return %returnhash;
1.1 albertel 1082: }
1083:
1.617 albertel 1084: # ---------------------------------------------------------- Get a studentphoto
1085: sub studentphoto {
1086: my ($udom,$unam,$ext) = @_;
1087: my $home=&Apache::lonnet::homeserver($unam,$udom);
1.706 raeburn 1088: if (defined($env{'request.course.id'})) {
1.708 raeburn 1089: if ($env{'course.'.$env{'request.course.id'}.'.internal.showphoto'}) {
1.706 raeburn 1090: if ($udom eq $env{'course.'.$env{'request.course.id'}.'.domain'}) {
1091: return(&retrievestudentphoto($udom,$unam,$ext));
1092: } else {
1093: my ($result,$perm_reqd)=
1.707 albertel 1094: &Apache::lonnet::auto_photo_permission($unam,$udom);
1.706 raeburn 1095: if ($result eq 'ok') {
1096: if (!($perm_reqd eq 'yes')) {
1097: return(&retrievestudentphoto($udom,$unam,$ext));
1098: }
1099: }
1100: }
1101: }
1102: } else {
1103: my ($result,$perm_reqd) =
1.707 albertel 1104: &Apache::lonnet::auto_photo_permission($unam,$udom);
1.706 raeburn 1105: if ($result eq 'ok') {
1106: if (!($perm_reqd eq 'yes')) {
1107: return(&retrievestudentphoto($udom,$unam,$ext));
1108: }
1109: }
1110: }
1111: return '/adm/lonKaputt/lonlogo_broken.gif';
1112: }
1113:
1114: sub retrievestudentphoto {
1115: my ($udom,$unam,$ext,$type) = @_;
1116: my $home=&Apache::lonnet::homeserver($unam,$udom);
1117: my $ret=&Apache::lonnet::reply("studentphoto:$udom:$unam:$ext:$type",$home);
1118: if ($ret eq 'ok') {
1119: my $url="/uploaded/$udom/$unam/internal/studentphoto.$ext";
1120: if ($type eq 'thumbnail') {
1121: $url="/uploaded/$udom/$unam/internal/studentphoto_tn.$ext";
1122: }
1123: my $tokenurl=&Apache::lonnet::tokenwrapper($url);
1124: return $tokenurl;
1125: } else {
1126: if ($type eq 'thumbnail') {
1127: return '/adm/lonKaputt/genericstudent_tn.gif';
1128: } else {
1129: return '/adm/lonKaputt/lonlogo_broken.gif';
1130: }
1.617 albertel 1131: }
1132: }
1133:
1.263 www 1134: # -------------------------------------------------------------------- New chat
1135:
1136: sub chatsend {
1.724 raeburn 1137: my ($newentry,$anon,$group)=@_;
1.620 albertel 1138: my $cnum=$env{'course.'.$env{'request.course.id'}.'.num'};
1139: my $cdom=$env{'course.'.$env{'request.course.id'}.'.domain'};
1140: my $chome=$env{'course.'.$env{'request.course.id'}.'.home'};
1.263 www 1141: &reply('chatsend:'.$cdom.':'.$cnum.':'.
1.620 albertel 1142: &escape($env{'user.domain'}.':'.$env{'user.name'}.':'.$anon.':'.
1.724 raeburn 1143: &escape($newentry)).':'.$group,$chome);
1.292 www 1144: }
1145:
1146: # ------------------------------------------ Find current version of a resource
1147:
1148: sub getversion {
1149: my $fname=&clutter(shift);
1150: unless ($fname=~/^\/res\//) { return -1; }
1151: return ¤tversion(&filelocation('',$fname));
1152: }
1153:
1154: sub currentversion {
1155: my $fname=shift;
1.599 albertel 1156: my ($result,$cached)=&is_cached_new('resversion',$fname);
1.440 www 1157: if (defined($cached)) { return $result; }
1.292 www 1158: my $author=$fname;
1159: $author=~s/\/home\/httpd\/html\/res\/([^\/]*)\/([^\/]*).*/$1\/$2/;
1160: my ($udom,$uname)=split(/\//,$author);
1161: my $home=homeserver($uname,$udom);
1162: if ($home eq 'no_host') {
1163: return -1;
1164: }
1165: my $answer=reply("currentversion:$fname",$home);
1166: if (($answer eq 'con_lost') || ($answer eq 'rejected')) {
1167: return -1;
1168: }
1.599 albertel 1169: return &do_cache_new('resversion',$fname,$answer,600);
1.263 www 1170: }
1171:
1.1 albertel 1172: # ----------------------------- Subscribe to a resource, return URL if possible
1.11 www 1173:
1.1 albertel 1174: sub subscribe {
1175: my $fname=shift;
1.761 raeburn 1176: if ($fname=~/\/(aboutme|syllabus|bulletinboard|smppg)$/) { return ''; }
1.532 albertel 1177: $fname=~s/[\n\r]//g;
1.1 albertel 1178: my $author=$fname;
1179: $author=~s/\/home\/httpd\/html\/res\/([^\/]*)\/([^\/]*).*/$1\/$2/;
1180: my ($udom,$uname)=split(/\//,$author);
1181: my $home=homeserver($uname,$udom);
1.335 albertel 1182: if ($home eq 'no_host') {
1183: return 'not_found';
1.1 albertel 1184: }
1185: my $answer=reply("sub:$fname",$home);
1.64 www 1186: if (($answer eq 'con_lost') || ($answer eq 'rejected')) {
1187: $answer.=' by '.$home;
1188: }
1.1 albertel 1189: return $answer;
1190: }
1191:
1.8 www 1192: # -------------------------------------------------------------- Replicate file
1193:
1194: sub repcopy {
1195: my $filename=shift;
1.23 www 1196: $filename=~s/\/+/\//g;
1.607 raeburn 1197: if ($filename=~m|^/home/httpd/html/adm/|) { return 'ok'; }
1198: if ($filename=~m|^/home/httpd/html/lonUsers/|) { return 'ok'; }
1.538 albertel 1199: if ($filename=~m|^/home/httpd/html/userfiles/| or
1.609 banghart 1200: $filename=~m -^/*(uploaded|editupload)/-) {
1.538 albertel 1201: return &repcopy_userfile($filename);
1202: }
1.532 albertel 1203: $filename=~s/[\n\r]//g;
1.8 www 1204: my $transname="$filename.in.transfer";
1.828 www 1205: # FIXME: this should flock
1.607 raeburn 1206: if ((-e $filename) || (-e $transname)) { return 'ok'; }
1.8 www 1207: my $remoteurl=subscribe($filename);
1.64 www 1208: if ($remoteurl =~ /^con_lost by/) {
1209: &logthis("Subscribe returned $remoteurl: $filename");
1.607 raeburn 1210: return 'unavailable';
1.8 www 1211: } elsif ($remoteurl eq 'not_found') {
1.441 albertel 1212: #&logthis("Subscribe returned not_found: $filename");
1.607 raeburn 1213: return 'not_found';
1.64 www 1214: } elsif ($remoteurl =~ /^rejected by/) {
1215: &logthis("Subscribe returned $remoteurl: $filename");
1.607 raeburn 1216: return 'forbidden';
1.20 www 1217: } elsif ($remoteurl eq 'directory') {
1.607 raeburn 1218: return 'ok';
1.8 www 1219: } else {
1.290 www 1220: my $author=$filename;
1221: $author=~s/\/home\/httpd\/html\/res\/([^\/]*)\/([^\/]*).*/$1\/$2/;
1222: my ($udom,$uname)=split(/\//,$author);
1223: my $home=homeserver($uname,$udom);
1224: unless ($home eq $perlvar{'lonHostID'}) {
1.8 www 1225: my @parts=split(/\//,$filename);
1226: my $path="/$parts[1]/$parts[2]/$parts[3]/$parts[4]";
1227: if ($path ne "$perlvar{'lonDocRoot'}/res") {
1228: &logthis("Malconfiguration for replication: $filename");
1.607 raeburn 1229: return 'bad_request';
1.8 www 1230: }
1231: my $count;
1232: for ($count=5;$count<$#parts;$count++) {
1233: $path.="/$parts[$count]";
1234: if ((-e $path)!=1) {
1235: mkdir($path,0777);
1236: }
1237: }
1238: my $ua=new LWP::UserAgent;
1239: my $request=new HTTP::Request('GET',"$remoteurl");
1240: my $response=$ua->request($request,$transname);
1241: if ($response->is_error()) {
1242: unlink($transname);
1243: my $message=$response->status_line;
1.672 albertel 1244: &logthis("<font color=\"blue\">WARNING:"
1.12 www 1245: ." LWP get: $message: $filename</font>");
1.607 raeburn 1246: return 'unavailable';
1.8 www 1247: } else {
1.16 www 1248: if ($remoteurl!~/\.meta$/) {
1249: my $mrequest=new HTTP::Request('GET',$remoteurl.'.meta');
1250: my $mresponse=$ua->request($mrequest,$filename.'.meta');
1251: if ($mresponse->is_error()) {
1252: unlink($filename.'.meta');
1253: &logthis(
1.672 albertel 1254: "<font color=\"yellow\">INFO: No metadata: $filename</font>");
1.16 www 1255: }
1256: }
1.8 www 1257: rename($transname,$filename);
1.607 raeburn 1258: return 'ok';
1.8 www 1259: }
1.290 www 1260: }
1.8 www 1261: }
1.330 www 1262: }
1263:
1264: # ------------------------------------------------ Get server side include body
1265: sub ssi_body {
1.381 albertel 1266: my ($filelink,%form)=@_;
1.606 matthew 1267: if (! exists($form{'LONCAPA_INTERNAL_no_discussion'})) {
1268: $form{'LONCAPA_INTERNAL_no_discussion'}='true';
1269: }
1.330 www 1270: my $output=($filelink=~/^http\:/?&externalssi($filelink):
1.381 albertel 1271: &ssi($filelink,%form));
1.778 albertel 1272: $output=~s|//(\s*<!--)? BEGIN LON-CAPA Internal.+?// END LON-CAPA Internal\s*(-->)?\s||gs;
1.451 albertel 1273: $output=~s/^.*?\<body[^\>]*\>//si;
1274: $output=~s/(.*)\<\/body\s*\>.*?$/$1/si;
1.330 www 1275: return $output;
1.8 www 1276: }
1277:
1.15 www 1278: # --------------------------------------------------------- Server Side Include
1279:
1.782 albertel 1280: sub absolute_url {
1281: my ($host_name) = @_;
1282: my $protocol = ($ENV{'SERVER_PORT'} == 443?'https://':'http://');
1283: if ($host_name eq '') {
1284: $host_name = $ENV{'SERVER_NAME'};
1285: }
1286: return $protocol.$host_name;
1287: }
1288:
1.15 www 1289: sub ssi {
1290:
1.23 www 1291: my ($fn,%form)=@_;
1.15 www 1292:
1293: my $ua=new LWP::UserAgent;
1.23 www 1294:
1295: my $request;
1.711 albertel 1296:
1297: $form{'no_update_last_known'}=1;
1298:
1.23 www 1299: if (%form) {
1.782 albertel 1300: $request=new HTTP::Request('POST',&absolute_url().$fn);
1.201 albertel 1301: $request->content(join('&',map { &escape($_).'='.&escape($form{$_}) } keys %form));
1.23 www 1302: } else {
1.782 albertel 1303: $request=new HTTP::Request('GET',&absolute_url().$fn);
1.23 www 1304: }
1305:
1.15 www 1306: $request->header(Cookie => $ENV{'HTTP_COOKIE'});
1307: my $response=$ua->request($request);
1308:
1.324 www 1309: return $response->content;
1310: }
1311:
1312: sub externalssi {
1313: my ($url)=@_;
1314: my $ua=new LWP::UserAgent;
1315: my $request=new HTTP::Request('GET',$url);
1316: my $response=$ua->request($request);
1.15 www 1317: return $response->content;
1318: }
1.254 www 1319:
1.492 albertel 1320: # -------------------------------- Allow a /uploaded/ URI to be vouched for
1321:
1322: sub allowuploaded {
1323: my ($srcurl,$url)=@_;
1324: $url=&clutter(&declutter($url));
1325: my $dir=$url;
1326: $dir=~s/\/[^\/]+$//;
1327: my %httpref=();
1328: my $httpurl=&hreflocation('',$url);
1329: $httpref{'httpref.'.$httpurl}=$srcurl;
1330: &Apache::lonnet::appenv(%httpref);
1.254 www 1331: }
1.477 raeburn 1332:
1.478 albertel 1333: # --------- File operations in /home/httpd/html/userfiles/$domain/1/2/3/$course
1.638 albertel 1334: # input: action, courseID, current domain, intended
1.637 raeburn 1335: # path to file, source of file, instruction to parse file for objects,
1336: # ref to hash for embedded objects,
1337: # ref to hash for codebase of java objects.
1338: #
1.485 raeburn 1339: # output: url to file (if action was uploaddoc),
1340: # ok if successful, or diagnostic message otherwise (if action was propagate or copy)
1.477 raeburn 1341: #
1.478 albertel 1342: # Allows directory structure to be used within lonUsers/../userfiles/ for a
1343: # course.
1.477 raeburn 1344: #
1.478 albertel 1345: # action = propagate - /home/httpd/html/userfiles/$domain/1/2/3/$course/$file
1346: # will be copied to /home/httpd/lonUsers/1/2/3/$course/userfiles in
1347: # course's home server.
1.477 raeburn 1348: #
1.478 albertel 1349: # action = copy - /home/httpd/html/userfiles/$domain/1/2/3/$course/$file will
1350: # be copied from $source (current location) to
1351: # /home/httpd/html/userfiles/$domain/1/2/3/$course/$file
1352: # and will then be copied to
1353: # /home/httpd/lonUsers/$domain/1/2/3/$course/userfiles/$file in
1354: # course's home server.
1.485 raeburn 1355: #
1.481 raeburn 1356: # action = uploaddoc - /home/httpd/html/userfiles/$domain/1/2/3/$course/$file
1.620 albertel 1357: # will be retrived from $env{form.uploaddoc} (from DOCS interface) to
1.481 raeburn 1358: # /home/httpd/html/userfiles/$domain/1/2/3/$course/$file
1359: # and will then be copied to /home/httpd/lonUsers/1/2/3/$course/userfiles/$file
1360: # in course's home server.
1.637 raeburn 1361: #
1.477 raeburn 1362:
1363: sub process_coursefile {
1.638 albertel 1364: my ($action,$docuname,$docudom,$file,$source,$parser,$allfiles,$codebase)=@_;
1.477 raeburn 1365: my $fetchresult;
1.638 albertel 1366: my $home=&homeserver($docuname,$docudom);
1.477 raeburn 1367: if ($action eq 'propagate') {
1.638 albertel 1368: $fetchresult= &reply('fetchuserfile:'.$docudom.'/'.$docuname.'/'.$file,
1369: $home);
1.481 raeburn 1370: } else {
1.477 raeburn 1371: my $fpath = '';
1372: my $fname = $file;
1.478 albertel 1373: ($fpath,$fname) = ($file =~ m|^(.*)/([^/]+)$|);
1.477 raeburn 1374: $fpath=$docudom.'/'.$docuname.'/'.$fpath;
1.637 raeburn 1375: my $filepath = &build_filepath($fpath);
1.481 raeburn 1376: if ($action eq 'copy') {
1377: if ($source eq '') {
1378: $fetchresult = 'no source file';
1379: return $fetchresult;
1380: } else {
1381: my $destination = $filepath.'/'.$fname;
1382: rename($source,$destination);
1383: $fetchresult= &reply('fetchuserfile:'.$docudom.'/'.$docuname.'/'.$file,
1.638 albertel 1384: $home);
1.481 raeburn 1385: }
1386: } elsif ($action eq 'uploaddoc') {
1387: open(my $fh,'>'.$filepath.'/'.$fname);
1.620 albertel 1388: print $fh $env{'form.'.$source};
1.481 raeburn 1389: close($fh);
1.637 raeburn 1390: if ($parser eq 'parse') {
1391: my $parse_result = &extract_embedded_items($filepath,$fname,$allfiles,$codebase);
1392: unless ($parse_result eq 'ok') {
1393: &logthis('Failed to parse '.$filepath.'/'.$fname.' for embedded media: '.$parse_result);
1394: }
1395: }
1.477 raeburn 1396: $fetchresult= &reply('fetchuserfile:'.$docudom.'/'.$docuname.'/'.$file,
1.638 albertel 1397: $home);
1.481 raeburn 1398: if ($fetchresult eq 'ok') {
1399: return '/uploaded/'.$fpath.'/'.$fname;
1400: } else {
1401: &logthis('Failed to transfer '.$docudom.'/'.$docuname.'/'.$file.
1.638 albertel 1402: ' to host '.$home.': '.$fetchresult);
1.481 raeburn 1403: return '/adm/notfound.html';
1404: }
1.477 raeburn 1405: }
1406: }
1.485 raeburn 1407: unless ( $fetchresult eq 'ok') {
1.477 raeburn 1408: &logthis('Failed to transfer '.$docudom.'/'.$docuname.'/'.$file.
1.638 albertel 1409: ' to host '.$home.': '.$fetchresult);
1.477 raeburn 1410: }
1411: return $fetchresult;
1412: }
1413:
1.637 raeburn 1414: sub build_filepath {
1415: my ($fpath) = @_;
1416: my $filepath=$perlvar{'lonDocRoot'}.'/userfiles';
1417: unless ($fpath eq '') {
1418: my @parts=split('/',$fpath);
1419: foreach my $part (@parts) {
1420: $filepath.= '/'.$part;
1421: if ((-e $filepath)!=1) {
1422: mkdir($filepath,0777);
1423: }
1424: }
1425: }
1426: return $filepath;
1427: }
1428:
1429: sub store_edited_file {
1.638 albertel 1430: my ($primary_url,$content,$docudom,$docuname,$fetchresult) = @_;
1.637 raeburn 1431: my $file = $primary_url;
1432: $file =~ s#^/uploaded/$docudom/$docuname/##;
1433: my $fpath = '';
1434: my $fname = $file;
1435: ($fpath,$fname) = ($file =~ m|^(.*)/([^/]+)$|);
1436: $fpath=$docudom.'/'.$docuname.'/'.$fpath;
1437: my $filepath = &build_filepath($fpath);
1438: open(my $fh,'>'.$filepath.'/'.$fname);
1439: print $fh $content;
1440: close($fh);
1.638 albertel 1441: my $home=&homeserver($docuname,$docudom);
1.637 raeburn 1442: $$fetchresult= &reply('fetchuserfile:'.$docudom.'/'.$docuname.'/'.$file,
1.638 albertel 1443: $home);
1.637 raeburn 1444: if ($$fetchresult eq 'ok') {
1445: return '/uploaded/'.$fpath.'/'.$fname;
1446: } else {
1.638 albertel 1447: &logthis('Failed to transfer '.$docudom.'/'.$docuname.'/'.$file.
1448: ' to host '.$home.': '.$$fetchresult);
1.637 raeburn 1449: return '/adm/notfound.html';
1450: }
1451: }
1452:
1.531 albertel 1453: sub clean_filename {
1.831 albertel 1454: my ($fname,$args)=@_;
1.315 www 1455: # Replace Windows backslashes by forward slashes
1.257 www 1456: $fname=~s/\\/\//g;
1.831 albertel 1457: if (!$args->{'keep_path'}) {
1458: # Get rid of everything but the actual filename
1459: $fname=~s/^.*\/([^\/]+)$/$1/;
1460: }
1.315 www 1461: # Replace spaces by underscores
1462: $fname=~s/\s+/\_/g;
1463: # Replace all other weird characters by nothing
1.831 albertel 1464: $fname=~s{[^/\w\.\-]}{}g;
1.540 albertel 1465: # Replace all .\d. sequences with _\d. so they no longer look like version
1466: # numbers
1467: $fname=~s/\.(\d+)(?=\.)/_$1/g;
1.531 albertel 1468: return $fname;
1469: }
1470:
1.608 albertel 1471: # --------------- Take an uploaded file and put it into the userfiles directory
1.686 albertel 1472: # input: $formname - the contents of the file are in $env{"form.$formname"}
1.719 banghart 1473: # the desired filenam is in $env{"form.$formname.filename"}
1.686 albertel 1474: # $coursedoc - if true up to the current course
1475: # if false
1476: # $subdir - directory in userfile to store the file into
1477: # $parser, $allfiles, $codebase - unknown
1478: #
1479: # output: url of file in userspace, or error: <message>
1480: # or /adm/notfound.html if failure to upload occurse
1.608 albertel 1481:
1482:
1.531 albertel 1483: sub userfileupload {
1.719 banghart 1484: my ($formname,$coursedoc,$subdir,$parser,$allfiles,$codebase,$destuname,$destudom)=@_;
1.531 albertel 1485: if (!defined($subdir)) { $subdir='unknown'; }
1.620 albertel 1486: my $fname=$env{'form.'.$formname.'.filename'};
1.531 albertel 1487: $fname=&clean_filename($fname);
1.315 www 1488: # See if there is anything left
1.257 www 1489: unless ($fname) { return 'error: no uploaded file'; }
1.620 albertel 1490: chop($env{'form.'.$formname});
1.523 raeburn 1491: if (($formname eq 'screenshot') && ($subdir eq 'helprequests')) { #files uploaded to help request form are handled differently
1492: my $now = time;
1493: my $filepath = 'tmp/helprequests/'.$now;
1494: my @parts=split(/\//,$filepath);
1495: my $fullpath = $perlvar{'lonDaemons'};
1496: for (my $i=0;$i<@parts;$i++) {
1497: $fullpath .= '/'.$parts[$i];
1498: if ((-e $fullpath)!=1) {
1499: mkdir($fullpath,0777);
1500: }
1501: }
1502: open(my $fh,'>'.$fullpath.'/'.$fname);
1.620 albertel 1503: print $fh $env{'form.'.$formname};
1.523 raeburn 1504: close($fh);
1.741 raeburn 1505: return $fullpath.'/'.$fname;
1506: } elsif (($formname eq 'coursecreatorxml') && ($subdir eq 'batchupload')) { #files uploaded to create course page are handled differently
1507: my $filepath = 'tmp/addcourse/'.$destudom.'/web/'.$env{'user.name'}.
1508: '_'.$env{'user.domain'}.'/pending';
1509: my @parts=split(/\//,$filepath);
1510: my $fullpath = $perlvar{'lonDaemons'};
1511: for (my $i=0;$i<@parts;$i++) {
1512: $fullpath .= '/'.$parts[$i];
1513: if ((-e $fullpath)!=1) {
1514: mkdir($fullpath,0777);
1515: }
1516: }
1517: open(my $fh,'>'.$fullpath.'/'.$fname);
1518: print $fh $env{'form.'.$formname};
1519: close($fh);
1520: return $fullpath.'/'.$fname;
1.523 raeburn 1521: }
1.719 banghart 1522:
1.258 www 1523: # Create the directory if not present
1.493 albertel 1524: $fname="$subdir/$fname";
1.259 www 1525: if ($coursedoc) {
1.638 albertel 1526: my $docuname=$env{'course.'.$env{'request.course.id'}.'.num'};
1527: my $docudom=$env{'course.'.$env{'request.course.id'}.'.domain'};
1.646 raeburn 1528: if ($env{'form.folder'} =~ m/^(default|supplemental)/) {
1.638 albertel 1529: return &finishuserfileupload($docuname,$docudom,
1530: $formname,$fname,$parser,$allfiles,
1531: $codebase);
1.481 raeburn 1532: } else {
1.620 albertel 1533: $fname=$env{'form.folder'}.'/'.$fname;
1.638 albertel 1534: return &process_coursefile('uploaddoc',$docuname,$docudom,
1535: $fname,$formname,$parser,
1536: $allfiles,$codebase);
1.481 raeburn 1537: }
1.719 banghart 1538: } elsif (defined($destuname)) {
1539: my $docuname=$destuname;
1540: my $docudom=$destudom;
1541: return &finishuserfileupload($docuname,$docudom,$formname,
1542: $fname,$parser,$allfiles,$codebase);
1543:
1.259 www 1544: } else {
1.638 albertel 1545: my $docuname=$env{'user.name'};
1546: my $docudom=$env{'user.domain'};
1.714 raeburn 1547: if (exists($env{'form.group'})) {
1548: $docuname=$env{'course.'.$env{'request.course.id'}.'.num'};
1549: $docudom=$env{'course.'.$env{'request.course.id'}.'.domain'};
1550: }
1.638 albertel 1551: return &finishuserfileupload($docuname,$docudom,$formname,
1552: $fname,$parser,$allfiles,$codebase);
1.259 www 1553: }
1.271 www 1554: }
1555:
1556: sub finishuserfileupload {
1.638 albertel 1557: my ($docuname,$docudom,$formname,$fname,$parser,$allfiles,$codebase) = @_;
1.477 raeburn 1558: my $path=$docudom.'/'.$docuname.'/';
1.258 www 1559: my $filepath=$perlvar{'lonDocRoot'};
1.494 albertel 1560: my ($fnamepath,$file);
1561: $file=$fname;
1562: if ($fname=~m|/|) {
1563: ($fnamepath,$file) = ($fname =~ m|^(.*)/([^/]+)$|);
1564: $path.=$fnamepath.'/';
1565: }
1.259 www 1566: my @parts=split(/\//,$filepath.'/userfiles/'.$path);
1.258 www 1567: my $count;
1568: for ($count=4;$count<=$#parts;$count++) {
1569: $filepath.="/$parts[$count]";
1570: if ((-e $filepath)!=1) {
1571: mkdir($filepath,0777);
1572: }
1573: }
1574: # Save the file
1575: {
1.701 albertel 1576: if (!open(FH,'>'.$filepath.'/'.$file)) {
1577: &logthis('Failed to create '.$filepath.'/'.$file);
1578: print STDERR ('Failed to create '.$filepath.'/'.$file."\n");
1579: return '/adm/notfound.html';
1580: }
1581: if (!print FH ($env{'form.'.$formname})) {
1582: &logthis('Failed to write to '.$filepath.'/'.$file);
1583: print STDERR ('Failed to write to '.$filepath.'/'.$file."\n");
1584: return '/adm/notfound.html';
1585: }
1.570 albertel 1586: close(FH);
1.258 www 1587: }
1.637 raeburn 1588: if ($parser eq 'parse') {
1.638 albertel 1589: my $parse_result = &extract_embedded_items($filepath,$file,$allfiles,
1590: $codebase);
1.637 raeburn 1591: unless ($parse_result eq 'ok') {
1.638 albertel 1592: &logthis('Failed to parse '.$filepath.$file.
1593: ' for embedded media: '.$parse_result);
1.637 raeburn 1594: }
1595: }
1.259 www 1596: # Notify homeserver to grep it
1597: #
1.638 albertel 1598: my $docuhome=&homeserver($docuname,$docudom);
1.494 albertel 1599: my $fetchresult= &reply('fetchuserfile:'.$path.$file,$docuhome);
1.295 www 1600: if ($fetchresult eq 'ok') {
1.259 www 1601: #
1.258 www 1602: # Return the URL to it
1.494 albertel 1603: return '/uploaded/'.$path.$file;
1.263 www 1604: } else {
1.494 albertel 1605: &logthis('Failed to transfer '.$path.$file.' to host '.$docuhome.
1606: ': '.$fetchresult);
1.263 www 1607: return '/adm/notfound.html';
1608: }
1.493 albertel 1609: }
1610:
1.637 raeburn 1611: sub extract_embedded_items {
1.648 raeburn 1612: my ($filepath,$file,$allfiles,$codebase,$content) = @_;
1.637 raeburn 1613: my @state = ();
1614: my %javafiles = (
1615: codebase => '',
1616: code => '',
1617: archive => ''
1618: );
1619: my %mediafiles = (
1620: src => '',
1621: movie => '',
1622: );
1.648 raeburn 1623: my $p;
1624: if ($content) {
1625: $p = HTML::LCParser->new($content);
1626: } else {
1627: $p = HTML::LCParser->new($filepath.'/'.$file);
1628: }
1.641 albertel 1629: while (my $t=$p->get_token()) {
1.640 albertel 1630: if ($t->[0] eq 'S') {
1631: my ($tagname, $attr) = ($t->[1],$t->[2]);
1632: push (@state, $tagname);
1.648 raeburn 1633: if (lc($tagname) eq 'allow') {
1634: &add_filetype($allfiles,$attr->{'src'},'src');
1635: }
1.640 albertel 1636: if (lc($tagname) eq 'img') {
1637: &add_filetype($allfiles,$attr->{'src'},'src');
1638: }
1.645 raeburn 1639: if (lc($tagname) eq 'script') {
1640: if ($attr->{'archive'} =~ /\.jar$/i) {
1641: &add_filetype($allfiles,$attr->{'archive'},'archive');
1642: } else {
1643: &add_filetype($allfiles,$attr->{'src'},'src');
1644: }
1645: }
1646: if (lc($tagname) eq 'link') {
1647: if (lc($attr->{'rel'}) eq 'stylesheet') {
1648: &add_filetype($allfiles,$attr->{'href'},'href');
1649: }
1650: }
1.640 albertel 1651: if (lc($tagname) eq 'object' ||
1652: (lc($tagname) eq 'embed' && lc($state[-2]) ne 'object')) {
1653: foreach my $item (keys(%javafiles)) {
1654: $javafiles{$item} = '';
1655: }
1656: }
1657: if (lc($state[-2]) eq 'object' && lc($tagname) eq 'param') {
1658: my $name = lc($attr->{'name'});
1659: foreach my $item (keys(%javafiles)) {
1660: if ($name eq $item) {
1661: $javafiles{$item} = $attr->{'value'};
1662: last;
1663: }
1664: }
1665: foreach my $item (keys(%mediafiles)) {
1666: if ($name eq $item) {
1667: &add_filetype($allfiles, $attr->{'value'}, 'value');
1668: last;
1669: }
1670: }
1671: }
1672: if (lc($tagname) eq 'embed' || lc($tagname) eq 'applet') {
1673: foreach my $item (keys(%javafiles)) {
1674: if ($attr->{$item}) {
1675: $javafiles{$item} = $attr->{$item};
1676: last;
1677: }
1678: }
1679: foreach my $item (keys(%mediafiles)) {
1680: if ($attr->{$item}) {
1681: &add_filetype($allfiles,$attr->{$item},$item);
1682: last;
1683: }
1684: }
1685: }
1686: } elsif ($t->[0] eq 'E') {
1687: my ($tagname) = ($t->[1]);
1688: if ($javafiles{'codebase'} ne '') {
1689: $javafiles{'codebase'} .= '/';
1690: }
1691: if (lc($tagname) eq 'applet' ||
1692: lc($tagname) eq 'object' ||
1693: (lc($tagname) eq 'embed' && lc($state[-2]) ne 'object')
1694: ) {
1695: foreach my $item (keys(%javafiles)) {
1696: if ($item ne 'codebase' && $javafiles{$item} ne '') {
1697: my $file=$javafiles{'codebase'}.$javafiles{$item};
1698: &add_filetype($allfiles,$file,$item);
1699: }
1700: }
1701: }
1702: pop @state;
1703: }
1704: }
1.637 raeburn 1705: return 'ok';
1706: }
1707:
1.639 albertel 1708: sub add_filetype {
1709: my ($allfiles,$file,$type)=@_;
1710: if (exists($allfiles->{$file})) {
1711: unless (grep/^\Q$type\E$/, @{$allfiles->{$file}}) {
1712: push(@{$allfiles->{$file}}, &escape($type));
1713: }
1714: } else {
1715: @{$allfiles->{$file}} = (&escape($type));
1.637 raeburn 1716: }
1717: }
1718:
1.493 albertel 1719: sub removeuploadedurl {
1720: my ($url)=@_;
1721: my (undef,undef,$udom,$uname,$fname)=split('/',$url,5);
1.613 albertel 1722: return &removeuserfile($uname,$udom,$fname);
1.490 albertel 1723: }
1724:
1725: sub removeuserfile {
1726: my ($docuname,$docudom,$fname)=@_;
1727: my $home=&homeserver($docuname,$docudom);
1.798 raeburn 1728: my $result = &reply("removeuserfile:$docudom/$docuname/$fname",$home);
1729: if ($result eq 'ok') {
1730: if (($fname !~ /\.meta$/) && (&is_portfolio_file($fname))) {
1731: my $metafile = $fname.'.meta';
1732: my $metaresult = &removeuserfile($docuname,$docudom,$metafile);
1.823 albertel 1733: my $url = "/uploaded/$docudom/$docuname/$fname";
1734: my ($file,$group) = (&parse_portfolio_url($url))[3,4];
1.821 raeburn 1735: my $sqlresult =
1.823 albertel 1736: &update_portfolio_table($docuname,$docudom,$file,
1.821 raeburn 1737: 'portfolio_metadata',$group,
1738: 'delete');
1.798 raeburn 1739: }
1740: }
1741: return $result;
1.257 www 1742: }
1.15 www 1743:
1.530 albertel 1744: sub mkdiruserfile {
1745: my ($docuname,$docudom,$dir)=@_;
1746: my $home=&homeserver($docuname,$docudom);
1747: return &reply("mkdiruserfile:".&escape("$docudom/$docuname/$dir"),$home);
1748: }
1749:
1.531 albertel 1750: sub renameuserfile {
1751: my ($docuname,$docudom,$old,$new)=@_;
1752: my $home=&homeserver($docuname,$docudom);
1.798 raeburn 1753: my $result = &reply("renameuserfile:$docudom:$docuname:".
1754: &escape("$old").':'.&escape("$new"),$home);
1755: if ($result eq 'ok') {
1756: if (($old !~ /\.meta$/) && (&is_portfolio_file($old))) {
1757: my $oldmeta = $old.'.meta';
1758: my $newmeta = $new.'.meta';
1759: my $metaresult =
1760: &renameuserfile($docuname,$docudom,$oldmeta,$newmeta);
1.823 albertel 1761: my $url = "/uploaded/$docudom/$docuname/$old";
1762: my ($file,$group) = (&parse_portfolio_url($url))[3,4];
1.821 raeburn 1763: my $sqlresult =
1.823 albertel 1764: &update_portfolio_table($docuname,$docudom,$file,
1.821 raeburn 1765: 'portfolio_metadata',$group,
1766: 'delete');
1.798 raeburn 1767: }
1768: }
1769: return $result;
1.531 albertel 1770: }
1771:
1.14 www 1772: # ------------------------------------------------------------------------- Log
1773:
1774: sub log {
1775: my ($dom,$nam,$hom,$what)=@_;
1.47 www 1776: return critical("log:$dom:$nam:$what",$hom);
1.157 www 1777: }
1778:
1779: # ------------------------------------------------------------------ Course Log
1.352 www 1780: #
1781: # This routine flushes several buffers of non-mission-critical nature
1782: #
1.157 www 1783:
1784: sub flushcourselogs {
1.352 www 1785: &logthis('Flushing log buffers');
1786: #
1787: # course logs
1788: # This is a log of all transactions in a course, which can be used
1789: # for data mining purposes
1790: #
1791: # It also collects the courseid database, which lists last transaction
1792: # times and course titles for all courseids
1793: #
1794: my %courseidbuffer=();
1.800 albertel 1795: foreach my $crsid (keys %courselogs) {
1.352 www 1796: if (&reply('log:'.$coursedombuf{$crsid}.':'.$coursenumbuf{$crsid}.':'.
1.188 www 1797: &escape($courselogs{$crsid}),
1798: $coursehombuf{$crsid}) eq 'ok') {
1.157 www 1799: delete $courselogs{$crsid};
1800: } else {
1801: &logthis('Failed to flush log buffer for '.$crsid);
1802: if (length($courselogs{$crsid})>40000) {
1.672 albertel 1803: &logthis("<font color=\"blue\">WARNING: Buffer for ".$crsid.
1.157 www 1804: " exceeded maximum size, deleting.</font>");
1805: delete $courselogs{$crsid};
1806: }
1.352 www 1807: }
1808: if ($courseidbuffer{$coursehombuf{$crsid}}) {
1809: $courseidbuffer{$coursehombuf{$crsid}}.='&'.
1.516 raeburn 1810: &escape($crsid).'='.&escape($coursedescrbuf{$crsid}).
1.741 raeburn 1811: ':'.&escape($courseinstcodebuf{$crsid}).':'.&escape($courseownerbuf{$crsid}).':'.&escape($coursetypebuf{$crsid});
1.352 www 1812: } else {
1813: $courseidbuffer{$coursehombuf{$crsid}}=
1.516 raeburn 1814: &escape($crsid).'='.&escape($coursedescrbuf{$crsid}).
1.741 raeburn 1815: ':'.&escape($courseinstcodebuf{$crsid}).':'.&escape($courseownerbuf{$crsid}).':'.&escape($coursetypebuf{$crsid});
1.571 raeburn 1816: }
1.191 harris41 1817: }
1.352 www 1818: #
1819: # Write course id database (reverse lookup) to homeserver of courses
1820: # Is used in pickcourse
1821: #
1.800 albertel 1822: foreach my $crsid (keys(%courseidbuffer)) {
1823: &courseidput($hostdom{$crsid},$courseidbuffer{$crsid},$crsid);
1.352 www 1824: }
1825: #
1826: # File accesses
1827: # Writes to the dynamic metadata of resources to get hit counts, etc.
1828: #
1.449 matthew 1829: foreach my $entry (keys(%accesshash)) {
1.458 matthew 1830: if ($entry =~ /___count$/) {
1831: my ($dom,$name);
1.807 albertel 1832: ($dom,$name,undef)=
1.811 albertel 1833: ($entry=~m{___($match_domain)/($match_name)/(.*)___count$});
1.458 matthew 1834: if (! defined($dom) || $dom eq '' ||
1835: ! defined($name) || $name eq '') {
1.620 albertel 1836: my $cid = $env{'request.course.id'};
1837: $dom = $env{'request.'.$cid.'.domain'};
1838: $name = $env{'request.'.$cid.'.num'};
1.458 matthew 1839: }
1.450 matthew 1840: my $value = $accesshash{$entry};
1841: my (undef,$url,undef) = ($entry =~ /^(.*)___(.*)___count$/);
1842: my %temphash=($url => $value);
1.449 matthew 1843: my $result = &inc('nohist_accesscount',\%temphash,$dom,$name);
1844: if ($result eq 'ok') {
1845: delete $accesshash{$entry};
1846: } elsif ($result eq 'unknown_cmd') {
1847: # Target server has old code running on it.
1.450 matthew 1848: my %temphash=($entry => $value);
1.449 matthew 1849: if (&put('nohist_resevaldata',\%temphash,$dom,$name) eq 'ok') {
1850: delete $accesshash{$entry};
1851: }
1852: }
1853: } else {
1.811 albertel 1854: my ($dom,$name) = ($entry=~m{___($match_domain)/($match_name)/(.*)___(\w+)$});
1.450 matthew 1855: my %temphash=($entry => $accesshash{$entry});
1.449 matthew 1856: if (&put('nohist_resevaldata',\%temphash,$dom,$name) eq 'ok') {
1857: delete $accesshash{$entry};
1858: }
1.185 www 1859: }
1.191 harris41 1860: }
1.352 www 1861: #
1862: # Roles
1863: # Reverse lookup of user roles for course faculty/staff and co-authorship
1864: #
1.800 albertel 1865: foreach my $entry (keys(%userrolehash)) {
1.351 www 1866: my ($role,$uname,$udom,$runame,$rudom,$rsec)=
1.349 www 1867: split(/\:/,$entry);
1868: if (&Apache::lonnet::put('nohist_userroles',
1.351 www 1869: { $role.':'.$uname.':'.$udom.':'.$rsec => $userrolehash{$entry} },
1.349 www 1870: $rudom,$runame) eq 'ok') {
1871: delete $userrolehash{$entry};
1872: }
1873: }
1.662 raeburn 1874: #
1875: # Reverse lookup of domain roles (dc, ad, li, sc, au)
1876: #
1877: my %domrolebuffer = ();
1878: foreach my $entry (keys %domainrolehash) {
1879: my ($role,$uname,$udom,$runame,$rudom,$rsec)=split/:/,$entry;
1880: if ($domrolebuffer{$rudom}) {
1881: $domrolebuffer{$rudom}.='&'.&escape($entry).
1882: '='.&escape($domainrolehash{$entry});
1883: } else {
1884: $domrolebuffer{$rudom}.=&escape($entry).
1885: '='.&escape($domainrolehash{$entry});
1886: }
1887: delete $domainrolehash{$entry};
1888: }
1889: foreach my $dom (keys(%domrolebuffer)) {
1890: foreach my $tryserver (keys %libserv) {
1891: if ($hostdom{$tryserver} eq $dom) {
1892: unless (&reply('domroleput:'.$dom.':'.
1893: $domrolebuffer{$dom},$tryserver) eq 'ok') {
1894: &logthis('Put of domain roles failed for '.$dom.' and '.$tryserver);
1895: }
1896: }
1897: }
1898: }
1.186 www 1899: $dumpcount++;
1.157 www 1900: }
1901:
1902: sub courselog {
1903: my $what=shift;
1.158 www 1904: $what=time.':'.$what;
1.620 albertel 1905: unless ($env{'request.course.id'}) { return ''; }
1906: $coursedombuf{$env{'request.course.id'}}=
1907: $env{'course.'.$env{'request.course.id'}.'.domain'};
1908: $coursenumbuf{$env{'request.course.id'}}=
1909: $env{'course.'.$env{'request.course.id'}.'.num'};
1910: $coursehombuf{$env{'request.course.id'}}=
1911: $env{'course.'.$env{'request.course.id'}.'.home'};
1912: $coursedescrbuf{$env{'request.course.id'}}=
1913: $env{'course.'.$env{'request.course.id'}.'.description'};
1914: $courseinstcodebuf{$env{'request.course.id'}}=
1915: $env{'course.'.$env{'request.course.id'}.'.internal.coursecode'};
1916: $courseownerbuf{$env{'request.course.id'}}=
1917: $env{'course.'.$env{'request.course.id'}.'.internal.courseowner'};
1.741 raeburn 1918: $coursetypebuf{$env{'request.course.id'}}=
1919: $env{'course.'.$env{'request.course.id'}.'.type'};
1.620 albertel 1920: if (defined $courselogs{$env{'request.course.id'}}) {
1921: $courselogs{$env{'request.course.id'}}.='&'.$what;
1.157 www 1922: } else {
1.620 albertel 1923: $courselogs{$env{'request.course.id'}}.=$what;
1.157 www 1924: }
1.620 albertel 1925: if (length($courselogs{$env{'request.course.id'}})>4048) {
1.157 www 1926: &flushcourselogs();
1927: }
1.158 www 1928: }
1929:
1930: sub courseacclog {
1931: my $fnsymb=shift;
1.620 albertel 1932: unless ($env{'request.course.id'}) { return ''; }
1933: my $what=$fnsymb.':'.$env{'user.name'}.':'.$env{'user.domain'};
1.657 albertel 1934: if ($fnsymb=~/(problem|exam|quiz|assess|survey|form|task|page)$/) {
1.187 www 1935: $what.=':POST';
1.583 matthew 1936: # FIXME: Probably ought to escape things....
1.800 albertel 1937: foreach my $key (keys(%env)) {
1938: if ($key=~/^form\.(.*)/) {
1939: $what.=':'.$1.'='.$env{$key};
1.158 www 1940: }
1.191 harris41 1941: }
1.583 matthew 1942: } elsif ($fnsymb =~ m:^/adm/searchcat:) {
1943: # FIXME: We should not be depending on a form parameter that someone
1944: # editing lonsearchcat.pm might change in the future.
1.620 albertel 1945: if ($env{'form.phase'} eq 'course_search') {
1.583 matthew 1946: $what.= ':POST';
1947: # FIXME: Probably ought to escape things....
1948: foreach my $element ('courseexp','crsfulltext','crsrelated',
1949: 'crsdiscuss') {
1.620 albertel 1950: $what.=':'.$element.'='.$env{'form.'.$element};
1.583 matthew 1951: }
1952: }
1.158 www 1953: }
1954: &courselog($what);
1.149 www 1955: }
1956:
1.185 www 1957: sub countacc {
1958: my $url=&declutter(shift);
1.458 matthew 1959: return if (! defined($url) || $url eq '');
1.620 albertel 1960: unless ($env{'request.course.id'}) { return ''; }
1961: $accesshash{$env{'request.course.id'}.'___'.$url.'___course'}=1;
1.281 www 1962: my $key=$$.$processmarker.'_'.$dumpcount.'___'.$url.'___count';
1.450 matthew 1963: $accesshash{$key}++;
1.185 www 1964: }
1.349 www 1965:
1.361 www 1966: sub linklog {
1967: my ($from,$to)=@_;
1968: $from=&declutter($from);
1969: $to=&declutter($to);
1970: $accesshash{$from.'___'.$to.'___comefrom'}=1;
1971: $accesshash{$to.'___'.$from.'___goto'}=1;
1972: }
1973:
1.349 www 1974: sub userrolelog {
1975: my ($trole,$username,$domain,$area,$tstart,$tend)=@_;
1.661 raeburn 1976: if (($trole=~/^ca/) || ($trole=~/^aa/) ||
1.662 raeburn 1977: ($trole=~/^in/) || ($trole=~/^cc/) ||
1.661 raeburn 1978: ($trole=~/^ep/) || ($trole=~/^cr/) ||
1979: ($trole=~/^ta/)) {
1.350 www 1980: my (undef,$rudom,$runame,$rsec)=split(/\//,$area);
1981: $userrolehash
1982: {$trole.':'.$username.':'.$domain.':'.$runame.':'.$rudom.':'.$rsec}
1.349 www 1983: =$tend.':'.$tstart;
1.662 raeburn 1984: }
1985: if (($trole=~/^dc/) || ($trole=~/^ad/) ||
1986: ($trole=~/^li/) || ($trole=~/^li/) ||
1987: ($trole=~/^au/) || ($trole=~/^dg/) ||
1988: ($trole=~/^sc/)) {
1989: my (undef,$rudom,$runame,$rsec)=split(/\//,$area);
1990: $domainrolehash
1991: {$trole.':'.$username.':'.$domain.':'.$runame.':'.$rudom.':'.$rsec}
1992: = $tend.':'.$tstart;
1993: }
1.351 www 1994: }
1995:
1996: sub get_course_adv_roles {
1997: my $cid=shift;
1.620 albertel 1998: $cid=$env{'request.course.id'} unless (defined($cid));
1.351 www 1999: my %coursehash=&coursedescription($cid);
1.470 www 2000: my %nothide=();
1.800 albertel 2001: foreach my $user (split(/\s*\,\s*/,$coursehash{'nothideprivileged'})) {
2002: $nothide{join(':',split(/[\@\:]/,$user))}=1;
1.470 www 2003: }
1.351 www 2004: my %returnhash=();
2005: my %dumphash=
2006: &dump('nohist_userroles',$coursehash{'domain'},$coursehash{'num'});
2007: my $now=time;
1.800 albertel 2008: foreach my $entry (keys %dumphash) {
2009: my ($tend,$tstart)=split(/\:/,$dumphash{$entry});
1.351 www 2010: if (($tstart) && ($tstart<0)) { next; }
2011: if (($tend) && ($tend<$now)) { next; }
2012: if (($tstart) && ($now<$tstart)) { next; }
1.800 albertel 2013: my ($role,$username,$domain,$section)=split(/\:/,$entry);
1.576 albertel 2014: if ($username eq '' || $domain eq '') { next; }
1.470 www 2015: if ((&privileged($username,$domain)) &&
2016: (!$nothide{$username.':'.$domain})) { next; }
1.656 albertel 2017: if ($role eq 'cr') { next; }
1.351 www 2018: my $key=&plaintext($role);
2019: if ($section) { $key.=' (Sec/Grp '.$section.')'; }
2020: if ($returnhash{$key}) {
2021: $returnhash{$key}.=','.$username.':'.$domain;
2022: } else {
2023: $returnhash{$key}=$username.':'.$domain;
2024: }
1.400 www 2025: }
2026: return %returnhash;
2027: }
2028:
2029: sub get_my_roles {
1.832 raeburn 2030: my ($uname,$udom,$types,$roles,$roledoms)=@_;
1.620 albertel 2031: unless (defined($uname)) { $uname=$env{'user.name'}; }
2032: unless (defined($udom)) { $udom=$env{'user.domain'}; }
1.400 www 2033: my %dumphash=
2034: &dump('nohist_userroles',$udom,$uname);
2035: my %returnhash=();
2036: my $now=time;
1.800 albertel 2037: foreach my $entry (keys(%dumphash)) {
2038: my ($tend,$tstart)=split(/\:/,$dumphash{$entry});
1.400 www 2039: if (($tstart) && ($tstart<0)) { next; }
1.832 raeburn 2040: my $status = 'active';
2041: if (($tend) && ($tend<$now)) {
2042: $status = 'previous';
2043: }
2044: if (($tstart) && ($now<$tstart)) {
2045: $status = 'future';
2046: }
2047: if (ref($types) eq 'ARRAY') {
2048: if (!grep(/^\Q$status\E$/,@{$types})) {
2049: next;
2050: }
2051: } else {
2052: if ($status ne 'active') {
2053: next;
2054: }
2055: }
1.800 albertel 2056: my ($role,$username,$domain,$section)=split(/\:/,$entry);
1.832 raeburn 2057: if (ref($roledoms) eq 'ARRAY') {
2058: if (!grep(/^\Q$domain\E$/,@{$roledoms})) {
2059: next;
2060: }
2061: }
2062: if (ref($roles) eq 'ARRAY') {
2063: if (!grep(/^\Q$role\E$/,@{$roles})) {
2064: next;
2065: }
2066: }
1.400 www 2067: $returnhash{$username.':'.$domain.':'.$role}=$tstart.':'.$tend;
1.832 raeburn 2068: }
1.373 www 2069: return %returnhash;
1.399 www 2070: }
2071:
2072: # ----------------------------------------------------- Frontpage Announcements
2073: #
2074: #
2075:
2076: sub postannounce {
2077: my ($server,$text)=@_;
2078: unless (&allowed('psa',$hostdom{$server})) { return 'refused'; }
2079: unless ($text=~/\w/) { $text=''; }
2080: return &reply('setannounce:'.&escape($text),$server);
2081: }
2082:
2083: sub getannounce {
1.448 albertel 2084:
2085: if (open(my $fh,$perlvar{'lonDocRoot'}.'/announcement.txt')) {
1.399 www 2086: my $announcement='';
1.800 albertel 2087: while (my $line = <$fh>) { $announcement .= $line; }
1.448 albertel 2088: close($fh);
1.399 www 2089: if ($announcement=~/\w/) {
2090: return
2091: '<table bgcolor="#FF5555" cellpadding="5" cellspacing="3">'.
1.518 albertel 2092: '<tr><td bgcolor="#FFFFFF"><tt>'.$announcement.'</tt></td></tr></table>';
1.399 www 2093: } else {
2094: return '';
2095: }
2096: } else {
2097: return '';
2098: }
1.351 www 2099: }
1.353 www 2100:
2101: # ---------------------------------------------------------- Course ID routines
2102: # Deal with domain's nohist_courseid.db files
2103: #
2104:
2105: sub courseidput {
2106: my ($domain,$what,$coursehome)=@_;
2107: return &reply('courseidput:'.$domain.':'.$what,$coursehome);
2108: }
2109:
2110: sub courseiddump {
1.791 raeburn 2111: my ($domfilter,$descfilter,$sincefilter,$instcodefilter,$ownerfilter,$coursefilter,$hostidflag,$hostidref,$typefilter,$regexp_ok)=@_;
1.353 www 2112: my %returnhash=();
1.355 www 2113: unless ($domfilter) { $domfilter=''; }
1.353 www 2114: foreach my $tryserver (keys %libserv) {
1.511 raeburn 2115: if ( ($hostidflag == 1 && grep/^$tryserver$/,@{$hostidref}) || (!defined($hostidflag)) ) {
1.506 raeburn 2116: if ((!$domfilter) || ($hostdom{$tryserver} eq $domfilter)) {
1.800 albertel 2117: foreach my $line (
1.506 raeburn 2118: split(/\&/,&reply('courseiddump:'.$hostdom{$tryserver}.':'.
1.571 raeburn 2119: $sincefilter.':'.&escape($descfilter).':'.
1.791 raeburn 2120: &escape($instcodefilter).':'.&escape($ownerfilter).':'.&escape($coursefilter).':'.&escape($typefilter).':'.&escape($regexp_ok),
1.354 www 2121: $tryserver))) {
1.800 albertel 2122: my ($key,$value)=split(/\=/,$line,2);
1.506 raeburn 2123: if (($key) && ($value)) {
1.516 raeburn 2124: $returnhash{&unescape($key)}=$value;
1.506 raeburn 2125: }
1.353 www 2126: }
2127: }
2128: }
2129: }
2130: return %returnhash;
2131: }
2132:
1.658 raeburn 2133: # ---------------------------------------------------------- DC e-mail
1.662 raeburn 2134:
2135: sub dcmailput {
1.685 raeburn 2136: my ($domain,$msgid,$message,$server)=@_;
1.662 raeburn 2137: my $status = &Apache::lonnet::critical(
1.740 www 2138: 'dcmailput:'.$domain.':'.&escape($msgid).'='.
2139: &escape($message),$server);
1.662 raeburn 2140: return $status;
2141: }
2142:
1.658 raeburn 2143: sub dcmaildump {
2144: my ($dom,$startdate,$enddate,$senders) = @_;
1.685 raeburn 2145: my %returnhash=();
2146: if (exists($domain_primary{$dom})) {
2147: my $cmd='dcmaildump:'.$dom.':'.&escape($startdate).':'.
2148: &escape($enddate).':';
2149: my @esc_senders=map { &escape($_)} @$senders;
2150: $cmd.=&escape(join('&',@esc_senders));
1.800 albertel 2151: foreach my $line (split(/\&/,&reply($cmd,$domain_primary{$dom}))) {
2152: my ($key,$value) = split(/\=/,$line,2);
1.685 raeburn 2153: if (($key) && ($value)) {
2154: $returnhash{&unescape($key)} = &unescape($value);
1.658 raeburn 2155: }
2156: }
2157: }
2158: return %returnhash;
2159: }
1.662 raeburn 2160: # ---------------------------------------------------------- Domain roles
2161:
2162: sub get_domain_roles {
2163: my ($dom,$roles,$startdate,$enddate)=@_;
2164: if (undef($startdate) || $startdate eq '') {
2165: $startdate = '.';
2166: }
2167: if (undef($enddate) || $enddate eq '') {
2168: $enddate = '.';
2169: }
2170: my $rolelist = join(':',@{$roles});
2171: my %personnel = ();
2172: foreach my $tryserver (keys(%libserv)) {
2173: if ($hostdom{$tryserver} eq $dom) {
2174: %{$personnel{$tryserver}}=();
1.800 albertel 2175: foreach my $line (
1.662 raeburn 2176: split(/\&/,&reply('domrolesdump:'.$dom.':'.
2177: &escape($startdate).':'.&escape($enddate).':'.
2178: &escape($rolelist), $tryserver))) {
1.800 albertel 2179: my ($key,$value) = split(/\=/,$line,2);
1.662 raeburn 2180: if (($key) && ($value)) {
2181: $personnel{$tryserver}{&unescape($key)} = &unescape($value);
2182: }
2183: }
2184: }
2185: }
2186: return %personnel;
2187: }
1.658 raeburn 2188:
1.149 www 2189: # ----------------------------------------------------------- Check out an item
2190:
1.504 albertel 2191: sub get_first_access {
2192: my ($type,$argsymb)=@_;
1.790 albertel 2193: my ($symb,$courseid,$udom,$uname)=&whichuser();
1.504 albertel 2194: if ($argsymb) { $symb=$argsymb; }
2195: my ($map,$id,$res)=&decode_symb($symb);
1.588 albertel 2196: if ($type eq 'map') {
2197: $res=&symbread($map);
2198: } else {
2199: $res=$symb;
2200: }
2201: my %times=&get('firstaccesstimes',["$courseid\0$res"],$udom,$uname);
2202: return $times{"$courseid\0$res"};
1.504 albertel 2203: }
2204:
2205: sub set_first_access {
2206: my ($type)=@_;
1.790 albertel 2207: my ($symb,$courseid,$udom,$uname)=&whichuser();
1.504 albertel 2208: my ($map,$id,$res)=&decode_symb($symb);
1.588 albertel 2209: if ($type eq 'map') {
2210: $res=&symbread($map);
2211: } else {
2212: $res=$symb;
2213: }
2214: my $firstaccess=&get_first_access($type,$symb);
1.505 albertel 2215: if (!$firstaccess) {
1.588 albertel 2216: return &put('firstaccesstimes',{"$courseid\0$res"=>time},$udom,$uname);
1.505 albertel 2217: }
2218: return 'already_set';
1.504 albertel 2219: }
2220:
1.149 www 2221: sub checkout {
2222: my ($symb,$tuname,$tudom,$tcrsid)=@_;
2223: my $now=time;
2224: my $lonhost=$perlvar{'lonHostID'};
2225: my $infostr=&escape(
1.234 www 2226: 'CHECKOUTTOKEN&'.
1.149 www 2227: $tuname.'&'.
2228: $tudom.'&'.
2229: $tcrsid.'&'.
2230: $symb.'&'.
2231: $now.'&'.$ENV{'REMOTE_ADDR'});
2232: my $token=&reply('tmpput:'.$infostr,$lonhost);
1.151 www 2233: if ($token=~/^error\:/) {
1.672 albertel 2234: &logthis("<font color=\"blue\">WARNING: ".
1.151 www 2235: "Checkout tmpput failed ".$tudom.' - '.$tuname.' - '.$symb.
2236: "</font>");
2237: return '';
2238: }
2239:
1.149 www 2240: $token=~s/^(\d+)\_.*\_(\d+)$/$1\*$2\*$lonhost/;
2241: $token=~tr/a-z/A-Z/;
2242:
1.153 www 2243: my %infohash=('resource.0.outtoken' => $token,
2244: 'resource.0.checkouttime' => $now,
2245: 'resource.0.outremote' => $ENV{'REMOTE_ADDR'});
1.149 www 2246:
2247: unless (&cstore(\%infohash,$symb,$tcrsid,$tudom,$tuname) eq 'ok') {
2248: return '';
1.151 www 2249: } else {
1.672 albertel 2250: &logthis("<font color=\"blue\">WARNING: ".
1.151 www 2251: "Checkout cstore failed ".$tudom.' - '.$tuname.' - '.$symb.
2252: "</font>");
1.149 www 2253: }
2254:
2255: if (&log($tudom,$tuname,&homeserver($tuname,$tudom),
2256: &escape('Checkout '.$infostr.' - '.
2257: $token)) ne 'ok') {
2258: return '';
1.151 www 2259: } else {
1.672 albertel 2260: &logthis("<font color=\"blue\">WARNING: ".
1.151 www 2261: "Checkout log failed ".$tudom.' - '.$tuname.' - '.$symb.
2262: "</font>");
1.149 www 2263: }
1.151 www 2264: return $token;
1.149 www 2265: }
2266:
2267: # ------------------------------------------------------------ Check in an item
2268:
2269: sub checkin {
2270: my $token=shift;
1.150 www 2271: my $now=time;
2272: my ($ta,$tb,$lonhost)=split(/\*/,$token);
2273: $lonhost=~tr/A-Z/a-z/;
1.595 albertel 2274: my $dtoken=$ta.'_'.$hostname{$lonhost}.'_'.$tb;
1.150 www 2275: $dtoken=~s/\W/\_/g;
1.234 www 2276: my ($dummy,$tuname,$tudom,$tcrsid,$symb,$chtim,$rmaddr)=
1.150 www 2277: split(/\&/,&unescape(&reply('tmpget:'.$dtoken,$lonhost)));
2278:
1.154 www 2279: unless (($tuname) && ($tudom)) {
2280: &logthis('Check in '.$token.' ('.$dtoken.') failed');
2281: return '';
2282: }
2283:
2284: unless (&allowed('mgr',$tcrsid)) {
2285: &logthis('Check in '.$token.' ('.$dtoken.') unauthorized: '.
1.620 albertel 2286: $env{'user.name'}.' - '.$env{'user.domain'});
1.154 www 2287: return '';
2288: }
2289:
1.153 www 2290: my %infohash=('resource.0.intoken' => $token,
2291: 'resource.0.checkintime' => $now,
2292: 'resource.0.inremote' => $ENV{'REMOTE_ADDR'});
1.150 www 2293:
2294: unless (&cstore(\%infohash,$symb,$tcrsid,$tudom,$tuname) eq 'ok') {
2295: return '';
2296: }
2297:
2298: if (&log($tudom,$tuname,&homeserver($tuname,$tudom),
2299: &escape('Checkin - '.$token)) ne 'ok') {
2300: return '';
2301: }
2302:
2303: return ($symb,$tuname,$tudom,$tcrsid);
1.110 www 2304: }
2305:
2306: # --------------------------------------------- Set Expire Date for Spreadsheet
2307:
2308: sub expirespread {
2309: my ($uname,$udom,$stype,$usymb)=@_;
1.620 albertel 2310: my $cid=$env{'request.course.id'};
1.110 www 2311: if ($cid) {
2312: my $now=time;
2313: my $key=$uname.':'.$udom.':'.$stype.':'.$usymb;
1.620 albertel 2314: return &reply('put:'.$env{'course.'.$cid.'.domain'}.':'.
2315: $env{'course.'.$cid.'.num'}.
1.110 www 2316: ':nohist_expirationdates:'.
2317: &escape($key).'='.$now,
1.620 albertel 2318: $env{'course.'.$cid.'.home'})
1.110 www 2319: }
2320: return 'ok';
1.14 www 2321: }
2322:
1.109 www 2323: # ----------------------------------------------------- Devalidate Spreadsheets
2324:
2325: sub devalidate {
1.325 www 2326: my ($symb,$uname,$udom)=@_;
1.620 albertel 2327: my $cid=$env{'request.course.id'};
1.109 www 2328: if ($cid) {
1.391 matthew 2329: # delete the stored spreadsheets for
2330: # - the student level sheet of this user in course's homespace
2331: # - the assessment level sheet for this resource
2332: # for this user in user's homespace
1.553 albertel 2333: # - current conditional state info
1.325 www 2334: my $key=$uname.':'.$udom.':';
1.109 www 2335: my $status=
1.299 matthew 2336: &del('nohist_calculatedsheets',
1.391 matthew 2337: [$key.'studentcalc:'],
1.620 albertel 2338: $env{'course.'.$cid.'.domain'},
2339: $env{'course.'.$cid.'.num'})
1.133 albertel 2340: .' '.
2341: &del('nohist_calculatedsheets_'.$cid,
1.391 matthew 2342: [$key.'assesscalc:'.$symb],$udom,$uname);
1.109 www 2343: unless ($status eq 'ok ok') {
2344: &logthis('Could not devalidate spreadsheet '.
1.325 www 2345: $uname.' at '.$udom.' for '.
1.109 www 2346: $symb.': '.$status);
1.133 albertel 2347: }
1.553 albertel 2348: &delenv('user.state.'.$cid);
1.109 www 2349: }
2350: }
2351:
1.265 albertel 2352: sub get_scalar {
2353: my ($string,$end) = @_;
2354: my $value;
2355: if ($$string =~ s/^([^&]*?)($end)/$2/) {
2356: $value = $1;
2357: } elsif ($$string =~ s/^([^&]*?)&//) {
2358: $value = $1;
2359: }
2360: return &unescape($value);
2361: }
2362:
2363: sub array2str {
2364: my (@array) = @_;
2365: my $result=&arrayref2str(\@array);
2366: $result=~s/^__ARRAY_REF__//;
2367: $result=~s/__END_ARRAY_REF__$//;
2368: return $result;
2369: }
2370:
1.204 albertel 2371: sub arrayref2str {
2372: my ($arrayref) = @_;
1.265 albertel 2373: my $result='__ARRAY_REF__';
1.204 albertel 2374: foreach my $elem (@$arrayref) {
1.265 albertel 2375: if(ref($elem) eq 'ARRAY') {
2376: $result.=&arrayref2str($elem).'&';
2377: } elsif(ref($elem) eq 'HASH') {
2378: $result.=&hashref2str($elem).'&';
2379: } elsif(ref($elem)) {
2380: #print("Got a ref of ".(ref($elem))." skipping.");
1.204 albertel 2381: } else {
2382: $result.=&escape($elem).'&';
2383: }
2384: }
2385: $result=~s/\&$//;
1.265 albertel 2386: $result .= '__END_ARRAY_REF__';
1.204 albertel 2387: return $result;
2388: }
2389:
1.168 albertel 2390: sub hash2str {
1.204 albertel 2391: my (%hash) = @_;
2392: my $result=&hashref2str(\%hash);
1.265 albertel 2393: $result=~s/^__HASH_REF__//;
2394: $result=~s/__END_HASH_REF__$//;
1.204 albertel 2395: return $result;
2396: }
2397:
2398: sub hashref2str {
2399: my ($hashref)=@_;
1.265 albertel 2400: my $result='__HASH_REF__';
1.800 albertel 2401: foreach my $key (sort(keys(%$hashref))) {
2402: if (ref($key) eq 'ARRAY') {
2403: $result.=&arrayref2str($key).'=';
2404: } elsif (ref($key) eq 'HASH') {
2405: $result.=&hashref2str($key).'=';
2406: } elsif (ref($key)) {
1.265 albertel 2407: $result.='=';
1.800 albertel 2408: #print("Got a ref of ".(ref($key))." skipping.");
1.204 albertel 2409: } else {
1.800 albertel 2410: if ($key) {$result.=&escape($key).'=';} else { last; }
1.204 albertel 2411: }
2412:
1.800 albertel 2413: if(ref($hashref->{$key}) eq 'ARRAY') {
2414: $result.=&arrayref2str($hashref->{$key}).'&';
2415: } elsif(ref($hashref->{$key}) eq 'HASH') {
2416: $result.=&hashref2str($hashref->{$key}).'&';
2417: } elsif(ref($hashref->{$key})) {
1.265 albertel 2418: $result.='&';
1.800 albertel 2419: #print("Got a ref of ".(ref($hashref->{$key}))." skipping.");
1.204 albertel 2420: } else {
1.800 albertel 2421: $result.=&escape($hashref->{$key}).'&';
1.204 albertel 2422: }
2423: }
1.168 albertel 2424: $result=~s/\&$//;
1.265 albertel 2425: $result .= '__END_HASH_REF__';
1.168 albertel 2426: return $result;
2427: }
2428:
2429: sub str2hash {
1.265 albertel 2430: my ($string)=@_;
2431: my ($hash)=&str2hashref('__HASH_REF__'.$string.'__END_HASH_REF__');
2432: return %$hash;
2433: }
2434:
2435: sub str2hashref {
1.168 albertel 2436: my ($string) = @_;
1.265 albertel 2437:
2438: my %hash;
2439:
2440: if($string !~ /^__HASH_REF__/) {
2441: if (! ($string eq '' || !defined($string))) {
2442: $hash{'error'}='Not hash reference';
2443: }
2444: return (\%hash, $string);
2445: }
2446:
2447: $string =~ s/^__HASH_REF__//;
2448:
2449: while($string !~ /^__END_HASH_REF__/) {
2450: #key
2451: my $key='';
2452: if($string =~ /^__HASH_REF__/) {
2453: ($key, $string)=&str2hashref($string);
2454: if(defined($key->{'error'})) {
2455: $hash{'error'}='Bad data';
2456: return (\%hash, $string);
2457: }
2458: } elsif($string =~ /^__ARRAY_REF__/) {
2459: ($key, $string)=&str2arrayref($string);
2460: if($key->[0] eq 'Array reference error') {
2461: $hash{'error'}='Bad data';
2462: return (\%hash, $string);
2463: }
2464: } else {
2465: $string =~ s/^(.*?)=//;
1.267 albertel 2466: $key=&unescape($1);
1.265 albertel 2467: }
2468: $string =~ s/^=//;
2469:
2470: #value
2471: my $value='';
2472: if($string =~ /^__HASH_REF__/) {
2473: ($value, $string)=&str2hashref($string);
2474: if(defined($value->{'error'})) {
2475: $hash{'error'}='Bad data';
2476: return (\%hash, $string);
2477: }
2478: } elsif($string =~ /^__ARRAY_REF__/) {
2479: ($value, $string)=&str2arrayref($string);
2480: if($value->[0] eq 'Array reference error') {
2481: $hash{'error'}='Bad data';
2482: return (\%hash, $string);
2483: }
2484: } else {
2485: $value=&get_scalar(\$string,'__END_HASH_REF__');
2486: }
2487: $string =~ s/^&//;
2488:
2489: $hash{$key}=$value;
1.204 albertel 2490: }
1.265 albertel 2491:
2492: $string =~ s/^__END_HASH_REF__//;
2493:
2494: return (\%hash, $string);
1.204 albertel 2495: }
2496:
2497: sub str2array {
1.265 albertel 2498: my ($string)=@_;
2499: my ($array)=&str2arrayref('__ARRAY_REF__'.$string.'__END_ARRAY_REF__');
2500: return @$array;
2501: }
2502:
2503: sub str2arrayref {
1.204 albertel 2504: my ($string) = @_;
1.265 albertel 2505: my @array;
2506:
2507: if($string !~ /^__ARRAY_REF__/) {
2508: if (! ($string eq '' || !defined($string))) {
2509: $array[0]='Array reference error';
2510: }
2511: return (\@array, $string);
2512: }
2513:
2514: $string =~ s/^__ARRAY_REF__//;
2515:
2516: while($string !~ /^__END_ARRAY_REF__/) {
2517: my $value='';
2518: if($string =~ /^__HASH_REF__/) {
2519: ($value, $string)=&str2hashref($string);
2520: if(defined($value->{'error'})) {
2521: $array[0] ='Array reference error';
2522: return (\@array, $string);
2523: }
2524: } elsif($string =~ /^__ARRAY_REF__/) {
2525: ($value, $string)=&str2arrayref($string);
2526: if($value->[0] eq 'Array reference error') {
2527: $array[0] ='Array reference error';
2528: return (\@array, $string);
2529: }
2530: } else {
2531: $value=&get_scalar(\$string,'__END_ARRAY_REF__');
2532: }
2533: $string =~ s/^&//;
2534:
2535: push(@array, $value);
1.191 harris41 2536: }
1.265 albertel 2537:
2538: $string =~ s/^__END_ARRAY_REF__//;
2539:
2540: return (\@array, $string);
1.168 albertel 2541: }
2542:
1.167 albertel 2543: # -------------------------------------------------------------------Temp Store
2544:
1.168 albertel 2545: sub tmpreset {
2546: my ($symb,$namespace,$domain,$stuname) = @_;
2547: if (!$symb) {
2548: $symb=&symbread();
1.620 albertel 2549: if (!$symb) { $symb= $env{'request.url'}; }
1.168 albertel 2550: }
2551: $symb=escape($symb);
2552:
1.620 albertel 2553: if (!$namespace) { $namespace=$env{'request.state'}; }
1.168 albertel 2554: $namespace=~s/\//\_/g;
2555: $namespace=~s/\W//g;
2556:
1.620 albertel 2557: if (!$domain) { $domain=$env{'user.domain'}; }
2558: if (!$stuname) { $stuname=$env{'user.name'}; }
1.591 albertel 2559: if ($domain eq 'public' && $stuname eq 'public') {
2560: $stuname=$ENV{'REMOTE_ADDR'};
2561: }
1.168 albertel 2562: my $path=$perlvar{'lonDaemons'}.'/tmp';
2563: my %hash;
2564: if (tie(%hash,'GDBM_File',
2565: $path.'/tmpstore_'.$stuname.'_'.$domain.'_'.$namespace.'.db',
1.256 albertel 2566: &GDBM_WRCREAT(),0640)) {
1.168 albertel 2567: foreach my $key (keys %hash) {
1.180 albertel 2568: if ($key=~ /:$symb/) {
1.168 albertel 2569: delete($hash{$key});
2570: }
2571: }
2572: }
2573: }
2574:
1.167 albertel 2575: sub tmpstore {
1.168 albertel 2576: my ($storehash,$symb,$namespace,$domain,$stuname) = @_;
2577:
2578: if (!$symb) {
2579: $symb=&symbread();
1.620 albertel 2580: if (!$symb) { $symb= $env{'request.url'}; }
1.168 albertel 2581: }
2582: $symb=escape($symb);
2583:
2584: if (!$namespace) {
2585: # I don't think we would ever want to store this for a course.
2586: # it seems this will only be used if we don't have a course.
1.620 albertel 2587: #$namespace=$env{'request.course.id'};
1.168 albertel 2588: #if (!$namespace) {
1.620 albertel 2589: $namespace=$env{'request.state'};
1.168 albertel 2590: #}
2591: }
2592: $namespace=~s/\//\_/g;
2593: $namespace=~s/\W//g;
1.620 albertel 2594: if (!$domain) { $domain=$env{'user.domain'}; }
2595: if (!$stuname) { $stuname=$env{'user.name'}; }
1.591 albertel 2596: if ($domain eq 'public' && $stuname eq 'public') {
2597: $stuname=$ENV{'REMOTE_ADDR'};
2598: }
1.168 albertel 2599: my $now=time;
2600: my %hash;
2601: my $path=$perlvar{'lonDaemons'}.'/tmp';
2602: if (tie(%hash,'GDBM_File',
2603: $path.'/tmpstore_'.$stuname.'_'.$domain.'_'.$namespace.'.db',
1.256 albertel 2604: &GDBM_WRCREAT(),0640)) {
1.168 albertel 2605: $hash{"version:$symb"}++;
2606: my $version=$hash{"version:$symb"};
2607: my $allkeys='';
2608: foreach my $key (keys(%$storehash)) {
2609: $allkeys.=$key.':';
1.591 albertel 2610: $hash{"$version:$symb:$key"}=&freeze_escape($$storehash{$key});
1.168 albertel 2611: }
2612: $hash{"$version:$symb:timestamp"}=$now;
2613: $allkeys.='timestamp';
2614: $hash{"$version:keys:$symb"}=$allkeys;
2615: if (untie(%hash)) {
2616: return 'ok';
2617: } else {
2618: return "error:$!";
2619: }
2620: } else {
2621: return "error:$!";
2622: }
2623: }
1.167 albertel 2624:
1.168 albertel 2625: # -----------------------------------------------------------------Temp Restore
1.167 albertel 2626:
1.168 albertel 2627: sub tmprestore {
2628: my ($symb,$namespace,$domain,$stuname) = @_;
1.167 albertel 2629:
1.168 albertel 2630: if (!$symb) {
2631: $symb=&symbread();
1.620 albertel 2632: if (!$symb) { $symb= $env{'request.url'}; }
1.168 albertel 2633: }
2634: $symb=escape($symb);
2635:
1.620 albertel 2636: if (!$namespace) { $namespace=$env{'request.state'}; }
1.591 albertel 2637:
1.620 albertel 2638: if (!$domain) { $domain=$env{'user.domain'}; }
2639: if (!$stuname) { $stuname=$env{'user.name'}; }
1.591 albertel 2640: if ($domain eq 'public' && $stuname eq 'public') {
2641: $stuname=$ENV{'REMOTE_ADDR'};
2642: }
1.168 albertel 2643: my %returnhash;
2644: $namespace=~s/\//\_/g;
2645: $namespace=~s/\W//g;
2646: my %hash;
2647: my $path=$perlvar{'lonDaemons'}.'/tmp';
2648: if (tie(%hash,'GDBM_File',
2649: $path.'/tmpstore_'.$stuname.'_'.$domain.'_'.$namespace.'.db',
1.256 albertel 2650: &GDBM_READER(),0640)) {
1.168 albertel 2651: my $version=$hash{"version:$symb"};
2652: $returnhash{'version'}=$version;
2653: my $scope;
2654: for ($scope=1;$scope<=$version;$scope++) {
2655: my $vkeys=$hash{"$scope:keys:$symb"};
2656: my @keys=split(/:/,$vkeys);
2657: my $key;
2658: $returnhash{"$scope:keys"}=$vkeys;
2659: foreach $key (@keys) {
1.591 albertel 2660: $returnhash{"$scope:$key"}=&thaw_unescape($hash{"$scope:$symb:$key"});
2661: $returnhash{"$key"}=&thaw_unescape($hash{"$scope:$symb:$key"});
1.167 albertel 2662: }
2663: }
1.168 albertel 2664: if (!(untie(%hash))) {
2665: return "error:$!";
2666: }
2667: } else {
2668: return "error:$!";
2669: }
2670: return %returnhash;
1.167 albertel 2671: }
2672:
1.9 www 2673: # ----------------------------------------------------------------------- Store
2674:
2675: sub store {
1.124 www 2676: my ($storehash,$symb,$namespace,$domain,$stuname) = @_;
2677: my $home='';
2678:
1.168 albertel 2679: if ($stuname) { $home=&homeserver($stuname,$domain); }
1.124 www 2680:
1.213 www 2681: $symb=&symbclean($symb);
1.122 albertel 2682: if (!$symb) { unless ($symb=&symbread()) { return ''; } }
1.109 www 2683:
1.620 albertel 2684: if (!$domain) { $domain=$env{'user.domain'}; }
2685: if (!$stuname) { $stuname=$env{'user.name'}; }
1.325 www 2686:
2687: &devalidate($symb,$stuname,$domain);
1.109 www 2688:
2689: $symb=escape($symb);
1.187 www 2690: if (!$namespace) {
1.620 albertel 2691: unless ($namespace=$env{'request.course.id'}) {
1.187 www 2692: return '';
2693: }
2694: }
1.620 albertel 2695: if (!$home) { $home=$env{'user.home'}; }
1.447 www 2696:
2697: $$storehash{'ip'}=$ENV{'REMOTE_ADDR'};
2698: $$storehash{'host'}=$perlvar{'lonHostID'};
2699:
1.12 www 2700: my $namevalue='';
1.800 albertel 2701: foreach my $key (keys(%$storehash)) {
2702: $namevalue.=&escape($key).'='.&freeze_escape($$storehash{$key}).'&';
1.191 harris41 2703: }
1.12 www 2704: $namevalue=~s/\&$//;
1.187 www 2705: &courselog($symb.':'.$stuname.':'.$domain.':STORE:'.$namevalue);
1.124 www 2706: return reply("store:$domain:$stuname:$namespace:$symb:$namevalue","$home");
1.9 www 2707: }
2708:
1.47 www 2709: # -------------------------------------------------------------- Critical Store
2710:
2711: sub cstore {
1.124 www 2712: my ($storehash,$symb,$namespace,$domain,$stuname) = @_;
2713: my $home='';
2714:
1.168 albertel 2715: if ($stuname) { $home=&homeserver($stuname,$domain); }
1.124 www 2716:
1.213 www 2717: $symb=&symbclean($symb);
1.122 albertel 2718: if (!$symb) { unless ($symb=&symbread()) { return ''; } }
1.109 www 2719:
1.620 albertel 2720: if (!$domain) { $domain=$env{'user.domain'}; }
2721: if (!$stuname) { $stuname=$env{'user.name'}; }
1.325 www 2722:
2723: &devalidate($symb,$stuname,$domain);
1.109 www 2724:
2725: $symb=escape($symb);
1.187 www 2726: if (!$namespace) {
1.620 albertel 2727: unless ($namespace=$env{'request.course.id'}) {
1.187 www 2728: return '';
2729: }
2730: }
1.620 albertel 2731: if (!$home) { $home=$env{'user.home'}; }
1.447 www 2732:
2733: $$storehash{'ip'}=$ENV{'REMOTE_ADDR'};
2734: $$storehash{'host'}=$perlvar{'lonHostID'};
1.122 albertel 2735:
1.47 www 2736: my $namevalue='';
1.800 albertel 2737: foreach my $key (keys(%$storehash)) {
2738: $namevalue.=&escape($key).'='.&freeze_escape($$storehash{$key}).'&';
1.191 harris41 2739: }
1.47 www 2740: $namevalue=~s/\&$//;
1.187 www 2741: &courselog($symb.':'.$stuname.':'.$domain.':CSTORE:'.$namevalue);
1.188 www 2742: return critical
2743: ("store:$domain:$stuname:$namespace:$symb:$namevalue","$home");
1.47 www 2744: }
2745:
1.9 www 2746: # --------------------------------------------------------------------- Restore
2747:
2748: sub restore {
1.124 www 2749: my ($symb,$namespace,$domain,$stuname) = @_;
2750: my $home='';
2751:
1.168 albertel 2752: if ($stuname) { $home=&homeserver($stuname,$domain); }
1.124 www 2753:
1.122 albertel 2754: if (!$symb) {
2755: unless ($symb=escape(&symbread())) { return ''; }
2756: } else {
1.213 www 2757: $symb=&escape(&symbclean($symb));
1.122 albertel 2758: }
1.188 www 2759: if (!$namespace) {
1.620 albertel 2760: unless ($namespace=$env{'request.course.id'}) {
1.188 www 2761: return '';
2762: }
2763: }
1.620 albertel 2764: if (!$domain) { $domain=$env{'user.domain'}; }
2765: if (!$stuname) { $stuname=$env{'user.name'}; }
2766: if (!$home) { $home=$env{'user.home'}; }
1.122 albertel 2767: my $answer=&reply("restore:$domain:$stuname:$namespace:$symb","$home");
2768:
1.12 www 2769: my %returnhash=();
1.800 albertel 2770: foreach my $line (split(/\&/,$answer)) {
2771: my ($name,$value)=split(/\=/,$line);
1.591 albertel 2772: $returnhash{&unescape($name)}=&thaw_unescape($value);
1.191 harris41 2773: }
1.75 www 2774: my $version;
2775: for ($version=1;$version<=$returnhash{'version'};$version++) {
1.800 albertel 2776: foreach my $item (split(/\:/,$returnhash{$version.':keys'})) {
2777: $returnhash{$item}=$returnhash{$version.':'.$item};
1.191 harris41 2778: }
1.75 www 2779: }
1.13 www 2780: return %returnhash;
1.34 www 2781: }
2782:
2783: # ---------------------------------------------------------- Course Description
2784:
2785: sub coursedescription {
1.731 albertel 2786: my ($courseid,$args)=@_;
1.34 www 2787: $courseid=~s/^\///;
1.49 www 2788: $courseid=~s/\_/\//g;
1.34 www 2789: my ($cdomain,$cnum)=split(/\//,$courseid);
1.129 albertel 2790: my $chome=&homeserver($cnum,$cdomain);
1.302 albertel 2791: my $normalid=$cdomain.'_'.$cnum;
2792: # need to always cache even if we get errors otherwise we keep
2793: # trying and trying and trying to get the course description.
2794: my %envhash=();
2795: my %returnhash=();
1.731 albertel 2796:
2797: my $expiretime=600;
2798: if ($env{'request.course.id'} eq $normalid) {
2799: $expiretime=120;
2800: }
2801:
2802: my $prefix='course.'.$cdomain.'_'.$cnum.'.';
2803: if (!$args->{'freshen_cache'}
2804: && ((time-$env{$prefix.'last_cache'}) < $expiretime) ) {
2805: foreach my $key (keys(%env)) {
2806: next if ($key !~ /^\Q$prefix\E(.*)/);
2807: my ($setting) = $1;
2808: $returnhash{$setting} = $env{$key};
2809: }
2810: return %returnhash;
2811: }
2812:
2813: # get the data agin
2814: if (!$args->{'one_time'}) {
2815: $envhash{'course.'.$normalid.'.last_cache'}=time;
2816: }
1.811 albertel 2817:
1.34 www 2818: if ($chome ne 'no_host') {
1.302 albertel 2819: %returnhash=&dump('environment',$cdomain,$cnum);
1.129 albertel 2820: if (!exists($returnhash{'con_lost'})) {
2821: $returnhash{'home'}= $chome;
2822: $returnhash{'domain'} = $cdomain;
2823: $returnhash{'num'} = $cnum;
1.741 raeburn 2824: if (!defined($returnhash{'type'})) {
2825: $returnhash{'type'} = 'Course';
2826: }
1.130 albertel 2827: while (my ($name,$value) = each %returnhash) {
1.53 www 2828: $envhash{'course.'.$normalid.'.'.$name}=$value;
1.129 albertel 2829: }
1.270 www 2830: $returnhash{'url'}=&clutter($returnhash{'url'});
1.34 www 2831: $returnhash{'fn'}=$perlvar{'lonDaemons'}.'/tmp/'.
1.620 albertel 2832: $env{'user.name'}.'_'.$cdomain.'_'.$cnum;
1.60 www 2833: $envhash{'course.'.$normalid.'.home'}=$chome;
2834: $envhash{'course.'.$normalid.'.domain'}=$cdomain;
2835: $envhash{'course.'.$normalid.'.num'}=$cnum;
1.34 www 2836: }
2837: }
1.731 albertel 2838: if (!$args->{'one_time'}) {
2839: &appenv(%envhash);
2840: }
1.302 albertel 2841: return %returnhash;
1.461 www 2842: }
2843:
2844: # -------------------------------------------------See if a user is privileged
2845:
2846: sub privileged {
2847: my ($username,$domain)=@_;
2848: my $rolesdump=&reply("dump:$domain:$username:roles",
2849: &homeserver($username,$domain));
2850: if (($rolesdump eq 'con_lost') || ($rolesdump eq '')) { return 0; }
2851: my $now=time;
2852: if ($rolesdump ne '') {
1.800 albertel 2853: foreach my $entry (split(/&/,$rolesdump)) {
2854: if ($entry!~/^rolesdef_/) {
2855: my ($area,$role)=split(/=/,$entry);
1.461 www 2856: $area=~s/\_\w\w$//;
2857: my ($trole,$tend,$tstart)=split(/_/,$role);
2858: if (($trole eq 'dc') || ($trole eq 'su')) {
2859: my $active=1;
2860: if ($tend) {
2861: if ($tend<$now) { $active=0; }
2862: }
2863: if ($tstart) {
2864: if ($tstart>$now) { $active=0; }
2865: }
2866: if ($active) { return 1; }
2867: }
2868: }
2869: }
2870: }
2871: return 0;
1.9 www 2872: }
1.1 albertel 2873:
1.103 harris41 2874: # -------------------------------------------------------- Get user privileges
1.11 www 2875:
2876: sub rolesinit {
2877: my ($domain,$username,$authhost)=@_;
2878: my $rolesdump=reply("dump:$domain:$username:roles",$authhost);
1.12 www 2879: if (($rolesdump eq 'con_lost') || ($rolesdump eq '')) { return ''; }
1.11 www 2880: my %allroles=();
1.678 raeburn 2881: my %allgroups=();
1.11 www 2882: my $now=time;
1.743 albertel 2883: my %userroles = ('user.login.time' => $now);
1.678 raeburn 2884: my $group_privs;
1.11 www 2885:
2886: if ($rolesdump ne '') {
1.800 albertel 2887: foreach my $entry (split(/&/,$rolesdump)) {
2888: if ($entry!~/^rolesdef_/) {
2889: my ($area,$role)=split(/=/,$entry);
1.587 albertel 2890: $area=~s/\_\w\w$//;
1.678 raeburn 2891: my ($trole,$tend,$tstart,$group_privs);
1.587 albertel 2892: if ($role=~/^cr/) {
1.807 albertel 2893: if ($role=~m|^(cr/$match_domain/$match_username/[a-zA-Z0-9]+)_(.*)$|) {
2894: ($trole,my $trest)=($role=~m|^(cr/$match_domain/$match_username/[a-zA-Z0-9]+)_(.*)$|);
1.655 albertel 2895: ($tend,$tstart)=split('_',$trest);
2896: } else {
2897: $trole=$role;
2898: }
1.678 raeburn 2899: } elsif ($role =~ m|^gr/|) {
2900: ($trole,$tend,$tstart) = split(/_/,$role);
2901: ($trole,$group_privs) = split(/\//,$trole);
2902: $group_privs = &unescape($group_privs);
1.587 albertel 2903: } else {
2904: ($trole,$tend,$tstart)=split(/_/,$role);
2905: }
1.743 albertel 2906: my %new_role = &set_arearole($trole,$area,$tstart,$tend,$domain,
2907: $username);
2908: @userroles{keys(%new_role)} = @new_role{keys(%new_role)};
1.567 raeburn 2909: if (($tend!=0) && ($tend<$now)) { $trole=''; }
2910: if (($tstart!=0) && ($tstart>$now)) { $trole=''; }
1.11 www 2911: if (($area ne '') && ($trole ne '')) {
1.347 albertel 2912: my $spec=$trole.'.'.$area;
2913: my ($tdummy,$tdomain,$trest)=split(/\//,$area);
2914: if ($trole =~ /^cr\//) {
1.567 raeburn 2915: &custom_roleprivs(\%allroles,$trole,$tdomain,$trest,$spec,$area);
1.678 raeburn 2916: } elsif ($trole eq 'gr') {
2917: &group_roleprivs(\%allgroups,$area,$group_privs,$tend,$tstart);
1.347 albertel 2918: } else {
1.567 raeburn 2919: &standard_roleprivs(\%allroles,$trole,$tdomain,$spec,$trest,$area);
1.347 albertel 2920: }
1.12 www 2921: }
1.662 raeburn 2922: }
1.191 harris41 2923: }
1.743 albertel 2924: my ($author,$adv) = &set_userprivs(\%userroles,\%allroles,\%allgroups);
2925: $userroles{'user.adv'} = $adv;
2926: $userroles{'user.author'} = $author;
1.620 albertel 2927: $env{'user.adv'}=$adv;
1.11 www 2928: }
1.743 albertel 2929: return \%userroles;
1.11 www 2930: }
2931:
1.567 raeburn 2932: sub set_arearole {
2933: my ($trole,$area,$tstart,$tend,$domain,$username) = @_;
2934: # log the associated role with the area
2935: &userrolelog($trole,$username,$domain,$area,$tstart,$tend);
1.743 albertel 2936: return ('user.role.'.$trole.'.'.$area => $tstart.'.'.$tend);
1.567 raeburn 2937: }
2938:
2939: sub custom_roleprivs {
2940: my ($allroles,$trole,$tdomain,$trest,$spec,$area) = @_;
2941: my ($rdummy,$rdomain,$rauthor,$rrole)=split(/\//,$trole);
2942: my $homsvr=homeserver($rauthor,$rdomain);
2943: if ($hostname{$homsvr} ne '') {
2944: my ($rdummy,$roledef)=
2945: &get('roles',["rolesdef_$rrole"],$rdomain,$rauthor);
2946: if (($rdummy ne 'con_lost') && ($roledef ne '')) {
2947: my ($syspriv,$dompriv,$coursepriv)=split(/\_/,$roledef);
2948: if (defined($syspriv)) {
2949: $$allroles{'cm./'}.=':'.$syspriv;
2950: $$allroles{$spec.'./'}.=':'.$syspriv;
2951: }
2952: if ($tdomain ne '') {
2953: if (defined($dompriv)) {
2954: $$allroles{'cm./'.$tdomain.'/'}.=':'.$dompriv;
2955: $$allroles{$spec.'./'.$tdomain.'/'}.=':'.$dompriv;
2956: }
2957: if (($trest ne '') && (defined($coursepriv))) {
2958: $$allroles{'cm.'.$area}.=':'.$coursepriv;
2959: $$allroles{$spec.'.'.$area}.=':'.$coursepriv;
2960: }
2961: }
2962: }
2963: }
2964: }
2965:
1.678 raeburn 2966: sub group_roleprivs {
2967: my ($allgroups,$area,$group_privs,$tend,$tstart) = @_;
2968: my $access = 1;
2969: my $now = time;
2970: if (($tend!=0) && ($tend<$now)) { $access = 0; }
2971: if (($tstart!=0) && ($tstart>$now)) { $access=0; }
2972: if ($access) {
1.811 albertel 2973: my ($course,$group) = ($area =~ m|(/$match_domain/$match_courseid)/([^/]+)$|);
1.678 raeburn 2974: $$allgroups{$course}{$group} .=':'.$group_privs;
2975: }
2976: }
1.567 raeburn 2977:
2978: sub standard_roleprivs {
2979: my ($allroles,$trole,$tdomain,$spec,$trest,$area) = @_;
2980: if (defined($pr{$trole.':s'})) {
2981: $$allroles{'cm./'}.=':'.$pr{$trole.':s'};
2982: $$allroles{$spec.'./'}.=':'.$pr{$trole.':s'};
2983: }
2984: if ($tdomain ne '') {
2985: if (defined($pr{$trole.':d'})) {
2986: $$allroles{'cm./'.$tdomain.'/'}.=':'.$pr{$trole.':d'};
2987: $$allroles{$spec.'./'.$tdomain.'/'}.=':'.$pr{$trole.':d'};
2988: }
2989: if (($trest ne '') && (defined($pr{$trole.':c'}))) {
2990: $$allroles{'cm.'.$area}.=':'.$pr{$trole.':c'};
2991: $$allroles{$spec.'.'.$area}.=':'.$pr{$trole.':c'};
2992: }
2993: }
2994: }
2995:
2996: sub set_userprivs {
1.678 raeburn 2997: my ($userroles,$allroles,$allgroups) = @_;
1.567 raeburn 2998: my $author=0;
2999: my $adv=0;
1.678 raeburn 3000: my %grouproles = ();
3001: if (keys(%{$allgroups}) > 0) {
3002: foreach my $role (keys %{$allroles}) {
1.681 raeburn 3003: my ($trole,$area,$sec,$extendedarea);
1.811 albertel 3004: if ($role =~ m-^(\w+|cr/$match_domain/$match_username/\w+)\.(/$match_domain/$match_courseid)(/?\w*)-) {
1.678 raeburn 3005: $trole = $1;
3006: $area = $2;
1.681 raeburn 3007: $sec = $3;
3008: $extendedarea = $area.$sec;
3009: if (exists($$allgroups{$area})) {
3010: foreach my $group (keys(%{$$allgroups{$area}})) {
3011: my $spec = $trole.'.'.$extendedarea;
3012: $grouproles{$spec.'.'.$area.'/'.$group} =
3013: $$allgroups{$area}{$group};
1.678 raeburn 3014: }
3015: }
3016: }
3017: }
3018: }
1.800 albertel 3019: foreach my $group (keys(%grouproles)) {
3020: $$allroles{$group} = $grouproles{$group};
1.678 raeburn 3021: }
1.800 albertel 3022: foreach my $role (keys(%{$allroles})) {
3023: my %thesepriv;
3024: if (($role=~/^au/) || ($role=~/^ca/)) { $author=1; }
3025: foreach my $item (split(/:/,$$allroles{$role})) {
3026: if ($item ne '') {
3027: my ($privilege,$restrictions)=split(/&/,$item);
1.567 raeburn 3028: if ($restrictions eq '') {
3029: $thesepriv{$privilege}='F';
3030: } elsif ($thesepriv{$privilege} ne 'F') {
3031: $thesepriv{$privilege}.=$restrictions;
3032: }
3033: if ($thesepriv{'adv'} eq 'F') { $adv=1; }
3034: }
3035: }
3036: my $thesestr='';
1.800 albertel 3037: foreach my $priv (keys(%thesepriv)) {
3038: $thesestr.=':'.$priv.'&'.$thesepriv{$priv};
3039: }
3040: $userroles->{'user.priv.'.$role} = $thesestr;
1.567 raeburn 3041: }
3042: return ($author,$adv);
3043: }
3044:
1.12 www 3045: # --------------------------------------------------------------- get interface
3046:
3047: sub get {
1.131 albertel 3048: my ($namespace,$storearr,$udomain,$uname)=@_;
1.12 www 3049: my $items='';
1.800 albertel 3050: foreach my $item (@$storearr) {
3051: $items.=&escape($item).'&';
1.191 harris41 3052: }
1.12 www 3053: $items=~s/\&$//;
1.620 albertel 3054: if (!$udomain) { $udomain=$env{'user.domain'}; }
3055: if (!$uname) { $uname=$env{'user.name'}; }
1.131 albertel 3056: my $uhome=&homeserver($uname,$udomain);
3057:
1.133 albertel 3058: my $rep=&reply("get:$udomain:$uname:$namespace:$items",$uhome);
1.15 www 3059: my @pairs=split(/\&/,$rep);
1.273 albertel 3060: if ( $#pairs==0 && $pairs[0] =~ /^(con_lost|error|no_such_host)/i) {
3061: return @pairs;
3062: }
1.15 www 3063: my %returnhash=();
1.42 www 3064: my $i=0;
1.800 albertel 3065: foreach my $item (@$storearr) {
3066: $returnhash{$item}=&thaw_unescape($pairs[$i]);
1.42 www 3067: $i++;
1.191 harris41 3068: }
1.15 www 3069: return %returnhash;
1.27 www 3070: }
3071:
3072: # --------------------------------------------------------------- del interface
3073:
3074: sub del {
1.133 albertel 3075: my ($namespace,$storearr,$udomain,$uname)=@_;
1.27 www 3076: my $items='';
1.800 albertel 3077: foreach my $item (@$storearr) {
3078: $items.=&escape($item).'&';
1.191 harris41 3079: }
1.27 www 3080: $items=~s/\&$//;
1.620 albertel 3081: if (!$udomain) { $udomain=$env{'user.domain'}; }
3082: if (!$uname) { $uname=$env{'user.name'}; }
1.133 albertel 3083: my $uhome=&homeserver($uname,$udomain);
3084:
3085: return &reply("del:$udomain:$uname:$namespace:$items",$uhome);
1.15 www 3086: }
3087:
3088: # -------------------------------------------------------------- dump interface
3089:
3090: sub dump {
1.755 albertel 3091: my ($namespace,$udomain,$uname,$regexp,$range)=@_;
3092: if (!$udomain) { $udomain=$env{'user.domain'}; }
3093: if (!$uname) { $uname=$env{'user.name'}; }
3094: my $uhome=&homeserver($uname,$udomain);
3095: if ($regexp) {
3096: $regexp=&escape($regexp);
3097: } else {
3098: $regexp='.';
3099: }
3100: my $rep=&reply("dump:$udomain:$uname:$namespace:$regexp:$range",$uhome);
3101: my @pairs=split(/\&/,$rep);
3102: my %returnhash=();
3103: foreach my $item (@pairs) {
3104: my ($key,$value)=split(/=/,$item,2);
3105: $key = &unescape($key);
3106: next if ($key =~ /^error: 2 /);
3107: $returnhash{$key}=&thaw_unescape($value);
3108: }
3109: return %returnhash;
1.407 www 3110: }
3111:
1.717 albertel 3112: # --------------------------------------------------------- dumpstore interface
3113:
3114: sub dumpstore {
3115: my ($namespace,$udomain,$uname,$regexp,$range)=@_;
1.822 albertel 3116: if (!$udomain) { $udomain=$env{'user.domain'}; }
3117: if (!$uname) { $uname=$env{'user.name'}; }
3118: my $uhome=&homeserver($uname,$udomain);
3119: if ($regexp) {
3120: $regexp=&escape($regexp);
3121: } else {
3122: $regexp='.';
3123: }
3124: my $rep=&reply("dump:$udomain:$uname:$namespace:$regexp:$range",$uhome);
3125: my @pairs=split(/\&/,$rep);
3126: my %returnhash=();
3127: foreach my $item (@pairs) {
3128: my ($key,$value)=split(/=/,$item,2);
3129: next if ($key =~ /^error: 2 /);
3130: $returnhash{$key}=&thaw_unescape($value);
3131: }
3132: return %returnhash;
1.717 albertel 3133: }
3134:
1.407 www 3135: # -------------------------------------------------------------- keys interface
3136:
3137: sub getkeys {
3138: my ($namespace,$udomain,$uname)=@_;
1.620 albertel 3139: if (!$udomain) { $udomain=$env{'user.domain'}; }
3140: if (!$uname) { $uname=$env{'user.name'}; }
1.407 www 3141: my $uhome=&homeserver($uname,$udomain);
3142: my $rep=reply("keys:$udomain:$uname:$namespace",$uhome);
3143: my @keyarray=();
1.800 albertel 3144: foreach my $key (split(/\&/,$rep)) {
1.812 raeburn 3145: next if ($key =~ /^error: 2 /);
1.800 albertel 3146: push(@keyarray,&unescape($key));
1.407 www 3147: }
3148: return @keyarray;
1.318 matthew 3149: }
3150:
1.319 matthew 3151: # --------------------------------------------------------------- currentdump
3152: sub currentdump {
1.328 matthew 3153: my ($courseid,$sdom,$sname)=@_;
1.620 albertel 3154: $courseid = $env{'request.course.id'} if (! defined($courseid));
3155: $sdom = $env{'user.domain'} if (! defined($sdom));
3156: $sname = $env{'user.name'} if (! defined($sname));
1.326 matthew 3157: my $uhome = &homeserver($sname,$sdom);
3158: my $rep=reply('currentdump:'.$sdom.':'.$sname.':'.$courseid,$uhome);
1.318 matthew 3159: return if ($rep =~ /^(error:|no_such_host)/);
1.319 matthew 3160: #
1.318 matthew 3161: my %returnhash=();
1.319 matthew 3162: #
3163: if ($rep eq "unknown_cmd") {
3164: # an old lond will not know currentdump
3165: # Do a dump and make it look like a currentdump
1.822 albertel 3166: my @tmp = &dumpstore($courseid,$sdom,$sname,'.');
1.319 matthew 3167: return if ($tmp[0] =~ /^(error:|no_such_host)/);
3168: my %hash = @tmp;
3169: @tmp=();
1.424 matthew 3170: %returnhash = %{&convert_dump_to_currentdump(\%hash)};
1.319 matthew 3171: } else {
3172: my @pairs=split(/\&/,$rep);
1.800 albertel 3173: foreach my $pair (@pairs) {
3174: my ($key,$value)=split(/=/,$pair,2);
1.319 matthew 3175: my ($symb,$param) = split(/:/,$key);
3176: $returnhash{&unescape($symb)}->{&unescape($param)} =
1.557 albertel 3177: &thaw_unescape($value);
1.319 matthew 3178: }
1.191 harris41 3179: }
1.12 www 3180: return %returnhash;
1.424 matthew 3181: }
3182:
3183: sub convert_dump_to_currentdump{
3184: my %hash = %{shift()};
3185: my %returnhash;
3186: # Code ripped from lond, essentially. The only difference
3187: # here is the unescaping done by lonnet::dump(). Conceivably
3188: # we might run in to problems with parameter names =~ /^v\./
3189: while (my ($key,$value) = each(%hash)) {
3190: my ($v,$symb,$param) = split(/:/,$key);
1.822 albertel 3191: $symb = &unescape($symb);
3192: $param = &unescape($param);
1.424 matthew 3193: next if ($v eq 'version' || $symb eq 'keys');
3194: next if (exists($returnhash{$symb}) &&
3195: exists($returnhash{$symb}->{$param}) &&
3196: $returnhash{$symb}->{'v.'.$param} > $v);
3197: $returnhash{$symb}->{$param}=$value;
3198: $returnhash{$symb}->{'v.'.$param}=$v;
3199: }
3200: #
3201: # Remove all of the keys in the hashes which keep track of
3202: # the version of the parameter.
3203: while (my ($symb,$param_hash) = each(%returnhash)) {
3204: # use a foreach because we are going to delete from the hash.
3205: foreach my $key (keys(%$param_hash)) {
3206: delete($param_hash->{$key}) if ($key =~ /^v\./);
3207: }
3208: }
3209: return \%returnhash;
1.12 www 3210: }
3211:
1.627 albertel 3212: # ------------------------------------------------------ critical inc interface
3213:
3214: sub cinc {
3215: return &inc(@_,'critical');
3216: }
3217:
1.449 matthew 3218: # --------------------------------------------------------------- inc interface
3219:
3220: sub inc {
1.627 albertel 3221: my ($namespace,$store,$udomain,$uname,$critical) = @_;
1.620 albertel 3222: if (!$udomain) { $udomain=$env{'user.domain'}; }
3223: if (!$uname) { $uname=$env{'user.name'}; }
1.449 matthew 3224: my $uhome=&homeserver($uname,$udomain);
3225: my $items='';
3226: if (! ref($store)) {
3227: # got a single value, so use that instead
3228: $items = &escape($store).'=&';
3229: } elsif (ref($store) eq 'SCALAR') {
3230: $items = &escape($$store).'=&';
3231: } elsif (ref($store) eq 'ARRAY') {
3232: $items = join('=&',map {&escape($_);} @{$store});
3233: } elsif (ref($store) eq 'HASH') {
3234: while (my($key,$value) = each(%{$store})) {
3235: $items.= &escape($key).'='.&escape($value).'&';
3236: }
3237: }
3238: $items=~s/\&$//;
1.627 albertel 3239: if ($critical) {
3240: return &critical("inc:$udomain:$uname:$namespace:$items",$uhome);
3241: } else {
3242: return &reply("inc:$udomain:$uname:$namespace:$items",$uhome);
3243: }
1.449 matthew 3244: }
3245:
1.12 www 3246: # --------------------------------------------------------------- put interface
3247:
3248: sub put {
1.134 albertel 3249: my ($namespace,$storehash,$udomain,$uname)=@_;
1.620 albertel 3250: if (!$udomain) { $udomain=$env{'user.domain'}; }
3251: if (!$uname) { $uname=$env{'user.name'}; }
1.134 albertel 3252: my $uhome=&homeserver($uname,$udomain);
1.12 www 3253: my $items='';
1.800 albertel 3254: foreach my $item (keys(%$storehash)) {
3255: $items.=&escape($item).'='.&freeze_escape($$storehash{$item}).'&';
1.191 harris41 3256: }
1.12 www 3257: $items=~s/\&$//;
1.134 albertel 3258: return &reply("put:$udomain:$uname:$namespace:$items",$uhome);
1.47 www 3259: }
3260:
1.631 albertel 3261: # ------------------------------------------------------------ newput interface
3262:
3263: sub newput {
3264: my ($namespace,$storehash,$udomain,$uname)=@_;
3265: if (!$udomain) { $udomain=$env{'user.domain'}; }
3266: if (!$uname) { $uname=$env{'user.name'}; }
3267: my $uhome=&homeserver($uname,$udomain);
3268: my $items='';
3269: foreach my $key (keys(%$storehash)) {
3270: $items.=&escape($key).'='.&freeze_escape($$storehash{$key}).'&';
3271: }
3272: $items=~s/\&$//;
3273: return &reply("newput:$udomain:$uname:$namespace:$items",$uhome);
3274: }
3275:
3276: # --------------------------------------------------------- putstore interface
3277:
1.524 raeburn 3278: sub putstore {
1.715 albertel 3279: my ($namespace,$symb,$version,$storehash,$udomain,$uname)=@_;
1.620 albertel 3280: if (!$udomain) { $udomain=$env{'user.domain'}; }
3281: if (!$uname) { $uname=$env{'user.name'}; }
1.524 raeburn 3282: my $uhome=&homeserver($uname,$udomain);
3283: my $items='';
1.715 albertel 3284: foreach my $key (keys(%$storehash)) {
3285: $items.= &escape($key).'='.&freeze_escape($storehash->{$key}).'&';
1.524 raeburn 3286: }
1.715 albertel 3287: $items=~s/\&$//;
1.716 albertel 3288: my $esc_symb=&escape($symb);
3289: my $esc_v=&escape($version);
1.715 albertel 3290: my $reply =
1.716 albertel 3291: &reply("putstore:$udomain:$uname:$namespace:$esc_symb:$esc_v:$items",
1.715 albertel 3292: $uhome);
3293: if ($reply eq 'unknown_cmd') {
1.716 albertel 3294: # gfall back to way things use to be done
1.715 albertel 3295: return &old_putstore($namespace,$symb,$version,$storehash,$udomain,
3296: $uname);
1.524 raeburn 3297: }
1.715 albertel 3298: return $reply;
3299: }
3300:
3301: sub old_putstore {
1.716 albertel 3302: my ($namespace,$symb,$version,$storehash,$udomain,$uname)=@_;
3303: if (!$udomain) { $udomain=$env{'user.domain'}; }
3304: if (!$uname) { $uname=$env{'user.name'}; }
3305: my $uhome=&homeserver($uname,$udomain);
3306: my %newstorehash;
1.800 albertel 3307: foreach my $item (keys(%$storehash)) {
3308: my $key = $version.':'.&escape($symb).':'.$item;
3309: $newstorehash{$key} = $storehash->{$item};
1.716 albertel 3310: }
3311: my $items='';
3312: my %allitems = ();
1.800 albertel 3313: foreach my $item (keys(%newstorehash)) {
3314: if ($item =~ m/^([^\:]+):([^\:]+):([^\:]+)$/) {
1.716 albertel 3315: my $key = $1.':keys:'.$2;
3316: $allitems{$key} .= $3.':';
3317: }
1.800 albertel 3318: $items.=$item.'='.&freeze_escape($newstorehash{$item}).'&';
1.716 albertel 3319: }
1.800 albertel 3320: foreach my $item (keys(%allitems)) {
3321: $allitems{$item} =~ s/\:$//;
3322: $items.= $item.'='.$allitems{$item}.'&';
1.716 albertel 3323: }
3324: $items=~s/\&$//;
3325: return &reply("put:$udomain:$uname:$namespace:$items",$uhome);
1.524 raeburn 3326: }
3327:
1.47 www 3328: # ------------------------------------------------------ critical put interface
3329:
3330: sub cput {
1.134 albertel 3331: my ($namespace,$storehash,$udomain,$uname)=@_;
1.620 albertel 3332: if (!$udomain) { $udomain=$env{'user.domain'}; }
3333: if (!$uname) { $uname=$env{'user.name'}; }
1.134 albertel 3334: my $uhome=&homeserver($uname,$udomain);
1.47 www 3335: my $items='';
1.800 albertel 3336: foreach my $item (keys(%$storehash)) {
3337: $items.=&escape($item).'='.&freeze_escape($$storehash{$item}).'&';
1.191 harris41 3338: }
1.47 www 3339: $items=~s/\&$//;
1.134 albertel 3340: return &critical("put:$udomain:$uname:$namespace:$items",$uhome);
1.12 www 3341: }
3342:
3343: # -------------------------------------------------------------- eget interface
3344:
3345: sub eget {
1.133 albertel 3346: my ($namespace,$storearr,$udomain,$uname)=@_;
1.12 www 3347: my $items='';
1.800 albertel 3348: foreach my $item (@$storearr) {
3349: $items.=&escape($item).'&';
1.191 harris41 3350: }
1.12 www 3351: $items=~s/\&$//;
1.620 albertel 3352: if (!$udomain) { $udomain=$env{'user.domain'}; }
3353: if (!$uname) { $uname=$env{'user.name'}; }
1.133 albertel 3354: my $uhome=&homeserver($uname,$udomain);
3355: my $rep=&reply("eget:$udomain:$uname:$namespace:$items",$uhome);
1.12 www 3356: my @pairs=split(/\&/,$rep);
3357: my %returnhash=();
1.42 www 3358: my $i=0;
1.800 albertel 3359: foreach my $item (@$storearr) {
3360: $returnhash{$item}=&thaw_unescape($pairs[$i]);
1.42 www 3361: $i++;
1.191 harris41 3362: }
1.12 www 3363: return %returnhash;
3364: }
3365:
1.667 albertel 3366: # ------------------------------------------------------------ tmpput interface
3367: sub tmpput {
1.802 raeburn 3368: my ($storehash,$server,$context)=@_;
1.667 albertel 3369: my $items='';
1.800 albertel 3370: foreach my $item (keys(%$storehash)) {
3371: $items.=&escape($item).'='.&freeze_escape($$storehash{$item}).'&';
1.667 albertel 3372: }
3373: $items=~s/\&$//;
1.802 raeburn 3374: if (defined($context)) {
3375: $items .= ':'.&escape($context);
3376: }
1.667 albertel 3377: return &reply("tmpput:$items",$server);
3378: }
3379:
3380: # ------------------------------------------------------------ tmpget interface
3381: sub tmpget {
1.688 albertel 3382: my ($token,$server)=@_;
3383: if (!defined($server)) { $server = $perlvar{'lonHostID'}; }
3384: my $rep=&reply("tmpget:$token",$server);
1.667 albertel 3385: my %returnhash;
3386: foreach my $item (split(/\&/,$rep)) {
3387: my ($key,$value)=split(/=/,$item);
3388: $returnhash{&unescape($key)}=&thaw_unescape($value);
3389: }
3390: return %returnhash;
3391: }
3392:
1.688 albertel 3393: # ------------------------------------------------------------ tmpget interface
3394: sub tmpdel {
3395: my ($token,$server)=@_;
3396: if (!defined($server)) { $server = $perlvar{'lonHostID'}; }
3397: return &reply("tmpdel:$token",$server);
3398: }
3399:
1.765 albertel 3400: # -------------------------------------------------- portfolio access checking
3401:
3402: sub portfolio_access {
1.766 albertel 3403: my ($requrl) = @_;
1.765 albertel 3404: my (undef,$udom,$unum,$file_name,$group) = &parse_portfolio_url($requrl);
3405: my $result = &get_portfolio_access($udom,$unum,$file_name,$group);
1.814 raeburn 3406: if ($result) {
3407: my %setters;
3408: if ($env{'user.name'} eq 'public' && $env{'user.domain'} eq 'public') {
3409: my ($startblock,$endblock) =
3410: &Apache::loncommon::blockcheck(\%setters,'port',$unum,$udom);
3411: if ($startblock && $endblock) {
3412: return 'B';
3413: }
3414: } else {
3415: my ($startblock,$endblock) =
3416: &Apache::loncommon::blockcheck(\%setters,'port');
3417: if ($startblock && $endblock) {
3418: return 'B';
3419: }
3420: }
3421: }
1.765 albertel 3422: if ($result eq 'ok') {
1.766 albertel 3423: return 'F';
1.765 albertel 3424: } elsif ($result =~ /^[^:]+:guest_/) {
1.766 albertel 3425: return 'A';
1.765 albertel 3426: }
1.766 albertel 3427: return '';
1.765 albertel 3428: }
3429:
3430: sub get_portfolio_access {
1.767 albertel 3431: my ($udom,$unum,$file_name,$group,$access_hash) = @_;
3432:
3433: if (!ref($access_hash)) {
3434: my $current_perms = &get_portfile_permissions($udom,$unum);
3435: my %access_controls = &get_access_controls($current_perms,$group,
3436: $file_name);
3437: $access_hash = $access_controls{$file_name};
3438: }
3439:
1.765 albertel 3440: my ($public,$guest,@domains,@users,@courses,@groups);
3441: my $now = time;
3442: if (ref($access_hash) eq 'HASH') {
3443: foreach my $key (keys(%{$access_hash})) {
3444: my ($num,$scope,$end,$start) = ($key =~ /^([^:]+):([a-z]+)_(\d*)_?(\d*)$/);
3445: if ($start > $now) {
3446: next;
3447: }
3448: if ($end && $end<$now) {
3449: next;
3450: }
3451: if ($scope eq 'public') {
3452: $public = $key;
3453: last;
3454: } elsif ($scope eq 'guest') {
3455: $guest = $key;
3456: } elsif ($scope eq 'domains') {
3457: push(@domains,$key);
3458: } elsif ($scope eq 'users') {
3459: push(@users,$key);
3460: } elsif ($scope eq 'course') {
3461: push(@courses,$key);
3462: } elsif ($scope eq 'group') {
3463: push(@groups,$key);
3464: }
3465: }
3466: if ($public) {
3467: return 'ok';
3468: }
3469: if ($env{'user.name'} eq 'public' && $env{'user.domain'} eq 'public') {
3470: if ($guest) {
3471: return $guest;
3472: }
3473: } else {
3474: if (@domains > 0) {
3475: foreach my $domkey (@domains) {
3476: if (ref($access_hash->{$domkey}{'dom'}) eq 'ARRAY') {
3477: if (grep(/^\Q$env{'user.domain'}\E$/,@{$access_hash->{$domkey}{'dom'}})) {
3478: return 'ok';
3479: }
3480: }
3481: }
3482: }
3483: if (@users > 0) {
3484: foreach my $userkey (@users) {
3485: if (exists($access_hash->{$userkey}{'users'}{$env{'user.name'}.':'.$env{'user.domain'}})) {
3486: return 'ok';
3487: }
3488: }
3489: }
3490: my %roleshash;
3491: my @courses_and_groups = @courses;
3492: push(@courses_and_groups,@groups);
3493: if (@courses_and_groups > 0) {
3494: my (%allgroups,%allroles);
3495: my ($start,$end,$role,$sec,$group);
3496: foreach my $envkey (%env) {
1.811 albertel 3497: if ($envkey =~ m-^user\.role\.(gr|cc|in|ta|ep|st)\./($match_domain)/($match_courseid)/?([^/]*)$-) {
1.765 albertel 3498: my $cid = $2.'_'.$3;
3499: if ($1 eq 'gr') {
3500: $group = $4;
3501: $allgroups{$cid}{$group} = $env{$envkey};
3502: } else {
3503: if ($4 eq '') {
3504: $sec = 'none';
3505: } else {
3506: $sec = $4;
3507: }
3508: $allroles{$cid}{$1}{$sec} = $env{$envkey};
3509: }
1.811 albertel 3510: } elsif ($envkey =~ m-^user\.role\./cr/($match_domain/$match_username/\w*)./($match_domain)/($match_courseid)/?([^/]*)$-) {
1.765 albertel 3511: my $cid = $2.'_'.$3;
3512: if ($4 eq '') {
3513: $sec = 'none';
3514: } else {
3515: $sec = $4;
3516: }
3517: $allroles{$cid}{$1}{$sec} = $env{$envkey};
3518: }
3519: }
3520: if (keys(%allroles) == 0) {
3521: return;
3522: }
3523: foreach my $key (@courses_and_groups) {
3524: my %content = %{$$access_hash{$key}};
3525: my $cnum = $content{'number'};
3526: my $cdom = $content{'domain'};
3527: my $cid = $cdom.'_'.$cnum;
3528: if (!exists($allroles{$cid})) {
3529: next;
3530: }
3531: foreach my $role_id (keys(%{$content{'roles'}})) {
3532: my @sections = @{$content{'roles'}{$role_id}{'section'}};
3533: my @groups = @{$content{'roles'}{$role_id}{'group'}};
3534: my @status = @{$content{'roles'}{$role_id}{'access'}};
3535: my @roles = @{$content{'roles'}{$role_id}{'role'}};
3536: foreach my $role (keys(%{$allroles{$cid}})) {
3537: if ((grep/^all$/,@roles) || (grep/^\Q$role\E$/,@roles)) {
3538: foreach my $sec (keys(%{$allroles{$cid}{$role}})) {
3539: if (&course_group_datechecker($allroles{$cid}{$role}{$sec},$now,\@status) eq 'ok') {
3540: if (grep/^all$/,@sections) {
3541: return 'ok';
3542: } else {
3543: if (grep/^$sec$/,@sections) {
3544: return 'ok';
3545: }
3546: }
3547: }
3548: }
3549: if (keys(%{$allgroups{$cid}}) == 0) {
3550: if (grep/^none$/,@groups) {
3551: return 'ok';
3552: }
3553: } else {
3554: if (grep/^all$/,@groups) {
3555: return 'ok';
3556: }
3557: foreach my $group (keys(%{$allgroups{$cid}})) {
3558: if (grep/^$group$/,@groups) {
3559: return 'ok';
3560: }
3561: }
3562: }
3563: }
3564: }
3565: }
3566: }
3567: }
3568: if ($guest) {
3569: return $guest;
3570: }
3571: }
3572: }
3573: return;
3574: }
3575:
3576: sub course_group_datechecker {
3577: my ($dates,$now,$status) = @_;
3578: my ($start,$end) = split(/\./,$dates);
3579: if (!$start && !$end) {
3580: return 'ok';
3581: }
3582: if (grep/^active$/,@{$status}) {
3583: if (((!$start) || ($start && $start <= $now)) && ((!$end) || ($end && $end >= $now))) {
3584: return 'ok';
3585: }
3586: }
3587: if (grep/^previous$/,@{$status}) {
3588: if ($end > $now ) {
3589: return 'ok';
3590: }
3591: }
3592: if (grep/^future$/,@{$status}) {
3593: if ($start > $now) {
3594: return 'ok';
3595: }
3596: }
3597: return;
3598: }
3599:
3600: sub parse_portfolio_url {
3601: my ($url) = @_;
3602:
3603: my ($type,$udom,$unum,$group,$file_name);
3604:
1.823 albertel 3605: if ($url =~ m-^/*(?:uploaded|editupload)/($match_domain)/($match_username)/portfolio(/.+)$-) {
1.765 albertel 3606: $type = 1;
3607: $udom = $1;
3608: $unum = $2;
3609: $file_name = $3;
1.823 albertel 3610: } elsif ($url =~ m-^/*(?:uploaded|editupload)/($match_domain)/($match_courseid)/groups/([^/]+)/portfolio/(.+)$-) {
1.765 albertel 3611: $type = 2;
3612: $udom = $1;
3613: $unum = $2;
3614: $group = $3;
3615: $file_name = $3.'/'.$4;
3616: }
3617: if (wantarray) {
3618: return ($type,$udom,$unum,$file_name,$group);
3619: }
3620: return $type;
3621: }
3622:
3623: sub is_portfolio_url {
3624: my ($url) = @_;
3625: return scalar(&parse_portfolio_url($url));
3626: }
3627:
1.798 raeburn 3628: sub is_portfolio_file {
3629: my ($file) = @_;
1.820 raeburn 3630: if (($file =~ /^portfolio/) || ($file =~ /^groups\/\w+\/portfolio/)) {
1.798 raeburn 3631: return 1;
3632: }
3633: return;
3634: }
3635:
3636:
1.341 www 3637: # ---------------------------------------------- Custom access rule evaluation
3638:
3639: sub customaccess {
3640: my ($priv,$uri)=@_;
1.807 albertel 3641: my ($urole,$urealm)=split(/\./,$env{'request.role'},2);
1.819 www 3642: my (undef,$udom,$ucrs,$usec)=split(/\//,$urealm);
1.807 albertel 3643: $udom = &LONCAPA::clean_domain($udom);
3644: $ucrs = &LONCAPA::clean_username($ucrs);
1.341 www 3645: my $access=0;
1.800 albertel 3646: foreach my $right (split(/\s*\,\s*/,&metadata($uri,'rule_rights'))) {
3647: my ($effect,$realm,$role)=split(/\:/,$right);
1.343 www 3648: if ($role) {
3649: if ($role ne $urole) { next; }
3650: }
1.800 albertel 3651: foreach my $scope (split(/\s*\,\s*/,$realm)) {
3652: my ($tdom,$tcrs,$tsec)=split(/\_/,$scope);
1.343 www 3653: if ($tdom) {
3654: if ($tdom ne $udom) { next; }
3655: }
3656: if ($tcrs) {
3657: if ($tcrs ne $ucrs) { next; }
3658: }
3659: if ($tsec) {
3660: if ($tsec ne $usec) { next; }
3661: }
3662: $access=($effect eq 'allow');
3663: last;
1.342 www 3664: }
1.402 bowersj2 3665: if ($realm eq '' && $role eq '') {
3666: $access=($effect eq 'allow');
3667: }
1.341 www 3668: }
3669: return $access;
3670: }
3671:
1.103 harris41 3672: # ------------------------------------------------- Check for a user privilege
1.12 www 3673:
3674: sub allowed {
1.810 raeburn 3675: my ($priv,$uri,$symb,$role)=@_;
1.705 albertel 3676: my $ver_orguri=$uri;
1.439 www 3677: $uri=&deversion($uri);
1.152 www 3678: my $orguri=$uri;
1.52 www 3679: $uri=&declutter($uri);
1.809 raeburn 3680:
1.810 raeburn 3681: if ($priv eq 'evb') {
3682: # Evade communication block restrictions for specified role in a course
3683: if ($env{'user.priv.'.$role} =~/evb\&([^\:]*)/) {
3684: return $1;
3685: } else {
3686: return;
3687: }
3688: }
3689:
1.620 albertel 3690: if (defined($env{'allowed.'.$priv})) { return $env{'allowed.'.$priv}; }
1.54 www 3691: # Free bre access to adm and meta resources
1.775 albertel 3692: if (((($uri=~/^adm\//) && ($uri !~ m{/(?:smppg|bulletinboard)$}))
1.769 albertel 3693: || (($uri=~/\.meta$/) && ($uri!~m|^uploaded/|) ))
3694: && ($priv eq 'bre')) {
1.14 www 3695: return 'F';
1.159 www 3696: }
3697:
1.545 banghart 3698: # Free bre access to user's own portfolio contents
1.714 raeburn 3699: my ($space,$domain,$name,@dir)=split('/',$uri);
1.647 raeburn 3700: if (($space=~/^(uploaded|editupload)$/) && ($env{'user.name'} eq $name) &&
1.714 raeburn 3701: ($env{'user.domain'} eq $domain) && ('portfolio' eq $dir[0])) {
1.814 raeburn 3702: my %setters;
3703: my ($startblock,$endblock) =
3704: &Apache::loncommon::blockcheck(\%setters,'port');
3705: if ($startblock && $endblock) {
3706: return 'B';
3707: } else {
3708: return 'F';
3709: }
1.545 banghart 3710: }
3711:
1.762 raeburn 3712: # bre access to group portfolio for rgf priv in group, or mdg or vcg in course.
1.714 raeburn 3713: if (($space=~/^(uploaded|editupload)$/) && ($dir[0] eq 'groups')
3714: && ($dir[2] eq 'portfolio') && ($priv eq 'bre')) {
3715: if (exists($env{'request.course.id'})) {
3716: my $cdom = $env{'course.'.$env{'request.course.id'}.'.domain'};
3717: my $cnum = $env{'course.'.$env{'request.course.id'}.'.num'};
3718: if (($domain eq $cdom) && ($name eq $cnum)) {
3719: my $courseprivid=$env{'request.course.id'};
3720: $courseprivid=~s/\_/\//;
3721: if ($env{'user.priv.'.$env{'request.role'}.'./'.$courseprivid
3722: .'/'.$dir[1]} =~/rgf\&([^\:]*)/) {
3723: return $1;
1.762 raeburn 3724: } else {
3725: if ($env{'request.course.sec'}) {
3726: $courseprivid.='/'.$env{'request.course.sec'};
3727: }
3728: if ($env{'user.priv.'.$env{'request.role'}.'./'.
3729: $courseprivid} =~/(mdg|vcg)\&([^\:]*)/) {
3730: return $2;
3731: }
1.714 raeburn 3732: }
3733: }
3734: }
3735: }
3736:
1.159 www 3737: # Free bre to public access
3738:
3739: if ($priv eq 'bre') {
1.238 www 3740: my $copyright=&metadata($uri,'copyright');
1.620 albertel 3741: if (($copyright eq 'public') && (!$env{'request.course.id'})) {
1.301 www 3742: return 'F';
3743: }
1.238 www 3744: if ($copyright eq 'priv') {
3745: $uri=~/([^\/]+)\/([^\/]+)\//;
1.620 albertel 3746: unless (($env{'user.name'} eq $2) && ($env{'user.domain'} eq $1)) {
1.238 www 3747: return '';
3748: }
3749: }
3750: if ($copyright eq 'domain') {
3751: $uri=~/([^\/]+)\/([^\/]+)\//;
1.620 albertel 3752: unless (($env{'user.domain'} eq $1) ||
3753: ($env{'course.'.$env{'request.course.id'}.'.domain'} eq $1)) {
1.238 www 3754: return '';
3755: }
1.262 matthew 3756: }
1.620 albertel 3757: if ($env{'request.role'}=~ /li\.\//) {
1.262 matthew 3758: # Library role, so allow browsing of resources in this domain.
3759: return 'F';
1.238 www 3760: }
1.341 www 3761: if ($copyright eq 'custom') {
3762: unless (&customaccess($priv,$uri)) { return ''; }
3763: }
1.14 www 3764: }
1.264 matthew 3765: # Domain coordinator is trying to create a course
1.620 albertel 3766: if (($priv eq 'ccc') && ($env{'request.role'} =~ /^dc\./)) {
1.264 matthew 3767: # uri is the requested domain in this case.
3768: # comparison to 'request.role.domain' shows if the user has selected
1.678 raeburn 3769: # a role of dc for the domain in question.
1.620 albertel 3770: return 'F' if ($uri eq $env{'request.role.domain'});
1.264 matthew 3771: }
1.29 www 3772:
1.52 www 3773: my $thisallowed='';
3774: my $statecond=0;
3775: my $courseprivid='';
3776:
3777: # Course
3778:
1.620 albertel 3779: if ($env{'user.priv.'.$env{'request.role'}.'./'}=~/\Q$priv\E\&([^\:]*)/) {
1.52 www 3780: $thisallowed.=$1;
3781: }
1.29 www 3782:
1.52 www 3783: # Domain
3784:
1.620 albertel 3785: if ($env{'user.priv.'.$env{'request.role'}.'./'.(split(/\//,$uri))[0].'/'}
1.479 albertel 3786: =~/\Q$priv\E\&([^\:]*)/) {
1.12 www 3787: $thisallowed.=$1;
3788: }
1.52 www 3789:
3790: # Course: uri itself is a course
1.66 www 3791: my $courseuri=$uri;
3792: $courseuri=~s/\_(\d)/\/$1/;
1.83 www 3793: $courseuri=~s/^([^\/])/\/$1/;
1.81 www 3794:
1.620 albertel 3795: if ($env{'user.priv.'.$env{'request.role'}.'.'.$courseuri}
1.479 albertel 3796: =~/\Q$priv\E\&([^\:]*)/) {
1.12 www 3797: $thisallowed.=$1;
3798: }
1.29 www 3799:
1.665 albertel 3800: # URI is an uploaded document for this course, default permissions don't matter
1.611 albertel 3801: # not allowing 'edit' access (editupload) to uploaded course docs
1.492 albertel 3802: if (($priv eq 'bre') && ($uri=~m|^uploaded/|)) {
1.665 albertel 3803: $thisallowed='';
1.671 raeburn 3804: my ($match)=&is_on_map($uri);
3805: if ($match) {
3806: if ($env{'user.priv.'.$env{'request.role'}.'./'}
3807: =~/\Q$priv\E\&([^\:]*)/) {
3808: $thisallowed.=$1;
3809: }
3810: } else {
1.705 albertel 3811: my $refuri = $env{'httpref.'.$orguri} || $env{'httpref.'.$ver_orguri};
1.671 raeburn 3812: if ($refuri) {
3813: if ($refuri =~ m|^/adm/|) {
1.669 raeburn 3814: $thisallowed='F';
1.671 raeburn 3815: } else {
3816: $refuri=&declutter($refuri);
3817: my ($match) = &is_on_map($refuri);
3818: if ($match) {
3819: $thisallowed='F';
3820: }
1.669 raeburn 3821: }
1.671 raeburn 3822: }
3823: }
1.314 www 3824: }
1.492 albertel 3825:
1.766 albertel 3826: if ($priv eq 'bre'
3827: && $thisallowed ne 'F'
3828: && $thisallowed ne '2'
3829: && &is_portfolio_url($uri)) {
3830: $thisallowed = &portfolio_access($uri);
3831: }
3832:
1.52 www 3833: # Full access at system, domain or course-wide level? Exit.
1.29 www 3834:
3835: if ($thisallowed=~/F/) {
3836: return 'F';
3837: }
3838:
1.52 www 3839: # If this is generating or modifying users, exit with special codes
1.29 www 3840:
1.643 www 3841: if (':csu:cdc:ccc:cin:cta:cep:ccr:cst:cad:cli:cau:cdg:cca:caa:'=~/\:\Q$priv\E\:/) {
3842: if (($priv eq 'cca') || ($priv eq 'caa')) {
1.642 albertel 3843: my ($audom,$auname)=split('/',$uri);
1.643 www 3844: # no author name given, so this just checks on the general right to make a co-author in this domain
3845: unless ($auname) { return $thisallowed; }
3846: # an author name is given, so we are about to actually make a co-author for a certain account
1.642 albertel 3847: if (($auname ne $env{'user.name'} && $env{'request.role'} !~ /^dc\./) ||
3848: (($audom ne $env{'user.domain'} && $env{'request.role'} !~ /^dc\./) &&
3849: ($audom ne $env{'request.role.domain'}))) { return ''; }
3850: }
1.52 www 3851: return $thisallowed;
3852: }
3853: #
1.103 harris41 3854: # Gathered so far: system, domain and course wide privileges
1.52 www 3855: #
3856: # Course: See if uri or referer is an individual resource that is part of
3857: # the course
3858:
1.620 albertel 3859: if ($env{'request.course.id'}) {
1.232 www 3860:
1.620 albertel 3861: $courseprivid=$env{'request.course.id'};
3862: if ($env{'request.course.sec'}) {
3863: $courseprivid.='/'.$env{'request.course.sec'};
1.52 www 3864: }
3865: $courseprivid=~s/\_/\//;
3866: my $checkreferer=1;
1.232 www 3867: my ($match,$cond)=&is_on_map($uri);
3868: if ($match) {
3869: $statecond=$cond;
1.620 albertel 3870: if ($env{'user.priv.'.$env{'request.role'}.'./'.$courseprivid}
1.479 albertel 3871: =~/\Q$priv\E\&([^\:]*)/) {
1.52 www 3872: $thisallowed.=$1;
3873: $checkreferer=0;
3874: }
1.29 www 3875: }
1.83 www 3876:
1.148 www 3877: if ($checkreferer) {
1.620 albertel 3878: my $refuri=$env{'httpref.'.$orguri};
1.148 www 3879: unless ($refuri) {
1.800 albertel 3880: foreach my $key (keys(%env)) {
3881: if ($key=~/^httpref\..*\*/) {
3882: my $pattern=$key;
1.156 www 3883: $pattern=~s/^httpref\.\/res\///;
1.148 www 3884: $pattern=~s/\*/\[\^\/\]\+/g;
3885: $pattern=~s/\//\\\//g;
1.152 www 3886: if ($orguri=~/$pattern/) {
1.800 albertel 3887: $refuri=$env{$key};
1.148 www 3888: }
3889: }
1.191 harris41 3890: }
1.148 www 3891: }
1.232 www 3892:
1.148 www 3893: if ($refuri) {
1.152 www 3894: $refuri=&declutter($refuri);
1.232 www 3895: my ($match,$cond)=&is_on_map($refuri);
3896: if ($match) {
3897: my $refstatecond=$cond;
1.620 albertel 3898: if ($env{'user.priv.'.$env{'request.role'}.'./'.$courseprivid}
1.479 albertel 3899: =~/\Q$priv\E\&([^\:]*)/) {
1.52 www 3900: $thisallowed.=$1;
1.53 www 3901: $uri=$refuri;
3902: $statecond=$refstatecond;
1.52 www 3903: }
3904: }
1.148 www 3905: }
1.29 www 3906: }
1.52 www 3907: }
1.29 www 3908:
1.52 www 3909: #
1.103 harris41 3910: # Gathered now: all privileges that could apply, and condition number
1.52 www 3911: #
3912: #
3913: # Full or no access?
3914: #
1.29 www 3915:
1.52 www 3916: if ($thisallowed=~/F/) {
3917: return 'F';
3918: }
1.29 www 3919:
1.52 www 3920: unless ($thisallowed) {
3921: return '';
3922: }
1.29 www 3923:
1.52 www 3924: # Restrictions exist, deal with them
3925: #
3926: # C:according to course preferences
3927: # R:according to resource settings
3928: # L:unless locked
3929: # X:according to user session state
3930: #
3931:
3932: # Possibly locked functionality, check all courses
1.54 www 3933: # Locks might take effect only after 10 minutes cache expiration for other
3934: # courses, and 2 minutes for current course
1.52 www 3935:
3936: my $envkey;
3937: if ($thisallowed=~/L/) {
1.620 albertel 3938: foreach $envkey (keys %env) {
1.54 www 3939: if ($envkey=~/^user\.role\.(st|ta)\.([^\.]*)/) {
3940: my $courseid=$2;
3941: my $roleid=$1.'.'.$2;
1.92 www 3942: $courseid=~s/^\///;
1.54 www 3943: my $expiretime=600;
1.620 albertel 3944: if ($env{'request.role'} eq $roleid) {
1.54 www 3945: $expiretime=120;
3946: }
3947: my ($cdom,$cnum,$csec)=split(/\//,$courseid);
3948: my $prefix='course.'.$cdom.'_'.$cnum.'.';
1.620 albertel 3949: if ((time-$env{$prefix.'last_cache'})>$expiretime) {
1.731 albertel 3950: &coursedescription($courseid,{'freshen_cache' => 1});
1.54 www 3951: }
1.620 albertel 3952: if (($env{$prefix.'res.'.$uri.'.lock.sections'}=~/\,\Q$csec\E\,/)
3953: || ($env{$prefix.'res.'.$uri.'.lock.sections'} eq 'all')) {
3954: if ($env{$prefix.'res.'.$uri.'.lock.expire'}>time) {
3955: &log($env{'user.domain'},$env{'user.name'},
3956: $env{'user.home'},
1.57 www 3957: 'Locked by res: '.$priv.' for '.$uri.' due to '.
1.52 www 3958: $cdom.'/'.$cnum.'/'.$csec.' expire '.
1.620 albertel 3959: $env{$prefix.'priv.'.$priv.'.lock.expire'});
1.52 www 3960: return '';
3961: }
3962: }
1.620 albertel 3963: if (($env{$prefix.'priv.'.$priv.'.lock.sections'}=~/\,\Q$csec\E\,/)
3964: || ($env{$prefix.'priv.'.$priv.'.lock.sections'} eq 'all')) {
3965: if ($env{'priv.'.$priv.'.lock.expire'}>time) {
3966: &log($env{'user.domain'},$env{'user.name'},
3967: $env{'user.home'},
1.57 www 3968: 'Locked by priv: '.$priv.' for '.$uri.' due to '.
1.52 www 3969: $cdom.'/'.$cnum.'/'.$csec.' expire '.
1.620 albertel 3970: $env{$prefix.'priv.'.$priv.'.lock.expire'});
1.52 www 3971: return '';
3972: }
3973: }
3974: }
1.29 www 3975: }
1.52 www 3976: }
3977:
3978: #
3979: # Rest of the restrictions depend on selected course
3980: #
3981:
1.620 albertel 3982: unless ($env{'request.course.id'}) {
1.766 albertel 3983: if ($thisallowed eq 'A') {
3984: return 'A';
1.814 raeburn 3985: } elsif ($thisallowed eq 'B') {
3986: return 'B';
1.766 albertel 3987: } else {
3988: return '1';
3989: }
1.52 www 3990: }
1.29 www 3991:
1.52 www 3992: #
3993: # Now user is definitely in a course
3994: #
1.53 www 3995:
3996:
3997: # Course preferences
3998:
3999: if ($thisallowed=~/C/) {
1.620 albertel 4000: my $rolecode=(split(/\./,$env{'request.role'}))[0];
4001: my $unamedom=$env{'user.name'}.':'.$env{'user.domain'};
4002: if ($env{'course.'.$env{'request.course.id'}.'.'.$priv.'.roles.denied'}
1.479 albertel 4003: =~/\Q$rolecode\E/) {
1.689 albertel 4004: if ($priv ne 'pch') {
4005: &logthis($env{'user.domain'}.':'.$env{'user.name'}.':'.$env{'user.home'}.':'.
4006: 'Denied by role: '.$priv.' for '.$uri.' as '.$rolecode.' in '.
4007: $env{'request.course.id'});
4008: }
1.237 www 4009: return '';
4010: }
4011:
1.620 albertel 4012: if ($env{'course.'.$env{'request.course.id'}.'.'.$priv.'.users.denied'}
1.479 albertel 4013: =~/\Q$unamedom\E/) {
1.689 albertel 4014: if ($priv ne 'pch') {
4015: &logthis($env{'user.domain'}.':'.$env{'user.name'}.':'.$env{'user.home'}.
4016: 'Denied by user: '.$priv.' for '.$uri.' as '.$unamedom.' in '.
4017: $env{'request.course.id'});
4018: }
1.54 www 4019: return '';
4020: }
1.53 www 4021: }
4022:
4023: # Resource preferences
4024:
4025: if ($thisallowed=~/R/) {
1.620 albertel 4026: my $rolecode=(split(/\./,$env{'request.role'}))[0];
1.479 albertel 4027: if (&metadata($uri,'roledeny')=~/\Q$rolecode\E/) {
1.689 albertel 4028: if ($priv ne 'pch') {
4029: &logthis($env{'user.domain'}.':'.$env{'user.name'}.':'.$env{'user.home'}.':'.
4030: 'Denied by role: '.$priv.' for '.$uri.' as '.$rolecode);
4031: }
4032: return '';
1.54 www 4033: }
1.53 www 4034: }
1.30 www 4035:
1.246 www 4036: # Restricted by state or randomout?
1.30 www 4037:
1.52 www 4038: if ($thisallowed=~/X/) {
1.620 albertel 4039: if ($env{'acc.randomout'}) {
1.579 albertel 4040: if (!$symb) { $symb=&symbread($uri,1); }
1.620 albertel 4041: if (($symb) && ($env{'acc.randomout'}=~/\&\Q$symb\E\&/)) {
1.248 www 4042: return '';
4043: }
1.247 www 4044: }
4045: if (&condval($statecond)) {
1.52 www 4046: return '2';
4047: } else {
4048: return '';
4049: }
4050: }
1.30 www 4051:
1.766 albertel 4052: if ($thisallowed eq 'A') {
4053: return 'A';
1.814 raeburn 4054: } elsif ($thisallowed eq 'B') {
4055: return 'B';
1.766 albertel 4056: }
1.52 www 4057: return 'F';
1.232 www 4058: }
4059:
1.710 albertel 4060: sub split_uri_for_cond {
4061: my $uri=&deversion(&declutter(shift));
4062: my @uriparts=split(/\//,$uri);
4063: my $filename=pop(@uriparts);
4064: my $pathname=join('/',@uriparts);
4065: return ($pathname,$filename);
4066: }
1.232 www 4067: # --------------------------------------------------- Is a resource on the map?
4068:
4069: sub is_on_map {
1.710 albertel 4070: my ($pathname,$filename) = &split_uri_for_cond(shift);
1.289 bowersj2 4071: #Trying to find the conditional for the file
1.620 albertel 4072: my $match=($env{'acc.res.'.$env{'request.course.id'}.'.'.$pathname}=~
1.289 bowersj2 4073: /\&\Q$filename\E\:([\d\|]+)\&/);
1.232 www 4074: if ($match) {
1.289 bowersj2 4075: return (1,$1);
4076: } else {
1.434 www 4077: return (0,0);
1.289 bowersj2 4078: }
1.12 www 4079: }
4080:
1.427 www 4081: # --------------------------------------------------------- Get symb from alias
4082:
4083: sub get_symb_from_alias {
4084: my $symb=shift;
4085: my ($map,$resid,$url)=&decode_symb($symb);
4086: # Already is a symb
4087: if ($url) { return $symb; }
4088: # Must be an alias
4089: my $aliassymb='';
4090: my %bighash;
1.620 albertel 4091: if (tie(%bighash,'GDBM_File',$env{'request.course.fn'}.'.db',
1.427 www 4092: &GDBM_READER(),0640)) {
4093: my $rid=$bighash{'mapalias_'.$symb};
4094: if ($rid) {
4095: my ($mapid,$resid)=split(/\./,$rid);
1.429 albertel 4096: $aliassymb=&encode_symb($bighash{'map_id_'.$mapid},
4097: $resid,$bighash{'src_'.$rid});
1.427 www 4098: }
4099: untie %bighash;
4100: }
4101: return $aliassymb;
4102: }
4103:
1.12 www 4104: # ----------------------------------------------------------------- Define Role
4105:
4106: sub definerole {
4107: if (allowed('mcr','/')) {
4108: my ($rolename,$sysrole,$domrole,$courole)=@_;
1.800 albertel 4109: foreach my $role (split(':',$sysrole)) {
4110: my ($crole,$cqual)=split(/\&/,$role);
1.479 albertel 4111: if ($pr{'cr:s'}!~/\Q$crole\E/) { return "refused:s:$crole"; }
4112: if ($pr{'cr:s'}=~/\Q$crole\E\&/) {
4113: if ($pr{'cr:s'}!~/\Q$crole\E\&\w*\Q$cqual\E/) {
1.21 www 4114: return "refused:s:$crole&$cqual";
4115: }
4116: }
1.191 harris41 4117: }
1.800 albertel 4118: foreach my $role (split(':',$domrole)) {
4119: my ($crole,$cqual)=split(/\&/,$role);
1.479 albertel 4120: if ($pr{'cr:d'}!~/\Q$crole\E/) { return "refused:d:$crole"; }
4121: if ($pr{'cr:d'}=~/\Q$crole\E\&/) {
4122: if ($pr{'cr:d'}!~/\Q$crole\W\&\w*\Q$cqual\E/) {
1.21 www 4123: return "refused:d:$crole&$cqual";
4124: }
4125: }
1.191 harris41 4126: }
1.800 albertel 4127: foreach my $role (split(':',$courole)) {
4128: my ($crole,$cqual)=split(/\&/,$role);
1.479 albertel 4129: if ($pr{'cr:c'}!~/\Q$crole\E/) { return "refused:c:$crole"; }
4130: if ($pr{'cr:c'}=~/\Q$crole\E\&/) {
4131: if ($pr{'cr:c'}!~/\Q$crole\E\&\w*\Q$cqual\E/) {
1.21 www 4132: return "refused:c:$crole&$cqual";
4133: }
4134: }
1.191 harris41 4135: }
1.620 albertel 4136: my $command="encrypt:rolesput:$env{'user.domain'}:$env{'user.name'}:".
4137: "$env{'user.domain'}:$env{'user.name'}:".
1.21 www 4138: "rolesdef_$rolename=".
4139: escape($sysrole.'_'.$domrole.'_'.$courole);
1.620 albertel 4140: return reply($command,$env{'user.home'});
1.12 www 4141: } else {
4142: return 'refused';
4143: }
1.105 harris41 4144: }
4145:
4146: # ---------------- Make a metadata query against the network of library servers
4147:
4148: sub metadata_query {
1.244 matthew 4149: my ($query,$custom,$customshow,$server_array)=@_;
1.120 harris41 4150: my %rhash;
1.244 matthew 4151: my @server_list = (defined($server_array) ? @$server_array
4152: : keys(%libserv) );
4153: for my $server (@server_list) {
1.118 harris41 4154: unless ($custom or $customshow) {
4155: my $reply=&reply("querysend:".&escape($query),$server);
4156: $rhash{$server}=$reply;
4157: }
4158: else {
4159: my $reply=&reply("querysend:".&escape($query).':'.
4160: &escape($custom).':'.&escape($customshow),
4161: $server);
4162: $rhash{$server}=$reply;
4163: }
1.112 harris41 4164: }
1.118 harris41 4165: return \%rhash;
1.240 www 4166: }
4167:
4168: # ----------------------------------------- Send log queries and wait for reply
4169:
4170: sub log_query {
4171: my ($uname,$udom,$query,%filters)=@_;
4172: my $uhome=&homeserver($uname,$udom);
4173: if ($uhome eq 'no_host') { return 'error: no_host'; }
4174: my $uhost=$hostname{$uhome};
1.800 albertel 4175: my $command=&escape(join(':',map{$_.'='.$filters{$_}} keys(%filters)));
1.240 www 4176: my $queryid=&reply("querysend:".$query.':'.$udom.':'.$uname.':'.$command,
4177: $uhome);
1.479 albertel 4178: unless ($queryid=~/^\Q$uhost\E\_/) { return 'error: '.$queryid; }
1.242 www 4179: return get_query_reply($queryid);
4180: }
4181:
1.818 raeburn 4182: # -------------------------- Update MySQL table for portfolio file
4183:
4184: sub update_portfolio_table {
1.821 raeburn 4185: my ($uname,$udom,$file_name,$query,$group,$action) = @_;
1.818 raeburn 4186: my $homeserver = &homeserver($uname,$udom);
4187: my $queryid=
1.821 raeburn 4188: &reply("querysend:".$query.':'.&escape($uname.':'.$udom.':'.$group).
4189: ':'.&escape($file_name).':'.$action,$homeserver);
1.818 raeburn 4190: my $reply = &get_query_reply($queryid);
4191: return $reply;
4192: }
4193:
1.508 raeburn 4194: # ------- Request retrieval of institutional classlists for course(s)
1.506 raeburn 4195:
4196: sub fetch_enrollment_query {
1.511 raeburn 4197: my ($context,$affiliatesref,$replyref,$dom,$cnum) = @_;
1.508 raeburn 4198: my $homeserver;
1.547 raeburn 4199: my $maxtries = 1;
1.508 raeburn 4200: if ($context eq 'automated') {
4201: $homeserver = $perlvar{'lonHostID'};
1.547 raeburn 4202: $maxtries = 10; # will wait for up to 2000s for retrieval of classlist data before timeout
1.508 raeburn 4203: } else {
4204: $homeserver = &homeserver($cnum,$dom);
4205: }
1.506 raeburn 4206: my $host=$hostname{$homeserver};
4207: my $cmd = '';
1.800 albertel 4208: foreach my $affiliate (keys %{$affiliatesref}) {
4209: $cmd .= $affiliate.'='.join(",",@{$$affiliatesref{$affiliate}}).'%%';
1.506 raeburn 4210: }
4211: $cmd =~ s/%%$//;
4212: $cmd = &escape($cmd);
4213: my $query = 'fetchenrollment';
1.620 albertel 4214: my $queryid=&reply("querysend:".$query.':'.$dom.':'.$env{'user.name'}.':'.$cmd,$homeserver);
1.526 raeburn 4215: unless ($queryid=~/^\Q$host\E\_/) {
4216: &logthis('fetch_enrollment_query: invalid queryid: '.$queryid.' for host: '.$host.' and homeserver: '.$homeserver.' context: '.$context.' '.$cnum);
4217: return 'error: '.$queryid;
4218: }
1.506 raeburn 4219: my $reply = &get_query_reply($queryid);
1.547 raeburn 4220: my $tries = 1;
4221: while (($reply=~/^timeout/) && ($tries < $maxtries)) {
4222: $reply = &get_query_reply($queryid);
4223: $tries ++;
4224: }
1.526 raeburn 4225: if ( ($reply =~/^timeout/) || ($reply =~/^error/) ) {
1.620 albertel 4226: &logthis('fetch_enrollment_query error: '.$reply.' for '.$dom.' '.$env{'user.name'}.' for '.$queryid.' context: '.$context.' '.$cnum.' maxtries: '.$maxtries.' tries: '.$tries);
1.526 raeburn 4227: } else {
1.515 raeburn 4228: my @responses = split/:/,$reply;
4229: if ($homeserver eq $perlvar{'lonHostID'}) {
1.800 albertel 4230: foreach my $line (@responses) {
4231: my ($key,$value) = split(/=/,$line,2);
1.515 raeburn 4232: $$replyref{$key} = $value;
4233: }
4234: } else {
1.506 raeburn 4235: my $pathname = $perlvar{'lonDaemons'}.'/tmp';
1.800 albertel 4236: foreach my $line (@responses) {
4237: my ($key,$value) = split(/=/,$line);
1.506 raeburn 4238: $$replyref{$key} = $value;
4239: if ($value > 0) {
1.800 albertel 4240: foreach my $item (@{$$affiliatesref{$key}}) {
4241: my $filename = $dom.'_'.$key.'_'.$item.'_classlist.xml';
1.506 raeburn 4242: my $destname = $pathname.'/'.$filename;
4243: my $xml_classlist = &reply("autoretrieve:".$filename,$homeserver);
1.526 raeburn 4244: if ($xml_classlist =~ /^error/) {
4245: &logthis('fetch_enrollment_query - autoretrieve error: '.$xml_classlist.' for '.$filename.' from server: '.$homeserver.' '.$context.' '.$cnum);
4246: } else {
1.506 raeburn 4247: if ( open(FILE,">$destname") ) {
4248: print FILE &unescape($xml_classlist);
4249: close(FILE);
1.526 raeburn 4250: } else {
4251: &logthis('fetch_enrollment_query - error opening classlist file '.$destname.' '.$context.' '.$cnum);
1.506 raeburn 4252: }
4253: }
4254: }
4255: }
4256: }
4257: }
4258: return 'ok';
4259: }
4260: return 'error';
4261: }
4262:
1.242 www 4263: sub get_query_reply {
4264: my $queryid=shift;
1.240 www 4265: my $replyfile=$perlvar{'lonDaemons'}.'/tmp/'.$queryid;
4266: my $reply='';
4267: for (1..100) {
4268: sleep 2;
4269: if (-e $replyfile.'.end') {
1.448 albertel 4270: if (open(my $fh,$replyfile)) {
1.240 www 4271: $reply.=<$fh>;
1.448 albertel 4272: close($fh);
1.240 www 4273: } else { return 'error: reply_file_error'; }
1.242 www 4274: return &unescape($reply);
4275: }
1.240 www 4276: }
1.242 www 4277: return 'timeout:'.$queryid;
1.240 www 4278: }
4279:
4280: sub courselog_query {
1.241 www 4281: #
4282: # possible filters:
4283: # url: url or symb
4284: # username
4285: # domain
4286: # action: view, submit, grade
4287: # start: timestamp
4288: # end: timestamp
4289: #
1.240 www 4290: my (%filters)=@_;
1.620 albertel 4291: unless ($env{'request.course.id'}) { return 'no_course'; }
1.241 www 4292: if ($filters{'url'}) {
4293: $filters{'url'}=&symbclean(&declutter($filters{'url'}));
4294: $filters{'url'}=~s/\.(\w+)$/(\\.\\d+)*\\.$1/;
4295: $filters{'url'}=~s/\.(\w+)\_\_\_/(\\.\\d+)*\\.$1/;
4296: }
1.620 albertel 4297: my $cname=$env{'course.'.$env{'request.course.id'}.'.num'};
4298: my $cdom=$env{'course.'.$env{'request.course.id'}.'.domain'};
1.240 www 4299: return &log_query($cname,$cdom,'courselog',%filters);
4300: }
4301:
4302: sub userlog_query {
4303: my ($uname,$udom,%filters)=@_;
4304: return &log_query($uname,$udom,'userlog',%filters);
1.12 www 4305: }
4306:
1.506 raeburn 4307: #--------- Call auto-enrollment subs in localenroll.pm for homeserver for course
4308:
4309: sub auto_run {
1.508 raeburn 4310: my ($cnum,$cdom) = @_;
4311: my $homeserver = &homeserver($cnum,$cdom);
1.511 raeburn 4312: my $response = &reply('autorun:'.$cdom,$homeserver);
1.506 raeburn 4313: return $response;
4314: }
1.776 albertel 4315:
1.506 raeburn 4316: sub auto_get_sections {
1.508 raeburn 4317: my ($cnum,$cdom,$inst_coursecode) = @_;
4318: my $homeserver = &homeserver($cnum,$cdom);
1.506 raeburn 4319: my @secs = ();
1.511 raeburn 4320: my $response=&unescape(&reply('autogetsections:'.$inst_coursecode.':'.$cdom,$homeserver));
1.506 raeburn 4321: unless ($response eq 'refused') {
4322: @secs = split/:/,$response;
4323: }
4324: return @secs;
4325: }
1.776 albertel 4326:
1.506 raeburn 4327: sub auto_new_course {
1.508 raeburn 4328: my ($cnum,$cdom,$inst_course_id,$owner) = @_;
4329: my $homeserver = &homeserver($cnum,$cdom);
1.515 raeburn 4330: my $response=&unescape(&reply('autonewcourse:'.$inst_course_id.':'.$owner.':'.$cdom,$homeserver));
1.506 raeburn 4331: return $response;
4332: }
1.776 albertel 4333:
1.506 raeburn 4334: sub auto_validate_courseID {
1.508 raeburn 4335: my ($cnum,$cdom,$inst_course_id) = @_;
4336: my $homeserver = &homeserver($cnum,$cdom);
1.511 raeburn 4337: my $response=&unescape(&reply('autovalidatecourse:'.$inst_course_id.':'.$cdom,$homeserver));
1.506 raeburn 4338: return $response;
4339: }
1.776 albertel 4340:
1.506 raeburn 4341: sub auto_create_password {
1.508 raeburn 4342: my ($cnum,$cdom,$authparam) = @_;
4343: my $homeserver = &homeserver($cnum,$cdom);
1.506 raeburn 4344: my $create_passwd = 0;
4345: my $authchk = '';
1.511 raeburn 4346: my $response=&unescape(&reply('autocreatepassword:'.$authparam.':'.$cdom,$homeserver));
1.506 raeburn 4347: if ($response eq 'refused') {
4348: $authchk = 'refused';
4349: } else {
4350: ($authparam,$create_passwd,$authchk) = split/:/,$response;
4351: }
4352: return ($authparam,$create_passwd,$authchk);
4353: }
4354:
1.706 raeburn 4355: sub auto_photo_permission {
4356: my ($cnum,$cdom,$students) = @_;
4357: my $homeserver = &homeserver($cnum,$cdom);
1.707 albertel 4358: my ($outcome,$perm_reqd,$conditions) =
4359: split(/:/,&unescape(&reply('autophotopermission:'.$cdom,$homeserver)),3);
1.709 albertel 4360: if ($outcome =~ /^(con_lost|unknown_cmd|no_such_host)$/) {
4361: return (undef,undef);
4362: }
1.706 raeburn 4363: return ($outcome,$perm_reqd,$conditions);
4364: }
4365:
4366: sub auto_checkphotos {
4367: my ($uname,$udom,$pid) = @_;
4368: my $homeserver = &homeserver($uname,$udom);
4369: my ($result,$resulttype);
4370: my $outcome = &unescape(&reply('autophotocheck:'.&escape($udom).':'.
1.707 albertel 4371: &escape($uname).':'.&escape($pid),
4372: $homeserver));
1.709 albertel 4373: if ($outcome =~ /^(con_lost|unknown_cmd|no_such_host)$/) {
4374: return (undef,undef);
4375: }
1.706 raeburn 4376: if ($outcome) {
4377: ($result,$resulttype) = split(/:/,$outcome);
4378: }
4379: return ($result,$resulttype);
4380: }
4381:
4382: sub auto_photochoice {
4383: my ($cnum,$cdom) = @_;
4384: my $homeserver = &homeserver($cnum,$cdom);
4385: my ($update,$comment) = split(/:/,&unescape(&reply('autophotochoice:'.
1.707 albertel 4386: &escape($cdom),
4387: $homeserver)));
1.709 albertel 4388: if ($update =~ /^(con_lost|unknown_cmd|no_such_host)$/) {
4389: return (undef,undef);
4390: }
1.706 raeburn 4391: return ($update,$comment);
4392: }
4393:
4394: sub auto_photoupdate {
4395: my ($affiliatesref,$dom,$cnum,$photo) = @_;
4396: my $homeserver = &homeserver($cnum,$dom);
4397: my $host=$hostname{$homeserver};
4398: my $cmd = '';
4399: my $maxtries = 1;
1.800 albertel 4400: foreach my $affiliate (keys(%{$affiliatesref})) {
4401: $cmd .= $affiliate.'='.join(",",@{$$affiliatesref{$affiliate}}).'%%';
1.706 raeburn 4402: }
4403: $cmd =~ s/%%$//;
4404: $cmd = &escape($cmd);
4405: my $query = 'institutionalphotos';
4406: my $queryid=&reply("querysend:".$query.':'.$dom.':'.$cnum.':'.$cmd,$homeserver);
4407: unless ($queryid=~/^\Q$host\E\_/) {
4408: &logthis('institutionalphotos: invalid queryid: '.$queryid.' for host: '.$host.' and homeserver: '.$homeserver.' and course: '.$cnum);
4409: return 'error: '.$queryid;
4410: }
4411: my $reply = &get_query_reply($queryid);
4412: my $tries = 1;
4413: while (($reply=~/^timeout/) && ($tries < $maxtries)) {
4414: $reply = &get_query_reply($queryid);
4415: $tries ++;
4416: }
4417: if ( ($reply =~/^timeout/) || ($reply =~/^error/) ) {
4418: &logthis('institutionalphotos error: '.$reply.' for '.$dom.' '.$env{'user.name'}.' for '.$queryid.' course: '.$cnum.' maxtries: '.$maxtries.' tries: '.$tries);
4419: } else {
4420: my @responses = split(/:/,$reply);
4421: my $outcome = shift(@responses);
4422: foreach my $item (@responses) {
4423: my ($key,$value) = split(/=/,$item);
4424: $$photo{$key} = $value;
4425: }
4426: return $outcome;
4427: }
4428: return 'error';
4429: }
4430:
1.521 raeburn 4431: sub auto_instcode_format {
1.793 albertel 4432: my ($caller,$codedom,$instcodes,$codes,$codetitles,$cat_titles,
4433: $cat_order) = @_;
1.521 raeburn 4434: my $courses = '';
1.772 raeburn 4435: my @homeservers;
1.521 raeburn 4436: if ($caller eq 'global') {
1.793 albertel 4437: foreach my $tryserver (keys(%libserv)) {
1.584 raeburn 4438: if ($hostdom{$tryserver} eq $codedom) {
1.793 albertel 4439: if (!grep(/^\Q$tryserver\E$/,@homeservers)) {
1.772 raeburn 4440: push(@homeservers,$tryserver);
4441: }
1.584 raeburn 4442: }
4443: }
1.521 raeburn 4444: } else {
1.772 raeburn 4445: push(@homeservers,&homeserver($caller,$codedom));
1.521 raeburn 4446: }
1.793 albertel 4447: foreach my $code (keys(%{$instcodes})) {
4448: $courses .= &escape($code).'='.&escape($$instcodes{$code}).'&';
1.521 raeburn 4449: }
4450: chop($courses);
1.772 raeburn 4451: my $ok_response = 0;
4452: my $response;
4453: while (@homeservers > 0 && $ok_response == 0) {
4454: my $server = shift(@homeservers);
4455: $response=&reply('autoinstcodeformat:'.$codedom.':'.$courses,$server);
4456: if ($response !~ /(con_lost|error|no_such_host|refused)/) {
4457: my ($codes_str,$codetitles_str,$cat_titles_str,$cat_order_str) =
1.793 albertel 4458: split/:/,$response;
1.772 raeburn 4459: %{$codes} = (%{$codes},&str2hash($codes_str));
4460: push(@{$codetitles},&str2array($codetitles_str));
4461: %{$cat_titles} = (%{$cat_titles},&str2hash($cat_titles_str));
4462: %{$cat_order} = (%{$cat_order},&str2hash($cat_order_str));
4463: $ok_response = 1;
4464: }
4465: }
4466: if ($ok_response) {
1.521 raeburn 4467: return 'ok';
1.772 raeburn 4468: } else {
4469: return $response;
1.521 raeburn 4470: }
4471: }
4472:
1.792 raeburn 4473: sub auto_instcode_defaults {
4474: my ($domain,$returnhash,$code_order) = @_;
4475: my @homeservers;
1.793 albertel 4476: foreach my $tryserver (keys(%libserv)) {
1.792 raeburn 4477: if ($hostdom{$tryserver} eq $domain) {
1.793 albertel 4478: if (!grep(/^\Q$tryserver\E$/,@homeservers)) {
1.792 raeburn 4479: push(@homeservers,$tryserver);
4480: }
4481: }
4482: }
4483: my $ok_response = 0;
4484: my $response;
4485: while (@homeservers > 0 && $ok_response == 0) {
4486: my $server = shift(@homeservers);
4487: $response=&reply('autoinstcodedefaults:'.$domain,$server);
4488: if ($response !~ /(con_lost|error|no_such_host|refused)/) {
1.793 albertel 4489: foreach my $pair (split(/\&/,$response)) {
4490: my ($name,$value)=split(/\=/,$pair);
1.792 raeburn 4491: if ($name eq 'code_order') {
1.796 raeburn 4492: @{$code_order} = split(/\&/,&unescape($value));
1.792 raeburn 4493: } else {
1.796 raeburn 4494: $returnhash->{&unescape($name)}=&unescape($value);
1.792 raeburn 4495: }
4496: }
1.804 raeburn 4497: $ok_response = 1;
1.792 raeburn 4498: }
4499: }
4500: if ($ok_response) {
4501: return 'ok';
4502: } else {
4503: return $response;
4504: }
4505: }
4506:
1.777 albertel 4507: sub auto_validate_class_sec {
1.773 raeburn 4508: my ($cdom,$cnum,$owner,$inst_class) = @_;
4509: my $homeserver = &homeserver($cnum,$cdom);
4510: my $response=&reply('autovalidateclass_sec:'.$inst_class.':'.
1.774 banghart 4511: &escape($owner).':'.$cdom,$homeserver);
1.773 raeburn 4512: return $response;
4513: }
4514:
1.679 raeburn 4515: # ------------------------------------------------------- Course Group routines
4516:
4517: sub get_coursegroups {
1.809 raeburn 4518: my ($cdom,$cnum,$group,$namespace) = @_;
4519: return(&dump($namespace,$cdom,$cnum,$group));
1.805 raeburn 4520: }
4521:
1.679 raeburn 4522: sub modify_coursegroup {
4523: my ($cdom,$cnum,$groupsettings) = @_;
4524: return(&put('coursegroups',$groupsettings,$cdom,$cnum));
4525: }
4526:
1.809 raeburn 4527: sub toggle_coursegroup_status {
4528: my ($cdom,$cnum,$group,$action) = @_;
4529: my ($from_namespace,$to_namespace);
4530: if ($action eq 'delete') {
4531: $from_namespace = 'coursegroups';
4532: $to_namespace = 'deleted_groups';
4533: } else {
4534: $from_namespace = 'deleted_groups';
4535: $to_namespace = 'coursegroups';
4536: }
4537: my %curr_group = &get_coursegroups($cdom,$cnum,$group,$from_namespace);
1.805 raeburn 4538: if (my $tmp = &error(%curr_group)) {
4539: &Apache::lonnet::logthis('Error retrieving group: '.$tmp.' in '.$cnum.':'.$cdom);
4540: return ('read error',$tmp);
4541: } else {
4542: my %savedsettings = %curr_group;
1.809 raeburn 4543: my $result = &put($to_namespace,\%savedsettings,$cdom,$cnum);
1.805 raeburn 4544: my $deloutcome;
4545: if ($result eq 'ok') {
1.809 raeburn 4546: $deloutcome = &del($from_namespace,[$group],$cdom,$cnum);
1.805 raeburn 4547: } else {
4548: return ('write error',$result);
4549: }
4550: if ($deloutcome eq 'ok') {
4551: return 'ok';
4552: } else {
4553: return ('delete error',$deloutcome);
4554: }
4555: }
4556: }
4557:
1.679 raeburn 4558: sub modify_group_roles {
4559: my ($cdom,$cnum,$group_id,$user,$end,$start,$userprivs) = @_;
4560: my $url = '/'.$cdom.'/'.$cnum.'/'.$group_id;
4561: my $role = 'gr/'.&escape($userprivs);
4562: my ($uname,$udom) = split(/:/,$user);
4563: my $result = &assignrole($udom,$uname,$url,$role,$end,$start);
1.684 raeburn 4564: if ($result eq 'ok') {
4565: &devalidate_getgroups_cache($udom,$uname,$cdom,$cnum);
4566: }
1.679 raeburn 4567: return $result;
4568: }
4569:
4570: sub modify_coursegroup_membership {
4571: my ($cdom,$cnum,$membership) = @_;
4572: my $result = &put('groupmembership',$membership,$cdom,$cnum);
4573: return $result;
4574: }
4575:
1.682 raeburn 4576: sub get_active_groups {
4577: my ($udom,$uname,$cdom,$cnum) = @_;
4578: my $now = time;
4579: my %groups = ();
4580: foreach my $key (keys(%env)) {
1.811 albertel 4581: if ($key =~ m-user\.role\.gr\./($match_domain)/($match_courseid)/(\w+)$-) {
1.682 raeburn 4582: my ($start,$end) = split(/\./,$env{$key});
4583: if (($end!=0) && ($end<$now)) { next; }
4584: if (($start!=0) && ($start>$now)) { next; }
4585: if ($1 eq $cdom && $2 eq $cnum) {
4586: $groups{$3} = $env{$key} ;
4587: }
4588: }
4589: }
4590: return %groups;
4591: }
4592:
1.683 raeburn 4593: sub get_group_membership {
4594: my ($cdom,$cnum,$group) = @_;
4595: return(&dump('groupmembership',$cdom,$cnum,$group));
4596: }
4597:
4598: sub get_users_groups {
4599: my ($udom,$uname,$courseid) = @_;
1.733 raeburn 4600: my @usersgroups;
1.683 raeburn 4601: my $cachetime=1800;
4602:
4603: my $hashid="$udom:$uname:$courseid";
1.733 raeburn 4604: my ($grouplist,$cached)=&is_cached_new('getgroups',$hashid);
4605: if (defined($cached)) {
1.734 albertel 4606: @usersgroups = split(/:/,$grouplist);
1.733 raeburn 4607: } else {
4608: $grouplist = '';
1.816 raeburn 4609: my $courseurl = &courseid_to_courseurl($courseid);
4610: my %roleshash = &dump('roles',$udom,$uname,$courseurl);
1.817 raeburn 4611: my $access_end = $env{'course.'.$courseid.
4612: '.default_enrollment_end_date'};
4613: my $now = time;
4614: foreach my $key (keys(%roleshash)) {
4615: if ($key =~ /^\Q$courseurl\E\/(\w+)\_gr$/) {
4616: my $group = $1;
4617: if ($roleshash{$key} =~ /_(\d+)_(\d+)$/) {
4618: my $start = $2;
4619: my $end = $1;
4620: if ($start == -1) { next; } # deleted from group
4621: if (($start!=0) && ($start>$now)) { next; }
4622: if (($end!=0) && ($end<$now)) {
4623: if ($access_end && $access_end < $now) {
4624: if ($access_end - $end < 86400) {
4625: push(@usersgroups,$group);
1.733 raeburn 4626: }
4627: }
1.817 raeburn 4628: next;
1.733 raeburn 4629: }
1.817 raeburn 4630: push(@usersgroups,$group);
1.683 raeburn 4631: }
4632: }
4633: }
1.817 raeburn 4634: @usersgroups = &sort_course_groups($courseid,@usersgroups);
4635: $grouplist = join(':',@usersgroups);
4636: &do_cache_new('getgroups',$hashid,$grouplist,$cachetime);
1.683 raeburn 4637: }
1.733 raeburn 4638: return @usersgroups;
1.683 raeburn 4639: }
4640:
4641: sub devalidate_getgroups_cache {
4642: my ($udom,$uname,$cdom,$cnum)=@_;
4643: my $courseid = $cdom.'_'.$cnum;
1.807 albertel 4644:
1.683 raeburn 4645: my $hashid="$udom:$uname:$courseid";
4646: &devalidate_cache_new('getgroups',$hashid);
4647: }
4648:
1.12 www 4649: # ------------------------------------------------------------------ Plain Text
4650:
4651: sub plaintext {
1.742 raeburn 4652: my ($short,$type,$cid) = @_;
1.758 albertel 4653: if ($short =~ /^cr/) {
4654: return (split('/',$short))[-1];
4655: }
1.742 raeburn 4656: if (!defined($cid)) {
4657: $cid = $env{'request.course.id'};
4658: }
4659: if (defined($cid) && defined($env{'course.'.$cid.'.'.$short.'.plaintext'})) {
4660: return &Apache::lonlocal::mt($env{'course.'.$cid.'.'.$short.
4661: '.plaintext'});
4662: }
4663: my %rolenames = (
4664: Course => 'std',
4665: Group => 'alt1',
4666: );
4667: if (defined($type) &&
4668: defined($rolenames{$type}) &&
4669: defined($prp{$short}{$rolenames{$type}})) {
4670: return &Apache::lonlocal::mt($prp{$short}{$rolenames{$type}});
4671: } else {
4672: return &Apache::lonlocal::mt($prp{$short}{'std'});
4673: }
1.12 www 4674: }
4675:
4676: # ----------------------------------------------------------------- Assign Role
4677:
4678: sub assignrole {
1.357 www 4679: my ($udom,$uname,$url,$role,$end,$start,$deleteflag)=@_;
1.21 www 4680: my $mrole;
4681: if ($role =~ /^cr\//) {
1.393 www 4682: my $cwosec=$url;
1.811 albertel 4683: $cwosec=~s/^\/($match_domain)\/($match_courseid)\/.*/$1\/$2/;
1.393 www 4684: unless (&allowed('ccr',$cwosec)) {
1.104 www 4685: &logthis('Refused custom assignrole: '.
4686: $udom.' '.$uname.' '.$url.' '.$role.' '.$end.' '.$start.' by '.
1.620 albertel 4687: $env{'user.name'}.' at '.$env{'user.domain'});
1.104 www 4688: return 'refused';
4689: }
1.21 www 4690: $mrole='cr';
1.678 raeburn 4691: } elsif ($role =~ /^gr\//) {
4692: my $cwogrp=$url;
1.811 albertel 4693: $cwogrp=~s{^/($match_domain)/($match_courseid)/.*}{$1/$2};
1.678 raeburn 4694: unless (&allowed('mdg',$cwogrp)) {
4695: &logthis('Refused group assignrole: '.
4696: $udom.' '.$uname.' '.$url.' '.$role.' '.$end.' '.$start.' by '.
4697: $env{'user.name'}.' at '.$env{'user.domain'});
4698: return 'refused';
4699: }
4700: $mrole='gr';
1.21 www 4701: } else {
1.82 www 4702: my $cwosec=$url;
1.811 albertel 4703: $cwosec=~s/^\/($match_domain)\/($match_courseid)\/.*/$1\/$2/;
1.373 www 4704: unless ((&allowed('c'.$role,$cwosec)) || &allowed('c'.$role,$udom)) {
1.104 www 4705: &logthis('Refused assignrole: '.
4706: $udom.' '.$uname.' '.$url.' '.$role.' '.$end.' '.$start.' by '.
1.620 albertel 4707: $env{'user.name'}.' at '.$env{'user.domain'});
1.104 www 4708: return 'refused';
4709: }
1.21 www 4710: $mrole=$role;
4711: }
1.620 albertel 4712: my $command="encrypt:rolesput:$env{'user.domain'}:$env{'user.name'}:".
1.21 www 4713: "$udom:$uname:$url".'_'."$mrole=$role";
1.81 www 4714: if ($end) { $command.='_'.$end; }
1.21 www 4715: if ($start) {
4716: if ($end) {
1.81 www 4717: $command.='_'.$start;
1.21 www 4718: } else {
1.81 www 4719: $command.='_0_'.$start;
1.21 www 4720: }
4721: }
1.739 raeburn 4722: my $origstart = $start;
4723: my $origend = $end;
1.357 www 4724: # actually delete
4725: if ($deleteflag) {
1.373 www 4726: if ((&allowed('dro',$udom)) || (&allowed('dro',$url))) {
1.357 www 4727: # modify command to delete the role
1.620 albertel 4728: $command="encrypt:rolesdel:$env{'user.domain'}:$env{'user.name'}:".
1.357 www 4729: "$udom:$uname:$url".'_'."$mrole";
1.620 albertel 4730: &logthis("$env{'user.name'} at $env{'user.domain'} deletes $mrole in $url for $uname at $udom");
1.357 www 4731: # set start and finish to negative values for userrolelog
4732: $start=-1;
4733: $end=-1;
4734: }
4735: }
4736: # send command
1.349 www 4737: my $answer=&reply($command,&homeserver($uname,$udom));
1.357 www 4738: # log new user role if status is ok
1.349 www 4739: if ($answer eq 'ok') {
1.663 raeburn 4740: &userrolelog($role,$uname,$udom,$url,$start,$end);
1.739 raeburn 4741: # for course roles, perform group memberships changes triggered by role change.
4742: unless ($role =~ /^gr/) {
4743: &Apache::longroup::group_changes($udom,$uname,$url,$role,$origend,
4744: $origstart);
4745: }
1.349 www 4746: }
4747: return $answer;
1.169 harris41 4748: }
4749:
4750: # -------------------------------------------------- Modify user authentication
1.197 www 4751: # Overrides without validation
4752:
1.169 harris41 4753: sub modifyuserauth {
4754: my ($udom,$uname,$umode,$upass)=@_;
4755: my $uhome=&homeserver($uname,$udom);
1.197 www 4756: unless (&allowed('mau',$udom)) { return 'refused'; }
4757: &logthis('Call to modify user authentication '.$udom.', '.$uname.', '.
1.620 albertel 4758: $umode.' by '.$env{'user.name'}.' at '.$env{'user.domain'}.
4759: ' in domain '.$env{'request.role.domain'});
1.169 harris41 4760: my $reply=&reply('encrypt:changeuserauth:'.$udom.':'.$uname.':'.$umode.':'.
4761: &escape($upass),$uhome);
1.620 albertel 4762: &log($env{'user.domain'},$env{'user.name'},$env{'user.home'},
1.197 www 4763: 'Authentication changed for '.$udom.', '.$uname.', '.$umode.
4764: '(Remote '.$ENV{'REMOTE_ADDR'}.'): '.$reply);
4765: &log($udom,,$uname,$uhome,
1.620 albertel 4766: 'Authentication changed by '.$env{'user.domain'}.', '.
4767: $env{'user.name'}.', '.$umode.
1.197 www 4768: '(Remote '.$ENV{'REMOTE_ADDR'}.'): '.$reply);
1.169 harris41 4769: unless ($reply eq 'ok') {
1.197 www 4770: &logthis('Authentication mode error: '.$reply);
1.169 harris41 4771: return 'error: '.$reply;
4772: }
1.170 harris41 4773: return 'ok';
1.80 www 4774: }
4775:
1.81 www 4776: # --------------------------------------------------------------- Modify a user
1.80 www 4777:
1.81 www 4778: sub modifyuser {
1.206 matthew 4779: my ($udom, $uname, $uid,
4780: $umode, $upass, $first,
4781: $middle, $last, $gene,
1.387 www 4782: $forceid, $desiredhome, $email)=@_;
1.807 albertel 4783: $udom= &LONCAPA::clean_domain($udom);
4784: $uname=&LONCAPA::clean_username($uname);
1.81 www 4785: &logthis('Call to modify user '.$udom.', '.$uname.', '.$uid.', '.
1.80 www 4786: $umode.', '.$first.', '.$middle.', '.
1.206 matthew 4787: $last.', '.$gene.'(forceid: '.$forceid.')'.
4788: (defined($desiredhome) ? ' desiredhome = '.$desiredhome :
4789: ' desiredhome not specified').
1.620 albertel 4790: ' by '.$env{'user.name'}.' at '.$env{'user.domain'}.
4791: ' in domain '.$env{'request.role.domain'});
1.230 stredwic 4792: my $uhome=&homeserver($uname,$udom,'true');
1.80 www 4793: # ----------------------------------------------------------------- Create User
1.406 albertel 4794: if (($uhome eq 'no_host') &&
4795: (($umode && $upass) || ($umode eq 'localauth'))) {
1.80 www 4796: my $unhome='';
1.209 matthew 4797: if (defined($desiredhome) && $hostdom{$desiredhome} eq $udom) {
4798: $unhome = $desiredhome;
1.620 albertel 4799: } elsif($env{'course.'.$env{'request.course.id'}.'.domain'} eq $udom) {
4800: $unhome=$env{'course.'.$env{'request.course.id'}.'.home'};
1.209 matthew 4801: } else { # load balancing routine for determining $unhome
1.80 www 4802: my $tryserver;
1.81 www 4803: my $loadm=10000000;
1.80 www 4804: foreach $tryserver (keys %libserv) {
4805: if ($hostdom{$tryserver} eq $udom) {
4806: my $answer=reply('load',$tryserver);
4807: if (($answer=~/\d+/) && ($answer<$loadm)) {
4808: $loadm=$answer;
4809: $unhome=$tryserver;
4810: }
4811: }
4812: }
4813: }
4814: if (($unhome eq '') || ($unhome eq 'no_host')) {
1.206 matthew 4815: return 'error: unable to find a home server for '.$uname.
4816: ' in domain '.$udom;
1.80 www 4817: }
4818: my $reply=&reply('encrypt:makeuser:'.$udom.':'.$uname.':'.$umode.':'.
4819: &escape($upass),$unhome);
4820: unless ($reply eq 'ok') {
4821: return 'error: '.$reply;
4822: }
1.230 stredwic 4823: $uhome=&homeserver($uname,$udom,'true');
1.80 www 4824: if (($uhome eq '') || ($uhome eq 'no_host') || ($uhome ne $unhome)) {
1.386 matthew 4825: return 'error: unable verify users home machine.';
1.80 www 4826: }
1.209 matthew 4827: } # End of creation of new user
1.80 www 4828: # ---------------------------------------------------------------------- Add ID
4829: if ($uid) {
4830: $uid=~tr/A-Z/a-z/;
4831: my %uidhash=&idrget($udom,$uname);
1.196 www 4832: if (($uidhash{$uname}) && ($uidhash{$uname}!~/error\:/)
4833: && (!$forceid)) {
1.80 www 4834: unless ($uid eq $uidhash{$uname}) {
1.386 matthew 4835: return 'error: user id "'.$uid.'" does not match '.
4836: 'current user id "'.$uidhash{$uname}.'".';
1.80 www 4837: }
4838: } else {
4839: &idput($udom,($uname => $uid));
4840: }
4841: }
4842: # -------------------------------------------------------------- Add names, etc
1.313 matthew 4843: my @tmp=&get('environment',
1.134 albertel 4844: ['firstname','middlename','lastname','generation'],
4845: $udom,$uname);
1.313 matthew 4846: my %names;
4847: if ($tmp[0] =~ m/^error:.*/) {
4848: %names=();
4849: } else {
4850: %names = @tmp;
4851: }
1.388 www 4852: #
4853: # Make sure to not trash student environment if instructor does not bother
4854: # to supply name and email information
4855: #
4856: if ($first) { $names{'firstname'} = $first; }
1.385 matthew 4857: if (defined($middle)) { $names{'middlename'} = $middle; }
1.388 www 4858: if ($last) { $names{'lastname'} = $last; }
1.385 matthew 4859: if (defined($gene)) { $names{'generation'} = $gene; }
1.592 www 4860: if ($email) {
4861: $email=~s/[^\w\@\.\-\,]//gs;
4862: if ($email=~/\@/) { $names{'notification'} = $email;
4863: $names{'critnotification'} = $email;
4864: $names{'permanentemail'} = $email; }
4865: }
1.134 albertel 4866: my $reply = &put('environment', \%names, $udom,$uname);
4867: if ($reply ne 'ok') { return 'error: '.$reply; }
1.680 www 4868: &devalidate_cache_new('namescache',$uname.':'.$udom);
1.81 www 4869: &logthis('Success modifying user '.$udom.', '.$uname.', '.$uid.', '.
1.80 www 4870: $umode.', '.$first.', '.$middle.', '.
4871: $last.', '.$gene.' by '.
1.620 albertel 4872: $env{'user.name'}.' at '.$env{'user.domain'});
1.134 albertel 4873: return 'ok';
1.80 www 4874: }
4875:
1.81 www 4876: # -------------------------------------------------------------- Modify student
1.80 www 4877:
1.81 www 4878: sub modifystudent {
4879: my ($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene,$usec,
1.515 raeburn 4880: $end,$start,$forceid,$desiredhome,$email,$type,$locktype,$cid)=@_;
1.455 albertel 4881: if (!$cid) {
1.620 albertel 4882: unless ($cid=$env{'request.course.id'}) {
1.455 albertel 4883: return 'not_in_class';
4884: }
1.80 www 4885: }
4886: # --------------------------------------------------------------- Make the user
1.81 www 4887: my $reply=&modifyuser
1.209 matthew 4888: ($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene,$forceid,
1.387 www 4889: $desiredhome,$email);
1.80 www 4890: unless ($reply eq 'ok') { return $reply; }
1.297 matthew 4891: # This will cause &modify_student_enrollment to get the uid from the
4892: # students environment
4893: $uid = undef if (!$forceid);
1.455 albertel 4894: $reply = &modify_student_enrollment($udom,$uname,$uid,$first,$middle,$last,
1.515 raeburn 4895: $gene,$usec,$end,$start,$type,$locktype,$cid);
1.297 matthew 4896: return $reply;
4897: }
4898:
4899: sub modify_student_enrollment {
1.515 raeburn 4900: my ($udom,$uname,$uid,$first,$middle,$last,$gene,$usec,$end,$start,$type,$locktype,$cid) = @_;
1.455 albertel 4901: my ($cdom,$cnum,$chome);
4902: if (!$cid) {
1.620 albertel 4903: unless ($cid=$env{'request.course.id'}) {
1.455 albertel 4904: return 'not_in_class';
4905: }
1.620 albertel 4906: $cdom=$env{'course.'.$cid.'.domain'};
4907: $cnum=$env{'course.'.$cid.'.num'};
1.455 albertel 4908: } else {
4909: ($cdom,$cnum)=split(/_/,$cid);
4910: }
1.620 albertel 4911: $chome=$env{'course.'.$cid.'.home'};
1.455 albertel 4912: if (!$chome) {
1.457 raeburn 4913: $chome=&homeserver($cnum,$cdom);
1.297 matthew 4914: }
1.455 albertel 4915: if (!$chome) { return 'unknown_course'; }
1.297 matthew 4916: # Make sure the user exists
1.81 www 4917: my $uhome=&homeserver($uname,$udom);
4918: if (($uhome eq '') || ($uhome eq 'no_host')) {
4919: return 'error: no such user';
4920: }
1.297 matthew 4921: # Get student data if we were not given enough information
4922: if (!defined($first) || $first eq '' ||
4923: !defined($last) || $last eq '' ||
4924: !defined($uid) || $uid eq '' ||
4925: !defined($middle) || $middle eq '' ||
4926: !defined($gene) || $gene eq '') {
1.294 matthew 4927: # They did not supply us with enough data to enroll the student, so
4928: # we need to pick up more information.
1.297 matthew 4929: my %tmp = &get('environment',
1.294 matthew 4930: ['firstname','middlename','lastname', 'generation','id']
1.297 matthew 4931: ,$udom,$uname);
4932:
1.800 albertel 4933: #foreach my $key (keys(%tmp)) {
4934: # &logthis("key $key = ".$tmp{$key});
1.455 albertel 4935: #}
1.294 matthew 4936: $first = $tmp{'firstname'} if (!defined($first) || $first eq '');
4937: $middle = $tmp{'middlename'} if (!defined($middle) || $middle eq '');
4938: $last = $tmp{'lastname'} if (!defined($last) || $last eq '');
1.297 matthew 4939: $gene = $tmp{'generation'} if (!defined($gene) || $gene eq '');
1.294 matthew 4940: $uid = $tmp{'id'} if (!defined($uid) || $uid eq '');
4941: }
1.556 albertel 4942: my $fullname = &format_name($first,$middle,$last,$gene,'lastname');
1.487 albertel 4943: my $reply=cput('classlist',
4944: {"$uname:$udom" =>
1.515 raeburn 4945: join(':',$end,$start,$uid,$usec,$fullname,$type,$locktype) },
1.487 albertel 4946: $cdom,$cnum);
1.81 www 4947: unless (($reply eq 'ok') || ($reply eq 'delayed')) {
4948: return 'error: '.$reply;
1.652 albertel 4949: } else {
4950: &devalidate_getsection_cache($udom,$uname,$cid);
1.81 www 4951: }
1.297 matthew 4952: # Add student role to user
1.83 www 4953: my $uurl='/'.$cid;
1.81 www 4954: $uurl=~s/\_/\//g;
4955: if ($usec) {
4956: $uurl.='/'.$usec;
4957: }
4958: return &assignrole($udom,$uname,$uurl,'st',$end,$start);
1.21 www 4959: }
4960:
1.556 albertel 4961: sub format_name {
4962: my ($firstname,$middlename,$lastname,$generation,$first)=@_;
4963: my $name;
4964: if ($first ne 'lastname') {
4965: $name=$firstname.' '.$middlename.' '.$lastname.' '.$generation;
4966: } else {
4967: if ($lastname=~/\S/) {
4968: $name.= $lastname.' '.$generation.', '.$firstname.' '.$middlename;
4969: $name=~s/\s+,/,/;
4970: } else {
4971: $name.= $firstname.' '.$middlename.' '.$generation;
4972: }
4973: }
4974: $name=~s/^\s+//;
4975: $name=~s/\s+$//;
4976: $name=~s/\s+/ /g;
4977: return $name;
4978: }
4979:
1.84 www 4980: # ------------------------------------------------- Write to course preferences
4981:
4982: sub writecoursepref {
4983: my ($courseid,%prefs)=@_;
4984: $courseid=~s/^\///;
4985: $courseid=~s/\_/\//g;
4986: my ($cdomain,$cnum)=split(/\//,$courseid);
4987: my $chome=homeserver($cnum,$cdomain);
4988: if (($chome eq '') || ($chome eq 'no_host')) {
4989: return 'error: no such course';
4990: }
4991: my $cstring='';
1.800 albertel 4992: foreach my $pref (keys(%prefs)) {
4993: $cstring.=&escape($pref).'='.&escape($prefs{$pref}).'&';
1.191 harris41 4994: }
1.84 www 4995: $cstring=~s/\&$//;
4996: return reply('put:'.$cdomain.':'.$cnum.':environment:'.$cstring,$chome);
4997: }
4998:
4999: # ---------------------------------------------------------- Make/modify course
5000:
5001: sub createcourse {
1.741 raeburn 5002: my ($udom,$description,$url,$course_server,$nonstandard,$inst_code,
5003: $course_owner,$crstype)=@_;
1.84 www 5004: $url=&declutter($url);
5005: my $cid='';
1.264 matthew 5006: unless (&allowed('ccc',$udom)) {
1.84 www 5007: return 'refused';
5008: }
5009: # ------------------------------------------------------------------- Create ID
1.674 www 5010: my $uname=int(1+rand(9)).
5011: ('a'..'z','A'..'Z','0'..'9')[int(rand(62))].
5012: substr($$.time,0,5).unpack("H8",pack("I32",time)).
1.84 www 5013: unpack("H2",pack("I32",int(rand(255)))).$perlvar{'lonHostID'};
5014: # ----------------------------------------------- Make sure that does not exist
1.230 stredwic 5015: my $uhome=&homeserver($uname,$udom,'true');
1.84 www 5016: unless (($uhome eq '') || ($uhome eq 'no_host')) {
5017: $uname=substr($$.time,0,5).unpack("H8",pack("I32",time)).
5018: unpack("H2",pack("I32",int(rand(255)))).$perlvar{'lonHostID'};
1.230 stredwic 5019: $uhome=&homeserver($uname,$udom,'true');
1.84 www 5020: unless (($uhome eq '') || ($uhome eq 'no_host')) {
5021: return 'error: unable to generate unique course-ID';
5022: }
5023: }
1.264 matthew 5024: # ------------------------------------------------ Check supplied server name
1.620 albertel 5025: $course_server = $env{'user.homeserver'} if (! defined($course_server));
1.264 matthew 5026: if (! exists($libserv{$course_server})) {
5027: return 'error:bad server name '.$course_server;
5028: }
1.84 www 5029: # ------------------------------------------------------------- Make the course
5030: my $reply=&reply('encrypt:makeuser:'.$udom.':'.$uname.':none::',
1.264 matthew 5031: $course_server);
1.84 www 5032: unless ($reply eq 'ok') { return 'error: '.$reply; }
1.230 stredwic 5033: $uhome=&homeserver($uname,$udom,'true');
1.84 www 5034: if (($uhome eq '') || ($uhome eq 'no_host')) {
5035: return 'error: no such course';
5036: }
1.271 www 5037: # ----------------------------------------------------------------- Course made
1.516 raeburn 5038: # log existence
5039: &courseidput($udom,&escape($udom.'_'.$uname).'='.&escape($description).
1.741 raeburn 5040: ':'.&escape($inst_code).':'.&escape($course_owner).':'.
5041: &escape($crstype),$uhome);
1.358 www 5042: &flushcourselogs();
5043: # set toplevel url
1.271 www 5044: my $topurl=$url;
5045: unless ($nonstandard) {
5046: # ------------------------------------------ For standard courses, make top url
5047: my $mapurl=&clutter($url);
1.278 www 5048: if ($mapurl eq '/res/') { $mapurl=''; }
1.620 albertel 5049: $env{'form.initmap'}=(<<ENDINITMAP);
1.271 www 5050: <map>
5051: <resource id="1" type="start"></resource>
5052: <resource id="2" src="$mapurl"></resource>
5053: <resource id="3" type="finish"></resource>
5054: <link index="1" from="1" to="2"></link>
5055: <link index="2" from="2" to="3"></link>
5056: </map>
5057: ENDINITMAP
5058: $topurl=&declutter(
1.638 albertel 5059: &finishuserfileupload($uname,$udom,'initmap','default.sequence')
1.271 www 5060: );
5061: }
5062: # ----------------------------------------------------------- Write preferences
1.84 www 5063: &writecoursepref($udom.'_'.$uname,
5064: ('description' => $description,
1.271 www 5065: 'url' => $topurl));
1.84 www 5066: return '/'.$udom.'/'.$uname;
5067: }
5068:
1.813 albertel 5069: sub is_course {
5070: my ($cdom,$cnum) = @_;
5071: my %courses = &courseiddump($cdom,'.',1,'.','.',$cnum,undef,
5072: undef,'.');
5073: if (exists($courses{$cdom.'_'.$cnum})) {
5074: return 1;
5075: }
5076: return 0;
5077: }
5078:
1.21 www 5079: # ---------------------------------------------------------- Assign Custom Role
5080:
5081: sub assigncustomrole {
1.357 www 5082: my ($udom,$uname,$url,$rdom,$rnam,$rolename,$end,$start,$deleteflag)=@_;
1.21 www 5083: return &assignrole($udom,$uname,$url,'cr/'.$rdom.'/'.$rnam.'/'.$rolename,
1.357 www 5084: $end,$start,$deleteflag);
1.21 www 5085: }
5086:
5087: # ----------------------------------------------------------------- Revoke Role
5088:
5089: sub revokerole {
1.357 www 5090: my ($udom,$uname,$url,$role,$deleteflag)=@_;
1.21 www 5091: my $now=time;
1.357 www 5092: return &assignrole($udom,$uname,$url,$role,$now,$deleteflag);
1.21 www 5093: }
5094:
5095: # ---------------------------------------------------------- Revoke Custom Role
5096:
5097: sub revokecustomrole {
1.357 www 5098: my ($udom,$uname,$url,$rdom,$rnam,$rolename,$deleteflag)=@_;
1.21 www 5099: my $now=time;
1.357 www 5100: return &assigncustomrole($udom,$uname,$url,$rdom,$rnam,$rolename,$now,
5101: $deleteflag);
1.17 www 5102: }
5103:
1.533 banghart 5104: # ------------------------------------------------------------ Disk usage
1.535 albertel 5105: sub diskusage {
1.533 banghart 5106: my ($udom,$uname,$directoryRoot)=@_;
5107: $directoryRoot =~ s/\/$//;
1.535 albertel 5108: my $listing=&reply('du:'.$directoryRoot,homeserver($uname,$udom));
1.514 albertel 5109: return $listing;
1.512 banghart 5110: }
5111:
1.566 banghart 5112: sub is_locked {
5113: my ($file_name, $domain, $user) = @_;
5114: my @check;
5115: my $is_locked;
5116: push @check, $file_name;
1.613 albertel 5117: my %locked = &get('file_permissions',\@check,
1.620 albertel 5118: $env{'user.domain'},$env{'user.name'});
1.615 albertel 5119: my ($tmp)=keys(%locked);
5120: if ($tmp=~/^error:/) { undef(%locked); }
1.745 raeburn 5121:
1.566 banghart 5122: if (ref($locked{$file_name}) eq 'ARRAY') {
1.745 raeburn 5123: $is_locked = 'false';
5124: foreach my $entry (@{$locked{$file_name}}) {
5125: if (ref($entry) eq 'ARRAY') {
1.746 raeburn 5126: $is_locked = 'true';
5127: last;
1.745 raeburn 5128: }
5129: }
1.566 banghart 5130: } else {
5131: $is_locked = 'false';
5132: }
5133: }
5134:
1.759 albertel 5135: sub declutter_portfile {
5136: my ($file) = @_;
1.833 ! albertel 5137: $file =~ s{^(/portfolio/|portfolio/)}{/};
1.759 albertel 5138: return $file;
5139: }
5140:
1.559 banghart 5141: # ------------------------------------------------------------- Mark as Read Only
5142:
5143: sub mark_as_readonly {
5144: my ($domain,$user,$files,$what) = @_;
1.613 albertel 5145: my %current_permissions = &dump('file_permissions',$domain,$user);
1.615 albertel 5146: my ($tmp)=keys(%current_permissions);
5147: if ($tmp=~/^error:/) { undef(%current_permissions); }
1.560 banghart 5148: foreach my $file (@{$files}) {
1.759 albertel 5149: $file = &declutter_portfile($file);
1.561 banghart 5150: push(@{$current_permissions{$file}},$what);
1.559 banghart 5151: }
1.613 albertel 5152: &put('file_permissions',\%current_permissions,$domain,$user);
1.559 banghart 5153: return;
5154: }
5155:
1.572 banghart 5156: # ------------------------------------------------------------Save Selected Files
5157:
5158: sub save_selected_files {
5159: my ($user, $path, @files) = @_;
5160: my $filename = $user."savedfiles";
1.573 banghart 5161: my @other_files = &files_not_in_path($user, $path);
1.574 banghart 5162: open (OUT, '>'.$Apache::lonnet::perlvar{'lonDaemons'}.'/tmp/'.$filename);
1.573 banghart 5163: foreach my $file (@files) {
1.620 albertel 5164: print (OUT $env{'form.currentpath'}.$file."\n");
1.573 banghart 5165: }
5166: foreach my $file (@other_files) {
1.574 banghart 5167: print (OUT $file."\n");
1.572 banghart 5168: }
1.574 banghart 5169: close (OUT);
1.572 banghart 5170: return 'ok';
5171: }
5172:
1.574 banghart 5173: sub clear_selected_files {
5174: my ($user) = @_;
5175: my $filename = $user."savedfiles";
5176: open (OUT, '>'.$Apache::lonnet::perlvar{'lonDaemons'}.'/tmp/'.$filename);
5177: print (OUT undef);
5178: close (OUT);
5179: return ("ok");
5180: }
5181:
1.572 banghart 5182: sub files_in_path {
5183: my ($user, $path) = @_;
5184: my $filename = $user."savedfiles";
5185: my %return_files;
1.574 banghart 5186: open (IN, '<'.$Apache::lonnet::perlvar{'lonDaemons'}.'/tmp/'.$filename);
1.573 banghart 5187: while (my $line_in = <IN>) {
1.574 banghart 5188: chomp ($line_in);
5189: my @paths_and_file = split (m!/!, $line_in);
5190: my $file_part = pop (@paths_and_file);
5191: my $path_part = join ('/', @paths_and_file);
1.573 banghart 5192: $path_part.='/';
5193: my $path_and_file = $path_part.$file_part;
5194: if ($path_part eq $path) {
5195: $return_files{$file_part}= 'selected';
5196: }
5197: }
1.574 banghart 5198: close (IN);
5199: return (\%return_files);
1.572 banghart 5200: }
5201:
5202: # called in portfolio select mode, to show files selected NOT in current directory
5203: sub files_not_in_path {
5204: my ($user, $path) = @_;
5205: my $filename = $user."savedfiles";
5206: my @return_files;
5207: my $path_part;
1.800 albertel 5208: open(IN, '<'.$Apache::lonnet::perlvar{'lonDaemons'}.'/tmp/'.$filename);
5209: while (my $line = <IN>) {
1.572 banghart 5210: #ok, I know it's clunky, but I want it to work
1.800 albertel 5211: my @paths_and_file = split(m|/|, $line);
5212: my $file_part = pop(@paths_and_file);
5213: chomp($file_part);
5214: my $path_part = join('/', @paths_and_file);
1.572 banghart 5215: $path_part .= '/';
5216: my $path_and_file = $path_part.$file_part;
5217: if ($path_part ne $path) {
1.800 albertel 5218: push(@return_files, ($path_and_file));
1.572 banghart 5219: }
5220: }
1.800 albertel 5221: close(OUT);
1.574 banghart 5222: return (@return_files);
1.572 banghart 5223: }
5224:
1.745 raeburn 5225: #----------------------------------------------Get portfolio file permissions
1.629 banghart 5226:
1.745 raeburn 5227: sub get_portfile_permissions {
5228: my ($domain,$user) = @_;
1.613 albertel 5229: my %current_permissions = &dump('file_permissions',$domain,$user);
1.615 albertel 5230: my ($tmp)=keys(%current_permissions);
5231: if ($tmp=~/^error:/) { undef(%current_permissions); }
1.745 raeburn 5232: return \%current_permissions;
5233: }
5234:
5235: #---------------------------------------------Get portfolio file access controls
5236:
1.749 raeburn 5237: sub get_access_controls {
1.745 raeburn 5238: my ($current_permissions,$group,$file) = @_;
1.769 albertel 5239: my %access;
5240: my $real_file = $file;
5241: $file =~ s/\.meta$//;
1.745 raeburn 5242: if (defined($file)) {
1.749 raeburn 5243: if (ref($$current_permissions{$file."\0".'accesscontrol'}) eq 'HASH') {
5244: foreach my $control (keys(%{$$current_permissions{$file."\0".'accesscontrol'}})) {
1.769 albertel 5245: $access{$real_file}{$control} = $$current_permissions{$file."\0".$control};
1.749 raeburn 5246: }
5247: }
1.745 raeburn 5248: } else {
1.749 raeburn 5249: foreach my $key (keys(%{$current_permissions})) {
5250: if ($key =~ /\0accesscontrol$/) {
5251: if (defined($group)) {
5252: if ($key !~ m-^\Q$group\E/-) {
5253: next;
5254: }
5255: }
5256: my ($fullpath) = split(/\0/,$key);
5257: if (ref($$current_permissions{$key}) eq 'HASH') {
5258: foreach my $control (keys(%{$$current_permissions{$key}})) {
5259: $access{$fullpath}{$control}=$$current_permissions{$fullpath."\0".$control};
5260: }
5261: }
5262: }
5263: }
5264: }
5265: return %access;
5266: }
5267:
5268: sub modify_access_controls {
5269: my ($file_name,$changes,$domain,$user)=@_;
5270: my ($outcome,$deloutcome);
5271: my %store_permissions;
5272: my %new_values;
5273: my %new_control;
5274: my %translation;
5275: my @deletions = ();
5276: my $now = time;
5277: if (exists($$changes{'activate'})) {
5278: if (ref($$changes{'activate'}) eq 'HASH') {
5279: my @newitems = sort(keys(%{$$changes{'activate'}}));
5280: my $numnew = scalar(@newitems);
5281: for (my $i=0; $i<$numnew; $i++) {
5282: my $newkey = $newitems[$i];
5283: my $newid = &Apache::loncommon::get_cgi_id();
1.797 raeburn 5284: if ($newkey =~ /^\d+:/) {
5285: $newkey =~ s/^(\d+)/$newid/;
5286: $translation{$1} = $newid;
5287: } elsif ($newkey =~ /^\d+_\d+_\d+:/) {
5288: $newkey =~ s/^(\d+_\d+_\d+)/$newid/;
5289: $translation{$1} = $newid;
5290: }
1.749 raeburn 5291: $new_values{$file_name."\0".$newkey} =
5292: $$changes{'activate'}{$newitems[$i]};
5293: $new_control{$newkey} = $now;
5294: }
5295: }
5296: }
5297: my %todelete;
5298: my %changed_items;
5299: foreach my $action ('delete','update') {
5300: if (exists($$changes{$action})) {
5301: if (ref($$changes{$action}) eq 'HASH') {
5302: foreach my $key (keys(%{$$changes{$action}})) {
5303: my ($itemnum) = ($key =~ /^([^:]+):/);
5304: if ($action eq 'delete') {
5305: $todelete{$itemnum} = 1;
5306: } else {
5307: $changed_items{$itemnum} = $key;
5308: }
5309: }
1.745 raeburn 5310: }
5311: }
1.749 raeburn 5312: }
5313: # get lock on access controls for file.
5314: my $lockhash = {
5315: $file_name."\0".'locked_access_records' => $env{'user.name'}.
5316: ':'.$env{'user.domain'},
5317: };
5318: my $tries = 0;
5319: my $gotlock = &newput('file_permissions',$lockhash,$domain,$user);
5320:
5321: while (($gotlock ne 'ok') && $tries <3) {
5322: $tries ++;
5323: sleep 1;
5324: $gotlock = &newput('file_permissions',$lockhash,$domain,$user);
5325: }
5326: if ($gotlock eq 'ok') {
5327: my %curr_permissions = &dump('file_permissions',$domain,$user,$file_name);
5328: my ($tmp)=keys(%curr_permissions);
5329: if ($tmp=~/^error:/) { undef(%curr_permissions); }
5330: if (exists($curr_permissions{$file_name."\0".'accesscontrol'})) {
5331: my $curr_controls = $curr_permissions{$file_name."\0".'accesscontrol'};
5332: if (ref($curr_controls) eq 'HASH') {
5333: foreach my $control_item (keys(%{$curr_controls})) {
5334: my ($itemnum) = ($control_item =~ /^([^:]+):/);
5335: if (defined($todelete{$itemnum})) {
5336: push(@deletions,$file_name."\0".$control_item);
5337: } else {
5338: if (defined($changed_items{$itemnum})) {
5339: $new_control{$changed_items{$itemnum}} = $now;
5340: push(@deletions,$file_name."\0".$control_item);
5341: $new_values{$file_name."\0".$changed_items{$itemnum}} = $$changes{'update'}{$changed_items{$itemnum}};
5342: } else {
5343: $new_control{$control_item} = $$curr_controls{$control_item};
5344: }
5345: }
1.745 raeburn 5346: }
5347: }
5348: }
1.749 raeburn 5349: $deloutcome = &del('file_permissions',\@deletions,$domain,$user);
5350: $new_values{$file_name."\0".'accesscontrol'} = \%new_control;
5351: $outcome = &put('file_permissions',\%new_values,$domain,$user);
5352: # remove lock
5353: my @del_lock = ($file_name."\0".'locked_access_records');
5354: my $dellockoutcome = &del('file_permissions',\@del_lock,$domain,$user);
1.818 raeburn 5355: my ($file,$group);
5356: if (&is_course($domain,$user)) {
5357: ($group,$file) = split(/\//,$file_name,2);
5358: } else {
5359: $file = $file_name;
5360: }
5361: my $sqlresult =
5362: &update_portfolio_table($user,$domain,$file,'portfolio_access',
5363: $group);
1.749 raeburn 5364: } else {
5365: $outcome = "error: could not obtain lockfile\n";
1.745 raeburn 5366: }
1.749 raeburn 5367: return ($outcome,$deloutcome,\%new_values,\%translation);
1.745 raeburn 5368: }
5369:
1.827 raeburn 5370: sub make_public_indefinitely {
5371: my ($requrl) = @_;
5372: my $now = time;
5373: my $action = 'activate';
5374: my $aclnum = 0;
5375: if (&is_portfolio_url($requrl)) {
5376: my (undef,$udom,$unum,$file_name,$group) =
5377: &parse_portfolio_url($requrl);
5378: my $current_perms = &get_portfile_permissions($udom,$unum);
5379: my %access_controls = &get_access_controls($current_perms,
5380: $group,$file_name);
5381: foreach my $key (keys(%{$access_controls{$file_name}})) {
5382: my ($num,$scope,$end,$start) =
5383: ($key =~ /^([^:]+):([a-z]+)_(\d*)_?(\d*)$/);
5384: if ($scope eq 'public') {
5385: if ($start <= $now && $end == 0) {
5386: $action = 'none';
5387: } else {
5388: $action = 'update';
5389: $aclnum = $num;
5390: }
5391: last;
5392: }
5393: }
5394: if ($action eq 'none') {
5395: return 'ok';
5396: } else {
5397: my %changes;
5398: my $newend = 0;
5399: my $newstart = $now;
5400: my $newkey = $aclnum.':public_'.$newend.'_'.$newstart;
5401: $changes{$action}{$newkey} = {
5402: type => 'public',
5403: time => {
5404: start => $newstart,
5405: end => $newend,
5406: },
5407: };
5408: my ($outcome,$deloutcome,$new_values,$translation) =
5409: &modify_access_controls($file_name,\%changes,$udom,$unum);
5410: return $outcome;
5411: }
5412: } else {
5413: return 'invalid';
5414: }
5415: }
5416:
1.745 raeburn 5417: #------------------------------------------------------Get Marked as Read Only
5418:
5419: sub get_marked_as_readonly {
5420: my ($domain,$user,$what,$group) = @_;
5421: my $current_permissions = &get_portfile_permissions($domain,$user);
1.563 banghart 5422: my @readonly_files;
1.629 banghart 5423: my $cmp1=$what;
5424: if (ref($what)) { $cmp1=join('',@{$what}) };
1.745 raeburn 5425: while (my ($file_name,$value) = each(%{$current_permissions})) {
5426: if (defined($group)) {
5427: if ($file_name !~ m-^\Q$group\E/-) {
5428: next;
5429: }
5430: }
1.561 banghart 5431: if (ref($value) eq "ARRAY"){
5432: foreach my $stored_what (@{$value}) {
1.629 banghart 5433: my $cmp2=$stored_what;
1.759 albertel 5434: if (ref($stored_what) eq 'ARRAY') {
1.746 raeburn 5435: $cmp2=join('',@{$stored_what});
1.745 raeburn 5436: }
1.629 banghart 5437: if ($cmp1 eq $cmp2) {
1.561 banghart 5438: push(@readonly_files, $file_name);
1.745 raeburn 5439: last;
1.563 banghart 5440: } elsif (!defined($what)) {
5441: push(@readonly_files, $file_name);
1.745 raeburn 5442: last;
1.561 banghart 5443: }
5444: }
1.745 raeburn 5445: }
1.561 banghart 5446: }
5447: return @readonly_files;
5448: }
1.577 banghart 5449: #-----------------------------------------------------------Get Marked as Read Only Hash
1.561 banghart 5450:
1.577 banghart 5451: sub get_marked_as_readonly_hash {
1.745 raeburn 5452: my ($current_permissions,$group,$what) = @_;
1.577 banghart 5453: my %readonly_files;
1.745 raeburn 5454: while (my ($file_name,$value) = each(%{$current_permissions})) {
5455: if (defined($group)) {
5456: if ($file_name !~ m-^\Q$group\E/-) {
5457: next;
5458: }
5459: }
1.577 banghart 5460: if (ref($value) eq "ARRAY"){
5461: foreach my $stored_what (@{$value}) {
1.745 raeburn 5462: if (ref($stored_what) eq 'ARRAY') {
1.750 banghart 5463: foreach my $lock_descriptor(@{$stored_what}) {
5464: if ($lock_descriptor eq 'graded') {
5465: $readonly_files{$file_name} = 'graded';
5466: } elsif ($lock_descriptor eq 'handback') {
5467: $readonly_files{$file_name} = 'handback';
5468: } else {
5469: if (!exists($readonly_files{$file_name})) {
5470: $readonly_files{$file_name} = 'locked';
5471: }
5472: }
1.745 raeburn 5473: }
1.750 banghart 5474: }
1.577 banghart 5475: }
5476: }
5477: }
5478: return %readonly_files;
5479: }
1.559 banghart 5480: # ------------------------------------------------------------ Unmark as Read Only
5481:
5482: sub unmark_as_readonly {
1.629 banghart 5483: # unmarks $file_name (if $file_name is defined), or all files locked by $what
5484: # for portfolio submissions, $what contains [$symb,$crsid]
1.745 raeburn 5485: my ($domain,$user,$what,$file_name,$group) = @_;
1.759 albertel 5486: $file_name = &declutter_portfile($file_name);
1.634 albertel 5487: my $symb_crs = $what;
5488: if (ref($what)) { $symb_crs=join('',@$what); }
1.745 raeburn 5489: my %current_permissions = &dump('file_permissions',$domain,$user,$group);
1.615 albertel 5490: my ($tmp)=keys(%current_permissions);
5491: if ($tmp=~/^error:/) { undef(%current_permissions); }
1.745 raeburn 5492: my @readonly_files = &get_marked_as_readonly($domain,$user,$what,$group);
1.650 albertel 5493: foreach my $file (@readonly_files) {
1.759 albertel 5494: my $clean_file = &declutter_portfile($file);
5495: if (defined($file_name) && ($file_name ne $clean_file)) { next; }
1.650 albertel 5496: my $current_locks = $current_permissions{$file};
1.563 banghart 5497: my @new_locks;
5498: my @del_keys;
5499: if (ref($current_locks) eq "ARRAY"){
5500: foreach my $locker (@{$current_locks}) {
1.632 albertel 5501: my $compare=$locker;
1.749 raeburn 5502: if (ref($locker) eq 'ARRAY') {
1.745 raeburn 5503: $compare=join('',@{$locker});
1.746 raeburn 5504: if ($compare ne $symb_crs) {
5505: push(@new_locks, $locker);
5506: }
1.563 banghart 5507: }
5508: }
1.650 albertel 5509: if (scalar(@new_locks) > 0) {
1.563 banghart 5510: $current_permissions{$file} = \@new_locks;
5511: } else {
5512: push(@del_keys, $file);
1.613 albertel 5513: &del('file_permissions',\@del_keys, $domain, $user);
1.650 albertel 5514: delete($current_permissions{$file});
1.563 banghart 5515: }
5516: }
1.561 banghart 5517: }
1.613 albertel 5518: &put('file_permissions',\%current_permissions,$domain,$user);
1.559 banghart 5519: return;
5520: }
1.512 banghart 5521:
1.17 www 5522: # ------------------------------------------------------------ Directory lister
5523:
5524: sub dirlist {
1.253 stredwic 5525: my ($uri,$userdomain,$username,$alternateDirectoryRoot)=@_;
5526:
1.18 www 5527: $uri=~s/^\///;
5528: $uri=~s/\/$//;
1.253 stredwic 5529: my ($udom, $uname);
5530: (undef,$udom,$uname)=split(/\//,$uri);
5531: if(defined($userdomain)) {
5532: $udom = $userdomain;
5533: }
5534: if(defined($username)) {
5535: $uname = $username;
5536: }
5537:
5538: my $dirRoot = $perlvar{'lonDocRoot'};
5539: if(defined($alternateDirectoryRoot)) {
5540: $dirRoot = $alternateDirectoryRoot;
5541: $dirRoot =~ s/\/$//;
1.751 banghart 5542: }
1.253 stredwic 5543:
5544: if($udom) {
5545: if($uname) {
1.800 albertel 5546: my $listing = &reply('ls2:'.$dirRoot.'/'.$uri,
5547: &homeserver($uname,$udom));
1.605 matthew 5548: my @listing_results;
5549: if ($listing eq 'unknown_cmd') {
1.800 albertel 5550: $listing = &reply('ls:'.$dirRoot.'/'.$uri,
5551: &homeserver($uname,$udom));
1.605 matthew 5552: @listing_results = split(/:/,$listing);
5553: } else {
5554: @listing_results = map { &unescape($_); } split(/:/,$listing);
5555: }
5556: return @listing_results;
1.253 stredwic 5557: } elsif(!defined($alternateDirectoryRoot)) {
1.800 albertel 5558: my %allusers;
5559: foreach my $tryserver (keys(%libserv)) {
1.253 stredwic 5560: if($hostdom{$tryserver} eq $udom) {
1.800 albertel 5561: my $listing = &reply('ls2:'.$perlvar{'lonDocRoot'}.'/res/'.
5562: $udom, $tryserver);
1.605 matthew 5563: my @listing_results;
5564: if ($listing eq 'unknown_cmd') {
1.800 albertel 5565: $listing = &reply('ls:'.$perlvar{'lonDocRoot'}.'/res/'.
5566: $udom, $tryserver);
1.605 matthew 5567: @listing_results = split(/:/,$listing);
5568: } else {
5569: @listing_results =
5570: map { &unescape($_); } split(/:/,$listing);
5571: }
5572: if ($listing_results[0] ne 'no_such_dir' &&
5573: $listing_results[0] ne 'empty' &&
5574: $listing_results[0] ne 'con_lost') {
1.800 albertel 5575: foreach my $line (@listing_results) {
5576: my ($entry) = split(/&/,$line,2);
5577: $allusers{$entry} = 1;
1.253 stredwic 5578: }
5579: }
1.191 harris41 5580: }
1.253 stredwic 5581: }
5582: my $alluserstr='';
1.800 albertel 5583: foreach my $user (sort(keys(%allusers))) {
5584: $alluserstr.=$user.'&user:';
1.253 stredwic 5585: }
5586: $alluserstr=~s/:$//;
5587: return split(/:/,$alluserstr);
5588: } else {
1.800 albertel 5589: return ('missing user name');
1.253 stredwic 5590: }
5591: } elsif(!defined($alternateDirectoryRoot)) {
5592: my $tryserver;
5593: my %alldom=();
1.800 albertel 5594: foreach $tryserver (keys(%libserv)) {
1.253 stredwic 5595: $alldom{$hostdom{$tryserver}}=1;
5596: }
5597: my $alldomstr='';
1.800 albertel 5598: foreach my $domain (sort(keys(%alldom))) {
5599: $alldomstr.=$perlvar{'lonDocRoot'}.'/res/'.$domain.'/&domain:';
1.253 stredwic 5600: }
5601: $alldomstr=~s/:$//;
5602: return split(/:/,$alldomstr);
5603: } else {
1.800 albertel 5604: return ('missing domain');
1.275 stredwic 5605: }
5606: }
5607:
5608: # --------------------------------------------- GetFileTimestamp
5609: # This function utilizes dirlist and returns the date stamp for
5610: # when it was last modified. It will also return an error of -1
5611: # if an error occurs
5612:
1.410 matthew 5613: ##
5614: ## FIXME: This subroutine assumes its caller knows something about the
5615: ## directory structure of the home server for the student ($root).
5616: ## Not a good assumption to make. Since this is for looking up files
5617: ## in user directories, the full path should be constructed by lond, not
5618: ## whatever machine we request data from.
5619: ##
1.275 stredwic 5620: sub GetFileTimestamp {
5621: my ($studentDomain,$studentName,$filename,$root)=@_;
1.807 albertel 5622: $studentDomain = &LONCAPA::clean_domain($studentDomain);
5623: $studentName = &LONCAPA::clean_username($studentName);
1.275 stredwic 5624: my $subdir=$studentName.'__';
5625: $subdir =~ s/(.)(.)(.).*/$1\/$2\/$3/;
5626: my $proname="$studentDomain/$subdir/$studentName";
5627: $proname .= '/'.$filename;
1.375 matthew 5628: my ($fileStat) = &Apache::lonnet::dirlist($proname, $studentDomain,
5629: $studentName, $root);
1.275 stredwic 5630: my @stats = split('&', $fileStat);
5631: if($stats[0] ne 'empty' && $stats[0] ne 'no_such_dir') {
1.375 matthew 5632: # @stats contains first the filename, then the stat output
5633: return $stats[10]; # so this is 10 instead of 9.
1.275 stredwic 5634: } else {
5635: return -1;
1.253 stredwic 5636: }
1.26 www 5637: }
5638:
1.712 albertel 5639: sub stat_file {
5640: my ($uri) = @_;
1.787 albertel 5641: $uri = &clutter_with_no_wrapper($uri);
1.722 albertel 5642:
1.712 albertel 5643: my ($udom,$uname,$file,$dir);
5644: if ($uri =~ m-^/(uploaded|editupload)/-) {
5645: ($udom,$uname,$file) =
1.811 albertel 5646: ($uri =~ m-/(?:uploaded|editupload)/?($match_domain)/?($match_name)/?(.*)-);
1.712 albertel 5647: $file = 'userfiles/'.$file;
1.740 www 5648: $dir = &propath($udom,$uname);
1.712 albertel 5649: }
5650: if ($uri =~ m-^/res/-) {
5651: ($udom,$uname) =
1.807 albertel 5652: ($uri =~ m-/(?:res)/?($match_domain)/?($match_username)/-);
1.712 albertel 5653: $file = $uri;
5654: }
5655:
5656: if (!$udom || !$uname || !$file) {
5657: # unable to handle the uri
5658: return ();
5659: }
5660:
5661: my ($result) = &dirlist($file,$udom,$uname,$dir);
5662: my @stats = split('&', $result);
1.721 banghart 5663:
1.712 albertel 5664: if($stats[0] ne 'empty' && $stats[0] ne 'no_such_dir') {
5665: shift(@stats); #filename is first
5666: return @stats;
5667: }
5668: return ();
5669: }
5670:
1.26 www 5671: # -------------------------------------------------------- Value of a Condition
5672:
1.713 albertel 5673: # gets the value of a specific preevaluated condition
5674: # stored in the string $env{user.state.<cid>}
5675: # or looks up a condition reference in the bighash and if if hasn't
5676: # already been evaluated recurses into docondval to get the value of
5677: # the condition, then memoizing it to
5678: # $env{user.state.<cid>.<condition>}
1.40 www 5679: sub directcondval {
5680: my $number=shift;
1.620 albertel 5681: if (!defined($env{'user.state.'.$env{'request.course.id'}})) {
1.555 albertel 5682: &Apache::lonuserstate::evalstate();
5683: }
1.713 albertel 5684: if (exists($env{'user.state.'.$env{'request.course.id'}.".$number"})) {
5685: return $env{'user.state.'.$env{'request.course.id'}.".$number"};
5686: } elsif ($number =~ /^_/) {
5687: my $sub_condition;
5688: if (tie(my %bighash,'GDBM_File',$env{'request.course.fn'}.'.db',
5689: &GDBM_READER(),0640)) {
5690: $sub_condition=$bighash{'conditions'.$number};
5691: untie(%bighash);
5692: }
5693: my $value = &docondval($sub_condition);
5694: &appenv('user.state.'.$env{'request.course.id'}.".$number" => $value);
5695: return $value;
5696: }
1.620 albertel 5697: if ($env{'user.state.'.$env{'request.course.id'}}) {
5698: return substr($env{'user.state.'.$env{'request.course.id'}},$number,1);
1.40 www 5699: } else {
5700: return 2;
5701: }
5702: }
5703:
1.713 albertel 5704: # get the collection of conditions for this resource
1.26 www 5705: sub condval {
5706: my $condidx=shift;
1.54 www 5707: my $allpathcond='';
1.713 albertel 5708: foreach my $cond (split(/\|/,$condidx)) {
5709: if (defined($env{'acc.cond.'.$env{'request.course.id'}.'.'.$cond})) {
5710: $allpathcond.=
5711: '('.$env{'acc.cond.'.$env{'request.course.id'}.'.'.$cond}.')|';
5712: }
1.191 harris41 5713: }
1.54 www 5714: $allpathcond=~s/\|$//;
1.713 albertel 5715: return &docondval($allpathcond);
5716: }
5717:
5718: #evaluates an expression of conditions
5719: sub docondval {
5720: my ($allpathcond) = @_;
5721: my $result=0;
5722: if ($env{'request.course.id'}
5723: && defined($allpathcond)) {
5724: my $operand='|';
5725: my @stack;
5726: foreach my $chunk ($allpathcond=~/(\d+|_\d+\.\d+|\(|\)|\&|\|)/g) {
5727: if ($chunk eq '(') {
5728: push @stack,($operand,$result);
5729: } elsif ($chunk eq ')') {
5730: my $before=pop @stack;
5731: if (pop @stack eq '&') {
5732: $result=$result>$before?$before:$result;
5733: } else {
5734: $result=$result>$before?$result:$before;
5735: }
5736: } elsif (($chunk eq '&') || ($chunk eq '|')) {
5737: $operand=$chunk;
5738: } else {
5739: my $new=directcondval($chunk);
5740: if ($operand eq '&') {
5741: $result=$result>$new?$new:$result;
5742: } else {
5743: $result=$result>$new?$result:$new;
5744: }
5745: }
5746: }
1.26 www 5747: }
5748: return $result;
1.421 albertel 5749: }
5750:
5751: # ---------------------------------------------------- Devalidate courseresdata
5752:
5753: sub devalidatecourseresdata {
5754: my ($coursenum,$coursedomain)=@_;
5755: my $hashid=$coursenum.':'.$coursedomain;
1.599 albertel 5756: &devalidate_cache_new('courseres',$hashid);
1.28 www 5757: }
5758:
1.763 www 5759:
1.200 www 5760: # --------------------------------------------------- Course Resourcedata Query
5761:
1.624 albertel 5762: sub get_courseresdata {
5763: my ($coursenum,$coursedomain)=@_;
1.200 www 5764: my $coursehom=&homeserver($coursenum,$coursedomain);
5765: my $hashid=$coursenum.':'.$coursedomain;
1.599 albertel 5766: my ($result,$cached)=&is_cached_new('courseres',$hashid);
1.624 albertel 5767: my %dumpreply;
1.417 albertel 5768: unless (defined($cached)) {
1.624 albertel 5769: %dumpreply=&dump('resourcedata',$coursedomain,$coursenum);
1.417 albertel 5770: $result=\%dumpreply;
1.251 albertel 5771: my ($tmp) = keys(%dumpreply);
5772: if ($tmp !~ /^(con_lost|error|no_such_host)/i) {
1.599 albertel 5773: &do_cache_new('courseres',$hashid,$result,600);
1.306 albertel 5774: } elsif ($tmp =~ /^(con_lost|no_such_host)/) {
5775: return $tmp;
1.416 albertel 5776: } elsif ($tmp =~ /^(error)/) {
1.417 albertel 5777: $result=undef;
1.599 albertel 5778: &do_cache_new('courseres',$hashid,$result,600);
1.250 albertel 5779: }
5780: }
1.624 albertel 5781: return $result;
5782: }
5783:
1.633 albertel 5784: sub devalidateuserresdata {
5785: my ($uname,$udom)=@_;
5786: my $hashid="$udom:$uname";
5787: &devalidate_cache_new('userres',$hashid);
5788: }
5789:
1.624 albertel 5790: sub get_userresdata {
5791: my ($uname,$udom)=@_;
5792: #most student don\'t have any data set, check if there is some data
5793: if (&EXT_cache_status($udom,$uname)) { return undef; }
5794:
5795: my $hashid="$udom:$uname";
5796: my ($result,$cached)=&is_cached_new('userres',$hashid);
5797: if (!defined($cached)) {
5798: my %resourcedata=&dump('resourcedata',$udom,$uname);
5799: $result=\%resourcedata;
5800: &do_cache_new('userres',$hashid,$result,600);
5801: }
5802: my ($tmp)=keys(%$result);
5803: if (($tmp!~/^error\:/) && ($tmp!~/^con_lost/)) {
5804: return $result;
5805: }
5806: #error 2 occurs when the .db doesn't exist
5807: if ($tmp!~/error: 2 /) {
1.672 albertel 5808: &logthis("<font color=\"blue\">WARNING:".
1.624 albertel 5809: " Trying to get resource data for ".
5810: $uname." at ".$udom.": ".
5811: $tmp."</font>");
5812: } elsif ($tmp=~/error: 2 /) {
1.633 albertel 5813: #&EXT_cache_set($udom,$uname);
5814: &do_cache_new('userres',$hashid,undef,600);
1.636 albertel 5815: undef($tmp); # not really an error so don't send it back
1.624 albertel 5816: }
5817: return $tmp;
5818: }
5819:
5820: sub resdata {
5821: my ($name,$domain,$type,@which)=@_;
5822: my $result;
5823: if ($type eq 'course') {
5824: $result=&get_courseresdata($name,$domain);
5825: } elsif ($type eq 'user') {
5826: $result=&get_userresdata($name,$domain);
5827: }
5828: if (!ref($result)) { return $result; }
1.251 albertel 5829: foreach my $item (@which) {
1.417 albertel 5830: if (defined($result->{$item})) {
5831: return $result->{$item};
1.251 albertel 5832: }
1.250 albertel 5833: }
1.291 albertel 5834: return undef;
1.200 www 5835: }
5836:
1.379 matthew 5837: #
5838: # EXT resource caching routines
5839: #
5840:
5841: sub clear_EXT_cache_status {
1.383 albertel 5842: &delenv('cache.EXT.');
1.379 matthew 5843: }
5844:
5845: sub EXT_cache_status {
5846: my ($target_domain,$target_user) = @_;
1.383 albertel 5847: my $cachename = 'cache.EXT.'.$target_user.'.'.$target_domain;
1.620 albertel 5848: if (exists($env{$cachename}) && ($env{$cachename}+600) > time) {
1.379 matthew 5849: # We know already the user has no data
5850: return 1;
5851: } else {
5852: return 0;
5853: }
5854: }
5855:
5856: sub EXT_cache_set {
5857: my ($target_domain,$target_user) = @_;
1.383 albertel 5858: my $cachename = 'cache.EXT.'.$target_user.'.'.$target_domain;
1.633 albertel 5859: #&appenv($cachename => time);
1.379 matthew 5860: }
5861:
1.28 www 5862: # --------------------------------------------------------- Value of a Variable
1.58 www 5863: sub EXT {
1.715 albertel 5864:
1.395 albertel 5865: my ($varname,$symbparm,$udom,$uname,$usection,$recurse)=@_;
1.68 www 5866: unless ($varname) { return ''; }
1.218 albertel 5867: #get real user name/domain, courseid and symb
5868: my $courseid;
1.359 albertel 5869: my $publicuser;
1.427 www 5870: if ($symbparm) {
5871: $symbparm=&get_symb_from_alias($symbparm);
5872: }
1.218 albertel 5873: if (!($uname && $udom)) {
1.790 albertel 5874: (my $cursymb,$courseid,$udom,$uname,$publicuser)= &whichuser($symbparm);
1.218 albertel 5875: if (!$symbparm) { $symbparm=$cursymb; }
5876: } else {
1.620 albertel 5877: $courseid=$env{'request.course.id'};
1.218 albertel 5878: }
1.48 www 5879: my ($realm,$space,$qualifier,@therest)=split(/\./,$varname);
5880: my $rest;
1.320 albertel 5881: if (defined($therest[0])) {
1.48 www 5882: $rest=join('.',@therest);
5883: } else {
5884: $rest='';
5885: }
1.320 albertel 5886:
1.57 www 5887: my $qualifierrest=$qualifier;
5888: if ($rest) { $qualifierrest.='.'.$rest; }
5889: my $spacequalifierrest=$space;
5890: if ($qualifierrest) { $spacequalifierrest.='.'.$qualifierrest; }
1.28 www 5891: if ($realm eq 'user') {
1.48 www 5892: # --------------------------------------------------------------- user.resource
5893: if ($space eq 'resource') {
1.651 albertel 5894: if ( (defined($Apache::lonhomework::parsing_a_problem)
5895: || defined($Apache::lonhomework::parsing_a_task))
5896: &&
1.744 albertel 5897: ($symbparm eq &symbread()) ) {
5898: # if we are in the middle of processing the resource the
5899: # get the value we are planning on committing
5900: if (defined($Apache::lonhomework::results{$qualifierrest})) {
5901: return $Apache::lonhomework::results{$qualifierrest};
5902: } else {
5903: return $Apache::lonhomework::history{$qualifierrest};
5904: }
1.335 albertel 5905: } else {
1.359 albertel 5906: my %restored;
1.620 albertel 5907: if ($publicuser || $env{'request.state'} eq 'construct') {
1.359 albertel 5908: %restored=&tmprestore($symbparm,$courseid,$udom,$uname);
5909: } else {
5910: %restored=&restore($symbparm,$courseid,$udom,$uname);
5911: }
1.335 albertel 5912: return $restored{$qualifierrest};
5913: }
1.48 www 5914: # ----------------------------------------------------------------- user.access
5915: } elsif ($space eq 'access') {
1.218 albertel 5916: # FIXME - not supporting calls for a specific user
1.48 www 5917: return &allowed($qualifier,$rest);
5918: # ------------------------------------------ user.preferences, user.environment
5919: } elsif (($space eq 'preferences') || ($space eq 'environment')) {
1.620 albertel 5920: if (($uname eq $env{'user.name'}) &&
5921: ($udom eq $env{'user.domain'})) {
5922: return $env{join('.',('environment',$qualifierrest))};
1.218 albertel 5923: } else {
1.359 albertel 5924: my %returnhash;
5925: if (!$publicuser) {
5926: %returnhash=&userenvironment($udom,$uname,
5927: $qualifierrest);
5928: }
1.218 albertel 5929: return $returnhash{$qualifierrest};
5930: }
1.48 www 5931: # ----------------------------------------------------------------- user.course
5932: } elsif ($space eq 'course') {
1.218 albertel 5933: # FIXME - not supporting calls for a specific user
1.620 albertel 5934: return $env{join('.',('request.course',$qualifier))};
1.48 www 5935: # ------------------------------------------------------------------- user.role
5936: } elsif ($space eq 'role') {
1.218 albertel 5937: # FIXME - not supporting calls for a specific user
1.620 albertel 5938: my ($role,$where)=split(/\./,$env{'request.role'});
1.48 www 5939: if ($qualifier eq 'value') {
5940: return $role;
5941: } elsif ($qualifier eq 'extent') {
5942: return $where;
5943: }
5944: # ----------------------------------------------------------------- user.domain
5945: } elsif ($space eq 'domain') {
1.218 albertel 5946: return $udom;
1.48 www 5947: # ------------------------------------------------------------------- user.name
5948: } elsif ($space eq 'name') {
1.218 albertel 5949: return $uname;
1.48 www 5950: # ---------------------------------------------------- Any other user namespace
1.29 www 5951: } else {
1.359 albertel 5952: my %reply;
5953: if (!$publicuser) {
5954: %reply=&get($space,[$qualifierrest],$udom,$uname);
5955: }
5956: return $reply{$qualifierrest};
1.48 www 5957: }
1.236 www 5958: } elsif ($realm eq 'query') {
5959: # ---------------------------------------------- pull stuff out of query string
1.384 albertel 5960: &Apache::loncommon::get_unprocessed_cgi($ENV{'QUERY_STRING'},
5961: [$spacequalifierrest]);
1.620 albertel 5962: return $env{'form.'.$spacequalifierrest};
1.236 www 5963: } elsif ($realm eq 'request') {
1.48 www 5964: # ------------------------------------------------------------- request.browser
5965: if ($space eq 'browser') {
1.430 www 5966: if ($qualifier eq 'textremote') {
1.676 albertel 5967: if (&Apache::lonlocal::mt('textual_remote_display') eq 'on') {
1.430 www 5968: return 1;
5969: } else {
5970: return 0;
5971: }
5972: } else {
1.620 albertel 5973: return $env{'browser.'.$qualifier};
1.430 www 5974: }
1.57 www 5975: # ------------------------------------------------------------ request.filename
5976: } else {
1.620 albertel 5977: return $env{'request.'.$spacequalifierrest};
1.29 www 5978: }
1.28 www 5979: } elsif ($realm eq 'course') {
1.48 www 5980: # ---------------------------------------------------------- course.description
1.620 albertel 5981: return $env{'course.'.$courseid.'.'.$spacequalifierrest};
1.57 www 5982: } elsif ($realm eq 'resource') {
1.165 www 5983:
1.620 albertel 5984: if (defined($courseid) && $courseid eq $env{'request.course.id'}) {
1.539 albertel 5985: if (!$symbparm) { $symbparm=&symbread(); }
5986: }
1.693 albertel 5987:
5988: if ($space eq 'title') {
5989: if (!$symbparm) { $symbparm = $env{'request.filename'}; }
5990: return &gettitle($symbparm);
5991: }
5992:
5993: if ($space eq 'map') {
5994: my ($map) = &decode_symb($symbparm);
5995: return &symbread($map);
5996: }
5997:
5998: my ($section, $group, @groups);
1.593 albertel 5999: my ($courselevelm,$courselevel);
1.539 albertel 6000: if ($symbparm && defined($courseid) &&
1.620 albertel 6001: $courseid eq $env{'request.course.id'}) {
1.165 www 6002:
1.218 albertel 6003: #print '<br>'.$space.' - '.$qualifier.' - '.$spacequalifierrest;
1.165 www 6004:
1.60 www 6005: # ----------------------------------------------------- Cascading lookup scheme
1.218 albertel 6006: my $symbp=$symbparm;
1.735 albertel 6007: my $mapp=&deversion((&decode_symb($symbp))[0]);
1.218 albertel 6008:
6009: my $symbparm=$symbp.'.'.$spacequalifierrest;
6010: my $mapparm=$mapp.'___(all).'.$spacequalifierrest;
6011:
1.620 albertel 6012: if (($env{'user.name'} eq $uname) &&
6013: ($env{'user.domain'} eq $udom)) {
6014: $section=$env{'request.course.sec'};
1.733 raeburn 6015: @groups = split(/:/,$env{'request.course.groups'});
6016: @groups=&sort_course_groups($courseid,@groups);
1.218 albertel 6017: } else {
1.539 albertel 6018: if (! defined($usection)) {
1.551 albertel 6019: $section=&getsection($udom,$uname,$courseid);
1.539 albertel 6020: } else {
6021: $section = $usection;
6022: }
1.733 raeburn 6023: @groups = &get_users_groups($udom,$uname,$courseid);
1.218 albertel 6024: }
6025:
6026: my $seclevel=$courseid.'.['.$section.'].'.$spacequalifierrest;
6027: my $seclevelr=$courseid.'.['.$section.'].'.$symbparm;
6028: my $seclevelm=$courseid.'.['.$section.'].'.$mapparm;
6029:
1.593 albertel 6030: $courselevel=$courseid.'.'.$spacequalifierrest;
1.218 albertel 6031: my $courselevelr=$courseid.'.'.$symbparm;
1.593 albertel 6032: $courselevelm=$courseid.'.'.$mapparm;
1.69 www 6033:
1.60 www 6034: # ----------------------------------------------------------- first, check user
1.624 albertel 6035:
6036: my $userreply=&resdata($uname,$udom,'user',
6037: ($courselevelr,$courselevelm,
6038: $courselevel));
6039: if (defined($userreply)) { return $userreply; }
1.95 www 6040:
1.594 albertel 6041: # ------------------------------------------------ second, check some of course
1.684 raeburn 6042: my $coursereply;
1.691 raeburn 6043: if (@groups > 0) {
6044: $coursereply = &check_group_parms($courseid,\@groups,$symbparm,
6045: $mapparm,$spacequalifierrest);
1.684 raeburn 6046: if (defined($coursereply)) { return $coursereply; }
6047: }
1.96 www 6048:
1.684 raeburn 6049: $coursereply=&resdata($env{'course.'.$courseid.'.num'},
1.624 albertel 6050: $env{'course.'.$courseid.'.domain'},
6051: 'course',
6052: ($seclevelr,$seclevelm,$seclevel,
6053: $courselevelr));
1.287 albertel 6054: if (defined($coursereply)) { return $coursereply; }
1.200 www 6055:
1.60 www 6056: # ------------------------------------------------------ third, check map parms
1.218 albertel 6057: my %parmhash=();
6058: my $thisparm='';
6059: if (tie(%parmhash,'GDBM_File',
1.620 albertel 6060: $env{'request.course.fn'}.'_parms.db',
1.256 albertel 6061: &GDBM_READER(),0640)) {
1.218 albertel 6062: $thisparm=$parmhash{$symbparm};
6063: untie(%parmhash);
6064: }
6065: if ($thisparm) { return $thisparm; }
6066: }
1.594 albertel 6067: # ------------------------------------------ fourth, look in resource metadata
1.71 www 6068:
1.218 albertel 6069: $spacequalifierrest=~s/\./\_/;
1.282 albertel 6070: my $filename;
6071: if (!$symbparm) { $symbparm=&symbread(); }
6072: if ($symbparm) {
1.409 www 6073: $filename=(&decode_symb($symbparm))[2];
1.282 albertel 6074: } else {
1.620 albertel 6075: $filename=$env{'request.filename'};
1.282 albertel 6076: }
6077: my $metadata=&metadata($filename,$spacequalifierrest);
1.288 albertel 6078: if (defined($metadata)) { return $metadata; }
1.282 albertel 6079: $metadata=&metadata($filename,'parameter_'.$spacequalifierrest);
1.288 albertel 6080: if (defined($metadata)) { return $metadata; }
1.142 www 6081:
1.594 albertel 6082: # ---------------------------------------------- fourth, look in rest pf course
1.593 albertel 6083: if ($symbparm && defined($courseid) &&
1.620 albertel 6084: $courseid eq $env{'request.course.id'}) {
1.624 albertel 6085: my $coursereply=&resdata($env{'course.'.$courseid.'.num'},
6086: $env{'course.'.$courseid.'.domain'},
6087: 'course',
6088: ($courselevelm,$courselevel));
1.593 albertel 6089: if (defined($coursereply)) { return $coursereply; }
6090: }
1.145 www 6091: # ------------------------------------------------------------------ Cascade up
1.218 albertel 6092: unless ($space eq '0') {
1.336 albertel 6093: my @parts=split(/_/,$space);
6094: my $id=pop(@parts);
6095: my $part=join('_',@parts);
6096: if ($part eq '') { $part='0'; }
6097: my $partgeneral=&EXT('resource.'.$part.'.'.$qualifierrest,
1.395 albertel 6098: $symbparm,$udom,$uname,$section,1);
1.337 albertel 6099: if (defined($partgeneral)) { return $partgeneral; }
1.218 albertel 6100: }
1.395 albertel 6101: if ($recurse) { return undef; }
6102: my $pack_def=&packages_tab_default($filename,$varname);
6103: if (defined($pack_def)) { return $pack_def; }
1.71 www 6104:
1.48 www 6105: # ---------------------------------------------------- Any other user namespace
6106: } elsif ($realm eq 'environment') {
6107: # ----------------------------------------------------------------- environment
1.620 albertel 6108: if (($uname eq $env{'user.name'})&&($udom eq $env{'user.domain'})) {
6109: return $env{'environment.'.$spacequalifierrest};
1.219 albertel 6110: } else {
1.770 albertel 6111: if ($uname eq 'anonymous' && $udom eq '') {
6112: return '';
6113: }
1.219 albertel 6114: my %returnhash=&userenvironment($udom,$uname,
6115: $spacequalifierrest);
6116: return $returnhash{$spacequalifierrest};
6117: }
1.28 www 6118: } elsif ($realm eq 'system') {
1.48 www 6119: # ----------------------------------------------------------------- system.time
6120: if ($space eq 'time') {
6121: return time;
6122: }
1.696 albertel 6123: } elsif ($realm eq 'server') {
6124: # ----------------------------------------------------------------- system.time
6125: if ($space eq 'name') {
6126: return $ENV{'SERVER_NAME'};
6127: }
1.28 www 6128: }
1.48 www 6129: return '';
1.61 www 6130: }
6131:
1.691 raeburn 6132: sub check_group_parms {
6133: my ($courseid,$groups,$symbparm,$mapparm,$what) = @_;
6134: my @groupitems = ();
6135: my $resultitem;
6136: my @levels = ($symbparm,$mapparm,$what);
6137: foreach my $group (@{$groups}) {
6138: foreach my $level (@levels) {
6139: my $item = $courseid.'.['.$group.'].'.$level;
6140: push(@groupitems,$item);
6141: }
6142: }
6143: my $coursereply = &resdata($env{'course.'.$courseid.'.num'},
6144: $env{'course.'.$courseid.'.domain'},
6145: 'course',@groupitems);
6146: return $coursereply;
6147: }
6148:
6149: sub sort_course_groups { # Sort groups based on defined rankings. Default is sort().
1.733 raeburn 6150: my ($courseid,@groups) = @_;
6151: @groups = sort(@groups);
1.691 raeburn 6152: return @groups;
6153: }
6154:
1.395 albertel 6155: sub packages_tab_default {
6156: my ($uri,$varname)=@_;
6157: my (undef,$part,$name)=split(/\./,$varname);
1.738 albertel 6158:
6159: my (@extension,@specifics,$do_default);
6160: foreach my $package (split(/,/,&metadata($uri,'packages'))) {
1.395 albertel 6161: my ($pack_type,$pack_part)=split(/_/,$package,2);
1.738 albertel 6162: if ($pack_type eq 'default') {
6163: $do_default=1;
6164: } elsif ($pack_type eq 'extension') {
6165: push(@extension,[$package,$pack_type,$pack_part]);
6166: } else {
6167: push(@specifics,[$package,$pack_type,$pack_part]);
6168: }
6169: }
6170: # first look for a package that matches the requested part id
6171: foreach my $package (@specifics) {
6172: my (undef,$pack_type,$pack_part)=@{$package};
6173: next if ($pack_part ne $part);
6174: if (defined($packagetab{"$pack_type&$name&default"})) {
6175: return $packagetab{"$pack_type&$name&default"};
6176: }
6177: }
6178: # look for any possible matching non extension_ package
6179: foreach my $package (@specifics) {
6180: my (undef,$pack_type,$pack_part)=@{$package};
1.468 albertel 6181: if (defined($packagetab{"$pack_type&$name&default"})) {
6182: return $packagetab{"$pack_type&$name&default"};
6183: }
1.585 albertel 6184: if ($pack_type eq 'part') { $pack_part='0'; }
1.468 albertel 6185: if (defined($packagetab{$pack_type."_".$pack_part."&$name&default"})) {
6186: return $packagetab{$pack_type."_".$pack_part."&$name&default"};
1.395 albertel 6187: }
6188: }
1.738 albertel 6189: # look for any posible extension_ match
6190: foreach my $package (@extension) {
6191: my ($package,$pack_type)=@{$package};
6192: if (defined($packagetab{"$pack_type&$name&default"})) {
6193: return $packagetab{"$pack_type&$name&default"};
6194: }
6195: if (defined($packagetab{$package."&$name&default"})) {
6196: return $packagetab{$package."&$name&default"};
6197: }
6198: }
6199: # look for a global default setting
6200: if ($do_default && defined($packagetab{"default&$name&default"})) {
6201: return $packagetab{"default&$name&default"};
6202: }
1.395 albertel 6203: return undef;
6204: }
6205:
1.334 albertel 6206: sub add_prefix_and_part {
6207: my ($prefix,$part)=@_;
6208: my $keyroot;
6209: if (defined($prefix) && $prefix !~ /^__/) {
6210: # prefix that has a part already
6211: $keyroot=$prefix;
6212: } elsif (defined($prefix)) {
6213: # prefix that is missing a part
6214: if (defined($part)) { $keyroot='_'.$part.substr($prefix,1); }
6215: } else {
6216: # no prefix at all
6217: if (defined($part)) { $keyroot='_'.$part; }
6218: }
6219: return $keyroot;
6220: }
6221:
1.71 www 6222: # ---------------------------------------------------------------- Get metadata
6223:
1.599 albertel 6224: my %metaentry;
1.71 www 6225: sub metadata {
1.176 www 6226: my ($uri,$what,$liburi,$prefix,$depthcount)=@_;
1.71 www 6227: $uri=&declutter($uri);
1.288 albertel 6228: # if it is a non metadata possible uri return quickly
1.529 albertel 6229: if (($uri eq '') ||
6230: (($uri =~ m|^/*adm/|) &&
1.698 albertel 6231: ($uri !~ m|^adm/includes|) && ($uri !~ m|/bulletinboard$|)) ||
1.423 albertel 6232: ($uri =~ m|/$|) || ($uri =~ m|/.meta$|) || ($uri =~ /^~/) ||
1.807 albertel 6233: ($uri =~ m|home/$match_username/public_html/|)) {
1.468 albertel 6234: return undef;
1.288 albertel 6235: }
1.73 www 6236: my $filename=$uri;
6237: $uri=~s/\.meta$//;
1.172 www 6238: #
6239: # Is the metadata already cached?
1.177 www 6240: # Look at timestamp of caching
1.172 www 6241: # Everything is cached by the main uri, libraries are never directly cached
6242: #
1.428 albertel 6243: if (!defined($liburi)) {
1.599 albertel 6244: my ($result,$cached)=&is_cached_new('meta',$uri);
1.428 albertel 6245: if (defined($cached)) { return $result->{':'.$what}; }
6246: }
6247: {
1.172 www 6248: #
6249: # Is this a recursive call for a library?
6250: #
1.599 albertel 6251: # if (! exists($metacache{$uri})) {
6252: # $metacache{$uri}={};
6253: # }
1.171 www 6254: if ($liburi) {
6255: $liburi=&declutter($liburi);
6256: $filename=$liburi;
1.401 bowersj2 6257: } else {
1.599 albertel 6258: &devalidate_cache_new('meta',$uri);
6259: undef(%metaentry);
1.401 bowersj2 6260: }
1.140 www 6261: my %metathesekeys=();
1.73 www 6262: unless ($filename=~/\.meta$/) { $filename.='.meta'; }
1.489 albertel 6263: my $metastring;
1.768 albertel 6264: if ($uri !~ m -^(editupload)/-) {
1.543 albertel 6265: my $file=&filelocation('',&clutter($filename));
1.599 albertel 6266: #push(@{$metaentry{$uri.'.file'}},$file);
1.543 albertel 6267: $metastring=&getfile($file);
1.489 albertel 6268: }
1.208 albertel 6269: my $parser=HTML::LCParser->new(\$metastring);
1.71 www 6270: my $token;
1.140 www 6271: undef %metathesekeys;
1.71 www 6272: while ($token=$parser->get_token) {
1.339 albertel 6273: if ($token->[0] eq 'S') {
6274: if (defined($token->[2]->{'package'})) {
1.172 www 6275: #
6276: # This is a package - get package info
6277: #
1.339 albertel 6278: my $package=$token->[2]->{'package'};
6279: my $keyroot=&add_prefix_and_part($prefix,$token->[2]->{'part'});
6280: if (defined($token->[2]->{'id'})) {
6281: $keyroot.='_'.$token->[2]->{'id'};
6282: }
1.599 albertel 6283: if ($metaentry{':packages'}) {
6284: $metaentry{':packages'}.=','.$package.$keyroot;
1.339 albertel 6285: } else {
1.599 albertel 6286: $metaentry{':packages'}=$package.$keyroot;
1.339 albertel 6287: }
1.736 albertel 6288: foreach my $pack_entry (keys(%packagetab)) {
1.432 albertel 6289: my $part=$keyroot;
6290: $part=~s/^\_//;
1.736 albertel 6291: if ($pack_entry=~/^\Q$package\E\&/ ||
6292: $pack_entry=~/^\Q$package\E_0\&/) {
6293: my ($pack,$name,$subp)=split(/\&/,$pack_entry);
1.395 albertel 6294: # ignore package.tab specified default values
6295: # here &package_tab_default() will fetch those
6296: if ($subp eq 'default') { next; }
1.736 albertel 6297: my $value=$packagetab{$pack_entry};
1.432 albertel 6298: my $unikey;
6299: if ($pack =~ /_0$/) {
6300: $unikey='parameter_0_'.$name;
6301: $part=0;
6302: } else {
6303: $unikey='parameter'.$keyroot.'_'.$name;
6304: }
1.339 albertel 6305: if ($subp eq 'display') {
6306: $value.=' [Part: '.$part.']';
6307: }
1.599 albertel 6308: $metaentry{':'.$unikey.'.part'}=$part;
1.395 albertel 6309: $metathesekeys{$unikey}=1;
1.599 albertel 6310: unless (defined($metaentry{':'.$unikey.'.'.$subp})) {
6311: $metaentry{':'.$unikey.'.'.$subp}=$value;
1.339 albertel 6312: }
1.599 albertel 6313: if (defined($metaentry{':'.$unikey.'.default'})) {
6314: $metaentry{':'.$unikey}=
6315: $metaentry{':'.$unikey.'.default'};
1.356 albertel 6316: }
1.339 albertel 6317: }
6318: }
6319: } else {
1.172 www 6320: #
6321: # This is not a package - some other kind of start tag
1.339 albertel 6322: #
6323: my $entry=$token->[1];
6324: my $unikey;
6325: if ($entry eq 'import') {
6326: $unikey='';
6327: } else {
6328: $unikey=$entry;
6329: }
6330: $unikey.=&add_prefix_and_part($prefix,$token->[2]->{'part'});
6331:
6332: if (defined($token->[2]->{'id'})) {
6333: $unikey.='_'.$token->[2]->{'id'};
6334: }
1.175 www 6335:
1.339 albertel 6336: if ($entry eq 'import') {
1.175 www 6337: #
6338: # Importing a library here
1.339 albertel 6339: #
6340: if ($depthcount<20) {
6341: my $location=$parser->get_text('/import');
6342: my $dir=$filename;
6343: $dir=~s|[^/]*$||;
6344: $location=&filelocation($dir,$location);
1.736 albertel 6345: my $metadata =
6346: &metadata($uri,'keys', $location,$unikey,
6347: $depthcount+1);
6348: foreach my $meta (split(',',$metadata)) {
6349: $metaentry{':'.$meta}=$metaentry{':'.$meta};
6350: $metathesekeys{$meta}=1;
1.339 albertel 6351: }
6352: }
6353: } else {
6354:
6355: if (defined($token->[2]->{'name'})) {
6356: $unikey.='_'.$token->[2]->{'name'};
6357: }
6358: $metathesekeys{$unikey}=1;
1.736 albertel 6359: foreach my $param (@{$token->[3]}) {
6360: $metaentry{':'.$unikey.'.'.$param} =
6361: $token->[2]->{$param};
1.339 albertel 6362: }
6363: my $internaltext=&HTML::Entities::decode($parser->get_text('/'.$entry));
1.599 albertel 6364: my $default=$metaentry{':'.$unikey.'.default'};
1.339 albertel 6365: if ( $internaltext =~ /^\s*$/ && $default !~ /^\s*$/) {
6366: # only ws inside the tag, and not in default, so use default
6367: # as value
1.599 albertel 6368: $metaentry{':'.$unikey}=$default;
1.339 albertel 6369: } else {
1.321 albertel 6370: # either something interesting inside the tag or default
6371: # uninteresting
1.599 albertel 6372: $metaentry{':'.$unikey}=$internaltext;
1.339 albertel 6373: }
1.172 www 6374: # end of not-a-package not-a-library import
1.339 albertel 6375: }
1.172 www 6376: # end of not-a-package start tag
1.339 albertel 6377: }
1.172 www 6378: # the next is the end of "start tag"
1.339 albertel 6379: }
6380: }
1.483 albertel 6381: my ($extension) = ($uri =~ /\.(\w+)$/);
1.737 albertel 6382: foreach my $key (keys(%packagetab)) {
1.483 albertel 6383: #no specific packages #how's our extension
6384: if ($key!~/^extension_\Q$extension\E&/) { next; }
1.488 albertel 6385: &metadata_create_package_def($uri,$key,'extension_'.$extension,
1.483 albertel 6386: \%metathesekeys);
6387: }
1.599 albertel 6388: if (!exists($metaentry{':packages'})) {
1.737 albertel 6389: foreach my $key (keys(%packagetab)) {
1.483 albertel 6390: #no specific packages well let's get default then
6391: if ($key!~/^default&/) { next; }
1.488 albertel 6392: &metadata_create_package_def($uri,$key,'default',
1.483 albertel 6393: \%metathesekeys);
6394: }
6395: }
1.338 www 6396: # are there custom rights to evaluate
1.599 albertel 6397: if ($metaentry{':copyright'} eq 'custom') {
1.339 albertel 6398:
1.338 www 6399: #
6400: # Importing a rights file here
1.339 albertel 6401: #
6402: unless ($depthcount) {
1.599 albertel 6403: my $location=$metaentry{':customdistributionfile'};
1.339 albertel 6404: my $dir=$filename;
6405: $dir=~s|[^/]*$||;
6406: $location=&filelocation($dir,$location);
1.736 albertel 6407: my $rights_metadata =
6408: &metadata($uri,'keys',$location,'_rights',
6409: $depthcount+1);
6410: foreach my $rights (split(',',$rights_metadata)) {
6411: #$metaentry{':'.$rights}=$metacache{$uri}->{':'.$rights};
6412: $metathesekeys{$rights}=1;
1.339 albertel 6413: }
6414: }
6415: }
1.737 albertel 6416: # uniqifiy package listing
6417: my %seen;
6418: my @uniq_packages =
6419: grep { ! $seen{$_} ++ } (split(',',$metaentry{':packages'}));
6420: $metaentry{':packages'} = join(',',@uniq_packages);
6421:
6422: $metaentry{':keys'} = join(',',keys(%metathesekeys));
1.599 albertel 6423: &metadata_generate_part0(\%metathesekeys,\%metaentry,$uri);
6424: $metaentry{':allpossiblekeys'}=join(',',keys %metathesekeys);
1.699 albertel 6425: &do_cache_new('meta',$uri,\%metaentry,60*60);
1.177 www 6426: # this is the end of "was not already recently cached
1.71 www 6427: }
1.599 albertel 6428: return $metaentry{':'.$what};
1.261 albertel 6429: }
6430:
1.488 albertel 6431: sub metadata_create_package_def {
1.483 albertel 6432: my ($uri,$key,$package,$metathesekeys)=@_;
6433: my ($pack,$name,$subp)=split(/\&/,$key);
6434: if ($subp eq 'default') { next; }
6435:
1.599 albertel 6436: if (defined($metaentry{':packages'})) {
6437: $metaentry{':packages'}.=','.$package;
1.483 albertel 6438: } else {
1.599 albertel 6439: $metaentry{':packages'}=$package;
1.483 albertel 6440: }
6441: my $value=$packagetab{$key};
6442: my $unikey;
6443: $unikey='parameter_0_'.$name;
1.599 albertel 6444: $metaentry{':'.$unikey.'.part'}=0;
1.483 albertel 6445: $$metathesekeys{$unikey}=1;
1.599 albertel 6446: unless (defined($metaentry{':'.$unikey.'.'.$subp})) {
6447: $metaentry{':'.$unikey.'.'.$subp}=$value;
1.483 albertel 6448: }
1.599 albertel 6449: if (defined($metaentry{':'.$unikey.'.default'})) {
6450: $metaentry{':'.$unikey}=
6451: $metaentry{':'.$unikey.'.default'};
1.483 albertel 6452: }
6453: }
6454:
1.261 albertel 6455: sub metadata_generate_part0 {
6456: my ($metadata,$metacache,$uri) = @_;
6457: my %allnames;
1.737 albertel 6458: foreach my $metakey (keys(%$metadata)) {
1.261 albertel 6459: if ($metakey=~/^parameter\_(.*)/) {
1.428 albertel 6460: my $part=$$metacache{':'.$metakey.'.part'};
6461: my $name=$$metacache{':'.$metakey.'.name'};
1.356 albertel 6462: if (! exists($$metadata{'parameter_0_'.$name.'.name'})) {
1.261 albertel 6463: $allnames{$name}=$part;
6464: }
6465: }
6466: }
6467: foreach my $name (keys(%allnames)) {
6468: $$metadata{"parameter_0_$name"}=1;
1.428 albertel 6469: my $key=":parameter_0_$name";
1.261 albertel 6470: $$metacache{"$key.part"}='0';
6471: $$metacache{"$key.name"}=$name;
1.428 albertel 6472: $$metacache{"$key.type"}=$$metacache{':parameter_'.
1.261 albertel 6473: $allnames{$name}.'_'.$name.
6474: '.type'};
1.428 albertel 6475: my $olddis=$$metacache{':parameter_'.$allnames{$name}.'_'.$name.
1.261 albertel 6476: '.display'};
1.644 www 6477: my $expr='[Part: '.$allnames{$name}.']';
1.479 albertel 6478: $olddis=~s/\Q$expr\E/\[Part: 0\]/;
1.261 albertel 6479: $$metacache{"$key.display"}=$olddis;
6480: }
1.71 www 6481: }
6482:
1.764 albertel 6483: # ------------------------------------------------------ Devalidate title cache
6484:
6485: sub devalidate_title_cache {
6486: my ($url)=@_;
6487: if (!$env{'request.course.id'}) { return; }
6488: my $symb=&symbread($url);
6489: if (!$symb) { return; }
6490: my $key=$env{'request.course.id'}."\0".$symb;
6491: &devalidate_cache_new('title',$key);
6492: }
6493:
1.301 www 6494: # ------------------------------------------------- Get the title of a resource
6495:
6496: sub gettitle {
6497: my $urlsymb=shift;
6498: my $symb=&symbread($urlsymb);
1.534 albertel 6499: if ($symb) {
1.620 albertel 6500: my $key=$env{'request.course.id'}."\0".$symb;
1.599 albertel 6501: my ($result,$cached)=&is_cached_new('title',$key);
1.575 albertel 6502: if (defined($cached)) {
6503: return $result;
6504: }
1.534 albertel 6505: my ($map,$resid,$url)=&decode_symb($symb);
6506: my $title='';
6507: my %bighash;
1.620 albertel 6508: if (tie(%bighash,'GDBM_File',$env{'request.course.fn'}.'.db',
1.534 albertel 6509: &GDBM_READER(),0640)) {
6510: my $mapid=$bighash{'map_pc_'.&clutter($map)};
6511: $title=$bighash{'title_'.$mapid.'.'.$resid};
6512: untie %bighash;
6513: }
6514: $title=~s/\&colon\;/\:/gs;
6515: if ($title) {
1.599 albertel 6516: return &do_cache_new('title',$key,$title,600);
1.534 albertel 6517: }
6518: $urlsymb=$url;
6519: }
6520: my $title=&metadata($urlsymb,'title');
6521: if (!$title) { $title=(split('/',$urlsymb))[-1]; }
6522: return $title;
1.301 www 6523: }
1.613 albertel 6524:
1.614 albertel 6525: sub get_slot {
6526: my ($which,$cnum,$cdom)=@_;
6527: if (!$cnum || !$cdom) {
1.790 albertel 6528: (undef,my $courseid)=&whichuser();
1.620 albertel 6529: $cdom=$env{'course.'.$courseid.'.domain'};
6530: $cnum=$env{'course.'.$courseid.'.num'};
1.614 albertel 6531: }
1.703 albertel 6532: my $key=join("\0",'slots',$cdom,$cnum,$which);
6533: my %slotinfo;
6534: if (exists($remembered{$key})) {
6535: $slotinfo{$which} = $remembered{$key};
6536: } else {
6537: %slotinfo=&get('slots',[$which],$cdom,$cnum);
6538: &Apache::lonhomework::showhash(%slotinfo);
6539: my ($tmp)=keys(%slotinfo);
6540: if ($tmp=~/^error:/) { return (); }
6541: $remembered{$key} = $slotinfo{$which};
6542: }
1.616 albertel 6543: if (ref($slotinfo{$which}) eq 'HASH') {
6544: return %{$slotinfo{$which}};
6545: }
6546: return $slotinfo{$which};
1.614 albertel 6547: }
1.31 www 6548: # ------------------------------------------------- Update symbolic store links
6549:
6550: sub symblist {
6551: my ($mapname,%newhash)=@_;
1.438 www 6552: $mapname=&deversion(&declutter($mapname));
1.31 www 6553: my %hash;
1.620 albertel 6554: if (($env{'request.course.fn'}) && (%newhash)) {
6555: if (tie(%hash,'GDBM_File',$env{'request.course.fn'}.'_symb.db',
1.256 albertel 6556: &GDBM_WRCREAT(),0640)) {
1.711 albertel 6557: foreach my $url (keys %newhash) {
6558: next if ($url eq 'last_known'
6559: && $env{'form.no_update_last_known'});
6560: $hash{declutter($url)}=&encode_symb($mapname,
6561: $newhash{$url}->[1],
6562: $newhash{$url}->[0]);
1.191 harris41 6563: }
1.31 www 6564: if (untie(%hash)) {
6565: return 'ok';
6566: }
6567: }
6568: }
6569: return 'error';
1.212 www 6570: }
6571:
6572: # --------------------------------------------------------------- Verify a symb
6573:
6574: sub symbverify {
1.510 www 6575: my ($symb,$thisurl)=@_;
6576: my $thisfn=$thisurl;
1.439 www 6577: $thisfn=&declutter($thisfn);
1.215 www 6578: # direct jump to resource in page or to a sequence - will construct own symbs
6579: if ($thisfn=~/\.(page|sequence)$/) { return 1; }
6580: # check URL part
1.409 www 6581: my ($map,$resid,$url)=&decode_symb($symb);
1.439 www 6582:
1.431 www 6583: unless ($url eq $thisfn) { return 0; }
1.213 www 6584:
1.216 www 6585: $symb=&symbclean($symb);
1.510 www 6586: $thisurl=&deversion($thisurl);
1.439 www 6587: $thisfn=&deversion($thisfn);
1.213 www 6588:
6589: my %bighash;
6590: my $okay=0;
1.431 www 6591:
1.620 albertel 6592: if (tie(%bighash,'GDBM_File',$env{'request.course.fn'}.'.db',
1.256 albertel 6593: &GDBM_READER(),0640)) {
1.510 www 6594: my $ids=$bighash{'ids_'.&clutter($thisurl)};
1.216 www 6595: unless ($ids) {
1.510 www 6596: $ids=$bighash{'ids_/'.$thisurl};
1.216 www 6597: }
6598: if ($ids) {
6599: # ------------------------------------------------------------------- Has ID(s)
1.800 albertel 6600: foreach my $id (split(/\,/,$ids)) {
6601: my ($mapid,$resid)=split(/\./,$id);
1.216 www 6602: if (
6603: &symbclean(&declutter($bighash{'map_id_'.$mapid}).'___'.$resid.'___'.$thisfn)
6604: eq $symb) {
1.620 albertel 6605: if (($env{'request.role.adv'}) ||
1.800 albertel 6606: $bighash{'encrypted_'.$id} eq $env{'request.enc'}) {
1.582 albertel 6607: $okay=1;
6608: }
6609: }
1.216 www 6610: }
6611: }
1.213 www 6612: untie(%bighash);
6613: }
6614: return $okay;
1.31 www 6615: }
6616:
1.210 www 6617: # --------------------------------------------------------------- Clean-up symb
6618:
6619: sub symbclean {
6620: my $symb=shift;
1.568 albertel 6621: if ($symb=~m|^/enc/|) { $symb=&Apache::lonenc::unencrypted($symb); }
1.210 www 6622: # remove version from map
6623: $symb=~s/\.(\d+)\.(\w+)\_\_\_/\.$2\_\_\_/;
1.215 www 6624:
1.210 www 6625: # remove version from URL
6626: $symb=~s/\.(\d+)\.(\w+)$/\.$2/;
1.213 www 6627:
1.507 www 6628: # remove wrapper
6629:
1.510 www 6630: $symb=~s/(\_\_\_\d+\_\_\_)adm\/wrapper\/(res\/)*/$1/;
1.694 albertel 6631: $symb=~s/(\_\_\_\d+\_\_\_)adm\/coursedocs\/showdoc\/(res\/)*/$1/;
1.210 www 6632: return $symb;
1.409 www 6633: }
6634:
6635: # ---------------------------------------------- Split symb to find map and url
1.429 albertel 6636:
6637: sub encode_symb {
6638: my ($map,$resid,$url)=@_;
6639: return &symbclean(&declutter($map).'___'.$resid.'___'.&declutter($url));
6640: }
1.409 www 6641:
6642: sub decode_symb {
1.568 albertel 6643: my $symb=shift;
6644: if ($symb=~m|^/enc/|) { $symb=&Apache::lonenc::unencrypted($symb); }
6645: my ($map,$resid,$url)=split(/___/,$symb);
1.413 www 6646: return (&fixversion($map),$resid,&fixversion($url));
6647: }
6648:
6649: sub fixversion {
6650: my $fn=shift;
1.609 banghart 6651: if ($fn=~/^(adm|uploaded|editupload|public)/) { return $fn; }
1.435 www 6652: my %bighash;
6653: my $uri=&clutter($fn);
1.620 albertel 6654: my $key=$env{'request.course.id'}.'_'.$uri;
1.440 www 6655: # is this cached?
1.599 albertel 6656: my ($result,$cached)=&is_cached_new('courseresversion',$key);
1.440 www 6657: if (defined($cached)) { return $result; }
6658: # unfortunately not cached, or expired
1.620 albertel 6659: if (tie(%bighash,'GDBM_File',$env{'request.course.fn'}.'.db',
1.440 www 6660: &GDBM_READER(),0640)) {
6661: if ($bighash{'version_'.$uri}) {
6662: my $version=$bighash{'version_'.$uri};
1.444 www 6663: unless (($version eq 'mostrecent') ||
6664: ($version==&getversion($uri))) {
1.440 www 6665: $uri=~s/\.(\w+)$/\.$version\.$1/;
6666: }
6667: }
6668: untie %bighash;
1.413 www 6669: }
1.599 albertel 6670: return &do_cache_new('courseresversion',$key,&declutter($uri),600);
1.438 www 6671: }
6672:
6673: sub deversion {
6674: my $url=shift;
6675: $url=~s/\.\d+\.(\w+)$/\.$1/;
6676: return $url;
1.210 www 6677: }
6678:
1.31 www 6679: # ------------------------------------------------------ Return symb list entry
6680:
6681: sub symbread {
1.249 www 6682: my ($thisfn,$donotrecurse)=@_;
1.542 albertel 6683: my $cache_str='request.symbread.cached.'.$thisfn;
1.620 albertel 6684: if (defined($env{$cache_str})) { return $env{$cache_str}; }
1.242 www 6685: # no filename provided? try from environment
1.44 www 6686: unless ($thisfn) {
1.620 albertel 6687: if ($env{'request.symb'}) {
6688: return $env{$cache_str}=&symbclean($env{'request.symb'});
1.539 albertel 6689: }
1.620 albertel 6690: $thisfn=$env{'request.filename'};
1.44 www 6691: }
1.569 albertel 6692: if ($thisfn=~m|^/enc/|) { $thisfn=&Apache::lonenc::unencrypted($thisfn); }
1.242 www 6693: # is that filename actually a symb? Verify, clean, and return
6694: if ($thisfn=~/\_\_\_\d+\_\_\_(.*)$/) {
1.539 albertel 6695: if (&symbverify($thisfn,$1)) {
1.620 albertel 6696: return $env{$cache_str}=&symbclean($thisfn);
1.539 albertel 6697: }
1.242 www 6698: }
1.44 www 6699: $thisfn=declutter($thisfn);
1.31 www 6700: my %hash;
1.37 www 6701: my %bighash;
6702: my $syval='';
1.620 albertel 6703: if (($env{'request.course.fn'}) && ($thisfn)) {
1.481 raeburn 6704: my $targetfn = $thisfn;
1.609 banghart 6705: if ( ($thisfn =~ m/^(uploaded|editupload)\//) && ($thisfn !~ m/\.(page|sequence)$/) ) {
1.481 raeburn 6706: $targetfn = 'adm/wrapper/'.$thisfn;
6707: }
1.687 albertel 6708: if ($targetfn =~ m|^adm/wrapper/(ext/.*)|) {
6709: $targetfn=$1;
6710: }
1.620 albertel 6711: if (tie(%hash,'GDBM_File',$env{'request.course.fn'}.'_symb.db',
1.256 albertel 6712: &GDBM_READER(),0640)) {
1.481 raeburn 6713: $syval=$hash{$targetfn};
1.37 www 6714: untie(%hash);
6715: }
6716: # ---------------------------------------------------------- There was an entry
6717: if ($syval) {
1.601 albertel 6718: #unless ($syval=~/\_\d+$/) {
1.620 albertel 6719: #unless ($env{'form.request.prefix'}=~/\.(\d+)\_$/) {
1.601 albertel 6720: #&appenv('request.ambiguous' => $thisfn);
1.620 albertel 6721: #return $env{$cache_str}='';
1.601 albertel 6722: #}
6723: #$syval.=$1;
6724: #}
1.37 www 6725: } else {
6726: # ------------------------------------------------------- Was not in symb table
1.620 albertel 6727: if (tie(%bighash,'GDBM_File',$env{'request.course.fn'}.'.db',
1.256 albertel 6728: &GDBM_READER(),0640)) {
1.37 www 6729: # ---------------------------------------------- Get ID(s) for current resource
1.280 www 6730: my $ids=$bighash{'ids_'.&clutter($thisfn)};
1.65 www 6731: unless ($ids) {
6732: $ids=$bighash{'ids_/'.$thisfn};
1.242 www 6733: }
6734: unless ($ids) {
6735: # alias?
6736: $ids=$bighash{'mapalias_'.$thisfn};
1.65 www 6737: }
1.37 www 6738: if ($ids) {
6739: # ------------------------------------------------------------------- Has ID(s)
6740: my @possibilities=split(/\,/,$ids);
1.39 www 6741: if ($#possibilities==0) {
6742: # ----------------------------------------------- There is only one possibility
1.37 www 6743: my ($mapid,$resid)=split(/\./,$ids);
1.626 albertel 6744: $syval=&encode_symb($bighash{'map_id_'.$mapid},
6745: $resid,$thisfn);
1.249 www 6746: } elsif (!$donotrecurse) {
1.39 www 6747: # ------------------------------------------ There is more than one possibility
6748: my $realpossible=0;
1.800 albertel 6749: foreach my $id (@possibilities) {
6750: my $file=$bighash{'src_'.$id};
1.39 www 6751: if (&allowed('bre',$file)) {
1.800 albertel 6752: my ($mapid,$resid)=split(/\./,$id);
1.39 www 6753: if ($bighash{'map_type_'.$mapid} ne 'page') {
6754: $realpossible++;
1.626 albertel 6755: $syval=&encode_symb($bighash{'map_id_'.$mapid},
6756: $resid,$thisfn);
1.39 www 6757: }
6758: }
1.191 harris41 6759: }
1.39 www 6760: if ($realpossible!=1) { $syval=''; }
1.249 www 6761: } else {
6762: $syval='';
1.37 www 6763: }
6764: }
6765: untie(%bighash)
1.481 raeburn 6766: }
1.31 www 6767: }
1.62 www 6768: if ($syval) {
1.620 albertel 6769: return $env{$cache_str}=$syval;
1.62 www 6770: }
1.31 www 6771: }
1.44 www 6772: &appenv('request.ambiguous' => $thisfn);
1.620 albertel 6773: return $env{$cache_str}='';
1.31 www 6774: }
6775:
6776: # ---------------------------------------------------------- Return random seed
6777:
1.32 www 6778: sub numval {
6779: my $txt=shift;
6780: $txt=~tr/A-J/0-9/;
6781: $txt=~tr/a-j/0-9/;
6782: $txt=~tr/K-T/0-9/;
6783: $txt=~tr/k-t/0-9/;
6784: $txt=~tr/U-Z/0-5/;
6785: $txt=~tr/u-z/0-5/;
6786: $txt=~s/\D//g;
1.564 albertel 6787: if ($_64bit) { if ($txt > 2**32) { return -1; } }
1.32 www 6788: return int($txt);
1.368 albertel 6789: }
6790:
1.484 albertel 6791: sub numval2 {
6792: my $txt=shift;
6793: $txt=~tr/A-J/0-9/;
6794: $txt=~tr/a-j/0-9/;
6795: $txt=~tr/K-T/0-9/;
6796: $txt=~tr/k-t/0-9/;
6797: $txt=~tr/U-Z/0-5/;
6798: $txt=~tr/u-z/0-5/;
6799: $txt=~s/\D//g;
6800: my @txts=split(/(\d\d\d\d\d\d\d\d\d)/,$txt);
6801: my $total;
6802: foreach my $val (@txts) { $total+=$val; }
1.564 albertel 6803: if ($_64bit) { if ($total > 2**32) { return -1; } }
1.484 albertel 6804: return int($total);
6805: }
6806:
1.575 albertel 6807: sub numval3 {
6808: use integer;
6809: my $txt=shift;
6810: $txt=~tr/A-J/0-9/;
6811: $txt=~tr/a-j/0-9/;
6812: $txt=~tr/K-T/0-9/;
6813: $txt=~tr/k-t/0-9/;
6814: $txt=~tr/U-Z/0-5/;
6815: $txt=~tr/u-z/0-5/;
6816: $txt=~s/\D//g;
6817: my @txts=split(/(\d\d\d\d\d\d\d\d\d)/,$txt);
6818: my $total;
6819: foreach my $val (@txts) { $total+=$val; }
6820: if ($_64bit) { $total=(($total<<32)>>32); }
6821: return $total;
6822: }
6823:
1.675 albertel 6824: sub digest {
6825: my ($data)=@_;
6826: my $digest=&Digest::MD5::md5($data);
6827: my ($a,$b,$c,$d)=unpack("iiii",$digest);
6828: my ($e,$f);
6829: {
6830: use integer;
6831: $e=($a+$b);
6832: $f=($c+$d);
6833: if ($_64bit) {
6834: $e=(($e<<32)>>32);
6835: $f=(($f<<32)>>32);
6836: }
6837: }
6838: if (wantarray) {
6839: return ($e,$f);
6840: } else {
6841: my $g;
6842: {
6843: use integer;
6844: $g=($e+$f);
6845: if ($_64bit) {
6846: $g=(($g<<32)>>32);
6847: }
6848: }
6849: return $g;
6850: }
6851: }
6852:
1.368 albertel 6853: sub latest_rnd_algorithm_id {
1.675 albertel 6854: return '64bit5';
1.366 albertel 6855: }
1.32 www 6856:
1.503 albertel 6857: sub get_rand_alg {
6858: my ($courseid)=@_;
1.790 albertel 6859: if (!$courseid) { $courseid=(&whichuser())[1]; }
1.503 albertel 6860: if ($courseid) {
1.620 albertel 6861: return $env{"course.$courseid.rndseed"};
1.503 albertel 6862: }
6863: return &latest_rnd_algorithm_id();
6864: }
6865:
1.562 albertel 6866: sub validCODE {
6867: my ($CODE)=@_;
6868: if (defined($CODE) && $CODE ne '' && $CODE =~ /^\w+$/) { return 1; }
6869: return 0;
6870: }
6871:
1.491 albertel 6872: sub getCODE {
1.620 albertel 6873: if (&validCODE($env{'form.CODE'})) { return $env{'form.CODE'}; }
1.618 albertel 6874: if ( (defined($Apache::lonhomework::parsing_a_problem) ||
6875: defined($Apache::lonhomework::parsing_a_task) ) &&
6876: &validCODE($Apache::lonhomework::history{'resource.CODE'})) {
1.491 albertel 6877: return $Apache::lonhomework::history{'resource.CODE'};
6878: }
6879: return undef;
6880: }
6881:
1.31 www 6882: sub rndseed {
1.155 albertel 6883: my ($symb,$courseid,$domain,$username)=@_;
1.366 albertel 6884:
1.790 albertel 6885: my ($wsymb,$wcourseid,$wdomain,$wusername)=&whichuser();
1.155 albertel 6886: if (!$symb) {
1.366 albertel 6887: unless ($symb=$wsymb) { return time; }
6888: }
6889: if (!$courseid) { $courseid=$wcourseid; }
6890: if (!$domain) { $domain=$wdomain; }
6891: if (!$username) { $username=$wusername }
1.503 albertel 6892: my $which=&get_rand_alg();
1.803 albertel 6893:
1.491 albertel 6894: if (defined(&getCODE())) {
1.675 albertel 6895: if ($which eq '64bit5') {
6896: return &rndseed_CODE_64bit5($symb,$courseid,$domain,$username);
6897: } elsif ($which eq '64bit4') {
1.575 albertel 6898: return &rndseed_CODE_64bit4($symb,$courseid,$domain,$username);
6899: } else {
6900: return &rndseed_CODE_64bit($symb,$courseid,$domain,$username);
6901: }
1.675 albertel 6902: } elsif ($which eq '64bit5') {
6903: return &rndseed_64bit5($symb,$courseid,$domain,$username);
1.575 albertel 6904: } elsif ($which eq '64bit4') {
6905: return &rndseed_64bit4($symb,$courseid,$domain,$username);
1.501 albertel 6906: } elsif ($which eq '64bit3') {
6907: return &rndseed_64bit3($symb,$courseid,$domain,$username);
1.443 albertel 6908: } elsif ($which eq '64bit2') {
6909: return &rndseed_64bit2($symb,$courseid,$domain,$username);
1.366 albertel 6910: } elsif ($which eq '64bit') {
6911: return &rndseed_64bit($symb,$courseid,$domain,$username);
6912: }
6913: return &rndseed_32bit($symb,$courseid,$domain,$username);
6914: }
6915:
6916: sub rndseed_32bit {
6917: my ($symb,$courseid,$domain,$username)=@_;
6918: {
6919: use integer;
6920: my $symbchck=unpack("%32C*",$symb) << 27;
6921: my $symbseed=numval($symb) << 22;
6922: my $namechck=unpack("%32C*",$username) << 17;
6923: my $nameseed=numval($username) << 12;
6924: my $domainseed=unpack("%32C*",$domain) << 7;
6925: my $courseseed=unpack("%32C*",$courseid);
6926: my $num=$symbseed+$nameseed+$domainseed+$courseseed+$namechck+$symbchck;
1.790 albertel 6927: #&logthis("$symbseed:$nameseed;$domainseed|$courseseed;$namechck:$symbchck");
6928: #&logthis("rndseed :$num:$symb");
1.564 albertel 6929: if ($_64bit) { $num=(($num<<32)>>32); }
1.366 albertel 6930: return $num;
6931: }
6932: }
6933:
6934: sub rndseed_64bit {
6935: my ($symb,$courseid,$domain,$username)=@_;
6936: {
6937: use integer;
6938: my $symbchck=unpack("%32S*",$symb) << 21;
6939: my $symbseed=numval($symb) << 10;
6940: my $namechck=unpack("%32S*",$username);
6941:
6942: my $nameseed=numval($username) << 21;
6943: my $domainseed=unpack("%32S*",$domain) << 10;
6944: my $courseseed=unpack("%32S*",$courseid);
6945:
6946: my $num1=$symbchck+$symbseed+$namechck;
6947: my $num2=$nameseed+$domainseed+$courseseed;
1.790 albertel 6948: #&logthis("$symbseed:$nameseed;$domainseed|$courseseed;$namechck:$symbchck");
6949: #&logthis("rndseed :$num:$symb");
1.564 albertel 6950: if ($_64bit) { $num1=(($num1<<32)>>32); $num2=(($num2<<32)>>32); }
1.366 albertel 6951: return "$num1,$num2";
1.155 albertel 6952: }
1.366 albertel 6953: }
6954:
1.443 albertel 6955: sub rndseed_64bit2 {
6956: my ($symb,$courseid,$domain,$username)=@_;
6957: {
6958: use integer;
6959: # strings need to be an even # of cahracters long, it it is odd the
6960: # last characters gets thrown away
6961: my $symbchck=unpack("%32S*",$symb.' ') << 21;
6962: my $symbseed=numval($symb) << 10;
6963: my $namechck=unpack("%32S*",$username.' ');
6964:
6965: my $nameseed=numval($username) << 21;
1.501 albertel 6966: my $domainseed=unpack("%32S*",$domain.' ') << 10;
6967: my $courseseed=unpack("%32S*",$courseid.' ');
6968:
6969: my $num1=$symbchck+$symbseed+$namechck;
6970: my $num2=$nameseed+$domainseed+$courseseed;
1.790 albertel 6971: #&logthis("$symbseed:$nameseed;$domainseed|$courseseed;$namechck:$symbchck");
6972: #&logthis("rndseed :$num:$symb");
1.803 albertel 6973: if ($_64bit) { $num1=(($num1<<32)>>32); $num2=(($num2<<32)>>32); }
1.501 albertel 6974: return "$num1,$num2";
6975: }
6976: }
6977:
6978: sub rndseed_64bit3 {
6979: my ($symb,$courseid,$domain,$username)=@_;
6980: {
6981: use integer;
6982: # strings need to be an even # of cahracters long, it it is odd the
6983: # last characters gets thrown away
6984: my $symbchck=unpack("%32S*",$symb.' ') << 21;
6985: my $symbseed=numval2($symb) << 10;
6986: my $namechck=unpack("%32S*",$username.' ');
6987:
6988: my $nameseed=numval2($username) << 21;
1.443 albertel 6989: my $domainseed=unpack("%32S*",$domain.' ') << 10;
6990: my $courseseed=unpack("%32S*",$courseid.' ');
6991:
6992: my $num1=$symbchck+$symbseed+$namechck;
6993: my $num2=$nameseed+$domainseed+$courseseed;
1.790 albertel 6994: #&logthis("$symbseed:$nameseed;$domainseed|$courseseed;$namechck:$symbchck");
6995: #&logthis("rndseed :$num1:$num2:$_64bit");
1.564 albertel 6996: if ($_64bit) { $num1=(($num1<<32)>>32); $num2=(($num2<<32)>>32); }
6997:
1.503 albertel 6998: return "$num1:$num2";
1.443 albertel 6999: }
7000: }
7001:
1.575 albertel 7002: sub rndseed_64bit4 {
7003: my ($symb,$courseid,$domain,$username)=@_;
7004: {
7005: use integer;
7006: # strings need to be an even # of cahracters long, it it is odd the
7007: # last characters gets thrown away
7008: my $symbchck=unpack("%32S*",$symb.' ') << 21;
7009: my $symbseed=numval3($symb) << 10;
7010: my $namechck=unpack("%32S*",$username.' ');
7011:
7012: my $nameseed=numval3($username) << 21;
7013: my $domainseed=unpack("%32S*",$domain.' ') << 10;
7014: my $courseseed=unpack("%32S*",$courseid.' ');
7015:
7016: my $num1=$symbchck+$symbseed+$namechck;
7017: my $num2=$nameseed+$domainseed+$courseseed;
1.790 albertel 7018: #&logthis("$symbseed:$nameseed;$domainseed|$courseseed;$namechck:$symbchck");
7019: #&logthis("rndseed :$num1:$num2:$_64bit");
1.575 albertel 7020: if ($_64bit) { $num1=(($num1<<32)>>32); $num2=(($num2<<32)>>32); }
7021:
7022: return "$num1:$num2";
7023: }
7024: }
7025:
1.675 albertel 7026: sub rndseed_64bit5 {
7027: my ($symb,$courseid,$domain,$username)=@_;
7028: my ($num1,$num2)=&digest("$symb,$courseid,$domain,$username");
7029: return "$num1:$num2";
7030: }
7031:
1.366 albertel 7032: sub rndseed_CODE_64bit {
7033: my ($symb,$courseid,$domain,$username)=@_;
1.155 albertel 7034: {
1.366 albertel 7035: use integer;
1.443 albertel 7036: my $symbchck=unpack("%32S*",$symb.' ') << 16;
1.484 albertel 7037: my $symbseed=numval2($symb);
1.491 albertel 7038: my $CODEchck=unpack("%32S*",&getCODE().' ') << 16;
7039: my $CODEseed=numval(&getCODE());
1.443 albertel 7040: my $courseseed=unpack("%32S*",$courseid.' ');
1.484 albertel 7041: my $num1=$symbseed+$CODEchck;
7042: my $num2=$CODEseed+$courseseed+$symbchck;
1.790 albertel 7043: #&logthis("$symbseed:$CODEchck|$CODEseed:$courseseed:$symbchck");
7044: #&logthis("rndseed :$num1:$num2:$symb");
1.564 albertel 7045: if ($_64bit) { $num1=(($num1<<32)>>32); }
7046: if ($_64bit) { $num2=(($num2<<32)>>32); }
1.503 albertel 7047: return "$num1:$num2";
1.366 albertel 7048: }
7049: }
7050:
1.575 albertel 7051: sub rndseed_CODE_64bit4 {
7052: my ($symb,$courseid,$domain,$username)=@_;
7053: {
7054: use integer;
7055: my $symbchck=unpack("%32S*",$symb.' ') << 16;
7056: my $symbseed=numval3($symb);
7057: my $CODEchck=unpack("%32S*",&getCODE().' ') << 16;
7058: my $CODEseed=numval3(&getCODE());
7059: my $courseseed=unpack("%32S*",$courseid.' ');
7060: my $num1=$symbseed+$CODEchck;
7061: my $num2=$CODEseed+$courseseed+$symbchck;
1.790 albertel 7062: #&logthis("$symbseed:$CODEchck|$CODEseed:$courseseed:$symbchck");
7063: #&logthis("rndseed :$num1:$num2:$symb");
1.575 albertel 7064: if ($_64bit) { $num1=(($num1<<32)>>32); }
7065: if ($_64bit) { $num2=(($num2<<32)>>32); }
7066: return "$num1:$num2";
7067: }
7068: }
7069:
1.675 albertel 7070: sub rndseed_CODE_64bit5 {
7071: my ($symb,$courseid,$domain,$username)=@_;
7072: my $code = &getCODE();
7073: my ($num1,$num2)=&digest("$symb,$courseid,$code");
7074: return "$num1:$num2";
7075: }
7076:
1.366 albertel 7077: sub setup_random_from_rndseed {
7078: my ($rndseed)=@_;
1.503 albertel 7079: if ($rndseed =~/([,:])/) {
7080: my ($num1,$num2)=split(/[,:]/,$rndseed);
1.366 albertel 7081: &Math::Random::random_set_seed(abs($num1),abs($num2));
7082: } else {
7083: &Math::Random::random_set_seed_from_phrase($rndseed);
1.98 albertel 7084: }
1.36 albertel 7085: }
7086:
1.474 albertel 7087: sub latest_receipt_algorithm_id {
7088: return 'receipt2';
7089: }
7090:
1.480 www 7091: sub recunique {
7092: my $fucourseid=shift;
7093: my $unique;
1.620 albertel 7094: if ($env{"course.$fucourseid.receiptalg"} eq 'receipt2') {
7095: $unique=$env{"course.$fucourseid.internal.encseed"};
1.480 www 7096: } else {
7097: $unique=$perlvar{'lonReceipt'};
7098: }
7099: return unpack("%32C*",$unique);
7100: }
7101:
7102: sub recprefix {
7103: my $fucourseid=shift;
7104: my $prefix;
1.620 albertel 7105: if ($env{"course.$fucourseid.receiptalg"} eq 'receipt2') {
7106: $prefix=$env{"course.$fucourseid.internal.encpref"};
1.480 www 7107: } else {
7108: $prefix=$perlvar{'lonHostID'};
7109: }
7110: return unpack("%32C*",$prefix);
7111: }
7112:
1.76 www 7113: sub ireceipt {
1.474 albertel 7114: my ($funame,$fudom,$fucourseid,$fusymb,$part)=@_;
1.76 www 7115: my $cuname=unpack("%32C*",$funame);
7116: my $cudom=unpack("%32C*",$fudom);
7117: my $cucourseid=unpack("%32C*",$fucourseid);
7118: my $cusymb=unpack("%32C*",$fusymb);
1.480 www 7119: my $cunique=&recunique($fucourseid);
1.474 albertel 7120: my $cpart=unpack("%32S*",$part);
1.480 www 7121: my $return =&recprefix($fucourseid).'-';
1.620 albertel 7122: if ($env{"course.$fucourseid.receiptalg"} eq 'receipt2' ||
7123: $env{'request.state'} eq 'construct') {
1.790 albertel 7124: #&logthis("doing receipt2 using parts $cpart, uname $cuname and udom $cudom gets ".($cpart%$cuname)." and ".($cpart%$cudom));
1.474 albertel 7125:
7126: $return.= ($cunique%$cuname+
7127: $cunique%$cudom+
7128: $cusymb%$cuname+
7129: $cusymb%$cudom+
7130: $cucourseid%$cuname+
7131: $cucourseid%$cudom+
7132: $cpart%$cuname+
7133: $cpart%$cudom);
7134: } else {
7135: $return.= ($cunique%$cuname+
7136: $cunique%$cudom+
7137: $cusymb%$cuname+
7138: $cusymb%$cudom+
7139: $cucourseid%$cuname+
7140: $cucourseid%$cudom);
7141: }
7142: return $return;
1.76 www 7143: }
7144:
7145: sub receipt {
1.474 albertel 7146: my ($part)=@_;
1.790 albertel 7147: my ($symb,$courseid,$domain,$name) = &whichuser();
1.474 albertel 7148: return &ireceipt($name,$domain,$courseid,$symb,$part);
1.76 www 7149: }
1.260 ng 7150:
1.790 albertel 7151: sub whichuser {
7152: my ($passedsymb)=@_;
7153: my ($symb,$courseid,$domain,$name,$publicuser);
7154: if (defined($env{'form.grade_symb'})) {
7155: my ($tmp_courseid)=&get_env_multiple('form.grade_courseid');
7156: my $allowed=&allowed('vgr',$tmp_courseid);
7157: if (!$allowed &&
7158: exists($env{'request.course.sec'}) &&
7159: $env{'request.course.sec'} !~ /^\s*$/) {
7160: $allowed=&allowed('vgr',$tmp_courseid.
7161: '/'.$env{'request.course.sec'});
7162: }
7163: if ($allowed) {
7164: ($symb)=&get_env_multiple('form.grade_symb');
7165: $courseid=$tmp_courseid;
7166: ($domain)=&get_env_multiple('form.grade_domain');
7167: ($name)=&get_env_multiple('form.grade_username');
7168: return ($symb,$courseid,$domain,$name,$publicuser);
7169: }
7170: }
7171: if (!$passedsymb) {
7172: $symb=&symbread();
7173: } else {
7174: $symb=$passedsymb;
7175: }
7176: $courseid=$env{'request.course.id'};
7177: $domain=$env{'user.domain'};
7178: $name=$env{'user.name'};
7179: if ($name eq 'public' && $domain eq 'public') {
7180: if (!defined($env{'form.username'})) {
7181: $env{'form.username'}.=time.rand(10000000);
7182: }
7183: $name.=$env{'form.username'};
7184: }
7185: return ($symb,$courseid,$domain,$name,$publicuser);
7186:
7187: }
7188:
1.36 albertel 7189: # ------------------------------------------------------------ Serves up a file
1.472 albertel 7190: # returns either the contents of the file or
7191: # -1 if the file doesn't exist
1.481 raeburn 7192: #
7193: # if the target is a file that was uploaded via DOCS,
7194: # a check will be made to see if a current copy exists on the local server,
7195: # if it does this will be served, otherwise a copy will be retrieved from
7196: # the home server for the course and stored in /home/httpd/html/userfiles on
7197: # the local server.
1.472 albertel 7198:
1.36 albertel 7199: sub getfile {
1.538 albertel 7200: my ($file) = @_;
1.609 banghart 7201: if ($file =~ m -^/*(uploaded|editupload)/-) { $file=&filelocation("",$file); }
1.538 albertel 7202: &repcopy($file);
7203: return &readfile($file);
7204: }
7205:
7206: sub repcopy_userfile {
7207: my ($file)=@_;
1.609 banghart 7208: if ($file =~ m -^/*(uploaded|editupload)/-) { $file=&filelocation("",$file); }
1.610 albertel 7209: if ($file =~ m|^/home/httpd/html/lonUsers/|) { return 'ok'; }
1.538 albertel 7210: my ($cdom,$cnum,$filename) =
1.811 albertel 7211: ($file=~m|^\Q$perlvar{'lonDocRoot'}\E/+userfiles/+($match_domain)/+($match_name)/+(.*)|);
1.538 albertel 7212: my $uri="/uploaded/$cdom/$cnum/$filename";
7213: if (-e "$file") {
1.828 www 7214: # we already have a local copy, check it out
1.538 albertel 7215: my @fileinfo = stat($file);
1.828 www 7216: my $rtncode;
7217: my $info;
1.538 albertel 7218: my $lwpresp = &getuploaded('HEAD',$uri,$cdom,$cnum,\$info,\$rtncode);
1.482 albertel 7219: if ($lwpresp ne 'ok') {
1.828 www 7220: # there is no such file anymore, even though we had a local copy
1.482 albertel 7221: if ($rtncode eq '404') {
1.538 albertel 7222: unlink($file);
1.482 albertel 7223: }
7224: return -1;
7225: }
7226: if ($info < $fileinfo[9]) {
1.828 www 7227: # nice, the file we have is up-to-date, just say okay
1.607 raeburn 7228: return 'ok';
1.828 www 7229: } else {
7230: # the file is outdated, get rid of it
7231: unlink($file);
1.482 albertel 7232: }
1.828 www 7233: }
7234: # one way or the other, at this point, we don't have the file
7235: # construct the correct path for the file
7236: my @parts = ($cdom,$cnum);
7237: if ($filename =~ m|^(.+)/[^/]+$|) {
7238: push @parts, split(/\//,$1);
7239: }
7240: my $path = $perlvar{'lonDocRoot'}.'/userfiles';
7241: foreach my $part (@parts) {
7242: $path .= '/'.$part;
7243: if (!-e $path) {
7244: mkdir($path,0770);
1.482 albertel 7245: }
7246: }
1.828 www 7247: # now the path exists for sure
7248: # get a user agent
7249: my $ua=new LWP::UserAgent;
7250: my $transferfile=$file.'.in.transfer';
7251: # FIXME: this should flock
7252: if (-e $transferfile) { return 'ok'; }
7253: my $request;
7254: $uri=~s/^\///;
1.829 www 7255: $request=new HTTP::Request('GET','http://'.$hostname{&homeserver($cnum,$cdom)}.'/raw/'.$uri);
1.828 www 7256: my $response=$ua->request($request,$transferfile);
7257: # did it work?
7258: if ($response->is_error()) {
7259: unlink($transferfile);
7260: &logthis("Userfile repcopy failed for $uri");
7261: return -1;
7262: }
7263: # worked, rename the transfer file
7264: rename($transferfile,$file);
1.607 raeburn 7265: return 'ok';
1.481 raeburn 7266: }
7267:
1.517 albertel 7268: sub tokenwrapper {
7269: my $uri=shift;
1.552 albertel 7270: $uri=~s|^http\://([^/]+)||;
7271: $uri=~s|^/||;
1.620 albertel 7272: $env{'user.environment'}=~/\/([^\/]+)\.id/;
1.517 albertel 7273: my $token=$1;
1.552 albertel 7274: my (undef,$udom,$uname,$file)=split('/',$uri,4);
7275: if ($udom && $uname && $file) {
7276: $file=~s|(\?\.*)*$||;
1.620 albertel 7277: &appenv("userfile.$udom/$uname/$file" => $env{'request.course.id'});
1.552 albertel 7278: return 'http://'.$hostname{ &homeserver($uname,$udom)}.'/'.$uri.
1.517 albertel 7279: (($uri=~/\?/)?'&':'?').'token='.$token.
7280: '&tokenissued='.$perlvar{'lonHostID'};
7281: } else {
7282: return '/adm/notfound.html';
7283: }
7284: }
7285:
1.828 www 7286: # call with reqtype HEAD: get last modification time
7287: # call with reqtype GET: get the file contents
7288: # Do not call this with reqtype GET for large files! It loads everything into memory
7289: #
1.481 raeburn 7290: sub getuploaded {
7291: my ($reqtype,$uri,$cdom,$cnum,$info,$rtncode) = @_;
7292: $uri=~s/^\///;
7293: $uri = 'http://'.$hostname{ &homeserver($cnum,$cdom)}.'/raw/'.$uri;
7294: my $ua=new LWP::UserAgent;
7295: my $request=new HTTP::Request($reqtype,$uri);
7296: my $response=$ua->request($request);
7297: $$rtncode = $response->code;
1.482 albertel 7298: if (! $response->is_success()) {
7299: return 'failed';
7300: }
7301: if ($reqtype eq 'HEAD') {
1.486 www 7302: $$info = &HTTP::Date::str2time( $response->header('Last-modified') );
1.482 albertel 7303: } elsif ($reqtype eq 'GET') {
7304: $$info = $response->content;
1.472 albertel 7305: }
1.482 albertel 7306: return 'ok';
1.36 albertel 7307: }
7308:
1.481 raeburn 7309: sub readfile {
7310: my $file = shift;
7311: if ( (! -e $file ) || ($file eq '') ) { return -1; };
7312: my $fh;
7313: open($fh,"<$file");
7314: my $a='';
1.800 albertel 7315: while (my $line = <$fh>) { $a .= $line; }
1.481 raeburn 7316: return $a;
7317: }
7318:
1.36 albertel 7319: sub filelocation {
1.590 banghart 7320: my ($dir,$file) = @_;
7321: my $location;
7322: $file=~ s/^\s*(\S+)\s*$/$1/; ## strip off leading and trailing spaces
1.700 albertel 7323:
7324: if ($file =~ m-^/adm/-) {
7325: $file=~s-^/adm/wrapper/-/-;
7326: $file=~s-^/adm/coursedocs/showdoc/-/-;
7327: }
1.590 banghart 7328: if ($file=~m:^/~:) { # is a contruction space reference
7329: $location = $file;
7330: $location =~ s:/~(.*?)/(.*):/home/$1/public_html/$2:;
1.807 albertel 7331: } elsif ($file=~m{^/home/$match_username/public_html/}) {
1.649 albertel 7332: # is a correct contruction space reference
7333: $location = $file;
1.609 banghart 7334: } elsif ($file=~/^\/*(uploaded|editupload)/) { # is an uploaded file
1.590 banghart 7335: my ($udom,$uname,$filename)=
1.811 albertel 7336: ($file=~m -^/+(?:uploaded|editupload)/+($match_domain)/+($match_name)/+(.*)$-);
1.590 banghart 7337: my $home=&homeserver($uname,$udom);
7338: my $is_me=0;
7339: my @ids=¤t_machine_ids();
7340: foreach my $id (@ids) { if ($id eq $home) { $is_me=1; } }
7341: if ($is_me) {
1.740 www 7342: $location=&propath($udom,$uname).
1.590 banghart 7343: '/userfiles/'.$filename;
7344: } else {
7345: $location=$Apache::lonnet::perlvar{'lonDocRoot'}.'/userfiles/'.
7346: $udom.'/'.$uname.'/'.$filename;
7347: }
7348: } else {
7349: $file=~s/^\Q$perlvar{'lonDocRoot'}\E//;
7350: $file=~s:^/res/:/:;
7351: if ( !( $file =~ m:^/:) ) {
7352: $location = $dir. '/'.$file;
7353: } else {
7354: $location = '/home/httpd/html/res'.$file;
7355: }
1.59 albertel 7356: }
1.590 banghart 7357: $location=~s://+:/:g; # remove duplicate /
7358: while ($location=~m:/\.\./:) {$location=~ s:/[^/]+/\.\./:/:g;} #remove dir/..
7359: while ($location=~m:/\./:) {$location=~ s:/\./:/:g;} #remove /./
7360: return $location;
1.46 www 7361: }
1.36 albertel 7362:
1.46 www 7363: sub hreflocation {
7364: my ($dir,$file)=@_;
1.460 albertel 7365: unless (($file=~m-^http://-i) || ($file=~m-^/-)) {
1.666 albertel 7366: $file=filelocation($dir,$file);
1.700 albertel 7367: } elsif ($file=~m-^/adm/-) {
7368: $file=~s-^/adm/wrapper/-/-;
7369: $file=~s-^/adm/coursedocs/showdoc/-/-;
1.666 albertel 7370: }
7371: if ($file=~m-^\Q$perlvar{'lonDocRoot'}\E-) {
7372: $file=~s-^\Q$perlvar{'lonDocRoot'}\E--;
1.807 albertel 7373: } elsif ($file=~m-/home/($match_username)/public_html/-) {
7374: $file=~s-^/home/($match_username)/public_html/-/~$1/-;
1.666 albertel 7375: } elsif ($file=~m-^\Q$perlvar{'lonUsersDir'}\E-) {
1.811 albertel 7376: $file=~s-^/home/httpd/lonUsers/($match_domain)/./././($match_name)/userfiles/
1.666 albertel 7377: -/uploaded/$1/$2/-x;
1.46 www 7378: }
1.462 albertel 7379: return $file;
1.465 albertel 7380: }
7381:
7382: sub current_machine_domains {
7383: my $hostname=$hostname{$perlvar{'lonHostID'}};
7384: my @domains;
7385: while( my($id, $name) = each(%hostname)) {
1.467 matthew 7386: # &logthis("-$id-$name-$hostname-");
1.465 albertel 7387: if ($hostname eq $name) {
7388: push(@domains,$hostdom{$id});
7389: }
7390: }
7391: return @domains;
7392: }
7393:
7394: sub current_machine_ids {
7395: my $hostname=$hostname{$perlvar{'lonHostID'}};
7396: my @ids;
7397: while( my($id, $name) = each(%hostname)) {
1.467 matthew 7398: # &logthis("-$id-$name-$hostname-");
1.465 albertel 7399: if ($hostname eq $name) {
7400: push(@ids,$id);
7401: }
7402: }
7403: return @ids;
1.31 www 7404: }
7405:
1.824 raeburn 7406: sub additional_machine_domains {
7407: my @domains;
7408: open(my $fh,"<$perlvar{'lonTabDir'}/expected_domains.tab");
7409: while( my $line = <$fh>) {
7410: $line =~ s/\s//g;
7411: push(@domains,$line);
7412: }
7413: return @domains;
7414: }
7415:
7416: sub default_login_domain {
7417: my $domain = $perlvar{'lonDefDomain'};
7418: my $testdomain=(split(/\./,$ENV{'HTTP_HOST'}))[0];
7419: foreach my $posdom (¤t_machine_domains(),
7420: &additional_machine_domains()) {
7421: if (lc($posdom) eq lc($testdomain)) {
7422: $domain=$posdom;
7423: last;
7424: }
7425: }
7426: return $domain;
7427: }
7428:
1.31 www 7429: # ------------------------------------------------------------- Declutters URLs
7430:
7431: sub declutter {
7432: my $thisfn=shift;
1.569 albertel 7433: if ($thisfn=~m|^/enc/|) { $thisfn=&Apache::lonenc::unencrypted($thisfn); }
1.479 albertel 7434: $thisfn=~s/^\Q$perlvar{'lonDocRoot'}\E//;
1.31 www 7435: $thisfn=~s/^\///;
1.697 albertel 7436: $thisfn=~s|^adm/wrapper/||;
7437: $thisfn=~s|^adm/coursedocs/showdoc/||;
1.31 www 7438: $thisfn=~s/^res\///;
1.235 www 7439: $thisfn=~s/\?.+$//;
1.268 www 7440: return $thisfn;
7441: }
7442:
7443: # ------------------------------------------------------------- Clutter up URLs
7444:
7445: sub clutter {
7446: my $thisfn='/'.&declutter(shift);
1.609 banghart 7447: unless ($thisfn=~/^\/(uploaded|editupload|adm|userfiles|ext|raw|priv|public)\//) {
1.270 www 7448: $thisfn='/res'.$thisfn;
7449: }
1.694 albertel 7450: if ($thisfn !~m|/adm|) {
1.695 albertel 7451: if ($thisfn =~ m|/ext/|) {
1.694 albertel 7452: $thisfn='/adm/wrapper'.$thisfn;
1.695 albertel 7453: } else {
7454: my ($ext) = ($thisfn =~ /\.(\w+)$/);
7455: my $embstyle=&Apache::loncommon::fileembstyle($ext);
1.698 albertel 7456: if ($embstyle eq 'ssi'
7457: || ($embstyle eq 'hdn')
7458: || ($embstyle eq 'rat')
7459: || ($embstyle eq 'prv')
7460: || ($embstyle eq 'ign')) {
7461: #do nothing with these
7462: } elsif (($embstyle eq 'img')
1.695 albertel 7463: || ($embstyle eq 'emb')
7464: || ($embstyle eq 'wrp')) {
7465: $thisfn='/adm/wrapper'.$thisfn;
1.698 albertel 7466: } elsif ($embstyle eq 'unk'
7467: && $thisfn!~/\.(sequence|page)$/) {
1.695 albertel 7468: $thisfn='/adm/coursedocs/showdoc'.$thisfn;
1.698 albertel 7469: } else {
1.718 www 7470: # &logthis("Got a blank emb style");
1.695 albertel 7471: }
1.694 albertel 7472: }
7473: }
1.31 www 7474: return $thisfn;
1.12 www 7475: }
7476:
1.787 albertel 7477: sub clutter_with_no_wrapper {
7478: my $uri = &clutter(shift);
7479: if ($uri =~ m-^/adm/-) {
7480: $uri =~ s-^/adm/wrapper/-/-;
7481: $uri =~ s-^/adm/coursedocs/showdoc/-/-;
7482: }
7483: return $uri;
7484: }
7485:
1.557 albertel 7486: sub freeze_escape {
7487: my ($value)=@_;
7488: if (ref($value)) {
7489: $value=&nfreeze($value);
7490: return '__FROZEN__'.&escape($value);
7491: }
7492: return &escape($value);
7493: }
7494:
1.11 www 7495:
1.557 albertel 7496: sub thaw_unescape {
7497: my ($value)=@_;
7498: if ($value =~ /^__FROZEN__/) {
7499: substr($value,0,10,undef);
7500: $value=&unescape($value);
7501: return &thaw($value);
7502: }
7503: return &unescape($value);
7504: }
7505:
1.436 albertel 7506: sub correct_line_ends {
7507: my ($result)=@_;
7508: $$result =~s/\r\n/\n/mg;
7509: $$result =~s/\r/\n/mg;
1.415 albertel 7510: }
1.1 albertel 7511: # ================================================================ Main Program
7512:
1.184 www 7513: sub goodbye {
1.204 albertel 7514: &logthis("Starting Shut down");
1.443 albertel 7515: #not converted to using infrastruture and probably shouldn't be
1.599 albertel 7516: &logthis(sprintf("%-20s is %s",'%badServerCache',length(&freeze(\%badServerCache))));
1.443 albertel 7517: #converted
1.599 albertel 7518: # &logthis(sprintf("%-20s is %s",'%metacache',scalar(%metacache)));
7519: &logthis(sprintf("%-20s is %s",'%homecache',length(&freeze(\%homecache))));
7520: # &logthis(sprintf("%-20s is %s",'%titlecache',length(&freeze(\%titlecache))));
7521: # &logthis(sprintf("%-20s is %s",'%courseresdatacache',length(&freeze(\%courseresdatacache))));
1.425 albertel 7522: #1.1 only
1.599 albertel 7523: # &logthis(sprintf("%-20s is %s",'%userresdatacache',length(&freeze(\%userresdatacache))));
7524: # &logthis(sprintf("%-20s is %s",'%getsectioncache',length(&freeze(\%getsectioncache))));
7525: # &logthis(sprintf("%-20s is %s",'%courseresversioncache',length(&freeze(\%courseresversioncache))));
7526: # &logthis(sprintf("%-20s is %s",'%resversioncache',length(&freeze(\%resversioncache))));
7527: &logthis(sprintf("%-20s is %s",'%remembered',length(&freeze(\%remembered))));
7528: &logthis(sprintf("%-20s is %s",'kicks',$kicks));
7529: &logthis(sprintf("%-20s is %s",'hits',$hits));
1.184 www 7530: &flushcourselogs();
7531: &logthis("Shutting down");
7532: }
7533:
1.179 www 7534: BEGIN {
1.228 harris41 7535: # ----------------------------------- Read loncapa.conf and loncapa_apache.conf
1.195 www 7536: unless ($readit) {
1.217 harris41 7537: {
1.781 raeburn 7538: my $configvars = LONCAPA::Configuration::read_conf('loncapa.conf');
7539: %perlvar = (%perlvar,%{$configvars});
1.227 harris41 7540: }
1.1 albertel 7541:
1.327 albertel 7542: # ------------------------------------------------------------ Read domain file
7543: {
7544: %domaindescription = ();
7545: %domain_auth_def = ();
7546: %domain_auth_arg_def = ();
1.448 albertel 7547: my $fh;
7548: if (open($fh,"<".$Apache::lonnet::perlvar{'lonTabDir'}.'/domain.tab')) {
1.800 albertel 7549: while (my $line = <$fh>) {
7550: next if ($line =~ /^(\#|\s*$)/);
1.390 matthew 7551: # next if /^\#/;
1.801 foxr 7552: chomp $line;
1.403 www 7553: my ($domain, $domain_description, $def_auth, $def_auth_arg,
1.800 albertel 7554: $def_lang, $city, $longi, $lati, $primary) = split(/:/,$line,9);
1.403 www 7555: $domain_auth_def{$domain}=$def_auth;
1.327 albertel 7556: $domain_auth_arg_def{$domain}=$def_auth_arg;
1.403 www 7557: $domaindescription{$domain}=$domain_description;
7558: $domain_lang_def{$domain}=$def_lang;
7559: $domain_city{$domain}=$city;
7560: $domain_longi{$domain}=$longi;
7561: $domain_lati{$domain}=$lati;
1.685 raeburn 7562: $domain_primary{$domain}=$primary;
1.403 www 7563:
1.448 albertel 7564: # &logthis("Domain.tab: $domain, $domain_auth_def{$domain}, $domain_auth_arg_def{$domain},$domaindescription{$domain}");
1.327 albertel 7565: # &logthis("Domain.tab: $domain ".$domaindescription{$domain} );
1.448 albertel 7566: }
1.327 albertel 7567: }
1.448 albertel 7568: close ($fh);
1.327 albertel 7569: }
7570:
7571:
1.1 albertel 7572: # ------------------------------------------------------------- Read hosts file
7573: {
1.448 albertel 7574: open(my $config,"<$perlvar{'lonTabDir'}/hosts.tab");
1.1 albertel 7575:
7576: while (my $configline=<$config>) {
1.303 matthew 7577: next if ($configline =~ /^(\#|\s*$)/);
1.154 www 7578: chomp($configline);
1.595 albertel 7579: my ($id,$domain,$role,$name)=split(/:/,$configline);
1.597 albertel 7580: $name=~s/\s//g;
1.595 albertel 7581: if ($id && $domain && $role && $name) {
1.252 albertel 7582: $hostname{$id}=$name;
7583: $hostdom{$id}=$domain;
7584: if ($role eq 'library') { $libserv{$id}=$name; }
1.245 www 7585: }
1.1 albertel 7586: }
1.448 albertel 7587: close($config);
1.619 albertel 7588: # FIXME: dev server don't want this, production servers _do_ want this
1.654 albertel 7589: #&get_iphost();
1.1 albertel 7590: }
7591:
1.598 albertel 7592: sub get_iphost {
7593: if (%iphost) { return %iphost; }
1.653 albertel 7594: my %name_to_ip;
1.598 albertel 7595: foreach my $id (keys(%hostname)) {
7596: my $name=$hostname{$id};
1.653 albertel 7597: my $ip;
7598: if (!exists($name_to_ip{$name})) {
7599: $ip = gethostbyname($name);
7600: if (!$ip || length($ip) ne 4) {
1.826 www 7601: &logthis("Skipping host $id name $name no IP found");
1.653 albertel 7602: next;
7603: }
7604: $ip=inet_ntoa($ip);
7605: $name_to_ip{$name} = $ip;
7606: } else {
7607: $ip = $name_to_ip{$name};
1.598 albertel 7608: }
7609: push(@{$iphost{$ip}},$id);
7610: }
7611: return %iphost;
7612: }
7613:
1.1 albertel 7614: # ------------------------------------------------------ Read spare server file
7615: {
1.448 albertel 7616: open(my $config,"<$perlvar{'lonTabDir'}/spare.tab");
1.1 albertel 7617:
7618: while (my $configline=<$config>) {
7619: chomp($configline);
1.284 matthew 7620: if ($configline) {
1.784 albertel 7621: my ($host,$type) = split(':',$configline,2);
1.785 albertel 7622: if (!defined($type) || $type eq '') { $type = 'default' };
1.784 albertel 7623: push(@{ $spareid{$type} }, $host);
1.1 albertel 7624: }
7625: }
1.448 albertel 7626: close($config);
1.1 albertel 7627: }
1.11 www 7628: # ------------------------------------------------------------ Read permissions
7629: {
1.448 albertel 7630: open(my $config,"<$perlvar{'lonTabDir'}/roles.tab");
1.11 www 7631:
7632: while (my $configline=<$config>) {
1.448 albertel 7633: chomp($configline);
7634: if ($configline) {
7635: my ($role,$perm)=split(/ /,$configline);
7636: if ($perm ne '') { $pr{$role}=$perm; }
7637: }
1.11 www 7638: }
1.448 albertel 7639: close($config);
1.11 www 7640: }
7641:
7642: # -------------------------------------------- Read plain texts for permissions
7643: {
1.448 albertel 7644: open(my $config,"<$perlvar{'lonTabDir'}/rolesplain.tab");
1.11 www 7645:
7646: while (my $configline=<$config>) {
1.448 albertel 7647: chomp($configline);
7648: if ($configline) {
1.742 raeburn 7649: my ($short,@plain)=split(/:/,$configline);
7650: %{$prp{$short}} = ();
7651: if (@plain > 0) {
7652: $prp{$short}{'std'} = $plain[0];
7653: for (my $i=1; $i<@plain; $i++) {
7654: $prp{$short}{'alt'.$i} = $plain[$i];
7655: }
7656: }
1.448 albertel 7657: }
1.135 www 7658: }
1.448 albertel 7659: close($config);
1.135 www 7660: }
7661:
7662: # ---------------------------------------------------------- Read package table
7663: {
1.448 albertel 7664: open(my $config,"<$perlvar{'lonTabDir'}/packages.tab");
1.135 www 7665:
7666: while (my $configline=<$config>) {
1.483 albertel 7667: if ($configline !~ /\S/ || $configline=~/^#/) { next; }
1.448 albertel 7668: chomp($configline);
7669: my ($short,$plain)=split(/:/,$configline);
7670: my ($pack,$name)=split(/\&/,$short);
7671: if ($plain ne '') {
7672: $packagetab{$pack.'&'.$name.'&name'}=$name;
7673: $packagetab{$short}=$plain;
7674: }
1.11 www 7675: }
1.448 albertel 7676: close($config);
1.329 matthew 7677: }
7678:
7679: # ------------- set up temporary directory
7680: {
7681: $tmpdir = $perlvar{'lonDaemons'}.'/tmp/';
7682:
1.11 www 7683: }
7684:
1.794 albertel 7685: $memcache=new Cache::Memcached({'servers' => ['127.0.0.1:11211'],
7686: 'compress_threshold'=> 20_000,
7687: });
1.185 www 7688:
1.281 www 7689: $processmarker='_'.time.'_'.$perlvar{'lonHostID'};
1.186 www 7690: $dumpcount=0;
1.22 www 7691:
1.163 harris41 7692: &logtouch();
1.672 albertel 7693: &logthis('<font color="yellow">INFO: Read configuration</font>');
1.195 www 7694: $readit=1;
1.564 albertel 7695: {
7696: use integer;
7697: my $test=(2**32)+1;
1.568 albertel 7698: if ($test != 0) { $_64bit=1; } else { $_64bit=0; }
1.564 albertel 7699: &logthis(" Detected 64bit platform ($_64bit)");
7700: }
1.195 www 7701: }
1.1 albertel 7702: }
1.179 www 7703:
1.1 albertel 7704: 1;
1.191 harris41 7705: __END__
7706:
1.243 albertel 7707: =pod
7708:
1.191 harris41 7709: =head1 NAME
7710:
1.243 albertel 7711: Apache::lonnet - Subroutines to ask questions about things in the network.
1.191 harris41 7712:
7713: =head1 SYNOPSIS
7714:
1.243 albertel 7715: Invoked by other LON-CAPA modules, when they need to talk to or about objects in the network.
1.191 harris41 7716:
7717: &Apache::lonnet::SUBROUTINENAME(ARGUMENTS);
7718:
1.243 albertel 7719: Common parameters:
7720:
7721: =over 4
7722:
7723: =item *
7724:
7725: $uname : an internal username (if $cname expecting a course Id specifically)
7726:
7727: =item *
7728:
7729: $udom : a domain (if $cdom expecting a course's domain specifically)
7730:
7731: =item *
7732:
7733: $symb : a resource instance identifier
7734:
7735: =item *
7736:
7737: $namespace : the name of a .db file that contains the data needed or
7738: being set.
7739:
7740: =back
7741:
1.394 bowersj2 7742: =head1 OVERVIEW
1.191 harris41 7743:
1.394 bowersj2 7744: lonnet provides subroutines which interact with the
7745: lonc/lond (TCP) network layer of LON-CAPA. They can be used to ask
7746: about classes, users, and resources.
1.243 albertel 7747:
7748: For many of these objects you can also use this to store data about
7749: them or modify them in various ways.
1.191 harris41 7750:
1.394 bowersj2 7751: =head2 Symbs
1.191 harris41 7752:
1.394 bowersj2 7753: To identify a specific instance of a resource, LON-CAPA uses symbols
7754: or "symbs"X<symb>. These identifiers are built from the URL of the
7755: map, the resource number of the resource in the map, and the URL of
7756: the resource itself. The latter is somewhat redundant, but might help
7757: if maps change.
7758:
7759: An example is
7760:
7761: msu/korte/parts/part1.sequence___19___msu/korte/tests/part12.problem
7762:
7763: The respective map entry is
7764:
7765: <resource id="19" src="/res/msu/korte/tests/part12.problem"
7766: title="Problem 2">
7767: </resource>
7768:
7769: Symbs are used by the random number generator, as well as to store and
7770: restore data specific to a certain instance of for example a problem.
7771:
7772: =head2 Storing And Retrieving Data
7773:
7774: X<store()>X<cstore()>X<restore()>Three of the most important functions
7775: in C<lonnet.pm> are C<&Apache::lonnet::cstore()>,
7776: C<&Apache::lonnet:restore()>, and C<&Apache::lonnet::store()>, which
7777: is is the non-critical message twin of cstore. These functions are for
7778: handlers to store a perl hash to a user's permanent data space in an
7779: easy manner, and to retrieve it again on another call. It is expected
7780: that a handler would use this once at the beginning to retrieve data,
7781: and then again once at the end to send only the new data back.
7782:
7783: The data is stored in the user's data directory on the user's
7784: homeserver under the ID of the course.
7785:
7786: The hash that is returned by restore will have all of the previous
7787: value for all of the elements of the hash.
7788:
7789: Example:
7790:
7791: #creating a hash
7792: my %hash;
7793: $hash{'foo'}='bar';
7794:
7795: #storing it
7796: &Apache::lonnet::cstore(\%hash);
7797:
7798: #changing a value
7799: $hash{'foo'}='notbar';
7800:
7801: #adding a new value
7802: $hash{'bar'}='foo';
7803: &Apache::lonnet::cstore(\%hash);
7804:
7805: #retrieving the hash
7806: my %history=&Apache::lonnet::restore();
7807:
7808: #print the hash
7809: foreach my $key (sort(keys(%history))) {
7810: print("\%history{$key} = $history{$key}");
7811: }
7812:
7813: Will print out:
1.191 harris41 7814:
1.394 bowersj2 7815: %history{1:foo} = bar
7816: %history{1:keys} = foo:timestamp
7817: %history{1:timestamp} = 990455579
7818: %history{2:bar} = foo
7819: %history{2:foo} = notbar
7820: %history{2:keys} = foo:bar:timestamp
7821: %history{2:timestamp} = 990455580
7822: %history{bar} = foo
7823: %history{foo} = notbar
7824: %history{timestamp} = 990455580
7825: %history{version} = 2
7826:
7827: Note that the special hash entries C<keys>, C<version> and
7828: C<timestamp> were added to the hash. C<version> will be equal to the
7829: total number of versions of the data that have been stored. The
7830: C<timestamp> attribute will be the UNIX time the hash was
7831: stored. C<keys> is available in every historical section to list which
7832: keys were added or changed at a specific historical revision of a
7833: hash.
7834:
7835: B<Warning>: do not store the hash that restore returns directly. This
7836: will cause a mess since it will restore the historical keys as if the
7837: were new keys. I.E. 1:foo will become 1:1:foo etc.
1.191 harris41 7838:
1.394 bowersj2 7839: Calling convention:
1.191 harris41 7840:
1.394 bowersj2 7841: my %record=&Apache::lonnet::restore($symb,$courseid,$domain,$uname,$home);
7842: &Apache::lonnet::cstore(\%newrecord,$symb,$courseid,$domain,$uname,$home);
1.191 harris41 7843:
1.394 bowersj2 7844: For more detailed information, see lonnet specific documentation.
1.191 harris41 7845:
1.394 bowersj2 7846: =head1 RETURN MESSAGES
1.191 harris41 7847:
1.394 bowersj2 7848: =over 4
1.191 harris41 7849:
1.394 bowersj2 7850: =item * B<con_lost>: unable to contact remote host
1.191 harris41 7851:
1.394 bowersj2 7852: =item * B<con_delayed>: unable to contact remote host, message will be delivered
7853: when the connection is brought back up
1.191 harris41 7854:
1.394 bowersj2 7855: =item * B<con_failed>: unable to contact remote host and unable to save message
7856: for later delivery
1.191 harris41 7857:
1.394 bowersj2 7858: =item * B<error:>: an error a occured, a description of the error follows the :
1.191 harris41 7859:
1.394 bowersj2 7860: =item * B<no_such_host>: unable to fund a host associated with the user/domain
1.243 albertel 7861: that was requested
1.191 harris41 7862:
1.243 albertel 7863: =back
1.191 harris41 7864:
1.243 albertel 7865: =head1 PUBLIC SUBROUTINES
1.191 harris41 7866:
1.243 albertel 7867: =head2 Session Environment Functions
1.191 harris41 7868:
1.243 albertel 7869: =over 4
1.191 harris41 7870:
1.394 bowersj2 7871: =item *
7872: X<appenv()>
7873: B<appenv(%hash)>: the value of %hash is written to
7874: the user envirnoment file, and will be restored for each access this
1.620 albertel 7875: user makes during this session, also modifies the %env for the current
1.394 bowersj2 7876: process
1.191 harris41 7877:
7878: =item *
1.394 bowersj2 7879: X<delenv()>
7880: B<delenv($regexp)>: removes all items from the session
7881: environment file that matches the regular expression in $regexp. The
1.620 albertel 7882: values are also delted from the current processes %env.
1.191 harris41 7883:
1.795 albertel 7884: =item * get_env_multiple($name)
7885:
7886: gets $name from the %env hash, it seemlessly handles the cases where multiple
7887: values may be defined and end up as an array ref.
7888:
7889: returns an array of values
7890:
1.243 albertel 7891: =back
7892:
7893: =head2 User Information
1.191 harris41 7894:
1.243 albertel 7895: =over 4
1.191 harris41 7896:
7897: =item *
1.394 bowersj2 7898: X<queryauthenticate()>
7899: B<queryauthenticate($uname,$udom)>: try to determine user's current
1.191 harris41 7900: authentication scheme
7901:
7902: =item *
1.394 bowersj2 7903: X<authenticate()>
7904: B<authenticate($uname,$upass,$udom)>: try to
7905: authenticate user from domain's lib servers (first use the current
7906: one). C<$upass> should be the users password.
1.191 harris41 7907:
7908: =item *
1.394 bowersj2 7909: X<homeserver()>
7910: B<homeserver($uname,$udom)>: find the server which has
7911: the user's directory and files (there must be only one), this caches
7912: the answer, and also caches if there is a borken connection.
1.191 harris41 7913:
7914: =item *
1.394 bowersj2 7915: X<idget()>
7916: B<idget($udom,@ids)>: find the usernames behind a list of IDs
7917: (IDs are a unique resource in a domain, there must be only 1 ID per
7918: username, and only 1 username per ID in a specific domain) (returns
7919: hash: id=>name,id=>name)
1.191 harris41 7920:
7921: =item *
1.394 bowersj2 7922: X<idrget()>
7923: B<idrget($udom,@unames)>: find the IDs behind a list of
7924: usernames (returns hash: name=>id,name=>id)
1.191 harris41 7925:
7926: =item *
1.394 bowersj2 7927: X<idput()>
7928: B<idput($udom,%ids)>: store away a list of names and associated IDs
1.191 harris41 7929:
7930: =item *
1.394 bowersj2 7931: X<rolesinit()>
7932: B<rolesinit($udom,$username,$authhost)>: get user privileges
1.243 albertel 7933:
7934: =item *
1.551 albertel 7935: X<getsection()>
7936: B<getsection($udom,$uname,$cname)>: finds the section of student in the
1.243 albertel 7937: course $cname, return section name/number or '' for "not in course"
7938: and '-1' for "no section"
7939:
7940: =item *
1.394 bowersj2 7941: X<userenvironment()>
7942: B<userenvironment($udom,$uname,@what)>: gets the values of the keys
1.243 albertel 7943: passed in @what from the requested user's environment, returns a hash
7944:
7945: =back
7946:
7947: =head2 User Roles
7948:
7949: =over 4
7950:
7951: =item *
7952:
1.810 raeburn 7953: allowed($priv,$uri,$symb,$role) : check for a user privilege; returns codes for allowed actions
1.243 albertel 7954: F: full access
7955: U,I,K: authentication modes (cxx only)
7956: '': forbidden
7957: 1: user needs to choose course
7958: 2: browse allowed
1.766 albertel 7959: A: passphrase authentication needed
1.243 albertel 7960:
7961: =item *
7962:
7963: definerole($rolename,$sysrole,$domrole,$courole) : define role; define a custom
7964: role rolename set privileges in format of lonTabs/roles.tab for system, domain,
7965: and course level
7966:
7967: =item *
7968:
7969: plaintext($short) : return value in %prp hash (rolesplain.tab); plain text
7970: explanation of a user role term
7971:
1.832 raeburn 7972: =item *
7973:
7974: get_my_roles($uname,$udom,$types,$roles,$roledoms) : All arguments are optional. Returns a hash of a user's roles, with keys set to colon-sparated $uname,$udom,and $role, and value set to colon-separated start and end times for the role. If no username and domain are specified, will default to current user/domain. Types, roles, and roledoms are references to arrays, of role statuses (active, future or previous), roles (e.g., cc,in, st etc.) and domains of the roles which can be used to restrict the list if roles reported. If no array ref is provided for types, will default to return only active roles.
1.243 albertel 7975: =back
7976:
7977: =head2 User Modification
7978:
7979: =over 4
7980:
7981: =item *
7982:
7983: assignrole($udom,$uname,$url,$role,$end,$start) : assign role; give a role to a
7984: user for the level given by URL. Optional start and end dates (leave empty
7985: string or zero for "no date")
1.191 harris41 7986:
7987: =item *
7988:
1.243 albertel 7989: changepass($uname,$udom,$currentpass,$newpass,$server) : attempts to
7990: change a users, password, possible return values are: ok,
7991: pwchange_failure, non_authorized, auth_mode_error, unknown_user,
7992: refused
1.191 harris41 7993:
7994: =item *
7995:
1.243 albertel 7996: modifyuserauth($udom,$uname,$umode,$upass) : modify user authentication
1.191 harris41 7997:
7998: =item *
7999:
1.243 albertel 8000: modifyuser($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene) :
8001: modify user
1.191 harris41 8002:
8003: =item *
8004:
1.286 matthew 8005: modifystudent
8006:
8007: modify a students enrollment and identification information.
8008: The course id is resolved based on the current users environment.
8009: This means the envoking user must be a course coordinator or otherwise
8010: associated with a course.
8011:
1.297 matthew 8012: This call is essentially a wrapper for lonnet::modifyuser and
8013: lonnet::modify_student_enrollment
1.286 matthew 8014:
8015: Inputs:
8016:
8017: =over 4
8018:
8019: =item B<$udom> Students loncapa domain
8020:
8021: =item B<$uname> Students loncapa login name
8022:
8023: =item B<$uid> Students id/student number
8024:
8025: =item B<$umode> Students authentication mode
8026:
8027: =item B<$upass> Students password
8028:
8029: =item B<$first> Students first name
8030:
8031: =item B<$middle> Students middle name
8032:
8033: =item B<$last> Students last name
8034:
8035: =item B<$gene> Students generation
8036:
8037: =item B<$usec> Students section in course
8038:
8039: =item B<$end> Unix time of the roles expiration
8040:
8041: =item B<$start> Unix time of the roles start date
8042:
8043: =item B<$forceid> If defined, allow $uid to be changed
8044:
8045: =item B<$desiredhome> server to use as home server for student
8046:
8047: =back
1.297 matthew 8048:
8049: =item *
8050:
8051: modify_student_enrollment
8052:
8053: Change a students enrollment status in a class. The environment variable
8054: 'role.request.course' must be defined for this function to proceed.
8055:
8056: Inputs:
8057:
8058: =over 4
8059:
8060: =item $udom, students domain
8061:
8062: =item $uname, students name
8063:
8064: =item $uid, students user id
8065:
8066: =item $first, students first name
8067:
8068: =item $middle
8069:
8070: =item $last
8071:
8072: =item $gene
8073:
8074: =item $usec
8075:
8076: =item $end
8077:
8078: =item $start
8079:
8080: =back
8081:
1.191 harris41 8082:
8083: =item *
8084:
1.243 albertel 8085: assigncustomrole($udom,$uname,$url,$rdom,$rnam,$rolename,$end,$start) : assign
8086: custom role; give a custom role to a user for the level given by URL. Specify
8087: name and domain of role author, and role name
1.191 harris41 8088:
8089: =item *
8090:
1.243 albertel 8091: revokerole($udom,$uname,$url,$role) : revoke a role for url
1.191 harris41 8092:
8093: =item *
8094:
1.243 albertel 8095: revokecustomrole($udom,$uname,$url,$role) : revoke a custom role
8096:
8097: =back
8098:
8099: =head2 Course Infomation
8100:
8101: =over 4
1.191 harris41 8102:
8103: =item *
8104:
1.631 albertel 8105: coursedescription($courseid) : returns a hash of information about the
8106: specified course id, including all environment settings for the
8107: course, the description of the course will be in the hash under the
8108: key 'description'
1.191 harris41 8109:
8110: =item *
8111:
1.624 albertel 8112: resdata($name,$domain,$type,@which) : request for current parameter
8113: setting for a specific $type, where $type is either 'course' or 'user',
8114: @what should be a list of parameters to ask about. This routine caches
8115: answers for 5 minutes.
1.243 albertel 8116:
8117: =back
8118:
8119: =head2 Course Modification
8120:
8121: =over 4
1.191 harris41 8122:
8123: =item *
8124:
1.243 albertel 8125: writecoursepref($courseid,%prefs) : write preferences (environment
8126: database) for a course
1.191 harris41 8127:
8128: =item *
8129:
1.243 albertel 8130: createcourse($udom,$description,$url) : make/modify course
8131:
8132: =back
8133:
8134: =head2 Resource Subroutines
8135:
8136: =over 4
1.191 harris41 8137:
8138: =item *
8139:
1.243 albertel 8140: subscribe($fname) : subscribe to a resource, returns URL if possible (probably should use repcopy instead)
1.191 harris41 8141:
8142: =item *
8143:
1.243 albertel 8144: repcopy($filename) : subscribes to the requested file, and attempts to
8145: replicate from the owning library server, Might return
1.607 raeburn 8146: 'unavailable', 'not_found', 'forbidden', 'ok', or
8147: 'bad_request', also attempts to grab the metadata for the
1.243 albertel 8148: resource. Expects the local filesystem pathname
8149: (/home/httpd/html/res/....)
8150:
8151: =back
8152:
8153: =head2 Resource Information
8154:
8155: =over 4
1.191 harris41 8156:
8157: =item *
8158:
1.243 albertel 8159: EXT($varname,$symb,$udom,$uname) : evaluates and returns the value of
8160: a vairety of different possible values, $varname should be a request
8161: string, and the other parameters can be used to specify who and what
8162: one is asking about.
8163:
8164: Possible values for $varname are environment.lastname (or other item
8165: from the envirnment hash), user.name (or someother aspect about the
8166: user), resource.0.maxtries (or some other part and parameter of a
8167: resource)
1.204 albertel 8168:
8169: =item *
8170:
1.243 albertel 8171: directcondval($number) : get current value of a condition; reads from a state
8172: string
1.204 albertel 8173:
8174: =item *
8175:
1.243 albertel 8176: condval($condidx) : value of condition index based on state
1.204 albertel 8177:
8178: =item *
8179:
1.243 albertel 8180: metadata($uri,$what,$liburi,$prefix,$depthcount) : request a
8181: resource's metadata, $what should be either a specific key, or either
8182: 'keys' (to get a list of possible keys) or 'packages' to get a list of
8183: packages that this resource currently uses, the last 3 arguments are only used internally for recursive metadata.
8184:
8185: this function automatically caches all requests
1.191 harris41 8186:
8187: =item *
8188:
1.243 albertel 8189: metadata_query($query,$custom,$customshow) : make a metadata query against the
8190: network of library servers; returns file handle of where SQL and regex results
8191: will be stored for query
1.191 harris41 8192:
8193: =item *
8194:
1.243 albertel 8195: symbread($filename) : return symbolic list entry (filename argument optional);
8196: returns the data handle
1.191 harris41 8197:
8198: =item *
8199:
1.243 albertel 8200: symbverify($symb,$thisfn) : verifies that $symb actually exists and is
1.582 albertel 8201: a possible symb for the URL in $thisfn, and if is an encryypted
8202: resource that the user accessed using /enc/ returns a 1 on success, 0
8203: on failure, user must be in a course, as it assumes the existance of
1.620 albertel 8204: the course initial hash, and uses $env('request.course.id'}
1.243 albertel 8205:
1.191 harris41 8206:
8207: =item *
8208:
1.243 albertel 8209: symbclean($symb) : removes versions numbers from a symb, returns the
8210: cleaned symb
1.191 harris41 8211:
8212: =item *
8213:
1.243 albertel 8214: is_on_map($uri) : checks if the $uri is somewhere on the current
8215: course map, user must be in a course for it to work.
1.191 harris41 8216:
8217: =item *
8218:
1.243 albertel 8219: numval($salt) : return random seed value (addend for rndseed)
1.191 harris41 8220:
8221: =item *
8222:
1.243 albertel 8223: rndseed($symb,$courseid,$udom,$uname) : create a random sum; returns
8224: a random seed, all arguments are optional, if they aren't sent it uses the
8225: environment to derive them. Note: if symb isn't sent and it can't get one
8226: from &symbread it will use the current time as its return value
1.191 harris41 8227:
8228: =item *
8229:
1.243 albertel 8230: ireceipt($funame,$fudom,$fucourseid,$fusymb) : return unique,
8231: unfakeable, receipt
1.191 harris41 8232:
8233: =item *
8234:
1.620 albertel 8235: receipt() : API to ireceipt working off of env values; given out to users
1.191 harris41 8236:
8237: =item *
8238:
1.243 albertel 8239: countacc($url) : count the number of accesses to a given URL
1.191 harris41 8240:
8241: =item *
8242:
1.243 albertel 8243: checkout($symb,$tuname,$tudom,$tcrsid) : creates a record of a user having looked at an item, most likely printed out or otherwise using a resource
1.191 harris41 8244:
8245: =item *
8246:
1.243 albertel 8247: checkin($token) : updates that a resource has beeen returned (a hard copy version for instance) and returns the data that $token was Checkout with ($symb, $tuname, $tudom, and $tcrsid)
1.191 harris41 8248:
8249: =item *
8250:
1.243 albertel 8251: expirespread($uname,$udom,$stype,$usymb) : set expire date for spreadsheet
1.191 harris41 8252:
8253: =item *
8254:
1.243 albertel 8255: devalidate($symb) : devalidate temporary spreadsheet calculations,
8256: forcing spreadsheet to reevaluate the resource scores next time.
8257:
8258: =back
8259:
8260: =head2 Storing/Retreiving Data
8261:
8262: =over 4
1.191 harris41 8263:
8264: =item *
8265:
1.243 albertel 8266: store($storehash,$symb,$namespace,$udom,$uname) : stores hash permanently
8267: for this url; hashref needs to be given and should be a \%hashname; the
8268: remaining args aren't required and if they aren't passed or are '' they will
1.620 albertel 8269: be derived from the env
1.191 harris41 8270:
8271: =item *
8272:
1.243 albertel 8273: cstore($storehash,$symb,$namespace,$udom,$uname) : same as store but
8274: uses critical subroutine
1.191 harris41 8275:
8276: =item *
8277:
1.243 albertel 8278: restore($symb,$namespace,$udom,$uname) : returns hash for this symb;
8279: all args are optional
1.191 harris41 8280:
8281: =item *
8282:
1.717 albertel 8283: dumpstore($namespace,$udom,$uname,$regexp,$range) :
8284: dumps the complete (or key matching regexp) namespace into a hash
8285: ($udom, $uname, $regexp, $range are optional) for a namespace that is
8286: normally &store()ed into
8287:
8288: $range should be either an integer '100' (give me the first 100
8289: matching records)
8290: or be two integers sperated by a - with no spaces
8291: '30-50' (give me the 30th through the 50th matching
8292: records)
8293:
8294:
8295: =item *
8296:
8297: putstore($namespace,$symb,$version,$storehash,$udomain,$uname) :
8298: replaces a &store() version of data with a replacement set of data
8299: for a particular resource in a namespace passed in the $storehash hash
8300: reference
8301:
8302: =item *
8303:
1.243 albertel 8304: tmpstore($storehash,$symb,$namespace,$udom,$uname) : storage that
8305: works very similar to store/cstore, but all data is stored in a
8306: temporary location and can be reset using tmpreset, $storehash should
8307: be a hash reference, returns nothing on success
1.191 harris41 8308:
8309: =item *
8310:
1.243 albertel 8311: tmprestore($symb,$namespace,$udom,$uname) : storage that works very
8312: similar to restore, but all data is stored in a temporary location and
8313: can be reset using tmpreset. Returns a hash of values on success,
8314: error string otherwise.
1.191 harris41 8315:
8316: =item *
8317:
1.243 albertel 8318: tmpreset($symb,$namespace,$udom,$uname) : temporary storage reset,
8319: deltes all keys for $symb form the temporary storage hash.
1.191 harris41 8320:
8321: =item *
8322:
1.243 albertel 8323: get($namespace,$storearr,$udom,$uname) : returns hash with keys from array
8324: reference filled in from namesp ($udom and $uname are optional)
1.191 harris41 8325:
8326: =item *
8327:
1.243 albertel 8328: del($namespace,$storearr,$udom,$uname) : deletes keys out of array from
8329: namesp ($udom and $uname are optional)
1.191 harris41 8330:
8331: =item *
8332:
1.702 albertel 8333: dump($namespace,$udom,$uname,$regexp,$range) :
1.243 albertel 8334: dumps the complete (or key matching regexp) namespace into a hash
1.702 albertel 8335: ($udom, $uname, $regexp, $range are optional)
1.449 matthew 8336:
1.702 albertel 8337: $range should be either an integer '100' (give me the first 100
8338: matching records)
8339: or be two integers sperated by a - with no spaces
8340: '30-50' (give me the 30th through the 50th matching
8341: records)
1.449 matthew 8342: =item *
8343:
8344: inc($namespace,$store,$udom,$uname) : increments $store in $namespace.
8345: $store can be a scalar, an array reference, or if the amount to be
8346: incremented is > 1, a hash reference.
8347:
8348: ($udom and $uname are optional)
1.191 harris41 8349:
8350: =item *
8351:
1.243 albertel 8352: put($namespace,$storehash,$udom,$uname) : stores hash in namesp
8353: ($udom and $uname are optional)
1.191 harris41 8354:
8355: =item *
8356:
1.243 albertel 8357: cput($namespace,$storehash,$udom,$uname) : critical put
8358: ($udom and $uname are optional)
1.191 harris41 8359:
8360: =item *
8361:
1.748 albertel 8362: newput($namespace,$storehash,$udom,$uname) :
8363:
8364: Attempts to store the items in the $storehash, but only if they don't
8365: currently exist, if this succeeds you can be certain that you have
8366: successfully created a new key value pair in the $namespace db.
8367:
8368:
8369: Args:
8370: $namespace: name of database to store values to
8371: $storehash: hashref to store to the db
8372: $udom: (optional) domain of user containing the db
8373: $uname: (optional) name of user caontaining the db
8374:
8375: Returns:
8376: 'ok' -> succeeded in storing all keys of $storehash
8377: 'key_exists: <key>' -> failed to anything out of $storehash, as at
8378: least <key> already existed in the db (other
8379: requested keys may also already exist)
8380: 'error: <msg>' -> unable to tie the DB or other erorr occured
8381: 'con_lost' -> unable to contact request server
8382: 'refused' -> action was not allowed by remote machine
8383:
8384:
8385: =item *
8386:
1.243 albertel 8387: eget($namespace,$storearr,$udom,$uname) : returns hash with keys from array
8388: reference filled in from namesp (encrypts the return communication)
8389: ($udom and $uname are optional)
1.191 harris41 8390:
8391: =item *
8392:
1.243 albertel 8393: log($udom,$name,$home,$message) : write to permanent log for user; use
8394: critical subroutine
8395:
1.806 raeburn 8396: =item *
8397:
8398: get_dom($namespace,$storearr,$udomain) : returns hash with keys from array
8399: reference filled in from namespace found in domain level on primary domain server ($udomain is optional)
8400:
8401: =item *
8402:
8403: put_dom($namespace,$storehash,$udomain) : stores hash in namespace at domain level on primary domain server ($udomain is optional)
8404:
1.243 albertel 8405: =back
8406:
8407: =head2 Network Status Functions
8408:
8409: =over 4
1.191 harris41 8410:
8411: =item *
8412:
8413: dirlist($uri) : return directory list based on URI
8414:
8415: =item *
8416:
1.243 albertel 8417: spareserver() : find server with least workload from spare.tab
8418:
8419: =back
8420:
8421: =head2 Apache Request
8422:
8423: =over 4
1.191 harris41 8424:
8425: =item *
8426:
1.243 albertel 8427: ssi($url,%hash) : server side include, does a complete request cycle on url to
8428: localhost, posts hash
8429:
8430: =back
8431:
8432: =head2 Data to String to Data
8433:
8434: =over 4
1.191 harris41 8435:
8436: =item *
8437:
1.243 albertel 8438: hash2str(%hash) : convert a hash into a string complete with escaping and '='
8439: and '&' separators, supports elements that are arrayrefs and hashrefs
1.191 harris41 8440:
8441: =item *
8442:
1.243 albertel 8443: hashref2str($hashref) : convert a hashref into a string complete with
8444: escaping and '=' and '&' separators, supports elements that are
8445: arrayrefs and hashrefs
1.191 harris41 8446:
8447: =item *
8448:
1.243 albertel 8449: arrayref2str($arrayref) : convert an arrayref into a string complete
8450: with escaping and '&' separators, supports elements that are arrayrefs
8451: and hashrefs
1.191 harris41 8452:
8453: =item *
8454:
1.243 albertel 8455: str2hash($string) : convert string to hash using unescaping and
8456: splitting on '=' and '&', supports elements that are arrayrefs and
8457: hashrefs
1.191 harris41 8458:
8459: =item *
8460:
1.243 albertel 8461: str2array($string) : convert string to hash using unescaping and
8462: splitting on '&', supports elements that are arrayrefs and hashrefs
8463:
8464: =back
8465:
8466: =head2 Logging Routines
8467:
8468: =over 4
8469:
8470: These routines allow one to make log messages in the lonnet.log and
8471: lonnet.perm logfiles.
1.191 harris41 8472:
8473: =item *
8474:
1.243 albertel 8475: logtouch() : make sure the logfile, lonnet.log, exists
1.191 harris41 8476:
8477: =item *
8478:
1.243 albertel 8479: logthis() : append message to the normal lonnet.log file, it gets
8480: preiodically rolled over and deleted.
1.191 harris41 8481:
8482: =item *
8483:
1.243 albertel 8484: logperm() : append a permanent message to lonnet.perm.log, this log
8485: file never gets deleted by any automated portion of the system, only
8486: messages of critical importance should go in here.
8487:
8488: =back
8489:
8490: =head2 General File Helper Routines
8491:
8492: =over 4
1.191 harris41 8493:
8494: =item *
8495:
1.481 raeburn 8496: getfile($file,$caller) : two cases - requests for files in /res or in /uploaded.
8497: (a) files in /uploaded
8498: (i) If a local copy of the file exists -
8499: compares modification date of local copy with last-modified date for
8500: definitive version stored on home server for course. If local copy is
8501: stale, requests a new version from the home server and stores it.
8502: If the original has been removed from the home server, then local copy
8503: is unlinked.
8504: (ii) If local copy does not exist -
8505: requests the file from the home server and stores it.
8506:
8507: If $caller is 'uploadrep':
8508: This indicates a call from lonuploadrep.pm (PerlHeaderParserHandler phase)
8509: for request for files originally uploaded via DOCS.
8510: - returns 'ok' if fresh local copy now available, -1 otherwise.
8511:
8512: Otherwise:
8513: This indicates a call from the content generation phase of the request.
8514: - returns the entire contents of the file or -1.
8515:
8516: (b) files in /res
8517: - returns the entire contents of a file or -1;
8518: it properly subscribes to and replicates the file if neccessary.
1.191 harris41 8519:
1.712 albertel 8520:
8521: =item *
8522:
8523: stat_file($url) : $url is expected to be a /res/ or /uploaded/ style file
8524: reference
8525:
8526: returns either a stat() list of data about the file or an empty list
8527: if the file doesn't exist or couldn't find out about it (connection
8528: problems or user unknown)
8529:
1.191 harris41 8530: =item *
8531:
1.243 albertel 8532: filelocation($dir,$file) : returns file system location of a file
8533: based on URI; meant to be "fairly clean" absolute reference, $dir is a
8534: directory that relative $file lookups are to looked in ($dir of /a/dir
8535: and a file of ../bob will become /a/bob)
1.191 harris41 8536:
8537: =item *
8538:
8539: hreflocation($dir,$file) : returns file system location or a URL; same as
8540: filelocation except for hrefs
8541:
8542: =item *
8543:
8544: declutter() : declutters URLs (remove docroot, beginning slashes, 'res' etc)
8545:
1.243 albertel 8546: =back
8547:
1.608 albertel 8548: =head2 Usererfile file routines (/uploaded*)
8549:
8550: =over 4
8551:
8552: =item *
8553:
8554: userfileupload(): main rotine for putting a file in a user or course's
8555: filespace, arguments are,
8556:
1.620 albertel 8557: formname - required - this is the name of the element in $env where the
1.608 albertel 8558: filename, and the contents of the file to create/modifed exist
1.620 albertel 8559: the filename is in $env{'form.'.$formname.'.filename'} and the
8560: contents of the file is located in $env{'form.'.$formname}
1.608 albertel 8561: coursedoc - if true, store the file in the course of the active role
8562: of the current user
8563: subdir - required - subdirectory to put the file in under ../userfiles/
8564: if undefined, it will be placed in "unknown"
8565:
8566: (This routine calls clean_filename() to remove any dangerous
8567: characters from the filename, and then calls finuserfileupload() to
8568: complete the transaction)
8569:
8570: returns either the url of the uploaded file (/uploaded/....) if successful
8571: and /adm/notfound.html if unsuccessful
8572:
8573: =item *
8574:
8575: clean_filename(): routine for cleaing a filename up for storage in
8576: userfile space, argument is:
8577:
8578: filename - proposed filename
8579:
8580: returns: the new clean filename
8581:
8582: =item *
8583:
8584: finishuserfileupload(): routine that creaes and sends the file to
8585: userspace, probably shouldn't be called directly
8586:
8587: docuname: username or courseid of destination for the file
8588: docudom: domain of user/course of destination for the file
8589: formname: same as for userfileupload()
8590: fname: filename (inculding subdirectories) for the file
8591:
8592: returns either the url of the uploaded file (/uploaded/....) if successful
8593: and /adm/notfound.html if unsuccessful
8594:
8595: =item *
8596:
8597: renameuserfile(): renames an existing userfile to a new name
8598:
8599: Args:
8600: docuname: username or courseid of destination for the file
8601: docudom: domain of user/course of destination for the file
8602: old: current file name (including any subdirs under userfiles)
8603: new: desired file name (including any subdirs under userfiles)
8604:
8605: =item *
8606:
8607: mkdiruserfile(): creates a directory is a userfiles dir
8608:
8609: Args:
8610: docuname: username or courseid of destination for the file
8611: docudom: domain of user/course of destination for the file
8612: dir: dir to create (including any subdirs under userfiles)
8613:
8614: =item *
8615:
8616: removeuserfile(): removes a file that exists in userfiles
8617:
8618: Args:
8619: docuname: username or courseid of destination for the file
8620: docudom: domain of user/course of destination for the file
8621: fname: filname to delete (including any subdirs under userfiles)
8622:
8623: =item *
8624:
8625: removeuploadedurl(): convience function for removeuserfile()
8626:
8627: Args:
8628: url: a full /uploaded/... url to delete
8629:
1.747 albertel 8630: =item *
8631:
8632: get_portfile_permissions():
8633: Args:
8634: domain: domain of user or course contain the portfolio files
8635: user: name of user or num of course contain the portfolio files
8636: Returns:
8637: hashref of a dump of the proper file_permissions.db
8638:
8639:
8640: =item *
8641:
8642: get_access_controls():
8643:
8644: Args:
8645: current_permissions: the hash ref returned from get_portfile_permissions()
8646: group: (optional) the group you want the files associated with
8647: file: (optional) the file you want access info on
8648:
8649: Returns:
1.749 raeburn 8650: a hash (keys are file names) of hashes containing
8651: keys are: path to file/file_name\0uniqueID:scope_end_start (see below)
8652: values are XML containing access control settings (see below)
1.747 albertel 8653:
8654: Internal notes:
8655:
1.749 raeburn 8656: access controls are stored in file_permissions.db as key=value pairs.
8657: key -> path to file/file_name\0uniqueID:scope_end_start
8658: where scope -> public,guest,course,group,domains or users.
8659: end -> UNIX time for end of access (0 -> no end date)
8660: start -> UNIX time for start of access
8661:
8662: value -> XML description of access control
8663: <scope type=""> (type =1 of: public,guest,course,group,domains,users">
8664: <start></start>
8665: <end></end>
8666:
8667: <password></password> for scope type = guest
8668:
8669: <domain></domain> for scope type = course or group
8670: <number></number>
8671: <roles id="">
8672: <role></role>
8673: <access></access>
8674: <section></section>
8675: <group></group>
8676: </roles>
8677:
8678: <dom></dom> for scope type = domains
8679:
8680: <users> for scope type = users
8681: <user>
8682: <uname></uname>
8683: <udom></udom>
8684: </user>
8685: </users>
8686: </scope>
8687:
8688: Access data is also aggregated for each file in an additional key=value pair:
8689: key -> path to file/file_name\0accesscontrol
8690: value -> reference to hash
8691: hash contains key = value pairs
8692: where key = uniqueID:scope_end_start
8693: value = UNIX time record was last updated
8694:
8695: Used to improve speed of look-ups of access controls for each file.
8696:
8697: Locks on files (resulting from submission of portfolio file to a homework problem stored in array of arrays.
8698:
8699: modify_access_controls():
8700:
8701: Modifies access controls for a portfolio file
8702: Args
8703: 1. file name
8704: 2. reference to hash of required changes,
8705: 3. domain
8706: 4. username
8707: where domain,username are the domain of the portfolio owner
8708: (either a user or a course)
8709:
8710: Returns:
8711: 1. result of additions or updates ('ok' or 'error', with error message).
8712: 2. result of deletions ('ok' or 'error', with error message).
8713: 3. reference to hash of any new or updated access controls.
8714: 4. reference to hash used to map incoming IDs to uniqueIDs assigned to control.
8715: key = integer (inbound ID)
8716: value = uniqueID
1.747 albertel 8717:
1.608 albertel 8718: =back
8719:
1.243 albertel 8720: =head2 HTTP Helper Routines
8721:
8722: =over 4
8723:
1.191 harris41 8724: =item *
8725:
8726: escape() : unpack non-word characters into CGI-compatible hex codes
8727:
8728: =item *
8729:
8730: unescape() : pack CGI-compatible hex codes into actual non-word ASCII character
8731:
1.243 albertel 8732: =back
8733:
8734: =head1 PRIVATE SUBROUTINES
8735:
8736: =head2 Underlying communication routines (Shouldn't call)
8737:
8738: =over 4
8739:
8740: =item *
8741:
8742: subreply() : tries to pass a message to lonc, returns con_lost if incapable
8743:
8744: =item *
8745:
8746: reply() : uses subreply to send a message to remote machine, logs all failures
8747:
8748: =item *
8749:
8750: critical() : passes a critical message to another server; if cannot
8751: get through then place message in connection buffer directory and
8752: returns con_delayed, if incapable of saving message, returns
8753: con_failed
8754:
8755: =item *
8756:
8757: reconlonc() : tries to reconnect lonc client processes.
8758:
8759: =back
8760:
8761: =head2 Resource Access Logging
8762:
8763: =over 4
8764:
8765: =item *
8766:
8767: flushcourselogs() : flush (save) buffer logs and access logs
8768:
8769: =item *
8770:
8771: courselog($what) : save message for course in hash
8772:
8773: =item *
8774:
8775: courseacclog($what) : save message for course using &courselog(). Perform
8776: special processing for specific resource types (problems, exams, quizzes, etc).
8777:
1.191 harris41 8778: =item *
8779:
8780: goodbye() : flush course logs and log shutting down; it is called in srm.conf
8781: as a PerlChildExitHandler
1.243 albertel 8782:
8783: =back
8784:
8785: =head2 Other
8786:
8787: =over 4
8788:
8789: =item *
8790:
8791: symblist($mapname,%newhash) : update symbolic storage links
1.191 harris41 8792:
8793: =back
8794:
8795: =cut
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>
![[BACK]](/icons/back.gif){kind=icon}
Return to lonnet.pm CVS log ![[TXT]](/icons/text.gif){kind=icon}
![[DIR]](/icons/dir.gif){kind=icon}
Up to [LON-CAPA] / loncom / lonnet / perl