loncom/lonnet/perl/lonnet.pm - view

File: [LON-CAPA] / loncom / lonnet / perl / lonnet.pm
Revision 1.605: download - view: text, annotated - select for diffs
Thu Mar 3 23:21:54 2005 UTC (19 years, 4 months ago) by matthew
Branches: MAIN
CVS tags: HEAD

Bug 3964: Use of ':' in directory name prevented resource browsing
lond: added ls2_handler which encodes its results prior to concatenating
    them with ':'s.
lonnet::dirlist: modified to call 'ls2' and fall back to 'ls' on failure.
    unescapes values from 'ls2' before sending them back.

1: # The LearningOnline Network 2: # TCP networking package 3: # 4: # $Id: lonnet.pm,v 1.605 2005/03/03 23:21:54 matthew Exp $ 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: # 28: ### 29: 30: package Apache::lonnet; 31: 32: use strict; 33: use LWP::UserAgent(); 34: use HTTP::Headers; 35: use HTTP::Date; 36: # use Date::Parse; 37: use vars 38: qw(%perlvar %hostname %badServerCache %iphost %spareid %hostdom 39: %libserv %pr %prp $memcache %packagetab 40: %courselogs %accesshash %userrolehash $processmarker $dumpcount 41: %coursedombuf %coursenumbuf %coursehombuf %coursedescrbuf %courseinstcodebuf %courseownerbuf 42: %domaindescription %domain_auth_def %domain_auth_arg_def 43: %domain_lang_def %domain_city %domain_longi %domain_lati $tmpdir $_64bit); 44: 45: use IO::Socket; 46: use GDBM_File; 47: use Apache::Constants qw(:common :http); 48: use HTML::LCParser; 49: use Fcntl qw(:flock); 50: use Apache::lonlocal; 51: use Storable qw(lock_store lock_nstore lock_retrieve freeze thaw nfreeze); 52: use Time::HiRes qw( gettimeofday tv_interval ); 53: use Cache::Memcached; 54: my $readit; 55: my $max_connection_retries = 10; # Or some such value. 56: 57: =pod 58: 59: =head1 Package Variables 60: 61: These are largely undocumented, so if you decipher one please note it here. 62: 63: =over 4 64: 65: =item $processmarker 66: 67: Contains the time this process was started and this servers host id. 68: 69: =item $dumpcount 70: 71: Counts the number of times a message log flush has been attempted (regardless 72: of success) by this process. Used as part of the filename when messages are 73: delayed. 74: 75: =back 76: 77: =cut 78: 79: 80: # --------------------------------------------------------------------- Logging 81: 82: sub logtouch { 83: my $execdir=$perlvar{'lonDaemons'}; 84: unless (-e "$execdir/logs/lonnet.log") { 85: open(my $fh,">>$execdir/logs/lonnet.log"); 86: close $fh; 87: } 88: my ($wwwuid,$wwwgid)=(getpwnam('www'))[2,3]; 89: chown($wwwuid,$wwwgid,$execdir.'/logs/lonnet.log'); 90: } 91: 92: sub logthis { 93: my $message=shift; 94: my $execdir=$perlvar{'lonDaemons'}; 95: my $now=time; 96: my $local=localtime($now); 97: if (open(my $fh,">>$execdir/logs/lonnet.log")) { 98: print $fh "$local ($$): $message\n"; 99: close($fh); 100: } 101: return 1; 102: } 103: 104: sub logperm { 105: my $message=shift; 106: my $execdir=$perlvar{'lonDaemons'}; 107: my $now=time; 108: my $local=localtime($now); 109: if (open(my $fh,">>$execdir/logs/lonnet.perm.log")) { 110: print $fh "$now:$message:$local\n"; 111: close($fh); 112: } 113: return 1; 114: } 115: 116: # -------------------------------------------------- Non-critical communication 117: sub subreply { 118: my ($cmd,$server)=@_; 119: my $peerfile="$perlvar{'lonSockDir'}/$server"; 120: # 121: # With loncnew process trimming, there's a timing hole between lonc server 122: # process exit and the master server picking up the listen on the AF_UNIX 123: # socket. In that time interval, a lock file will exist: 124: 125: my $lockfile=$peerfile.".lock"; 126: while (-e $lockfile) { # Need to wait for the lockfile to disappear. 127: sleep(1); 128: } 129: # At this point, either a loncnew parent is listening or an old lonc 130: # or loncnew child is listening so we can connect or everything's dead. 131: # 132: # We'll give the connection a few tries before abandoning it. If 133: # connection is not possible, we'll con_lost back to the client. 134: # 135: my $client; 136: for (my $retries = 0; $retries < $max_connection_retries; $retries++) { 137: $client=IO::Socket::UNIX->new(Peer =>"$peerfile", 138: Type => SOCK_STREAM, 139: Timeout => 10); 140: if($client) { 141: last; # Connected! 142: } 143: sleep(1); # Try again later if failed connection. 144: } 145: my $answer; 146: if ($client) { 147: print $client "$cmd\n"; 148: $answer=<$client>; 149: if (!$answer) { $answer="con_lost"; } 150: chomp($answer); 151: } else { 152: $answer = 'con_lost'; # Failed connection. 153: } 154: return $answer; 155: } 156: 157: sub reply { 158: my ($cmd,$server)=@_; 159: unless (defined($hostname{$server})) { return 'no_such_host'; } 160: my $answer=subreply($cmd,$server); 161: if (($answer=~/^refused/) || ($answer=~/^rejected/)) { 162: &logthis("WARNING:". 163: " $cmd to $server returned $answer"); 164: } 165: return $answer; 166: } 167: 168: # ----------------------------------------------------------- Send USR1 to lonc 169: 170: sub reconlonc { 171: my $peerfile=shift; 172: &logthis("Trying to reconnect for $peerfile"); 173: my $loncfile="$perlvar{'lonDaemons'}/logs/lonc.pid"; 174: if (open(my $fh,"<$loncfile")) { 175: my $loncpid=<$fh>; 176: chomp($loncpid); 177: if (kill 0 => $loncpid) { 178: &logthis("lonc at pid $loncpid responding, sending USR1"); 179: kill USR1 => $loncpid; 180: sleep 1; 181: if (-e "$peerfile") { return; } 182: &logthis("$peerfile still not there, give it another try"); 183: sleep 5; 184: if (-e "$peerfile") { return; } 185: &logthis( 186: "WARNING: $peerfile still not there, giving up"); 187: } else { 188: &logthis( 189: "WARNING:". 190: " lonc at pid $loncpid not responding, giving up"); 191: } 192: } else { 193: &logthis('WARNING: lonc not running, giving up'); 194: } 195: } 196: 197: # ------------------------------------------------------ Critical communication 198: 199: sub critical { 200: my ($cmd,$server)=@_; 201: unless ($hostname{$server}) { 202: &logthis("WARNING:". 203: " Critical message to unknown server ($server)"); 204: return 'no_such_host'; 205: } 206: my $answer=reply($cmd,$server); 207: if ($answer eq 'con_lost') { 208: &reconlonc("$perlvar{'lonSockDir'}/$server"); 209: my $answer=reply($cmd,$server); 210: if ($answer eq 'con_lost') { 211: my $now=time; 212: my $middlename=$cmd; 213: $middlename=substr($middlename,0,16); 214: $middlename=~s/\W//g; 215: my $dfilename= 216: "$perlvar{'lonSockDir'}/delayed/$now.$dumpcount.$$.$middlename.$server"; 217: $dumpcount++; 218: { 219: my $dfh; 220: if (open($dfh,">$dfilename")) { 221: print $dfh "$cmd\n"; 222: close($dfh); 223: } 224: } 225: sleep 2; 226: my $wcmd=''; 227: { 228: my $dfh; 229: if (open($dfh,"<$dfilename")) { 230: $wcmd=<$dfh>; 231: close($dfh); 232: } 233: } 234: chomp($wcmd); 235: if ($wcmd eq $cmd) { 236: &logthis("WARNING: ". 237: "Connection buffer $dfilename: $cmd"); 238: &logperm("D:$server:$cmd"); 239: return 'con_delayed'; 240: } else { 241: &logthis("CRITICAL:" 242: ." Critical connection failed: $server $cmd"); 243: &logperm("F:$server:$cmd"); 244: return 'con_failed'; 245: } 246: } 247: } 248: return $answer; 249: } 250: 251: # 252: # -------------- Remove all key from the env that start witha lowercase letter 253: # (Which is always a lon-capa value) 254: 255: sub cleanenv { 256: # unless (defined(&Apache::exists_config_define("MODPERL2"))) { return; } 257: # unless (&Apache::exists_config_define("MODPERL2")) { return; } 258: foreach my $key (keys(%ENV)) { 259: if ($key =~ /^[a-z]/) { 260: delete($ENV{$key}); 261: } 262: } 263: } 264: 265: # ------------------------------------------- Transfer profile into environment 266: 267: sub transfer_profile_to_env { 268: my ($lonidsdir,$handle)=@_; 269: my @profile; 270: { 271: open(my $idf,"$lonidsdir/$handle.id"); 272: flock($idf,LOCK_SH); 273: @profile=<$idf>; 274: close($idf); 275: } 276: my $envi; 277: my %Remove; 278: for ($envi=0;$envi<=$#profile;$envi++) { 279: chomp($profile[$envi]); 280: my ($envname,$envvalue)=split(/=/,$profile[$envi]); 281: $ENV{$envname} = $envvalue; 282: if (my ($key,$time) = ($envname =~ /^(cgi\.(\d+)_\d+\.)/)) { 283: if ($time < time-300) { 284: $Remove{$key}++; 285: } 286: } 287: } 288: $ENV{'user.environment'} = "$lonidsdir/$handle.id"; 289: foreach my $expired_key (keys(%Remove)) { 290: &delenv($expired_key); 291: } 292: } 293: 294: # ---------------------------------------------------------- Append Environment 295: 296: sub appenv { 297: my %newenv=@_; 298: foreach (keys %newenv) { 299: if (($newenv{$_}=~/^user\.role/) || ($newenv{$_}=~/^user\.priv/)) { 300: &logthis("WARNING: ". 301: "Attempt to modify environment ".$_." to ".$newenv{$_} 302: .''); 303: delete($newenv{$_}); 304: } else { 305: $ENV{$_}=$newenv{$_}; 306: } 307: } 308: 309: my $lockfh; 310: unless (open($lockfh,"$ENV{'user.environment'}")) { 311: return 'error: '.$!; 312: } 313: unless (flock($lockfh,LOCK_EX)) { 314: &logthis("WARNING: ". 315: 'Could not obtain exclusive lock in appenv: '.$!); 316: close($lockfh); 317: return 'error: '.$!; 318: } 319: 320: my @oldenv; 321: { 322: my $fh; 323: unless (open($fh,"$ENV{'user.environment'}")) { 324: return 'error: '.$!; 325: } 326: @oldenv=<$fh>; 327: close($fh); 328: } 329: for (my $i=0; $i<=$#oldenv; $i++) { 330: chomp($oldenv[$i]); 331: if ($oldenv[$i] ne '') { 332: my ($name,$value)=split(/=/,$oldenv[$i]); 333: unless (defined($newenv{$name})) { 334: $newenv{$name}=$value; 335: } 336: } 337: } 338: { 339: my $fh; 340: unless (open($fh,">$ENV{'user.environment'}")) { 341: return 'error'; 342: } 343: my $newname; 344: foreach $newname (keys %newenv) { 345: print $fh "$newname=$newenv{$newname}\n"; 346: } 347: close($fh); 348: } 349: 350: close($lockfh); 351: return 'ok'; 352: } 353: # ----------------------------------------------------- Delete from Environment 354: 355: sub delenv { 356: my $delthis=shift; 357: my %newenv=(); 358: if (($delthis=~/user\.role/) || ($delthis=~/user\.priv/)) { 359: &logthis("WARNING: ". 360: "Attempt to delete from environment ".$delthis); 361: return 'error'; 362: } 363: my @oldenv; 364: { 365: my $fh; 366: unless (open($fh,"$ENV{'user.environment'}")) { 367: return 'error'; 368: } 369: unless (flock($fh,LOCK_SH)) { 370: &logthis("WARNING: ". 371: 'Could not obtain shared lock in delenv: '.$!); 372: close($fh); 373: return 'error: '.$!; 374: } 375: @oldenv=<$fh>; 376: close($fh); 377: } 378: { 379: my $fh; 380: unless (open($fh,">$ENV{'user.environment'}")) { 381: return 'error'; 382: } 383: unless (flock($fh,LOCK_EX)) { 384: &logthis("WARNING: ". 385: 'Could not obtain exclusive lock in delenv: '.$!); 386: close($fh); 387: return 'error: '.$!; 388: } 389: foreach (@oldenv) { 390: if ($_=~/^$delthis/) { 391: my ($key,undef) = split('=',$_); 392: delete($ENV{$key}); 393: } else { 394: print $fh $_; 395: } 396: } 397: close($fh); 398: } 399: return 'ok'; 400: } 401: 402: # ------------------------------------------ Find out current server userload 403: # there is a copy in lond 404: sub userload { 405: my $numusers=0; 406: { 407: opendir(LONIDS,$perlvar{'lonIDsDir'}); 408: my $filename; 409: my $curtime=time; 410: while ($filename=readdir(LONIDS)) { 411: if ($filename eq '.' || $filename eq '..') {next;} 412: my ($mtime)=(stat($perlvar{'lonIDsDir'}.'/'.$filename))[9]; 413: if ($curtime-$mtime < 1800) { $numusers++; } 414: } 415: closedir(LONIDS); 416: } 417: my $userloadpercent=0; 418: my $maxuserload=$perlvar{'lonUserLoadLim'}; 419: if ($maxuserload) { 420: $userloadpercent=100*$numusers/$maxuserload; 421: } 422: $userloadpercent=sprintf("%.2f",$userloadpercent); 423: return $userloadpercent; 424: } 425: 426: # ------------------------------------------ Fight off request when overloaded 427: 428: sub overloaderror { 429: my ($r,$checkserver)=@_; 430: unless ($checkserver) { $checkserver=$perlvar{'lonHostID'}; } 431: my $loadavg; 432: if ($checkserver eq $perlvar{'lonHostID'}) { 433: open(my $loadfile,'/proc/loadavg'); 434: $loadavg=<$loadfile>; 435: $loadavg =~ s/\s.*//g; 436: $loadavg = 100*$loadavg/$perlvar{'lonLoadLim'}; 437: close($loadfile); 438: } else { 439: $loadavg=&reply('load',$checkserver); 440: } 441: my $overload=$loadavg-100; 442: if ($overload>0) { 443: $r->err_headers_out->{'Retry-After'}=$overload; 444: $r->log_error('Overload of '.$overload.' on '.$checkserver); 445: return 413; 446: } 447: return ''; 448: } 449: 450: # ------------------------------ Find server with least workload from spare.tab 451: 452: sub spareserver { 453: my ($loadpercent,$userloadpercent) = @_; 454: my $tryserver; 455: my $spareserver=''; 456: if ($userloadpercent !~ /\d/) { $userloadpercent=0; } 457: my $lowestserver=$loadpercent > $userloadpercent? 458: $loadpercent : $userloadpercent; 459: foreach $tryserver (keys %spareid) { 460: my $loadans=reply('load',$tryserver); 461: my $userloadans=reply('userload',$tryserver); 462: if ($loadans !~ /\d/ && $userloadans !~ /\d/) { 463: next; #didn't get a number from the server 464: } 465: my $answer; 466: if ($loadans =~ /\d/) { 467: if ($userloadans =~ /\d/) { 468: #both are numbers, pick the bigger one 469: $answer=$loadans > $userloadans? 470: $loadans : $userloadans; 471: } else { 472: $answer = $loadans; 473: } 474: } else { 475: $answer = $userloadans; 476: } 477: if (($answer =~ /\d/) && ($answer<$lowestserver)) { 478: $spareserver="http://$hostname{$tryserver}"; 479: $lowestserver=$answer; 480: } 481: } 482: return $spareserver; 483: } 484: 485: # --------------------------------------------- Try to change a user's password 486: 487: sub changepass { 488: my ($uname,$udom,$currentpass,$newpass,$server)=@_; 489: $currentpass = &escape($currentpass); 490: $newpass = &escape($newpass); 491: my $answer = reply("encrypt:passwd:$udom:$uname:$currentpass:$newpass", 492: $server); 493: if (! $answer) { 494: &logthis("No reply on password change request to $server ". 495: "by $uname in domain $udom."); 496: } elsif ($answer =~ "^ok") { 497: &logthis("$uname in $udom successfully changed their password ". 498: "on $server."); 499: } elsif ($answer =~ "^pwchange_failure") { 500: &logthis("$uname in $udom was unable to change their password ". 501: "on $server. The action was blocked by either lcpasswd ". 502: "or pwchange"); 503: } elsif ($answer =~ "^non_authorized") { 504: &logthis("$uname in $udom did not get their password correct when ". 505: "attempting to change it on $server."); 506: } elsif ($answer =~ "^auth_mode_error") { 507: &logthis("$uname in $udom attempted to change their password despite ". 508: "not being locally or internally authenticated on $server."); 509: } elsif ($answer =~ "^unknown_user") { 510: &logthis("$uname in $udom attempted to change their password ". 511: "on $server but were unable to because $server is not ". 512: "their home server."); 513: } elsif ($answer =~ "^refused") { 514: &logthis("$server refused to change $uname in $udom password because ". 515: "it was sent an unencrypted request to change the password."); 516: } 517: return $answer; 518: } 519: 520: # ----------------------- Try to determine user's current authentication scheme 521: 522: sub queryauthenticate { 523: my ($uname,$udom)=@_; 524: my $uhome=&homeserver($uname,$udom); 525: if (!$uhome) { 526: &logthis("User $uname at $udom is unknown when looking for authentication mechanism"); 527: return 'no_host'; 528: } 529: my $answer=reply("encrypt:currentauth:$udom:$uname",$uhome); 530: if ($answer =~ /^(unknown_user|refused|con_lost)/) { 531: &logthis("User $uname at $udom threw error $answer when checking authentication mechanism"); 532: } 533: return $answer; 534: } 535: 536: # --------- Try to authenticate user from domain's lib servers (first this one) 537: 538: sub authenticate { 539: my ($uname,$upass,$udom)=@_; 540: $upass=escape($upass); 541: $uname=~s/\W//g; 542: my $uhome=&homeserver($uname,$udom); 543: if (!$uhome) { 544: &logthis("User $uname at $udom is unknown in authenticate"); 545: return 'no_host'; 546: } 547: my $answer=reply("encrypt:auth:$udom:$uname:$upass",$uhome); 548: if ($answer eq 'authorized') { 549: &logthis("User $uname at $udom authorized by $uhome"); 550: return $uhome; 551: } 552: if ($answer eq 'non_authorized') { 553: &logthis("User $uname at $udom rejected by $uhome"); 554: return 'no_host'; 555: } 556: &logthis("User $uname at $udom threw error $answer when checking authentication mechanism"); 557: return 'no_host'; 558: } 559: 560: # ---------------------- Find the homebase for a user from domain's lib servers 561: 562: my %homecache; 563: sub homeserver { 564: my ($uname,$udom,$ignoreBadCache)=@_; 565: my $index="$uname:$udom"; 566: 567: if (exists($homecache{$index})) { return $homecache{$index}; } 568: my $tryserver; 569: foreach $tryserver (keys %libserv) { 570: next if ($ignoreBadCache ne 'true' && 571: exists($badServerCache{$tryserver})); 572: if ($hostdom{$tryserver} eq $udom) { 573: my $answer=reply("home:$udom:$uname",$tryserver); 574: if ($answer eq 'found') { 575: return $homecache{$index}=$tryserver; 576: } elsif ($answer eq 'no_host') { 577: $badServerCache{$tryserver}=1; 578: } 579: } 580: } 581: return 'no_host'; 582: } 583: 584: # ------------------------------------- Find the usernames behind a list of IDs 585: 586: sub idget { 587: my ($udom,@ids)=@_; 588: my %returnhash=(); 589: 590: my $tryserver; 591: foreach $tryserver (keys %libserv) { 592: if ($hostdom{$tryserver} eq $udom) { 593: my $idlist=join('&',@ids); 594: $idlist=~tr/A-Z/a-z/; 595: my $reply=&reply("idget:$udom:".$idlist,$tryserver); 596: my @answer=(); 597: if (($reply ne 'con_lost') && ($reply!~/^error\:/)) { 598: @answer=split(/\&/,$reply); 599: } ; 600: my $i; 601: for ($i=0;$i<=$#ids;$i++) { 602: if ($answer[$i]) { 603: $returnhash{$ids[$i]}=$answer[$i]; 604: } 605: } 606: } 607: } 608: return %returnhash; 609: } 610: 611: # ------------------------------------- Find the IDs behind a list of usernames 612: 613: sub idrget { 614: my ($udom,@unames)=@_; 615: my %returnhash=(); 616: foreach (@unames) { 617: $returnhash{$_}=(&userenvironment($udom,$_,'id'))[1]; 618: } 619: return %returnhash; 620: } 621: 622: # ------------------------------- Store away a list of names and associated IDs 623: 624: sub idput { 625: my ($udom,%ids)=@_; 626: my %servers=(); 627: foreach (keys %ids) { 628: &cput('environment',{'id'=>$ids{$_}},$udom,$_); 629: my $uhom=&homeserver($_,$udom); 630: if ($uhom ne 'no_host') { 631: my $id=&escape($ids{$_}); 632: $id=~tr/A-Z/a-z/; 633: my $unam=&escape($_); 634: if ($servers{$uhom}) { 635: $servers{$uhom}.='&'.$id.'='.$unam; 636: } else { 637: $servers{$uhom}=$id.'='.$unam; 638: } 639: } 640: } 641: foreach (keys %servers) { 642: &critical('idput:'.$udom.':'.$servers{$_},$_); 643: } 644: } 645: 646: # --------------------------------------------------- Assign a key to a student 647: 648: sub assign_access_key { 649: # 650: # a valid key looks like uname:udom#comments 651: # comments are being appended 652: # 653: my ($ckey,$kdom,$knum,$cdom,$cnum,$udom,$uname,$logentry)=@_; 654: $kdom= 655: $ENV{'course.'.$ENV{'request.course.id'}.'.domain'} unless (defined($kdom)); 656: $knum= 657: $ENV{'course.'.$ENV{'request.course.id'}.'.num'} unless (defined($knum)); 658: $cdom= 659: $ENV{'course.'.$ENV{'request.course.id'}.'.domain'} unless (defined($cdom)); 660: $cnum= 661: $ENV{'course.'.$ENV{'request.course.id'}.'.num'} unless (defined($cnum)); 662: $udom=$ENV{'user.name'} unless (defined($udom)); 663: $uname=$ENV{'user.domain'} unless (defined($uname)); 664: my %existing=&get('accesskeys',[$ckey],$kdom,$knum); 665: if (($existing{$ckey}=~/^\#(.*)$/) || # - new key 666: ($existing{$ckey}=~/^\Q$uname\E\:\Q$udom\E\#(.*)$/)) { 667: # assigned to this person 668: # - this should not happen, 669: # unless something went wrong 670: # the first time around 671: # ready to assign 672: $logentry=$1.'; '.$logentry; 673: if (&put('accesskeys',{$ckey=>$uname.':'.$udom.'#'.$logentry}, 674: $kdom,$knum) eq 'ok') { 675: # key now belongs to user 676: my $envkey='key.'.$cdom.'_'.$cnum; 677: if (&put('environment',{$envkey => $ckey}) eq 'ok') { 678: &appenv('environment.'.$envkey => $ckey); 679: return 'ok'; 680: } else { 681: return 682: 'error: Count not permanently assign key, will need to be re-entered later.'; 683: } 684: } else { 685: return 'error: Could not assign key, try again later.'; 686: } 687: } elsif (!$existing{$ckey}) { 688: # the key does not exist 689: return 'error: The key does not exist'; 690: } else { 691: # the key is somebody else's 692: return 'error: The key is already in use'; 693: } 694: } 695: 696: # ------------------------------------------ put an additional comment on a key 697: 698: sub comment_access_key { 699: # 700: # a valid key looks like uname:udom#comments 701: # comments are being appended 702: # 703: my ($ckey,$cdom,$cnum,$logentry)=@_; 704: $cdom= 705: $ENV{'course.'.$ENV{'request.course.id'}.'.domain'} unless (defined($cdom)); 706: $cnum= 707: $ENV{'course.'.$ENV{'request.course.id'}.'.num'} unless (defined($cnum)); 708: my %existing=&get('accesskeys',[$ckey],$cdom,$cnum); 709: if ($existing{$ckey}) { 710: $existing{$ckey}.='; '.$logentry; 711: # ready to assign 712: if (&put('accesskeys',{$ckey=>$existing{$ckey}}, 713: $cdom,$cnum) eq 'ok') { 714: return 'ok'; 715: } else { 716: return 'error: Count not store comment.'; 717: } 718: } else { 719: # the key does not exist 720: return 'error: The key does not exist'; 721: } 722: } 723: 724: # ------------------------------------------------------ Generate a set of keys 725: 726: sub generate_access_keys { 727: my ($number,$cdom,$cnum,$logentry)=@_; 728: $cdom= 729: $ENV{'course.'.$ENV{'request.course.id'}.'.domain'} unless (defined($cdom)); 730: $cnum= 731: $ENV{'course.'.$ENV{'request.course.id'}.'.num'} unless (defined($cnum)); 732: unless (&allowed('mky',$cdom)) { return 0; } 733: unless (($cdom) && ($cnum)) { return 0; } 734: if ($number>10000) { return 0; } 735: sleep(2); # make sure don't get same seed twice 736: srand(time()^($$+($$<<15))); # from "Programming Perl" 737: my $total=0; 738: for (my $i=1;$i<=$number;$i++) { 739: my $newkey=sprintf("%lx",int(100000*rand)).'-'. 740: sprintf("%lx",int(100000*rand)).'-'. 741: sprintf("%lx",int(100000*rand)); 742: $newkey=~s/1/g/g; # folks mix up 1 and l 743: $newkey=~s/0/h/g; # and also 0 and O 744: my %existing=&get('accesskeys',[$newkey],$cdom,$cnum); 745: if ($existing{$newkey}) { 746: $i--; 747: } else { 748: if (&put('accesskeys', 749: { $newkey => '# generated '.localtime(). 750: ' by '.$ENV{'user.name'}.'@'.$ENV{'user.domain'}. 751: '; '.$logentry }, 752: $cdom,$cnum) eq 'ok') { 753: $total++; 754: } 755: } 756: } 757: &log($ENV{'user.domain'},$ENV{'user.name'},$ENV{'user.home'}, 758: 'Generated '.$total.' keys for '.$cnum.' at '.$cdom); 759: return $total; 760: } 761: 762: # ------------------------------------------------------- Validate an accesskey 763: 764: sub validate_access_key { 765: my ($ckey,$cdom,$cnum,$udom,$uname)=@_; 766: $cdom= 767: $ENV{'course.'.$ENV{'request.course.id'}.'.domain'} unless (defined($cdom)); 768: $cnum= 769: $ENV{'course.'.$ENV{'request.course.id'}.'.num'} unless (defined($cnum)); 770: $udom=$ENV{'user.domain'} unless (defined($udom)); 771: $uname=$ENV{'user.name'} unless (defined($uname)); 772: my %existing=&get('accesskeys',[$ckey],$cdom,$cnum); 773: return ($existing{$ckey}=~/^\Q$uname\E\:\Q$udom\E\#/); 774: } 775: 776: # ------------------------------------- Find the section of student in a course 777: 778: sub getsection { 779: my ($udom,$unam,$courseid)=@_; 780: my $cachetime=1800; 781: $courseid=~s/\_/\//g; 782: $courseid=~s/^(\w)/\/$1/; 783: 784: my $hashid="$udom:$unam:$courseid"; 785: my ($result,$cached)=&is_cached_new('getsection',$hashid); 786: if (defined($cached)) { return $result; } 787: 788: my %Pending; 789: my %Expired; 790: # 791: # Each role can either have not started yet (pending), be active, 792: # or have expired. 793: # 794: # If there is an active role, we are done. 795: # 796: # If there is more than one role which has not started yet, 797: # choose the one which will start sooner 798: # If there is one role which has not started yet, return it. 799: # 800: # If there is more than one expired role, choose the one which ended last. 801: # If there is a role which has expired, return it. 802: # 803: foreach (split(/\&/,&reply('dump:'.$udom.':'.$unam.':roles', 804: &homeserver($unam,$udom)))) { 805: my ($key,$value)=split(/\=/,$_); 806: $key=&unescape($key); 807: next if ($key !~/^\Q$courseid\E(?:\/)*(\w+)*\_st$/); 808: my $section=$1; 809: if ($key eq $courseid.'_st') { $section=''; } 810: my ($dummy,$end,$start)=split(/\_/,&unescape($value)); 811: my $now=time; 812: if (defined($end) && $end && ($now > $end)) { 813: $Expired{$end}=$section; 814: next; 815: } 816: if (defined($start) && $start && ($now < $start)) { 817: $Pending{$start}=$section; 818: next; 819: } 820: return &do_cache_new('getsection',$hashid,$section,$cachetime); 821: } 822: # 823: # Presumedly there will be few matching roles from the above 824: # loop and the sorting time will be negligible. 825: if (scalar(keys(%Pending))) { 826: my ($time) = sort {$a <=> $b} keys(%Pending); 827: return &do_cache_new('getsection',$hashid,$Pending{$time},$cachetime); 828: } 829: if (scalar(keys(%Expired))) { 830: my @sorted = sort {$a <=> $b} keys(%Expired); 831: my $time = pop(@sorted); 832: return &do_cache_new('getsection',$hashid,$Expired{$time},$cachetime); 833: } 834: return &do_cache_new('getsection',$hashid,'-1',$cachetime); 835: } 836: 837: sub save_cache { 838: &purge_remembered(); 839: } 840: 841: my $to_remember=-1; 842: my %remembered; 843: my %accessed; 844: my $kicks=0; 845: my $hits=0; 846: sub devalidate_cache_new { 847: my ($name,$id,$debug) = @_; 848: if ($debug) { &Apache::lonnet::logthis("deleting $name:$id"); } 849: $id=&escape($name.':'.$id); 850: $memcache->delete($id); 851: delete($remembered{$id}); 852: delete($accessed{$id}); 853: } 854: 855: sub is_cached_new { 856: my ($name,$id,$debug) = @_; 857: $id=&escape($name.':'.$id); 858: if (exists($remembered{$id})) { 859: if ($debug) { &Apache::lonnet::logthis("Earyl return $id of $remembered{$id} "); } 860: $accessed{$id}=[&gettimeofday()]; 861: $hits++; 862: return ($remembered{$id},1); 863: } 864: my $value = $memcache->get($id); 865: if (!(defined($value))) { 866: if ($debug) { &Apache::lonnet::logthis("getting $id is not defined"); } 867: return (undef,undef); 868: } 869: if ($value eq '__undef__') { 870: if ($debug) { &Apache::lonnet::logthis("getting $id is __undef__"); } 871: $value=undef; 872: } 873: &make_room($id,$value,$debug); 874: if ($debug) { &Apache::lonnet::logthis("getting $id is $value"); } 875: return ($value,1); 876: } 877: 878: sub do_cache_new { 879: my ($name,$id,$value,$time,$debug) = @_; 880: $id=&escape($name.':'.$id); 881: my $setvalue=$value; 882: if (!defined($setvalue)) { 883: $setvalue='__undef__'; 884: } 885: if ($debug) { &Apache::lonnet::logthis("Setting $id to $value"); } 886: $memcache->set($id,$setvalue,$time); 887: # need to make a copy of $value 888: #&make_room($id,$value,$debug); 889: return $value; 890: } 891: 892: sub make_room { 893: my ($id,$value,$debug)=@_; 894: $remembered{$id}=$value; 895: if ($to_remember<0) { return; } 896: $accessed{$id}=[&gettimeofday()]; 897: if (scalar(keys(%remembered)) <= $to_remember) { return; } 898: my $to_kick; 899: my $max_time=0; 900: foreach my $other (keys(%accessed)) { 901: if (&tv_interval($accessed{$other}) > $max_time) { 902: $to_kick=$other; 903: $max_time=&tv_interval($accessed{$other}); 904: } 905: } 906: delete($remembered{$to_kick}); 907: delete($accessed{$to_kick}); 908: $kicks++; 909: if ($debug) { &logthis("kicking $to_kick $max_time $kicks\n"); } 910: return; 911: } 912: 913: sub purge_remembered { 914: #&logthis("Tossing ".scalar(keys(%remembered))); 915: #&logthis(sprintf("%-20s is %s",'%remembered',length(&freeze(\%remembered)))); 916: undef(%remembered); 917: undef(%accessed); 918: } 919: # ------------------------------------- Read an entry from a user's environment 920: 921: sub userenvironment { 922: my ($udom,$unam,@what)=@_; 923: my %returnhash=(); 924: my @answer=split(/\&/, 925: &reply('get:'.$udom.':'.$unam.':environment:'.join('&',@what), 926: &homeserver($unam,$udom))); 927: my $i; 928: for ($i=0;$i<=$#what;$i++) { 929: $returnhash{$what[$i]}=&unescape($answer[$i]); 930: } 931: return %returnhash; 932: } 933: 934: # -------------------------------------------------------------------- New chat 935: 936: sub chatsend { 937: my ($newentry,$anon)=@_; 938: my $cnum=$ENV{'course.'.$ENV{'request.course.id'}.'.num'}; 939: my $cdom=$ENV{'course.'.$ENV{'request.course.id'}.'.domain'}; 940: my $chome=$ENV{'course.'.$ENV{'request.course.id'}.'.home'}; 941: &reply('chatsend:'.$cdom.':'.$cnum.':'. 942: &escape($ENV{'user.domain'}.':'.$ENV{'user.name'}.':'.$anon.':'. 943: &escape($newentry)),$chome); 944: } 945: 946: # ------------------------------------------ Find current version of a resource 947: 948: sub getversion { 949: my $fname=&clutter(shift); 950: unless ($fname=~/^\/res\//) { return -1; } 951: return &currentversion(&filelocation('',$fname)); 952: } 953: 954: sub currentversion { 955: my $fname=shift; 956: my ($result,$cached)=&is_cached_new('resversion',$fname); 957: if (defined($cached)) { return $result; } 958: my $author=$fname; 959: $author=~s/\/home\/httpd\/html\/res\/([^\/]*)\/([^\/]*).*/$1\/$2/; 960: my ($udom,$uname)=split(/\//,$author); 961: my $home=homeserver($uname,$udom); 962: if ($home eq 'no_host') { 963: return -1; 964: } 965: my $answer=reply("currentversion:$fname",$home); 966: if (($answer eq 'con_lost') || ($answer eq 'rejected')) { 967: return -1; 968: } 969: return &do_cache_new('resversion',$fname,$answer,600); 970: } 971: 972: # ----------------------------- Subscribe to a resource, return URL if possible 973: 974: sub subscribe { 975: my $fname=shift; 976: if ($fname=~/\/(aboutme|syllabus|bulletinboard|smppg)$/) { return ''; } 977: $fname=~s/[\n\r]//g; 978: my $author=$fname; 979: $author=~s/\/home\/httpd\/html\/res\/([^\/]*)\/([^\/]*).*/$1\/$2/; 980: my ($udom,$uname)=split(/\//,$author); 981: my $home=homeserver($uname,$udom); 982: if ($home eq 'no_host') { 983: return 'not_found'; 984: } 985: my $answer=reply("sub:$fname",$home); 986: if (($answer eq 'con_lost') || ($answer eq 'rejected')) { 987: $answer.=' by '.$home; 988: } 989: return $answer; 990: } 991: 992: # -------------------------------------------------------------- Replicate file 993: 994: sub repcopy { 995: my $filename=shift; 996: $filename=~s/\/+/\//g; 997: if ($filename=~m|^/home/httpd/html/adm/|) { return 'OK'; } 998: if ($filename=~m|^/home/httpd/html/lonUsers/|) { return 'OK'; } 999: if ($filename=~m|^/home/httpd/html/userfiles/| or 1000: $filename=~m|^/*uploaded/|) { 1001: return &repcopy_userfile($filename); 1002: } 1003: $filename=~s/[\n\r]//g; 1004: my $transname="$filename.in.transfer"; 1005: if ((-e $filename) || (-e $transname)) { return 'OK'; } 1006: my $remoteurl=subscribe($filename); 1007: if ($remoteurl =~ /^con_lost by/) { 1008: &logthis("Subscribe returned $remoteurl: $filename"); 1009: return 'HTTP_SERVICE_UNAVAILABLE'; 1010: } elsif ($remoteurl eq 'not_found') { 1011: #&logthis("Subscribe returned not_found: $filename"); 1012: return 'HTTP_NOT_FOUND'; 1013: } elsif ($remoteurl =~ /^rejected by/) { 1014: &logthis("Subscribe returned $remoteurl: $filename"); 1015: return 'FORBIDDEN'; 1016: } elsif ($remoteurl eq 'directory') { 1017: return 'OK'; 1018: } else { 1019: my $author=$filename; 1020: $author=~s/\/home\/httpd\/html\/res\/([^\/]*)\/([^\/]*).*/$1\/$2/; 1021: my ($udom,$uname)=split(/\//,$author); 1022: my $home=homeserver($uname,$udom); 1023: unless ($home eq $perlvar{'lonHostID'}) { 1024: my @parts=split(/\//,$filename); 1025: my $path="/$parts[1]/$parts[2]/$parts[3]/$parts[4]"; 1026: if ($path ne "$perlvar{'lonDocRoot'}/res") { 1027: &logthis("Malconfiguration for replication: $filename"); 1028: return 'HTTP_BAD_REQUEST'; 1029: } 1030: my $count; 1031: for ($count=5;$count<$#parts;$count++) { 1032: $path.="/$parts[$count]"; 1033: if ((-e $path)!=1) { 1034: mkdir($path,0777); 1035: } 1036: } 1037: my $ua=new LWP::UserAgent; 1038: my $request=new HTTP::Request('GET',"$remoteurl"); 1039: my $response=$ua->request($request,$transname); 1040: if ($response->is_error()) { 1041: unlink($transname); 1042: my $message=$response->status_line; 1043: &logthis("WARNING:" 1044: ." LWP get: $message: $filename"); 1045: return 'HTTP_SERVICE_UNAVAILABLE'; 1046: } else { 1047: if ($remoteurl!~/\.meta$/) { 1048: my $mrequest=new HTTP::Request('GET',$remoteurl.'.meta'); 1049: my $mresponse=$ua->request($mrequest,$filename.'.meta'); 1050: if ($mresponse->is_error()) { 1051: unlink($filename.'.meta'); 1052: &logthis( 1053: "INFO: No metadata: $filename"); 1054: } 1055: } 1056: rename($transname,$filename); 1057: return 'OK'; 1058: } 1059: } 1060: } 1061: } 1062: 1063: # ------------------------------------------------ Get server side include body 1064: sub ssi_body { 1065: my ($filelink,%form)=@_; 1066: my $output=($filelink=~/^http\:/?&externalssi($filelink): 1067: &ssi($filelink,%form)); 1068: $output=~s|//(\s*)?\s||gs; 1069: $output=~s/^.*?\<body[^\>]*\>//si; 1070: $output=~s/(.*)\<\/body\s*\>.*?$/$1/si; 1071: return $output; 1072: } 1073: 1074: # --------------------------------------------------------- Server Side Include 1075: 1076: sub ssi { 1077: 1078: my ($fn,%form)=@_; 1079: 1080: my $ua=new LWP::UserAgent; 1081: 1082: my $request; 1083: 1084: if (%form) { 1085: $request=new HTTP::Request('POST',"http://".$ENV{'HTTP_HOST'}.$fn); 1086: $request->content(join('&',map { &escape($_).'='.&escape($form{$_}) } keys %form)); 1087: } else { 1088: $request=new HTTP::Request('GET',"http://".$ENV{'HTTP_HOST'}.$fn); 1089: } 1090: 1091: $request->header(Cookie => $ENV{'HTTP_COOKIE'}); 1092: my $response=$ua->request($request); 1093: 1094: return $response->content; 1095: } 1096: 1097: sub externalssi { 1098: my ($url)=@_; 1099: my $ua=new LWP::UserAgent; 1100: my $request=new HTTP::Request('GET',$url); 1101: my $response=$ua->request($request); 1102: return $response->content; 1103: } 1104: 1105: # -------------------------------- Allow a /uploaded/ URI to be vouched for 1106: 1107: sub allowuploaded { 1108: my ($srcurl,$url)=@_; 1109: $url=&clutter(&declutter($url)); 1110: my $dir=$url; 1111: $dir=~s/\/[^\/]+$//; 1112: my %httpref=(); 1113: my $httpurl=&hreflocation('',$url); 1114: $httpref{'httpref.'.$httpurl}=$srcurl; 1115: &Apache::lonnet::appenv(%httpref); 1116: } 1117: 1118: # --------- File operations in /home/httpd/html/userfiles/$domain/1/2/3/$course 1119: # input: action, courseID, current domain, home server for course, intended 1120: # path to file, source of file. 1121: # output: url to file (if action was uploaddoc), 1122: # ok if successful, or diagnostic message otherwise (if action was propagate or copy) 1123: # 1124: # Allows directory structure to be used within lonUsers/../userfiles/ for a 1125: # course. 1126: # 1127: # action = propagate - /home/httpd/html/userfiles/$domain/1/2/3/$course/$file 1128: # will be copied to /home/httpd/lonUsers/1/2/3/$course/userfiles in 1129: # course's home server. 1130: # 1131: # action = copy - /home/httpd/html/userfiles/$domain/1/2/3/$course/$file will 1132: # be copied from $source (current location) to 1133: # /home/httpd/html/userfiles/$domain/1/2/3/$course/$file 1134: # and will then be copied to 1135: # /home/httpd/lonUsers/$domain/1/2/3/$course/userfiles/$file in 1136: # course's home server. 1137: # 1138: # action = uploaddoc - /home/httpd/html/userfiles/$domain/1/2/3/$course/$file 1139: # will be retrived from $ENV{form.uploaddoc} (from DOCS interface) to 1140: # /home/httpd/html/userfiles/$domain/1/2/3/$course/$file 1141: # and will then be copied to /home/httpd/lonUsers/1/2/3/$course/userfiles/$file 1142: # in course's home server. 1143: 1144: 1145: sub process_coursefile { 1146: my ($action,$docuname,$docudom,$docuhome,$file,$source)=@_; 1147: my $fetchresult; 1148: if ($action eq 'propagate') { 1149: $fetchresult= &reply('fetchuserfile:'.$docudom.'/'.$docuname.'/'.$file 1150: ,$docuhome); 1151: } else { 1152: my $fetchresult = ''; 1153: my $fpath = ''; 1154: my $fname = $file; 1155: ($fpath,$fname) = ($file =~ m|^(.*)/([^/]+)$|); 1156: $fpath=$docudom.'/'.$docuname.'/'.$fpath; 1157: my $filepath=$perlvar{'lonDocRoot'}.'/userfiles'; 1158: unless ($fpath eq '') { 1159: my @parts=split('/',$fpath); 1160: foreach my $part (@parts) { 1161: $filepath.= '/'.$part; 1162: if ((-e $filepath)!=1) { 1163: mkdir($filepath,0777); 1164: } 1165: } 1166: } 1167: if ($action eq 'copy') { 1168: if ($source eq '') { 1169: $fetchresult = 'no source file'; 1170: return $fetchresult; 1171: } else { 1172: my $destination = $filepath.'/'.$fname; 1173: rename($source,$destination); 1174: $fetchresult= &reply('fetchuserfile:'.$docudom.'/'.$docuname.'/'.$file, 1175: $docuhome); 1176: } 1177: } elsif ($action eq 'uploaddoc') { 1178: open(my $fh,'>'.$filepath.'/'.$fname); 1179: print $fh $ENV{'form.'.$source}; 1180: close($fh); 1181: $fetchresult= &reply('fetchuserfile:'.$docudom.'/'.$docuname.'/'.$file, 1182: $docuhome); 1183: if ($fetchresult eq 'ok') { 1184: return '/uploaded/'.$fpath.'/'.$fname; 1185: } else { 1186: &logthis('Failed to transfer '.$docudom.'/'.$docuname.'/'.$file. 1187: ' to host '.$docuhome.': '.$fetchresult); 1188: return '/adm/notfound.html'; 1189: } 1190: } 1191: } 1192: unless ( $fetchresult eq 'ok') { 1193: &logthis('Failed to transfer '.$docudom.'/'.$docuname.'/'.$file. 1194: ' to host '.$docuhome.': '.$fetchresult); 1195: } 1196: return $fetchresult; 1197: } 1198: 1199: # --------------- Take an uploaded file and put it into the userfiles directory 1200: # input: name of form element, coursedoc=1 means this is for the course 1201: # output: url of file in userspace 1202: 1203: sub clean_filename { 1204: my ($fname)=@_; 1205: # Replace Windows backslashes by forward slashes 1206: $fname=~s/\\/\//g; 1207: # Get rid of everything but the actual filename 1208: $fname=~s/^.*\/([^\/]+)$/$1/; 1209: # Replace spaces by underscores 1210: $fname=~s/\s+/\_/g; 1211: # Replace all other weird characters by nothing 1212: $fname=~s/[^\w\.\-]//g; 1213: # Replace all .\d. sequences with _\d. so they no longer look like version 1214: # numbers 1215: $fname=~s/\.(\d+)(?=\.)/_$1/g; 1216: return $fname; 1217: } 1218: 1219: sub userfileupload { 1220: my ($formname,$coursedoc,$subdir)=@_; 1221: if (!defined($subdir)) { $subdir='unknown'; } 1222: my $fname=$ENV{'form.'.$formname.'.filename'}; 1223: $fname=&clean_filename($fname); 1224: # See if there is anything left 1225: unless ($fname) { return 'error: no uploaded file'; } 1226: chop($ENV{'form.'.$formname}); 1227: if (($formname eq 'screenshot') && ($subdir eq 'helprequests')) { #files uploaded to help request form are handled differently 1228: my $now = time; 1229: my $filepath = 'tmp/helprequests/'.$now; 1230: my @parts=split(/\//,$filepath); 1231: my $fullpath = $perlvar{'lonDaemons'}; 1232: for (my $i=0;$i<@parts;$i++) { 1233: $fullpath .= '/'.$parts[$i]; 1234: if ((-e $fullpath)!=1) { 1235: mkdir($fullpath,0777); 1236: } 1237: } 1238: open(my $fh,'>'.$fullpath.'/'.$fname); 1239: print $fh $ENV{'form.'.$formname}; 1240: close($fh); 1241: return $fullpath.'/'.$fname; 1242: } 1243: # Create the directory if not present 1244: my $docuname=''; 1245: my $docudom=''; 1246: my $docuhome=''; 1247: $fname="$subdir/$fname"; 1248: if ($coursedoc) { 1249: $docuname=$ENV{'course.'.$ENV{'request.course.id'}.'.num'}; 1250: $docudom=$ENV{'course.'.$ENV{'request.course.id'}.'.domain'}; 1251: $docuhome=$ENV{'course.'.$ENV{'request.course.id'}.'.home'}; 1252: if ($ENV{'form.folder'} =~ m/^default/) { 1253: return &finishuserfileupload($docuname,$docudom,$docuhome,$formname,$fname); 1254: } else { 1255: $fname=$ENV{'form.folder'}.'/'.$fname; 1256: return &process_coursefile('uploaddoc',$docuname,$docudom,$docuhome,$fname,$formname); 1257: } 1258: } else { 1259: $docuname=$ENV{'user.name'}; 1260: $docudom=$ENV{'user.domain'}; 1261: $docuhome=$ENV{'user.home'}; 1262: return &finishuserfileupload($docuname,$docudom,$docuhome,$formname,$fname); 1263: } 1264: } 1265: 1266: sub finishuserfileupload { 1267: my ($docuname,$docudom,$docuhome,$formname,$fname)=@_; 1268: my $path=$docudom.'/'.$docuname.'/'; 1269: my $filepath=$perlvar{'lonDocRoot'}; 1270: my ($fnamepath,$file); 1271: $file=$fname; 1272: if ($fname=~m|/|) { 1273: ($fnamepath,$file) = ($fname =~ m|^(.*)/([^/]+)$|); 1274: $path.=$fnamepath.'/'; 1275: } 1276: my @parts=split(/\//,$filepath.'/userfiles/'.$path); 1277: my $count; 1278: for ($count=4;$count<=$#parts;$count++) { 1279: $filepath.="/$parts[$count]"; 1280: if ((-e $filepath)!=1) { 1281: mkdir($filepath,0777); 1282: } 1283: } 1284: # Save the file 1285: { 1286: open(FH,'>'.$filepath.'/'.$file); 1287: print FH $ENV{'form.'.$formname}; 1288: close(FH); 1289: } 1290: # Notify homeserver to grep it 1291: # 1292: &Apache::lonnet::logthis("fetching ".$path.$file); 1293: my $fetchresult= &reply('fetchuserfile:'.$path.$file,$docuhome); 1294: if ($fetchresult eq 'ok') { 1295: # 1296: # Return the URL to it 1297: return '/uploaded/'.$path.$file; 1298: } else { 1299: &logthis('Failed to transfer '.$path.$file.' to host '.$docuhome. 1300: ': '.$fetchresult); 1301: return '/adm/notfound.html'; 1302: } 1303: } 1304: 1305: sub removeuploadedurl { 1306: my ($url)=@_; 1307: my (undef,undef,$udom,$uname,$fname)=split('/',$url,5); 1308: return &Apache::lonnet::removeuserfile($uname,$udom,$fname); 1309: } 1310: 1311: sub removeuserfile { 1312: my ($docuname,$docudom,$fname)=@_; 1313: my $home=&homeserver($docuname,$docudom); 1314: return &reply("removeuserfile:$docudom/$docuname/$fname",$home); 1315: } 1316: 1317: sub mkdiruserfile { 1318: my ($docuname,$docudom,$dir)=@_; 1319: my $home=&homeserver($docuname,$docudom); 1320: return &reply("mkdiruserfile:".&escape("$docudom/$docuname/$dir"),$home); 1321: } 1322: 1323: sub renameuserfile { 1324: my ($docuname,$docudom,$old,$new)=@_; 1325: my $home=&homeserver($docuname,$docudom); 1326: return &reply("renameuserfile:$docudom:$docuname:".&escape("$old").':'. 1327: &escape("$new"),$home); 1328: } 1329: 1330: # ------------------------------------------------------------------------- Log 1331: 1332: sub log { 1333: my ($dom,$nam,$hom,$what)=@_; 1334: return critical("log:$dom:$nam:$what",$hom); 1335: } 1336: 1337: # ------------------------------------------------------------------ Course Log 1338: # 1339: # This routine flushes several buffers of non-mission-critical nature 1340: # 1341: 1342: sub flushcourselogs { 1343: &logthis('Flushing log buffers'); 1344: # 1345: # course logs 1346: # This is a log of all transactions in a course, which can be used 1347: # for data mining purposes 1348: # 1349: # It also collects the courseid database, which lists last transaction 1350: # times and course titles for all courseids 1351: # 1352: my %courseidbuffer=(); 1353: foreach (keys %courselogs) { 1354: my $crsid=$_; 1355: if (&reply('log:'.$coursedombuf{$crsid}.':'.$coursenumbuf{$crsid}.':'. 1356: &escape($courselogs{$crsid}), 1357: $coursehombuf{$crsid}) eq 'ok') { 1358: delete $courselogs{$crsid}; 1359: } else { 1360: &logthis('Failed to flush log buffer for '.$crsid); 1361: if (length($courselogs{$crsid})>40000) { 1362: &logthis("WARNING: Buffer for ".$crsid. 1363: " exceeded maximum size, deleting."); 1364: delete $courselogs{$crsid}; 1365: } 1366: } 1367: if ($courseidbuffer{$coursehombuf{$crsid}}) { 1368: $courseidbuffer{$coursehombuf{$crsid}}.='&'. 1369: &escape($crsid).'='.&escape($coursedescrbuf{$crsid}). 1370: ':'.&escape($courseinstcodebuf{$crsid}).':'.&escape($courseownerbuf{$crsid}); 1371: } else { 1372: $courseidbuffer{$coursehombuf{$crsid}}= 1373: &escape($crsid).'='.&escape($coursedescrbuf{$crsid}). 1374: ':'.&escape($courseinstcodebuf{$crsid}).':'.&escape($courseownerbuf{$crsid}); 1375: } 1376: } 1377: # 1378: # Write course id database (reverse lookup) to homeserver of courses 1379: # Is used in pickcourse 1380: # 1381: foreach (keys %courseidbuffer) { 1382: &courseidput($hostdom{$_},$courseidbuffer{$_},$_); 1383: } 1384: # 1385: # File accesses 1386: # Writes to the dynamic metadata of resources to get hit counts, etc. 1387: # 1388: foreach my $entry (keys(%accesshash)) { 1389: if ($entry =~ /___count$/) { 1390: my ($dom,$name); 1391: ($dom,$name,undef)=($entry=~m:___(\w+)/(\w+)/(.*)___count$:); 1392: if (! defined($dom) || $dom eq '' || 1393: ! defined($name) || $name eq '') { 1394: my $cid = $ENV{'request.course.id'}; 1395: $dom = $ENV{'request.'.$cid.'.domain'}; 1396: $name = $ENV{'request.'.$cid.'.num'}; 1397: } 1398: my $value = $accesshash{$entry}; 1399: my (undef,$url,undef) = ($entry =~ /^(.*)___(.*)___count$/); 1400: my %temphash=($url => $value); 1401: my $result = &inc('nohist_accesscount',\%temphash,$dom,$name); 1402: if ($result eq 'ok') { 1403: delete $accesshash{$entry}; 1404: } elsif ($result eq 'unknown_cmd') { 1405: # Target server has old code running on it. 1406: my %temphash=($entry => $value); 1407: if (&put('nohist_resevaldata',\%temphash,$dom,$name) eq 'ok') { 1408: delete $accesshash{$entry}; 1409: } 1410: } 1411: } else { 1412: my ($dom,$name) = ($entry=~m:___(\w+)/(\w+)/(.*)___(\w+)$:); 1413: my %temphash=($entry => $accesshash{$entry}); 1414: if (&put('nohist_resevaldata',\%temphash,$dom,$name) eq 'ok') { 1415: delete $accesshash{$entry}; 1416: } 1417: } 1418: } 1419: # 1420: # Roles 1421: # Reverse lookup of user roles for course faculty/staff and co-authorship 1422: # 1423: foreach (keys %userrolehash) { 1424: my $entry=$_; 1425: my ($role,$uname,$udom,$runame,$rudom,$rsec)= 1426: split(/\:/,$entry); 1427: if (&Apache::lonnet::put('nohist_userroles', 1428: { $role.':'.$uname.':'.$udom.':'.$rsec => $userrolehash{$entry} }, 1429: $rudom,$runame) eq 'ok') { 1430: delete $userrolehash{$entry}; 1431: } 1432: } 1433: $dumpcount++; 1434: } 1435: 1436: sub courselog { 1437: my $what=shift; 1438: $what=time.':'.$what; 1439: unless ($ENV{'request.course.id'}) { return ''; } 1440: $coursedombuf{$ENV{'request.course.id'}}= 1441: $ENV{'course.'.$ENV{'request.course.id'}.'.domain'}; 1442: $coursenumbuf{$ENV{'request.course.id'}}= 1443: $ENV{'course.'.$ENV{'request.course.id'}.'.num'}; 1444: $coursehombuf{$ENV{'request.course.id'}}= 1445: $ENV{'course.'.$ENV{'request.course.id'}.'.home'}; 1446: $coursedescrbuf{$ENV{'request.course.id'}}= 1447: $ENV{'course.'.$ENV{'request.course.id'}.'.description'}; 1448: $courseinstcodebuf{$ENV{'request.course.id'}}= 1449: $ENV{'course.'.$ENV{'request.course.id'}.'.internal.coursecode'}; 1450: $courseownerbuf{$ENV{'request.course.id'}}= 1451: $ENV{'course.'.$ENV{'request.course.id'}.'.internal.courseowner'}; 1452: if (defined $courselogs{$ENV{'request.course.id'}}) { 1453: $courselogs{$ENV{'request.course.id'}}.='&'.$what; 1454: } else { 1455: $courselogs{$ENV{'request.course.id'}}.=$what; 1456: } 1457: if (length($courselogs{$ENV{'request.course.id'}})>4048) { 1458: &flushcourselogs(); 1459: } 1460: } 1461: 1462: sub courseacclog { 1463: my $fnsymb=shift; 1464: unless ($ENV{'request.course.id'}) { return ''; } 1465: my $what=$fnsymb.':'.$ENV{'user.name'}.':'.$ENV{'user.domain'}; 1466: if ($fnsymb=~/(problem|exam|quiz|assess|survey|form|page)$/) { 1467: $what.=':POST'; 1468: # FIXME: Probably ought to escape things.... 1469: foreach (keys %ENV) { 1470: if ($_=~/^form\.(.*)/) { 1471: $what.=':'.$1.'='.$ENV{$_}; 1472: } 1473: } 1474: } elsif ($fnsymb =~ m:^/adm/searchcat:) { 1475: # FIXME: We should not be depending on a form parameter that someone 1476: # editing lonsearchcat.pm might change in the future. 1477: if ($ENV{'form.phase'} eq 'course_search') { 1478: $what.= ':POST'; 1479: # FIXME: Probably ought to escape things.... 1480: foreach my $element ('courseexp','crsfulltext','crsrelated', 1481: 'crsdiscuss') { 1482: $what.=':'.$element.'='.$ENV{'form.'.$element}; 1483: } 1484: } 1485: } 1486: &courselog($what); 1487: } 1488: 1489: sub countacc { 1490: my $url=&declutter(shift); 1491: return if (! defined($url) || $url eq ''); 1492: unless ($ENV{'request.course.id'}) { return ''; } 1493: $accesshash{$ENV{'request.course.id'}.'___'.$url.'___course'}=1; 1494: my $key=$$.$processmarker.'_'.$dumpcount.'___'.$url.'___count'; 1495: $accesshash{$key}++; 1496: } 1497: 1498: sub linklog { 1499: my ($from,$to)=@_; 1500: $from=&declutter($from); 1501: $to=&declutter($to); 1502: $accesshash{$from.'___'.$to.'___comefrom'}=1; 1503: $accesshash{$to.'___'.$from.'___goto'}=1; 1504: } 1505: 1506: sub userrolelog { 1507: my ($trole,$username,$domain,$area,$tstart,$tend)=@_; 1508: if (($trole=~/^ca/) || ($trole=~/^in/) || 1509: ($trole=~/^cc/) || ($trole=~/^ep/) || 1510: ($trole=~/^cr/) || ($trole=~/^ta/)) { 1511: my (undef,$rudom,$runame,$rsec)=split(/\//,$area); 1512: $userrolehash 1513: {$trole.':'.$username.':'.$domain.':'.$runame.':'.$rudom.':'.$rsec} 1514: =$tend.':'.$tstart; 1515: } 1516: } 1517: 1518: sub get_course_adv_roles { 1519: my $cid=shift; 1520: $cid=$ENV{'request.course.id'} unless (defined($cid)); 1521: my %coursehash=&coursedescription($cid); 1522: my %nothide=(); 1523: foreach (split(/\s*\,\s*/,$coursehash{'nothideprivileged'})) { 1524: $nothide{join(':',split(/[\@\:]/,$_))}=1; 1525: } 1526: my %returnhash=(); 1527: my %dumphash= 1528: &dump('nohist_userroles',$coursehash{'domain'},$coursehash{'num'}); 1529: my $now=time; 1530: foreach (keys %dumphash) { 1531: my ($tend,$tstart)=split(/\:/,$dumphash{$_}); 1532: if (($tstart) && ($tstart<0)) { next; } 1533: if (($tend) && ($tend<$now)) { next; } 1534: if (($tstart) && ($now<$tstart)) { next; } 1535: my ($role,$username,$domain,$section)=split(/\:/,$_); 1536: if ($username eq '' || $domain eq '') { next; } 1537: if ((&privileged($username,$domain)) && 1538: (!$nothide{$username.':'.$domain})) { next; } 1539: my $key=&plaintext($role); 1540: if ($section) { $key.=' (Sec/Grp '.$section.')'; } 1541: if ($returnhash{$key}) { 1542: $returnhash{$key}.=','.$username.':'.$domain; 1543: } else { 1544: $returnhash{$key}=$username.':'.$domain; 1545: } 1546: } 1547: return %returnhash; 1548: } 1549: 1550: sub get_my_roles { 1551: my ($uname,$udom)=@_; 1552: unless (defined($uname)) { $uname=$ENV{'user.name'}; } 1553: unless (defined($udom)) { $udom=$ENV{'user.domain'}; } 1554: my %dumphash= 1555: &dump('nohist_userroles',$udom,$uname); 1556: my %returnhash=(); 1557: my $now=time; 1558: foreach (keys %dumphash) { 1559: my ($tend,$tstart)=split(/\:/,$dumphash{$_}); 1560: if (($tstart) && ($tstart<0)) { next; } 1561: if (($tend) && ($tend<$now)) { next; } 1562: if (($tstart) && ($now<$tstart)) { next; } 1563: my ($role,$username,$domain,$section)=split(/\:/,$_); 1564: $returnhash{$username.':'.$domain.':'.$role}=$tstart.':'.$tend; 1565: } 1566: return %returnhash; 1567: } 1568: 1569: # ----------------------------------------------------- Frontpage Announcements 1570: # 1571: # 1572: 1573: sub postannounce { 1574: my ($server,$text)=@_; 1575: unless (&allowed('psa',$hostdom{$server})) { return 'refused'; } 1576: unless ($text=~/\w/) { $text=''; } 1577: return &reply('setannounce:'.&escape($text),$server); 1578: } 1579: 1580: sub getannounce { 1581: 1582: if (open(my $fh,$perlvar{'lonDocRoot'}.'/announcement.txt')) { 1583: my $announcement=''; 1584: while (<$fh>) { $announcement .=$_; } 1585: close($fh); 1586: if ($announcement=~/\w/) { 1587: return 1588: '<table bgcolor="#FF5555" cellpadding="5" cellspacing="3">'. 1589: '<tr><td bgcolor="#FFFFFF"><tt>'.$announcement.'</tt></td></tr></table>'; 1590: } else { 1591: return ''; 1592: } 1593: } else { 1594: return ''; 1595: } 1596: } 1597: 1598: # ---------------------------------------------------------- Course ID routines 1599: # Deal with domain's nohist_courseid.db files 1600: # 1601: 1602: sub courseidput { 1603: my ($domain,$what,$coursehome)=@_; 1604: return &reply('courseidput:'.$domain.':'.$what,$coursehome); 1605: } 1606: 1607: sub courseiddump { 1608: my ($domfilter,$descfilter,$sincefilter,$instcodefilter,$ownerfilter,$hostidflag,$hostidref)=@_; 1609: my %returnhash=(); 1610: unless ($domfilter) { $domfilter=''; } 1611: foreach my $tryserver (keys %libserv) { 1612: if ( ($hostidflag == 1 && grep/^$tryserver$/,@{$hostidref}) || (!defined($hostidflag)) ) { 1613: if ((!$domfilter) || ($hostdom{$tryserver} eq $domfilter)) { 1614: foreach ( 1615: split(/\&/,&reply('courseiddump:'.$hostdom{$tryserver}.':'. 1616: $sincefilter.':'.&escape($descfilter).':'. 1617: &escape($instcodefilter).':'.&escape($ownerfilter), 1618: $tryserver))) { 1619: my ($key,$value)=split(/\=/,$_); 1620: if (($key) && ($value)) { 1621: $returnhash{&unescape($key)}=$value; 1622: } 1623: } 1624: } 1625: } 1626: } 1627: return %returnhash; 1628: } 1629: 1630: # 1631: # ----------------------------------------------------------- Check out an item 1632: 1633: sub get_first_access { 1634: my ($type,$argsymb)=@_; 1635: my ($symb,$courseid,$udom,$uname)=&Apache::lonxml::whichuser(); 1636: if ($argsymb) { $symb=$argsymb; } 1637: my ($map,$id,$res)=&decode_symb($symb); 1638: if ($type eq 'map') { 1639: $res=&symbread($map); 1640: } else { 1641: $res=$symb; 1642: } 1643: my %times=&get('firstaccesstimes',["$courseid\0$res"],$udom,$uname); 1644: return $times{"$courseid\0$res"}; 1645: } 1646: 1647: sub set_first_access { 1648: my ($type)=@_; 1649: my ($symb,$courseid,$udom,$uname)=&Apache::lonxml::whichuser(); 1650: my ($map,$id,$res)=&decode_symb($symb); 1651: if ($type eq 'map') { 1652: $res=&symbread($map); 1653: } else { 1654: $res=$symb; 1655: } 1656: my $firstaccess=&get_first_access($type,$symb); 1657: if (!$firstaccess) { 1658: return &put('firstaccesstimes',{"$courseid\0$res"=>time},$udom,$uname); 1659: } 1660: return 'already_set'; 1661: } 1662: 1663: sub checkout { 1664: my ($symb,$tuname,$tudom,$tcrsid)=@_; 1665: my $now=time; 1666: my $lonhost=$perlvar{'lonHostID'}; 1667: my $infostr=&escape( 1668: 'CHECKOUTTOKEN&'. 1669: $tuname.'&'. 1670: $tudom.'&'. 1671: $tcrsid.'&'. 1672: $symb.'&'. 1673: $now.'&'.$ENV{'REMOTE_ADDR'}); 1674: my $token=&reply('tmpput:'.$infostr,$lonhost); 1675: if ($token=~/^error\:/) { 1676: &logthis("WARNING: ". 1677: "Checkout tmpput failed ".$tudom.' - '.$tuname.' - '.$symb. 1678: ""); 1679: return ''; 1680: } 1681: 1682: $token=~s/^(\d+)\_.*\_(\d+)$/$1\*$2\*$lonhost/; 1683: $token=~tr/a-z/A-Z/; 1684: 1685: my %infohash=('resource.0.outtoken' => $token, 1686: 'resource.0.checkouttime' => $now, 1687: 'resource.0.outremote' => $ENV{'REMOTE_ADDR'}); 1688: 1689: unless (&cstore(\%infohash,$symb,$tcrsid,$tudom,$tuname) eq 'ok') { 1690: return ''; 1691: } else { 1692: &logthis("WARNING: ". 1693: "Checkout cstore failed ".$tudom.' - '.$tuname.' - '.$symb. 1694: ""); 1695: } 1696: 1697: if (&log($tudom,$tuname,&homeserver($tuname,$tudom), 1698: &escape('Checkout '.$infostr.' - '. 1699: $token)) ne 'ok') { 1700: return ''; 1701: } else { 1702: &logthis("WARNING: ". 1703: "Checkout log failed ".$tudom.' - '.$tuname.' - '.$symb. 1704: ""); 1705: } 1706: return $token; 1707: } 1708: 1709: # ------------------------------------------------------------ Check in an item 1710: 1711: sub checkin { 1712: my $token=shift; 1713: my $now=time; 1714: my ($ta,$tb,$lonhost)=split(/\*/,$token); 1715: $lonhost=~tr/A-Z/a-z/; 1716: my $dtoken=$ta.'_'.$hostname{$lonhost}.'_'.$tb; 1717: $dtoken=~s/\W/\_/g; 1718: my ($dummy,$tuname,$tudom,$tcrsid,$symb,$chtim,$rmaddr)= 1719: split(/\&/,&unescape(&reply('tmpget:'.$dtoken,$lonhost))); 1720: 1721: unless (($tuname) && ($tudom)) { 1722: &logthis('Check in '.$token.' ('.$dtoken.') failed'); 1723: return ''; 1724: } 1725: 1726: unless (&allowed('mgr',$tcrsid)) { 1727: &logthis('Check in '.$token.' ('.$dtoken.') unauthorized: '. 1728: $ENV{'user.name'}.' - '.$ENV{'user.domain'}); 1729: return ''; 1730: } 1731: 1732: my %infohash=('resource.0.intoken' => $token, 1733: 'resource.0.checkintime' => $now, 1734: 'resource.0.inremote' => $ENV{'REMOTE_ADDR'}); 1735: 1736: unless (&cstore(\%infohash,$symb,$tcrsid,$tudom,$tuname) eq 'ok') { 1737: return ''; 1738: } 1739: 1740: if (&log($tudom,$tuname,&homeserver($tuname,$tudom), 1741: &escape('Checkin - '.$token)) ne 'ok') { 1742: return ''; 1743: } 1744: 1745: return ($symb,$tuname,$tudom,$tcrsid); 1746: } 1747: 1748: # --------------------------------------------- Set Expire Date for Spreadsheet 1749: 1750: sub expirespread { 1751: my ($uname,$udom,$stype,$usymb)=@_; 1752: my $cid=$ENV{'request.course.id'}; 1753: if ($cid) { 1754: my $now=time; 1755: my $key=$uname.':'.$udom.':'.$stype.':'.$usymb; 1756: return &reply('put:'.$ENV{'course.'.$cid.'.domain'}.':'. 1757: $ENV{'course.'.$cid.'.num'}. 1758: ':nohist_expirationdates:'. 1759: &escape($key).'='.$now, 1760: $ENV{'course.'.$cid.'.home'}) 1761: } 1762: return 'ok'; 1763: } 1764: 1765: # ----------------------------------------------------- Devalidate Spreadsheets 1766: 1767: sub devalidate { 1768: my ($symb,$uname,$udom)=@_; 1769: my $cid=$ENV{'request.course.id'}; 1770: if ($cid) { 1771: # delete the stored spreadsheets for 1772: # - the student level sheet of this user in course's homespace 1773: # - the assessment level sheet for this resource 1774: # for this user in user's homespace 1775: # - current conditional state info 1776: my $key=$uname.':'.$udom.':'; 1777: my $status= 1778: &del('nohist_calculatedsheets', 1779: [$key.'studentcalc:'], 1780: $ENV{'course.'.$cid.'.domain'}, 1781: $ENV{'course.'.$cid.'.num'}) 1782: .' '. 1783: &del('nohist_calculatedsheets_'.$cid, 1784: [$key.'assesscalc:'.$symb],$udom,$uname); 1785: unless ($status eq 'ok ok') { 1786: &logthis('Could not devalidate spreadsheet '. 1787: $uname.' at '.$udom.' for '. 1788: $symb.': '.$status); 1789: } 1790: &delenv('user.state.'.$cid); 1791: } 1792: } 1793: 1794: sub get_scalar { 1795: my ($string,$end) = @_; 1796: my $value; 1797: if ($$string =~ s/^([^&]*?)($end)/$2/) { 1798: $value = $1; 1799: } elsif ($$string =~ s/^([^&]*?)&//) { 1800: $value = $1; 1801: } 1802: return &unescape($value); 1803: } 1804: 1805: sub array2str { 1806: my (@array) = @_; 1807: my $result=&arrayref2str(\@array); 1808: $result=~s/^__ARRAY_REF__//; 1809: $result=~s/__END_ARRAY_REF__$//; 1810: return $result; 1811: } 1812: 1813: sub arrayref2str { 1814: my ($arrayref) = @_; 1815: my $result='__ARRAY_REF__'; 1816: foreach my $elem (@$arrayref) { 1817: if(ref($elem) eq 'ARRAY') { 1818: $result.=&arrayref2str($elem).'&'; 1819: } elsif(ref($elem) eq 'HASH') { 1820: $result.=&hashref2str($elem).'&'; 1821: } elsif(ref($elem)) { 1822: #print("Got a ref of ".(ref($elem))." skipping."); 1823: } else { 1824: $result.=&escape($elem).'&'; 1825: } 1826: } 1827: $result=~s/\&$//; 1828: $result .= '__END_ARRAY_REF__'; 1829: return $result; 1830: } 1831: 1832: sub hash2str { 1833: my (%hash) = @_; 1834: my $result=&hashref2str(\%hash); 1835: $result=~s/^__HASH_REF__//; 1836: $result=~s/__END_HASH_REF__$//; 1837: return $result; 1838: } 1839: 1840: sub hashref2str { 1841: my ($hashref)=@_; 1842: my $result='__HASH_REF__'; 1843: foreach (sort(keys(%$hashref))) { 1844: if (ref($_) eq 'ARRAY') { 1845: $result.=&arrayref2str($_).'='; 1846: } elsif (ref($_) eq 'HASH') { 1847: $result.=&hashref2str($_).'='; 1848: } elsif (ref($_)) { 1849: $result.='='; 1850: #print("Got a ref of ".(ref($_))." skipping."); 1851: } else { 1852: if ($_) {$result.=&escape($_).'=';} else { last; } 1853: } 1854: 1855: if(ref($hashref->{$_}) eq 'ARRAY') { 1856: $result.=&arrayref2str($hashref->{$_}).'&'; 1857: } elsif(ref($hashref->{$_}) eq 'HASH') { 1858: $result.=&hashref2str($hashref->{$_}).'&'; 1859: } elsif(ref($hashref->{$_})) { 1860: $result.='&'; 1861: #print("Got a ref of ".(ref($hashref->{$_}))." skipping."); 1862: } else { 1863: $result.=&escape($hashref->{$_}).'&'; 1864: } 1865: } 1866: $result=~s/\&$//; 1867: $result .= '__END_HASH_REF__'; 1868: return $result; 1869: } 1870: 1871: sub str2hash { 1872: my ($string)=@_; 1873: my ($hash)=&str2hashref('__HASH_REF__'.$string.'__END_HASH_REF__'); 1874: return %$hash; 1875: } 1876: 1877: sub str2hashref { 1878: my ($string) = @_; 1879: 1880: my %hash; 1881: 1882: if($string !~ /^__HASH_REF__/) { 1883: if (! ($string eq '' || !defined($string))) { 1884: $hash{'error'}='Not hash reference'; 1885: } 1886: return (\%hash, $string); 1887: } 1888: 1889: $string =~ s/^__HASH_REF__//; 1890: 1891: while($string !~ /^__END_HASH_REF__/) { 1892: #key 1893: my $key=''; 1894: if($string =~ /^__HASH_REF__/) { 1895: ($key, $string)=&str2hashref($string); 1896: if(defined($key->{'error'})) { 1897: $hash{'error'}='Bad data'; 1898: return (\%hash, $string); 1899: } 1900: } elsif($string =~ /^__ARRAY_REF__/) { 1901: ($key, $string)=&str2arrayref($string); 1902: if($key->[0] eq 'Array reference error') { 1903: $hash{'error'}='Bad data'; 1904: return (\%hash, $string); 1905: } 1906: } else { 1907: $string =~ s/^(.*?)=//; 1908: $key=&unescape($1); 1909: } 1910: $string =~ s/^=//; 1911: 1912: #value 1913: my $value=''; 1914: if($string =~ /^__HASH_REF__/) { 1915: ($value, $string)=&str2hashref($string); 1916: if(defined($value->{'error'})) { 1917: $hash{'error'}='Bad data'; 1918: return (\%hash, $string); 1919: } 1920: } elsif($string =~ /^__ARRAY_REF__/) { 1921: ($value, $string)=&str2arrayref($string); 1922: if($value->[0] eq 'Array reference error') { 1923: $hash{'error'}='Bad data'; 1924: return (\%hash, $string); 1925: } 1926: } else { 1927: $value=&get_scalar(\$string,'__END_HASH_REF__'); 1928: } 1929: $string =~ s/^&//; 1930: 1931: $hash{$key}=$value; 1932: } 1933: 1934: $string =~ s/^__END_HASH_REF__//; 1935: 1936: return (\%hash, $string); 1937: } 1938: 1939: sub str2array { 1940: my ($string)=@_; 1941: my ($array)=&str2arrayref('__ARRAY_REF__'.$string.'__END_ARRAY_REF__'); 1942: return @$array; 1943: } 1944: 1945: sub str2arrayref { 1946: my ($string) = @_; 1947: my @array; 1948: 1949: if($string !~ /^__ARRAY_REF__/) { 1950: if (! ($string eq '' || !defined($string))) { 1951: $array[0]='Array reference error'; 1952: } 1953: return (\@array, $string); 1954: } 1955: 1956: $string =~ s/^__ARRAY_REF__//; 1957: 1958: while($string !~ /^__END_ARRAY_REF__/) { 1959: my $value=''; 1960: if($string =~ /^__HASH_REF__/) { 1961: ($value, $string)=&str2hashref($string); 1962: if(defined($value->{'error'})) { 1963: $array[0] ='Array reference error'; 1964: return (\@array, $string); 1965: } 1966: } elsif($string =~ /^__ARRAY_REF__/) { 1967: ($value, $string)=&str2arrayref($string); 1968: if($value->[0] eq 'Array reference error') { 1969: $array[0] ='Array reference error'; 1970: return (\@array, $string); 1971: } 1972: } else { 1973: $value=&get_scalar(\$string,'__END_ARRAY_REF__'); 1974: } 1975: $string =~ s/^&//; 1976: 1977: push(@array, $value); 1978: } 1979: 1980: $string =~ s/^__END_ARRAY_REF__//; 1981: 1982: return (\@array, $string); 1983: } 1984: 1985: # -------------------------------------------------------------------Temp Store 1986: 1987: sub tmpreset { 1988: my ($symb,$namespace,$domain,$stuname) = @_; 1989: if (!$symb) { 1990: $symb=&symbread(); 1991: if (!$symb) { $symb= $ENV{'request.url'}; } 1992: } 1993: $symb=escape($symb); 1994: 1995: if (!$namespace) { $namespace=$ENV{'request.state'}; } 1996: $namespace=~s/\//\_/g; 1997: $namespace=~s/\W//g; 1998: 1999: if (!$domain) { $domain=$ENV{'user.domain'}; } 2000: if (!$stuname) { $stuname=$ENV{'user.name'}; } 2001: if ($domain eq 'public' && $stuname eq 'public') { 2002: $stuname=$ENV{'REMOTE_ADDR'}; 2003: } 2004: my $path=$perlvar{'lonDaemons'}.'/tmp'; 2005: my %hash; 2006: if (tie(%hash,'GDBM_File', 2007: $path.'/tmpstore_'.$stuname.'_'.$domain.'_'.$namespace.'.db', 2008: &GDBM_WRCREAT(),0640)) { 2009: foreach my $key (keys %hash) { 2010: if ($key=~ /:$symb/) { 2011: delete($hash{$key}); 2012: } 2013: } 2014: } 2015: } 2016: 2017: sub tmpstore { 2018: my ($storehash,$symb,$namespace,$domain,$stuname) = @_; 2019: 2020: if (!$symb) { 2021: $symb=&symbread(); 2022: if (!$symb) { $symb= $ENV{'request.url'}; } 2023: } 2024: $symb=escape($symb); 2025: 2026: if (!$namespace) { 2027: # I don't think we would ever want to store this for a course. 2028: # it seems this will only be used if we don't have a course. 2029: #$namespace=$ENV{'request.course.id'}; 2030: #if (!$namespace) { 2031: $namespace=$ENV{'request.state'}; 2032: #} 2033: } 2034: $namespace=~s/\//\_/g; 2035: $namespace=~s/\W//g; 2036: if (!$domain) { $domain=$ENV{'user.domain'}; } 2037: if (!$stuname) { $stuname=$ENV{'user.name'}; } 2038: if ($domain eq 'public' && $stuname eq 'public') { 2039: $stuname=$ENV{'REMOTE_ADDR'}; 2040: } 2041: my $now=time; 2042: my %hash; 2043: my $path=$perlvar{'lonDaemons'}.'/tmp'; 2044: if (tie(%hash,'GDBM_File', 2045: $path.'/tmpstore_'.$stuname.'_'.$domain.'_'.$namespace.'.db', 2046: &GDBM_WRCREAT(),0640)) { 2047: $hash{"version:$symb"}++; 2048: my $version=$hash{"version:$symb"}; 2049: my $allkeys=''; 2050: foreach my $key (keys(%$storehash)) { 2051: $allkeys.=$key.':'; 2052: $hash{"$version:$symb:$key"}=&freeze_escape($$storehash{$key}); 2053: } 2054: $hash{"$version:$symb:timestamp"}=$now; 2055: $allkeys.='timestamp'; 2056: $hash{"$version:keys:$symb"}=$allkeys; 2057: if (untie(%hash)) { 2058: return 'ok'; 2059: } else { 2060: return "error:$!"; 2061: } 2062: } else { 2063: return "error:$!"; 2064: } 2065: } 2066: 2067: # -----------------------------------------------------------------Temp Restore 2068: 2069: sub tmprestore { 2070: my ($symb,$namespace,$domain,$stuname) = @_; 2071: 2072: if (!$symb) { 2073: $symb=&symbread(); 2074: if (!$symb) { $symb= $ENV{'request.url'}; } 2075: } 2076: $symb=escape($symb); 2077: 2078: if (!$namespace) { $namespace=$ENV{'request.state'}; } 2079: 2080: if (!$domain) { $domain=$ENV{'user.domain'}; } 2081: if (!$stuname) { $stuname=$ENV{'user.name'}; } 2082: if ($domain eq 'public' && $stuname eq 'public') { 2083: $stuname=$ENV{'REMOTE_ADDR'}; 2084: } 2085: my %returnhash; 2086: $namespace=~s/\//\_/g; 2087: $namespace=~s/\W//g; 2088: my %hash; 2089: my $path=$perlvar{'lonDaemons'}.'/tmp'; 2090: if (tie(%hash,'GDBM_File', 2091: $path.'/tmpstore_'.$stuname.'_'.$domain.'_'.$namespace.'.db', 2092: &GDBM_READER(),0640)) { 2093: my $version=$hash{"version:$symb"}; 2094: $returnhash{'version'}=$version; 2095: my $scope; 2096: for ($scope=1;$scope<=$version;$scope++) { 2097: my $vkeys=$hash{"$scope:keys:$symb"}; 2098: my @keys=split(/:/,$vkeys); 2099: my $key; 2100: $returnhash{"$scope:keys"}=$vkeys; 2101: foreach $key (@keys) { 2102: $returnhash{"$scope:$key"}=&thaw_unescape($hash{"$scope:$symb:$key"}); 2103: $returnhash{"$key"}=&thaw_unescape($hash{"$scope:$symb:$key"}); 2104: } 2105: } 2106: if (!(untie(%hash))) { 2107: return "error:$!"; 2108: } 2109: } else { 2110: return "error:$!"; 2111: } 2112: return %returnhash; 2113: } 2114: 2115: # ----------------------------------------------------------------------- Store 2116: 2117: sub store { 2118: my ($storehash,$symb,$namespace,$domain,$stuname) = @_; 2119: my $home=''; 2120: 2121: if ($stuname) { $home=&homeserver($stuname,$domain); } 2122: 2123: $symb=&symbclean($symb); 2124: if (!$symb) { unless ($symb=&symbread()) { return ''; } } 2125: 2126: if (!$domain) { $domain=$ENV{'user.domain'}; } 2127: if (!$stuname) { $stuname=$ENV{'user.name'}; } 2128: 2129: &devalidate($symb,$stuname,$domain); 2130: 2131: $symb=escape($symb); 2132: if (!$namespace) { 2133: unless ($namespace=$ENV{'request.course.id'}) { 2134: return ''; 2135: } 2136: } 2137: if (!$home) { $home=$ENV{'user.home'}; } 2138: 2139: $$storehash{'ip'}=$ENV{'REMOTE_ADDR'}; 2140: $$storehash{'host'}=$perlvar{'lonHostID'}; 2141: 2142: my $namevalue=''; 2143: foreach (keys %$storehash) { 2144: $namevalue.=&escape($_).'='.&freeze_escape($$storehash{$_}).'&'; 2145: } 2146: $namevalue=~s/\&$//; 2147: &courselog($symb.':'.$stuname.':'.$domain.':STORE:'.$namevalue); 2148: return reply("store:$domain:$stuname:$namespace:$symb:$namevalue","$home"); 2149: } 2150: 2151: # -------------------------------------------------------------- Critical Store 2152: 2153: sub cstore { 2154: my ($storehash,$symb,$namespace,$domain,$stuname) = @_; 2155: my $home=''; 2156: 2157: if ($stuname) { $home=&homeserver($stuname,$domain); } 2158: 2159: $symb=&symbclean($symb); 2160: if (!$symb) { unless ($symb=&symbread()) { return ''; } } 2161: 2162: if (!$domain) { $domain=$ENV{'user.domain'}; } 2163: if (!$stuname) { $stuname=$ENV{'user.name'}; } 2164: 2165: &devalidate($symb,$stuname,$domain); 2166: 2167: $symb=escape($symb); 2168: if (!$namespace) { 2169: unless ($namespace=$ENV{'request.course.id'}) { 2170: return ''; 2171: } 2172: } 2173: if (!$home) { $home=$ENV{'user.home'}; } 2174: 2175: $$storehash{'ip'}=$ENV{'REMOTE_ADDR'}; 2176: $$storehash{'host'}=$perlvar{'lonHostID'}; 2177: 2178: my $namevalue=''; 2179: foreach (keys %$storehash) { 2180: $namevalue.=&escape($_).'='.&freeze_escape($$storehash{$_}).'&'; 2181: } 2182: $namevalue=~s/\&$//; 2183: &courselog($symb.':'.$stuname.':'.$domain.':CSTORE:'.$namevalue); 2184: return critical 2185: ("store:$domain:$stuname:$namespace:$symb:$namevalue","$home"); 2186: } 2187: 2188: # --------------------------------------------------------------------- Restore 2189: 2190: sub restore { 2191: my ($symb,$namespace,$domain,$stuname) = @_; 2192: my $home=''; 2193: 2194: if ($stuname) { $home=&homeserver($stuname,$domain); } 2195: 2196: if (!$symb) { 2197: unless ($symb=escape(&symbread())) { return ''; } 2198: } else { 2199: $symb=&escape(&symbclean($symb)); 2200: } 2201: if (!$namespace) { 2202: unless ($namespace=$ENV{'request.course.id'}) { 2203: return ''; 2204: } 2205: } 2206: if (!$domain) { $domain=$ENV{'user.domain'}; } 2207: if (!$stuname) { $stuname=$ENV{'user.name'}; } 2208: if (!$home) { $home=$ENV{'user.home'}; } 2209: my $answer=&reply("restore:$domain:$stuname:$namespace:$symb","$home"); 2210: 2211: my %returnhash=(); 2212: foreach (split(/\&/,$answer)) { 2213: my ($name,$value)=split(/\=/,$_); 2214: $returnhash{&unescape($name)}=&thaw_unescape($value); 2215: } 2216: my $version; 2217: for ($version=1;$version<=$returnhash{'version'};$version++) { 2218: foreach (split(/\:/,$returnhash{$version.':keys'})) { 2219: $returnhash{$_}=$returnhash{$version.':'.$_}; 2220: } 2221: } 2222: return %returnhash; 2223: } 2224: 2225: # ---------------------------------------------------------- Course Description 2226: 2227: sub coursedescription { 2228: my $courseid=shift; 2229: $courseid=~s/^\///; 2230: $courseid=~s/\_/\//g; 2231: my ($cdomain,$cnum)=split(/\//,$courseid); 2232: my $chome=&homeserver($cnum,$cdomain); 2233: my $normalid=$cdomain.'_'.$cnum; 2234: # need to always cache even if we get errors otherwise we keep 2235: # trying and trying and trying to get the course description. 2236: my %envhash=(); 2237: my %returnhash=(); 2238: $envhash{'course.'.$normalid.'.last_cache'}=time; 2239: if ($chome ne 'no_host') { 2240: %returnhash=&dump('environment',$cdomain,$cnum); 2241: if (!exists($returnhash{'con_lost'})) { 2242: $returnhash{'home'}= $chome; 2243: $returnhash{'domain'} = $cdomain; 2244: $returnhash{'num'} = $cnum; 2245: while (my ($name,$value) = each %returnhash) { 2246: $envhash{'course.'.$normalid.'.'.$name}=$value; 2247: } 2248: $returnhash{'url'}=&clutter($returnhash{'url'}); 2249: $returnhash{'fn'}=$perlvar{'lonDaemons'}.'/tmp/'. 2250: $ENV{'user.name'}.'_'.$cdomain.'_'.$cnum; 2251: $envhash{'course.'.$normalid.'.home'}=$chome; 2252: $envhash{'course.'.$normalid.'.domain'}=$cdomain; 2253: $envhash{'course.'.$normalid.'.num'}=$cnum; 2254: } 2255: } 2256: &appenv(%envhash); 2257: return %returnhash; 2258: } 2259: 2260: # -------------------------------------------------See if a user is privileged 2261: 2262: sub privileged { 2263: my ($username,$domain)=@_; 2264: my $rolesdump=&reply("dump:$domain:$username:roles", 2265: &homeserver($username,$domain)); 2266: if (($rolesdump eq 'con_lost') || ($rolesdump eq '')) { return 0; } 2267: my $now=time; 2268: if ($rolesdump ne '') { 2269: foreach (split(/&/,$rolesdump)) { 2270: if ($_!~/^rolesdef_/) { 2271: my ($area,$role)=split(/=/,$_); 2272: $area=~s/\_\w\w$//; 2273: my ($trole,$tend,$tstart)=split(/_/,$role); 2274: if (($trole eq 'dc') || ($trole eq 'su')) { 2275: my $active=1; 2276: if ($tend) { 2277: if ($tend<$now) { $active=0; } 2278: } 2279: if ($tstart) { 2280: if ($tstart>$now) { $active=0; } 2281: } 2282: if ($active) { return 1; } 2283: } 2284: } 2285: } 2286: } 2287: return 0; 2288: } 2289: 2290: # -------------------------------------------------------- Get user privileges 2291: 2292: sub rolesinit { 2293: my ($domain,$username,$authhost)=@_; 2294: my $rolesdump=reply("dump:$domain:$username:roles",$authhost); 2295: if (($rolesdump eq 'con_lost') || ($rolesdump eq '')) { return ''; } 2296: my %allroles=(); 2297: my $now=time; 2298: my $userroles="user.login.time=$now\n"; 2299: 2300: if ($rolesdump ne '') { 2301: foreach (split(/&/,$rolesdump)) { 2302: if ($_!~/^rolesdef_/) { 2303: my ($area,$role)=split(/=/,$_); 2304: $area=~s/\_\w\w$//; 2305: 2306: my ($trole,$tend,$tstart); 2307: if ($role=~/^cr/) { 2308: ($trole,my $trest)=($role=~m|^(cr/\w+/\w+/[a-zA-Z0-9]+)_(.*)$|); 2309: ($tend,$tstart)=split('_',$trest); 2310: } else { 2311: ($trole,$tend,$tstart)=split(/_/,$role); 2312: } 2313: $userroles.=&set_arearole($trole,$area,$tstart,$tend,$domain,$username); 2314: if (($tend!=0) && ($tend<$now)) { $trole=''; } 2315: if (($tstart!=0) && ($tstart>$now)) { $trole=''; } 2316: if (($area ne '') && ($trole ne '')) { 2317: my $spec=$trole.'.'.$area; 2318: my ($tdummy,$tdomain,$trest)=split(/\//,$area); 2319: if ($trole =~ /^cr\//) { 2320: &custom_roleprivs(\%allroles,$trole,$tdomain,$trest,$spec,$area); 2321: } else { 2322: &standard_roleprivs(\%allroles,$trole,$tdomain,$spec,$trest,$area); 2323: } 2324: } 2325: } 2326: } 2327: my ($author,$adv) = &set_userprivs(\$userroles,\%allroles); 2328: $userroles.='user.adv='.$adv."\n". 2329: 'user.author='.$author."\n"; 2330: $ENV{'user.adv'}=$adv; 2331: } 2332: return $userroles; 2333: } 2334: 2335: sub set_arearole { 2336: my ($trole,$area,$tstart,$tend,$domain,$username) = @_; 2337: # log the associated role with the area 2338: &userrolelog($trole,$username,$domain,$area,$tstart,$tend); 2339: return 'user.role.'.$trole.'.'.$area.'='.$tstart.'.'.$tend."\n"; 2340: } 2341: 2342: sub custom_roleprivs { 2343: my ($allroles,$trole,$tdomain,$trest,$spec,$area) = @_; 2344: my ($rdummy,$rdomain,$rauthor,$rrole)=split(/\//,$trole); 2345: my $homsvr=homeserver($rauthor,$rdomain); 2346: if ($hostname{$homsvr} ne '') { 2347: my ($rdummy,$roledef)= 2348: &get('roles',["rolesdef_$rrole"],$rdomain,$rauthor); 2349: if (($rdummy ne 'con_lost') && ($roledef ne '')) { 2350: my ($syspriv,$dompriv,$coursepriv)=split(/\_/,$roledef); 2351: if (defined($syspriv)) { 2352: $$allroles{'cm./'}.=':'.$syspriv; 2353: $$allroles{$spec.'./'}.=':'.$syspriv; 2354: } 2355: if ($tdomain ne '') { 2356: if (defined($dompriv)) { 2357: $$allroles{'cm./'.$tdomain.'/'}.=':'.$dompriv; 2358: $$allroles{$spec.'./'.$tdomain.'/'}.=':'.$dompriv; 2359: } 2360: if (($trest ne '') && (defined($coursepriv))) { 2361: $$allroles{'cm.'.$area}.=':'.$coursepriv; 2362: $$allroles{$spec.'.'.$area}.=':'.$coursepriv; 2363: } 2364: } 2365: } 2366: } 2367: } 2368: 2369: 2370: sub standard_roleprivs { 2371: my ($allroles,$trole,$tdomain,$spec,$trest,$area) = @_; 2372: if (defined($pr{$trole.':s'})) { 2373: $$allroles{'cm./'}.=':'.$pr{$trole.':s'}; 2374: $$allroles{$spec.'./'}.=':'.$pr{$trole.':s'}; 2375: } 2376: if ($tdomain ne '') { 2377: if (defined($pr{$trole.':d'})) { 2378: $$allroles{'cm./'.$tdomain.'/'}.=':'.$pr{$trole.':d'}; 2379: $$allroles{$spec.'./'.$tdomain.'/'}.=':'.$pr{$trole.':d'}; 2380: } 2381: if (($trest ne '') && (defined($pr{$trole.':c'}))) { 2382: $$allroles{'cm.'.$area}.=':'.$pr{$trole.':c'}; 2383: $$allroles{$spec.'.'.$area}.=':'.$pr{$trole.':c'}; 2384: } 2385: } 2386: } 2387: 2388: sub set_userprivs { 2389: my ($userroles,$allroles) = @_; 2390: my $author=0; 2391: my $adv=0; 2392: foreach (keys %{$allroles}) { 2393: my %thesepriv=(); 2394: if (($_=~/^au/) || ($_=~/^ca/)) { $author=1; } 2395: foreach (split(/:/,$$allroles{$_})) { 2396: if ($_ ne '') { 2397: my ($privilege,$restrictions)=split(/&/,$_); 2398: if ($restrictions eq '') { 2399: $thesepriv{$privilege}='F'; 2400: } elsif ($thesepriv{$privilege} ne 'F') { 2401: $thesepriv{$privilege}.=$restrictions; 2402: } 2403: if ($thesepriv{'adv'} eq 'F') { $adv=1; } 2404: } 2405: } 2406: my $thesestr=''; 2407: foreach (keys %thesepriv) { $thesestr.=':'.$_.'&'.$thesepriv{$_}; } 2408: $$userroles.='user.priv.'.$_.'='.$thesestr."\n"; 2409: } 2410: return ($author,$adv); 2411: } 2412: 2413: # --------------------------------------------------------------- get interface 2414: 2415: sub get { 2416: my ($namespace,$storearr,$udomain,$uname)=@_; 2417: my $items=''; 2418: foreach (@$storearr) { 2419: $items.=escape($_).'&'; 2420: } 2421: $items=~s/\&$//; 2422: if (!$udomain) { $udomain=$ENV{'user.domain'}; } 2423: if (!$uname) { $uname=$ENV{'user.name'}; } 2424: my $uhome=&homeserver($uname,$udomain); 2425: 2426: my $rep=&reply("get:$udomain:$uname:$namespace:$items",$uhome); 2427: my @pairs=split(/\&/,$rep); 2428: if ( $#pairs==0 && $pairs[0] =~ /^(con_lost|error|no_such_host)/i) { 2429: return @pairs; 2430: } 2431: my %returnhash=(); 2432: my $i=0; 2433: foreach (@$storearr) { 2434: $returnhash{$_}=&thaw_unescape($pairs[$i]); 2435: $i++; 2436: } 2437: return %returnhash; 2438: } 2439: 2440: # --------------------------------------------------------------- del interface 2441: 2442: sub del { 2443: my ($namespace,$storearr,$udomain,$uname)=@_; 2444: my $items=''; 2445: foreach (@$storearr) { 2446: $items.=escape($_).'&'; 2447: } 2448: $items=~s/\&$//; 2449: if (!$udomain) { $udomain=$ENV{'user.domain'}; } 2450: if (!$uname) { $uname=$ENV{'user.name'}; } 2451: my $uhome=&homeserver($uname,$udomain); 2452: 2453: return &reply("del:$udomain:$uname:$namespace:$items",$uhome); 2454: } 2455: 2456: # -------------------------------------------------------------- dump interface 2457: 2458: sub dump { 2459: my ($namespace,$udomain,$uname,$regexp)=@_; 2460: if (!$udomain) { $udomain=$ENV{'user.domain'}; } 2461: if (!$uname) { $uname=$ENV{'user.name'}; } 2462: my $uhome=&homeserver($uname,$udomain); 2463: if ($regexp) { 2464: $regexp=&escape($regexp); 2465: } else { 2466: $regexp='.'; 2467: } 2468: my $rep=reply("dump:$udomain:$uname:$namespace:$regexp",$uhome); 2469: my @pairs=split(/\&/,$rep); 2470: my %returnhash=(); 2471: foreach (@pairs) { 2472: my ($key,$value)=split(/=/,$_); 2473: $returnhash{unescape($key)}=&thaw_unescape($value); 2474: } 2475: return %returnhash; 2476: } 2477: 2478: # -------------------------------------------------------------- keys interface 2479: 2480: sub getkeys { 2481: my ($namespace,$udomain,$uname)=@_; 2482: if (!$udomain) { $udomain=$ENV{'user.domain'}; } 2483: if (!$uname) { $uname=$ENV{'user.name'}; } 2484: my $uhome=&homeserver($uname,$udomain); 2485: my $rep=reply("keys:$udomain:$uname:$namespace",$uhome); 2486: my @keyarray=(); 2487: foreach (split(/\&/,$rep)) { 2488: push (@keyarray,&unescape($_)); 2489: } 2490: return @keyarray; 2491: } 2492: 2493: # --------------------------------------------------------------- currentdump 2494: sub currentdump { 2495: my ($courseid,$sdom,$sname)=@_; 2496: $courseid = $ENV{'request.course.id'} if (! defined($courseid)); 2497: $sdom = $ENV{'user.domain'} if (! defined($sdom)); 2498: $sname = $ENV{'user.name'} if (! defined($sname)); 2499: my $uhome = &homeserver($sname,$sdom); 2500: my $rep=reply('currentdump:'.$sdom.':'.$sname.':'.$courseid,$uhome); 2501: return if ($rep =~ /^(error:|no_such_host)/); 2502: # 2503: my %returnhash=(); 2504: # 2505: if ($rep eq "unknown_cmd") { 2506: # an old lond will not know currentdump 2507: # Do a dump and make it look like a currentdump 2508: my @tmp = &dump($courseid,$sdom,$sname,'.'); 2509: return if ($tmp[0] =~ /^(error:|no_such_host)/); 2510: my %hash = @tmp; 2511: @tmp=(); 2512: %returnhash = %{&convert_dump_to_currentdump(\%hash)}; 2513: } else { 2514: my @pairs=split(/\&/,$rep); 2515: foreach (@pairs) { 2516: my ($key,$value)=split(/=/,$_); 2517: my ($symb,$param) = split(/:/,$key); 2518: $returnhash{&unescape($symb)}->{&unescape($param)} = 2519: &thaw_unescape($value); 2520: } 2521: } 2522: return %returnhash; 2523: } 2524: 2525: sub convert_dump_to_currentdump{ 2526: my %hash = %{shift()}; 2527: my %returnhash; 2528: # Code ripped from lond, essentially. The only difference 2529: # here is the unescaping done by lonnet::dump(). Conceivably 2530: # we might run in to problems with parameter names =~ /^v\./ 2531: while (my ($key,$value) = each(%hash)) { 2532: my ($v,$symb,$param) = split(/:/,$key); 2533: next if ($v eq 'version' || $symb eq 'keys'); 2534: next if (exists($returnhash{$symb}) && 2535: exists($returnhash{$symb}->{$param}) && 2536: $returnhash{$symb}->{'v.'.$param} > $v); 2537: $returnhash{$symb}->{$param}=$value; 2538: $returnhash{$symb}->{'v.'.$param}=$v; 2539: } 2540: # 2541: # Remove all of the keys in the hashes which keep track of 2542: # the version of the parameter. 2543: while (my ($symb,$param_hash) = each(%returnhash)) { 2544: # use a foreach because we are going to delete from the hash. 2545: foreach my $key (keys(%$param_hash)) { 2546: delete($param_hash->{$key}) if ($key =~ /^v\./); 2547: } 2548: } 2549: return \%returnhash; 2550: } 2551: 2552: # --------------------------------------------------------------- inc interface 2553: 2554: sub inc { 2555: my ($namespace,$store,$udomain,$uname) = @_; 2556: if (!$udomain) { $udomain=$ENV{'user.domain'}; } 2557: if (!$uname) { $uname=$ENV{'user.name'}; } 2558: my $uhome=&homeserver($uname,$udomain); 2559: my $items=''; 2560: if (! ref($store)) { 2561: # got a single value, so use that instead 2562: $items = &escape($store).'=&'; 2563: } elsif (ref($store) eq 'SCALAR') { 2564: $items = &escape($$store).'=&'; 2565: } elsif (ref($store) eq 'ARRAY') { 2566: $items = join('=&',map {&escape($_);} @{$store}); 2567: } elsif (ref($store) eq 'HASH') { 2568: while (my($key,$value) = each(%{$store})) { 2569: $items.= &escape($key).'='.&escape($value).'&'; 2570: } 2571: } 2572: $items=~s/\&$//; 2573: return &reply("inc:$udomain:$uname:$namespace:$items",$uhome); 2574: } 2575: 2576: # --------------------------------------------------------------- put interface 2577: 2578: sub put { 2579: my ($namespace,$storehash,$udomain,$uname)=@_; 2580: if (!$udomain) { $udomain=$ENV{'user.domain'}; } 2581: if (!$uname) { $uname=$ENV{'user.name'}; } 2582: my $uhome=&homeserver($uname,$udomain); 2583: my $items=''; 2584: foreach (keys %$storehash) { 2585: $items.=&escape($_).'='.&freeze_escape($$storehash{$_}).'&'; 2586: } 2587: $items=~s/\&$//; 2588: return &reply("put:$udomain:$uname:$namespace:$items",$uhome); 2589: } 2590: 2591: # ---------------------------------------------------------- putstore interface 2592: 2593: sub putstore { 2594: my ($namespace,$storehash,$udomain,$uname)=@_; 2595: if (!$udomain) { $udomain=$ENV{'user.domain'}; } 2596: if (!$uname) { $uname=$ENV{'user.name'}; } 2597: my $uhome=&homeserver($uname,$udomain); 2598: my $items=''; 2599: my %allitems = (); 2600: foreach (keys %$storehash) { 2601: if ($_ =~ m/^([^\:]+):([^\:]+):([^\:]+)$/) { 2602: my $key = $1.':keys:'.$2; 2603: $allitems{$key} .= $3.':'; 2604: } 2605: $items.=$_.'='.&freeze_escape($$storehash{$_}).'&'; 2606: } 2607: foreach (keys %allitems) { 2608: $allitems{$_} =~ s/\:$//; 2609: $items.= $_.'='.$allitems{$_}.'&'; 2610: } 2611: $items=~s/\&$//; 2612: return &reply("put:$udomain:$uname:$namespace:$items",$uhome); 2613: } 2614: 2615: # ------------------------------------------------------ critical put interface 2616: 2617: sub cput { 2618: my ($namespace,$storehash,$udomain,$uname)=@_; 2619: if (!$udomain) { $udomain=$ENV{'user.domain'}; } 2620: if (!$uname) { $uname=$ENV{'user.name'}; } 2621: my $uhome=&homeserver($uname,$udomain); 2622: my $items=''; 2623: foreach (keys %$storehash) { 2624: $items.=escape($_).'='.&freeze_escape($$storehash{$_}).'&'; 2625: } 2626: $items=~s/\&$//; 2627: return &critical("put:$udomain:$uname:$namespace:$items",$uhome); 2628: } 2629: 2630: # -------------------------------------------------------------- eget interface 2631: 2632: sub eget { 2633: my ($namespace,$storearr,$udomain,$uname)=@_; 2634: my $items=''; 2635: foreach (@$storearr) { 2636: $items.=escape($_).'&'; 2637: } 2638: $items=~s/\&$//; 2639: if (!$udomain) { $udomain=$ENV{'user.domain'}; } 2640: if (!$uname) { $uname=$ENV{'user.name'}; } 2641: my $uhome=&homeserver($uname,$udomain); 2642: my $rep=&reply("eget:$udomain:$uname:$namespace:$items",$uhome); 2643: my @pairs=split(/\&/,$rep); 2644: my %returnhash=(); 2645: my $i=0; 2646: foreach (@$storearr) { 2647: $returnhash{$_}=&thaw_unescape($pairs[$i]); 2648: $i++; 2649: } 2650: return %returnhash; 2651: } 2652: 2653: # ---------------------------------------------- Custom access rule evaluation 2654: 2655: sub customaccess { 2656: my ($priv,$uri)=@_; 2657: my ($urole,$urealm)=split(/\./,$ENV{'request.role'}); 2658: $urealm=~s/^\W//; 2659: my ($udom,$ucrs,$usec)=split(/\//,$urealm); 2660: my $access=0; 2661: foreach (split(/\s*\,\s*/,&metadata($uri,'rule_rights'))) { 2662: my ($effect,$realm,$role)=split(/\:/,$_); 2663: if ($role) { 2664: if ($role ne $urole) { next; } 2665: } 2666: foreach (split(/\s*\,\s*/,$realm)) { 2667: my ($tdom,$tcrs,$tsec)=split(/\_/,$_); 2668: if ($tdom) { 2669: if ($tdom ne $udom) { next; } 2670: } 2671: if ($tcrs) { 2672: if ($tcrs ne $ucrs) { next; } 2673: } 2674: if ($tsec) { 2675: if ($tsec ne $usec) { next; } 2676: } 2677: $access=($effect eq 'allow'); 2678: last; 2679: } 2680: if ($realm eq '' && $role eq '') { 2681: $access=($effect eq 'allow'); 2682: } 2683: } 2684: return $access; 2685: } 2686: 2687: # ------------------------------------------------- Check for a user privilege 2688: 2689: sub allowed { 2690: my ($priv,$uri,$symb)=@_; 2691: $uri=&deversion($uri); 2692: my $orguri=$uri; 2693: $uri=&declutter($uri); 2694: 2695: 2696: 2697: if (defined($ENV{'allowed.'.$priv})) { return $ENV{'allowed.'.$priv}; } 2698: # Free bre access to adm and meta resources 2699: if (((($uri=~/^adm\//) && ($uri !~ m|/bulletinboard$|)) 2700: || ($uri=~/\.meta$/)) && ($priv eq 'bre')) { 2701: return 'F'; 2702: } 2703: 2704: # Free bre access to user's own portfolio contents 2705: my ($space,$domain,$name,$dir)=split('/',$uri); 2706: if (('uploaded' eq $space) && ($ENV{'user.name'} eq $name) && 2707: ($ENV{'user.domain'} eq $domain) && ('portfolio' eq $dir)) { 2708: return 'F'; 2709: } 2710: 2711: # Free bre to public access 2712: 2713: if ($priv eq 'bre') { 2714: my $copyright=&metadata($uri,'copyright'); 2715: if (($copyright eq 'public') && (!$ENV{'request.course.id'})) { 2716: return 'F'; 2717: } 2718: if ($copyright eq 'priv') { 2719: $uri=~/([^\/]+)\/([^\/]+)\//; 2720: unless (($ENV{'user.name'} eq $2) && ($ENV{'user.domain'} eq $1)) { 2721: return ''; 2722: } 2723: } 2724: if ($copyright eq 'domain') { 2725: $uri=~/([^\/]+)\/([^\/]+)\//; 2726: unless (($ENV{'user.domain'} eq $1) || 2727: ($ENV{'course.'.$ENV{'request.course.id'}.'.domain'} eq $1)) { 2728: return ''; 2729: } 2730: } 2731: if ($ENV{'request.role'}=~ /li\.\//) { 2732: # Library role, so allow browsing of resources in this domain. 2733: return 'F'; 2734: } 2735: if ($copyright eq 'custom') { 2736: unless (&customaccess($priv,$uri)) { return ''; } 2737: } 2738: } 2739: # Domain coordinator is trying to create a course 2740: if (($priv eq 'ccc') && ($ENV{'request.role'} =~ /^dc\./)) { 2741: # uri is the requested domain in this case. 2742: # comparison to 'request.role.domain' shows if the user has selected 2743: # a role of dc for the domain in question. 2744: return 'F' if ($uri eq $ENV{'request.role.domain'}); 2745: } 2746: 2747: my $thisallowed=''; 2748: my $statecond=0; 2749: my $courseprivid=''; 2750: 2751: # Course 2752: 2753: if ($ENV{'user.priv.'.$ENV{'request.role'}.'./'}=~/\Q$priv\E\&([^\:]*)/) { 2754: $thisallowed.=$1; 2755: } 2756: 2757: # Domain 2758: 2759: if ($ENV{'user.priv.'.$ENV{'request.role'}.'./'.(split(/\//,$uri))[0].'/'} 2760: =~/\Q$priv\E\&([^\:]*)/) { 2761: $thisallowed.=$1; 2762: } 2763: 2764: # Course: uri itself is a course 2765: my $courseuri=$uri; 2766: $courseuri=~s/\_(\d)/\/$1/; 2767: $courseuri=~s/^([^\/])/\/$1/; 2768: 2769: if ($ENV{'user.priv.'.$ENV{'request.role'}.'.'.$courseuri} 2770: =~/\Q$priv\E\&([^\:]*)/) { 2771: $thisallowed.=$1; 2772: } 2773: 2774: # URI is an uploaded document for this course 2775: 2776: if (($priv eq 'bre') && ($uri=~m|^uploaded/|)) { 2777: my $refuri=$ENV{'httpref.'.$orguri}; 2778: if ($refuri) { 2779: if ($refuri =~ m|^/adm/|) { 2780: $thisallowed='F'; 2781: } 2782: } 2783: } 2784: 2785: # Full access at system, domain or course-wide level? Exit. 2786: 2787: if ($thisallowed=~/F/) { 2788: return 'F'; 2789: } 2790: 2791: # If this is generating or modifying users, exit with special codes 2792: 2793: if (':csu:cdc:ccc:cin:cta:cep:ccr:cst:cad:cli:cau:cdg:cca:'=~/\:\Q$priv\E\:/) { 2794: return $thisallowed; 2795: } 2796: # 2797: # Gathered so far: system, domain and course wide privileges 2798: # 2799: # Course: See if uri or referer is an individual resource that is part of 2800: # the course 2801: 2802: if ($ENV{'request.course.id'}) { 2803: 2804: $courseprivid=$ENV{'request.course.id'}; 2805: if ($ENV{'request.course.sec'}) { 2806: $courseprivid.='/'.$ENV{'request.course.sec'}; 2807: } 2808: $courseprivid=~s/\_/\//; 2809: my $checkreferer=1; 2810: my ($match,$cond)=&is_on_map($uri); 2811: if ($match) { 2812: $statecond=$cond; 2813: if ($ENV{'user.priv.'.$ENV{'request.role'}.'./'.$courseprivid} 2814: =~/\Q$priv\E\&([^\:]*)/) { 2815: $thisallowed.=$1; 2816: $checkreferer=0; 2817: } 2818: } 2819: 2820: if ($checkreferer) { 2821: my $refuri=$ENV{'httpref.'.$orguri}; 2822: unless ($refuri) { 2823: foreach (keys %ENV) { 2824: if ($_=~/^httpref\..*\*/) { 2825: my $pattern=$_; 2826: $pattern=~s/^httpref\.\/res\///; 2827: $pattern=~s/\*/\[\^\/\]\+/g; 2828: $pattern=~s/\//\\\//g; 2829: if ($orguri=~/$pattern/) { 2830: $refuri=$ENV{$_}; 2831: } 2832: } 2833: } 2834: } 2835: 2836: if ($refuri) { 2837: $refuri=&declutter($refuri); 2838: my ($match,$cond)=&is_on_map($refuri); 2839: if ($match) { 2840: my $refstatecond=$cond; 2841: if ($ENV{'user.priv.'.$ENV{'request.role'}.'./'.$courseprivid} 2842: =~/\Q$priv\E\&([^\:]*)/) { 2843: $thisallowed.=$1; 2844: $uri=$refuri; 2845: $statecond=$refstatecond; 2846: } 2847: } 2848: } 2849: } 2850: } 2851: 2852: # 2853: # Gathered now: all privileges that could apply, and condition number 2854: # 2855: # 2856: # Full or no access? 2857: # 2858: 2859: if ($thisallowed=~/F/) { 2860: return 'F'; 2861: } 2862: 2863: unless ($thisallowed) { 2864: return ''; 2865: } 2866: 2867: # Restrictions exist, deal with them 2868: # 2869: # C:according to course preferences 2870: # R:according to resource settings 2871: # L:unless locked 2872: # X:according to user session state 2873: # 2874: 2875: # Possibly locked functionality, check all courses 2876: # Locks might take effect only after 10 minutes cache expiration for other 2877: # courses, and 2 minutes for current course 2878: 2879: my $envkey; 2880: if ($thisallowed=~/L/) { 2881: foreach $envkey (keys %ENV) { 2882: if ($envkey=~/^user\.role\.(st|ta)\.([^\.]*)/) { 2883: my $courseid=$2; 2884: my $roleid=$1.'.'.$2; 2885: $courseid=~s/^\///; 2886: my $expiretime=600; 2887: if ($ENV{'request.role'} eq $roleid) { 2888: $expiretime=120; 2889: } 2890: my ($cdom,$cnum,$csec)=split(/\//,$courseid); 2891: my $prefix='course.'.$cdom.'_'.$cnum.'.'; 2892: if ((time-$ENV{$prefix.'last_cache'})>$expiretime) { 2893: &coursedescription($courseid); 2894: } 2895: if (($ENV{$prefix.'res.'.$uri.'.lock.sections'}=~/\,\Q$csec\E\,/) 2896: || ($ENV{$prefix.'res.'.$uri.'.lock.sections'} eq 'all')) { 2897: if ($ENV{$prefix.'res.'.$uri.'.lock.expire'}>time) { 2898: &log($ENV{'user.domain'},$ENV{'user.name'}, 2899: $ENV{'user.home'}, 2900: 'Locked by res: '.$priv.' for '.$uri.' due to '. 2901: $cdom.'/'.$cnum.'/'.$csec.' expire '. 2902: $ENV{$prefix.'priv.'.$priv.'.lock.expire'}); 2903: return ''; 2904: } 2905: } 2906: if (($ENV{$prefix.'priv.'.$priv.'.lock.sections'}=~/\,\Q$csec\E\,/) 2907: || ($ENV{$prefix.'priv.'.$priv.'.lock.sections'} eq 'all')) { 2908: if ($ENV{'priv.'.$priv.'.lock.expire'}>time) { 2909: &log($ENV{'user.domain'},$ENV{'user.name'}, 2910: $ENV{'user.home'}, 2911: 'Locked by priv: '.$priv.' for '.$uri.' due to '. 2912: $cdom.'/'.$cnum.'/'.$csec.' expire '. 2913: $ENV{$prefix.'priv.'.$priv.'.lock.expire'}); 2914: return ''; 2915: } 2916: } 2917: } 2918: } 2919: } 2920: 2921: # 2922: # Rest of the restrictions depend on selected course 2923: # 2924: 2925: unless ($ENV{'request.course.id'}) { 2926: return '1'; 2927: } 2928: 2929: # 2930: # Now user is definitely in a course 2931: # 2932: 2933: 2934: # Course preferences 2935: 2936: if ($thisallowed=~/C/) { 2937: my $rolecode=(split(/\./,$ENV{'request.role'}))[0]; 2938: my $unamedom=$ENV{'user.name'}.':'.$ENV{'user.domain'}; 2939: if ($ENV{'course.'.$ENV{'request.course.id'}.'.'.$priv.'.roles.denied'} 2940: =~/\Q$rolecode\E/) { 2941: &log($ENV{'user.domain'},$ENV{'user.name'},$ENV{'user.host'}, 2942: 'Denied by role: '.$priv.' for '.$uri.' as '.$rolecode.' in '. 2943: $ENV{'request.course.id'}); 2944: return ''; 2945: } 2946: 2947: if ($ENV{'course.'.$ENV{'request.course.id'}.'.'.$priv.'.users.denied'} 2948: =~/\Q$unamedom\E/) { 2949: &log($ENV{'user.domain'},$ENV{'user.name'},$ENV{'user.host'}, 2950: 'Denied by user: '.$priv.' for '.$uri.' as '.$unamedom.' in '. 2951: $ENV{'request.course.id'}); 2952: return ''; 2953: } 2954: } 2955: 2956: # Resource preferences 2957: 2958: if ($thisallowed=~/R/) { 2959: my $rolecode=(split(/\./,$ENV{'request.role'}))[0]; 2960: if (&metadata($uri,'roledeny')=~/\Q$rolecode\E/) { 2961: &log($ENV{'user.domain'},$ENV{'user.name'},$ENV{'user.host'}, 2962: 'Denied by role: '.$priv.' for '.$uri.' as '.$rolecode); 2963: return ''; 2964: } 2965: } 2966: 2967: # Restricted by state or randomout? 2968: 2969: if ($thisallowed=~/X/) { 2970: if ($ENV{'acc.randomout'}) { 2971: if (!$symb) { $symb=&symbread($uri,1); } 2972: if (($symb) && ($ENV{'acc.randomout'}=~/\&\Q$symb\E\&/)) { 2973: return ''; 2974: } 2975: } 2976: if (&condval($statecond)) { 2977: return '2'; 2978: } else { 2979: return ''; 2980: } 2981: } 2982: 2983: return 'F'; 2984: } 2985: 2986: # --------------------------------------------------- Is a resource on the map? 2987: 2988: sub is_on_map { 2989: my $uri=&declutter(shift); 2990: $uri=~s/\.\d+\.(\w+)$/\.$1/; 2991: my @uriparts=split(/\//,$uri); 2992: my $filename=$uriparts[$#uriparts]; 2993: my $pathname=$uri; 2994: $pathname=~s|/\Q$filename\E$||; 2995: $pathname=~s/^adm\/wrapper\///; 2996: #Trying to find the conditional for the file 2997: my $match=($ENV{'acc.res.'.$ENV{'request.course.id'}.'.'.$pathname}=~ 2998: /\&\Q$filename\E\:([\d\|]+)\&/); 2999: if ($match) { 3000: return (1,$1); 3001: } else { 3002: return (0,0); 3003: } 3004: } 3005: 3006: # --------------------------------------------------------- Get symb from alias 3007: 3008: sub get_symb_from_alias { 3009: my $symb=shift; 3010: my ($map,$resid,$url)=&decode_symb($symb); 3011: # Already is a symb 3012: if ($url) { return $symb; } 3013: # Must be an alias 3014: my $aliassymb=''; 3015: my %bighash; 3016: if (tie(%bighash,'GDBM_File',$ENV{'request.course.fn'}.'.db', 3017: &GDBM_READER(),0640)) { 3018: my $rid=$bighash{'mapalias_'.$symb}; 3019: if ($rid) { 3020: my ($mapid,$resid)=split(/\./,$rid); 3021: $aliassymb=&encode_symb($bighash{'map_id_'.$mapid}, 3022: $resid,$bighash{'src_'.$rid}); 3023: } 3024: untie %bighash; 3025: } 3026: return $aliassymb; 3027: } 3028: 3029: # ----------------------------------------------------------------- Define Role 3030: 3031: sub definerole { 3032: if (allowed('mcr','/')) { 3033: my ($rolename,$sysrole,$domrole,$courole)=@_; 3034: foreach (split(':',$sysrole)) { 3035: my ($crole,$cqual)=split(/\&/,$_); 3036: if ($pr{'cr:s'}!~/\Q$crole\E/) { return "refused:s:$crole"; } 3037: if ($pr{'cr:s'}=~/\Q$crole\E\&/) { 3038: if ($pr{'cr:s'}!~/\Q$crole\E\&\w*\Q$cqual\E/) { 3039: return "refused:s:$crole&$cqual"; 3040: } 3041: } 3042: } 3043: foreach (split(':',$domrole)) { 3044: my ($crole,$cqual)=split(/\&/,$_); 3045: if ($pr{'cr:d'}!~/\Q$crole\E/) { return "refused:d:$crole"; } 3046: if ($pr{'cr:d'}=~/\Q$crole\E\&/) { 3047: if ($pr{'cr:d'}!~/\Q$crole\W\&\w*\Q$cqual\E/) { 3048: return "refused:d:$crole&$cqual"; 3049: } 3050: } 3051: } 3052: foreach (split(':',$courole)) { 3053: my ($crole,$cqual)=split(/\&/,$_); 3054: if ($pr{'cr:c'}!~/\Q$crole\E/) { return "refused:c:$crole"; } 3055: if ($pr{'cr:c'}=~/\Q$crole\E\&/) { 3056: if ($pr{'cr:c'}!~/\Q$crole\E\&\w*\Q$cqual\E/) { 3057: return "refused:c:$crole&$cqual"; 3058: } 3059: } 3060: } 3061: my $command="encrypt:rolesput:$ENV{'user.domain'}:$ENV{'user.name'}:". 3062: "$ENV{'user.domain'}:$ENV{'user.name'}:". 3063: "rolesdef_$rolename=". 3064: escape($sysrole.'_'.$domrole.'_'.$courole); 3065: return reply($command,$ENV{'user.home'}); 3066: } else { 3067: return 'refused'; 3068: } 3069: } 3070: 3071: # ---------------- Make a metadata query against the network of library servers 3072: 3073: sub metadata_query { 3074: my ($query,$custom,$customshow,$server_array)=@_; 3075: my %rhash; 3076: my @server_list = (defined($server_array) ? @$server_array 3077: : keys(%libserv) ); 3078: for my $server (@server_list) { 3079: unless ($custom or $customshow) { 3080: my $reply=&reply("querysend:".&escape($query),$server); 3081: $rhash{$server}=$reply; 3082: } 3083: else { 3084: my $reply=&reply("querysend:".&escape($query).':'. 3085: &escape($custom).':'.&escape($customshow), 3086: $server); 3087: $rhash{$server}=$reply; 3088: } 3089: } 3090: return \%rhash; 3091: } 3092: 3093: # ----------------------------------------- Send log queries and wait for reply 3094: 3095: sub log_query { 3096: my ($uname,$udom,$query,%filters)=@_; 3097: my $uhome=&homeserver($uname,$udom); 3098: if ($uhome eq 'no_host') { return 'error: no_host'; } 3099: my $uhost=$hostname{$uhome}; 3100: my $command=&escape(join(':',map{$_.'='.$filters{$_}} keys %filters)); 3101: my $queryid=&reply("querysend:".$query.':'.$udom.':'.$uname.':'.$command, 3102: $uhome); 3103: unless ($queryid=~/^\Q$uhost\E\_/) { return 'error: '.$queryid; } 3104: return get_query_reply($queryid); 3105: } 3106: 3107: # ------- Request retrieval of institutional classlists for course(s) 3108: 3109: sub fetch_enrollment_query { 3110: my ($context,$affiliatesref,$replyref,$dom,$cnum) = @_; 3111: my $homeserver; 3112: my $maxtries = 1; 3113: if ($context eq 'automated') { 3114: $homeserver = $perlvar{'lonHostID'}; 3115: $maxtries = 10; # will wait for up to 2000s for retrieval of classlist data before timeout 3116: } else { 3117: $homeserver = &homeserver($cnum,$dom); 3118: } 3119: my $host=$hostname{$homeserver}; 3120: my $cmd = ''; 3121: foreach (keys %{$affiliatesref}) { 3122: $cmd .= $_.'='.join(",",@{$$affiliatesref{$_}}).'%%'; 3123: } 3124: $cmd =~ s/%%$//; 3125: $cmd = &escape($cmd); 3126: my $query = 'fetchenrollment'; 3127: my $queryid=&reply("querysend:".$query.':'.$dom.':'.$ENV{'user.name'}.':'.$cmd,$homeserver); 3128: unless ($queryid=~/^\Q$host\E\_/) { 3129: &logthis('fetch_enrollment_query: invalid queryid: '.$queryid.' for host: '.$host.' and homeserver: '.$homeserver.' context: '.$context.' '.$cnum); 3130: return 'error: '.$queryid; 3131: } 3132: my $reply = &get_query_reply($queryid); 3133: my $tries = 1; 3134: while (($reply=~/^timeout/) && ($tries < $maxtries)) { 3135: $reply = &get_query_reply($queryid); 3136: $tries ++; 3137: } 3138: if ( ($reply =~/^timeout/) || ($reply =~/^error/) ) { 3139: &logthis('fetch_enrollment_query error: '.$reply.' for '.$dom.' '.$ENV{'user.name'}.' for '.$queryid.' context: '.$context.' '.$cnum.' maxtries: '.$maxtries.' tries: '.$tries); 3140: } else { 3141: my @responses = split/:/,$reply; 3142: if ($homeserver eq $perlvar{'lonHostID'}) { 3143: foreach (@responses) { 3144: my ($key,$value) = split/=/,$_; 3145: $$replyref{$key} = $value; 3146: } 3147: } else { 3148: my $pathname = $perlvar{'lonDaemons'}.'/tmp'; 3149: foreach (@responses) { 3150: my ($key,$value) = split/=/,$_; 3151: $$replyref{$key} = $value; 3152: if ($value > 0) { 3153: foreach (@{$$affiliatesref{$key}}) { 3154: my $filename = $dom.'_'.$key.'_'.$_.'_classlist.xml'; 3155: my $destname = $pathname.'/'.$filename; 3156: my $xml_classlist = &reply("autoretrieve:".$filename,$homeserver); 3157: if ($xml_classlist =~ /^error/) { 3158: &logthis('fetch_enrollment_query - autoretrieve error: '.$xml_classlist.' for '.$filename.' from server: '.$homeserver.' '.$context.' '.$cnum); 3159: } else { 3160: if ( open(FILE,">$destname") ) { 3161: print FILE &unescape($xml_classlist); 3162: close(FILE); 3163: } else { 3164: &logthis('fetch_enrollment_query - error opening classlist file '.$destname.' '.$context.' '.$cnum); 3165: } 3166: } 3167: } 3168: } 3169: } 3170: } 3171: return 'ok'; 3172: } 3173: return 'error'; 3174: } 3175: 3176: sub get_query_reply { 3177: my $queryid=shift; 3178: my $replyfile=$perlvar{'lonDaemons'}.'/tmp/'.$queryid; 3179: my $reply=''; 3180: for (1..100) { 3181: sleep 2; 3182: if (-e $replyfile.'.end') { 3183: if (open(my $fh,$replyfile)) { 3184: $reply.=<$fh>; 3185: close($fh); 3186: } else { return 'error: reply_file_error'; } 3187: return &unescape($reply); 3188: } 3189: } 3190: return 'timeout:'.$queryid; 3191: } 3192: 3193: sub courselog_query { 3194: # 3195: # possible filters: 3196: # url: url or symb 3197: # username 3198: # domain 3199: # action: view, submit, grade 3200: # start: timestamp 3201: # end: timestamp 3202: # 3203: my (%filters)=@_; 3204: unless ($ENV{'request.course.id'}) { return 'no_course'; } 3205: if ($filters{'url'}) { 3206: $filters{'url'}=&symbclean(&declutter($filters{'url'})); 3207: $filters{'url'}=~s/\.(\w+)$/(\\.\\d+)*\\.$1/; 3208: $filters{'url'}=~s/\.(\w+)\_\_\_/(\\.\\d+)*\\.$1/; 3209: } 3210: my $cname=$ENV{'course.'.$ENV{'request.course.id'}.'.num'}; 3211: my $cdom=$ENV{'course.'.$ENV{'request.course.id'}.'.domain'}; 3212: return &log_query($cname,$cdom,'courselog',%filters); 3213: } 3214: 3215: sub userlog_query { 3216: my ($uname,$udom,%filters)=@_; 3217: return &log_query($uname,$udom,'userlog',%filters); 3218: } 3219: 3220: #--------- Call auto-enrollment subs in localenroll.pm for homeserver for course 3221: 3222: sub auto_run { 3223: my ($cnum,$cdom) = @_; 3224: my $homeserver = &homeserver($cnum,$cdom); 3225: my $response = &reply('autorun:'.$cdom,$homeserver); 3226: return $response; 3227: } 3228: 3229: sub auto_get_sections { 3230: my ($cnum,$cdom,$inst_coursecode) = @_; 3231: my $homeserver = &homeserver($cnum,$cdom); 3232: my @secs = (); 3233: my $response=&unescape(&reply('autogetsections:'.$inst_coursecode.':'.$cdom,$homeserver)); 3234: unless ($response eq 'refused') { 3235: @secs = split/:/,$response; 3236: } 3237: return @secs; 3238: } 3239: 3240: sub auto_new_course { 3241: my ($cnum,$cdom,$inst_course_id,$owner) = @_; 3242: my $homeserver = &homeserver($cnum,$cdom); 3243: my $response=&unescape(&reply('autonewcourse:'.$inst_course_id.':'.$owner.':'.$cdom,$homeserver)); 3244: return $response; 3245: } 3246: 3247: sub auto_validate_courseID { 3248: my ($cnum,$cdom,$inst_course_id) = @_; 3249: my $homeserver = &homeserver($cnum,$cdom); 3250: my $response=&unescape(&reply('autovalidatecourse:'.$inst_course_id.':'.$cdom,$homeserver)); 3251: return $response; 3252: } 3253: 3254: sub auto_create_password { 3255: my ($cnum,$cdom,$authparam) = @_; 3256: my $homeserver = &homeserver($cnum,$cdom); 3257: my $create_passwd = 0; 3258: my $authchk = ''; 3259: my $response=&unescape(&reply('autocreatepassword:'.$authparam.':'.$cdom,$homeserver)); 3260: if ($response eq 'refused') { 3261: $authchk = 'refused'; 3262: } else { 3263: ($authparam,$create_passwd,$authchk) = split/:/,$response; 3264: } 3265: return ($authparam,$create_passwd,$authchk); 3266: } 3267: 3268: sub auto_instcode_format { 3269: my ($caller,$codedom,$instcodes,$codes,$codetitles,$cat_titles,$cat_order) = @_; 3270: my $courses = ''; 3271: my $homeserver; 3272: if ($caller eq 'global') { 3273: foreach my $tryserver (keys %libserv) { 3274: if ($hostdom{$tryserver} eq $codedom) { 3275: $homeserver = $tryserver; 3276: last; 3277: } 3278: } 3279: if (($ENV{'user.name'}) && ($ENV{'user.domain'} eq $codedom)) { 3280: $homeserver = &homeserver($ENV{'user.name'},$codedom); 3281: } 3282: } else { 3283: $homeserver = &homeserver($caller,$codedom); 3284: } 3285: foreach (keys %{$instcodes}) { 3286: $courses .= &escape($_).'='.&escape($$instcodes{$_}).'&'; 3287: } 3288: chop($courses); 3289: my $response=&reply('autoinstcodeformat:'.$codedom.':'.$courses,$homeserver); 3290: unless ($response =~ /(con_lost|error|no_such_host|refused)/) { 3291: my ($codes_str,$codetitles_str,$cat_titles_str,$cat_order_str) = split/:/,$response; 3292: %{$codes} = &str2hash($codes_str); 3293: @{$codetitles} = &str2array($codetitles_str); 3294: %{$cat_titles} = &str2hash($cat_titles_str); 3295: %{$cat_order} = &str2hash($cat_order_str); 3296: return 'ok'; 3297: } 3298: return $response; 3299: } 3300: 3301: # ------------------------------------------------------------------ Plain Text 3302: 3303: sub plaintext { 3304: my $short=shift; 3305: return &mt($prp{$short}); 3306: } 3307: 3308: # ----------------------------------------------------------------- Assign Role 3309: 3310: sub assignrole { 3311: my ($udom,$uname,$url,$role,$end,$start,$deleteflag)=@_; 3312: my $mrole; 3313: if ($role =~ /^cr\//) { 3314: my $cwosec=$url; 3315: $cwosec=~s/^\/(\w+)\/(\w+)\/.*/$1\/$2/; 3316: unless (&allowed('ccr',$cwosec)) { 3317: &logthis('Refused custom assignrole: '. 3318: $udom.' '.$uname.' '.$url.' '.$role.' '.$end.' '.$start.' by '. 3319: $ENV{'user.name'}.' at '.$ENV{'user.domain'}); 3320: return 'refused'; 3321: } 3322: $mrole='cr'; 3323: } else { 3324: my $cwosec=$url; 3325: $cwosec=~s/^\/(\w+)\/(\w+)\/.*/$1\/$2/; 3326: unless ((&allowed('c'.$role,$cwosec)) || &allowed('c'.$role,$udom)) { 3327: &logthis('Refused assignrole: '. 3328: $udom.' '.$uname.' '.$url.' '.$role.' '.$end.' '.$start.' by '. 3329: $ENV{'user.name'}.' at '.$ENV{'user.domain'}); 3330: return 'refused'; 3331: } 3332: $mrole=$role; 3333: } 3334: my $command="encrypt:rolesput:$ENV{'user.domain'}:$ENV{'user.name'}:". 3335: "$udom:$uname:$url".'_'."$mrole=$role"; 3336: if ($end) { $command.='_'.$end; } 3337: if ($start) { 3338: if ($end) { 3339: $command.='_'.$start; 3340: } else { 3341: $command.='_0_'.$start; 3342: } 3343: } 3344: # actually delete 3345: if ($deleteflag) { 3346: if ((&allowed('dro',$udom)) || (&allowed('dro',$url))) { 3347: # modify command to delete the role 3348: $command="encrypt:rolesdel:$ENV{'user.domain'}:$ENV{'user.name'}:". 3349: "$udom:$uname:$url".'_'."$mrole"; 3350: &logthis("$ENV{'user.name'} at $ENV{'user.domain'} deletes $mrole in $url for $uname at $udom"); 3351: # set start and finish to negative values for userrolelog 3352: $start=-1; 3353: $end=-1; 3354: } 3355: } 3356: # send command 3357: my $answer=&reply($command,&homeserver($uname,$udom)); 3358: # log new user role if status is ok 3359: if ($answer eq 'ok') { 3360: &userrolelog($mrole,$uname,$udom,$url,$start,$end); 3361: } 3362: return $answer; 3363: } 3364: 3365: # -------------------------------------------------- Modify user authentication 3366: # Overrides without validation 3367: 3368: sub modifyuserauth { 3369: my ($udom,$uname,$umode,$upass)=@_; 3370: my $uhome=&homeserver($uname,$udom); 3371: unless (&allowed('mau',$udom)) { return 'refused'; } 3372: &logthis('Call to modify user authentication '.$udom.', '.$uname.', '. 3373: $umode.' by '.$ENV{'user.name'}.' at '.$ENV{'user.domain'}. 3374: ' in domain '.$ENV{'request.role.domain'}); 3375: my $reply=&reply('encrypt:changeuserauth:'.$udom.':'.$uname.':'.$umode.':'. 3376: &escape($upass),$uhome); 3377: &log($ENV{'user.domain'},$ENV{'user.name'},$ENV{'user.home'}, 3378: 'Authentication changed for '.$udom.', '.$uname.', '.$umode. 3379: '(Remote '.$ENV{'REMOTE_ADDR'}.'): '.$reply); 3380: &log($udom,,$uname,$uhome, 3381: 'Authentication changed by '.$ENV{'user.domain'}.', '. 3382: $ENV{'user.name'}.', '.$umode. 3383: '(Remote '.$ENV{'REMOTE_ADDR'}.'): '.$reply); 3384: unless ($reply eq 'ok') { 3385: &logthis('Authentication mode error: '.$reply); 3386: return 'error: '.$reply; 3387: } 3388: return 'ok'; 3389: } 3390: 3391: # --------------------------------------------------------------- Modify a user 3392: 3393: sub modifyuser { 3394: my ($udom, $uname, $uid, 3395: $umode, $upass, $first, 3396: $middle, $last, $gene, 3397: $forceid, $desiredhome, $email)=@_; 3398: $udom=~s/\W//g; 3399: $uname=~s/\W//g; 3400: &logthis('Call to modify user '.$udom.', '.$uname.', '.$uid.', '. 3401: $umode.', '.$first.', '.$middle.', '. 3402: $last.', '.$gene.'(forceid: '.$forceid.')'. 3403: (defined($desiredhome) ? ' desiredhome = '.$desiredhome : 3404: ' desiredhome not specified'). 3405: ' by '.$ENV{'user.name'}.' at '.$ENV{'user.domain'}. 3406: ' in domain '.$ENV{'request.role.domain'}); 3407: my $uhome=&homeserver($uname,$udom,'true'); 3408: # ----------------------------------------------------------------- Create User 3409: if (($uhome eq 'no_host') && 3410: (($umode && $upass) || ($umode eq 'localauth'))) { 3411: my $unhome=''; 3412: if (defined($desiredhome) && $hostdom{$desiredhome} eq $udom) { 3413: $unhome = $desiredhome; 3414: } elsif($ENV{'course.'.$ENV{'request.course.id'}.'.domain'} eq $udom) { 3415: $unhome=$ENV{'course.'.$ENV{'request.course.id'}.'.home'}; 3416: } else { # load balancing routine for determining $unhome 3417: my $tryserver; 3418: my $loadm=10000000; 3419: foreach $tryserver (keys %libserv) { 3420: if ($hostdom{$tryserver} eq $udom) { 3421: my $answer=reply('load',$tryserver); 3422: if (($answer=~/\d+/) && ($answer<$loadm)) { 3423: $loadm=$answer; 3424: $unhome=$tryserver; 3425: } 3426: } 3427: } 3428: } 3429: if (($unhome eq '') || ($unhome eq 'no_host')) { 3430: return 'error: unable to find a home server for '.$uname. 3431: ' in domain '.$udom; 3432: } 3433: my $reply=&reply('encrypt:makeuser:'.$udom.':'.$uname.':'.$umode.':'. 3434: &escape($upass),$unhome); 3435: unless ($reply eq 'ok') { 3436: return 'error: '.$reply; 3437: } 3438: $uhome=&homeserver($uname,$udom,'true'); 3439: if (($uhome eq '') || ($uhome eq 'no_host') || ($uhome ne $unhome)) { 3440: return 'error: unable verify users home machine.'; 3441: } 3442: } # End of creation of new user 3443: # ---------------------------------------------------------------------- Add ID 3444: if ($uid) { 3445: $uid=~tr/A-Z/a-z/; 3446: my %uidhash=&idrget($udom,$uname); 3447: if (($uidhash{$uname}) && ($uidhash{$uname}!~/error\:/) 3448: && (!$forceid)) { 3449: unless ($uid eq $uidhash{$uname}) { 3450: return 'error: user id "'.$uid.'" does not match '. 3451: 'current user id "'.$uidhash{$uname}.'".'; 3452: } 3453: } else { 3454: &idput($udom,($uname => $uid)); 3455: } 3456: } 3457: # -------------------------------------------------------------- Add names, etc 3458: my @tmp=&get('environment', 3459: ['firstname','middlename','lastname','generation'], 3460: $udom,$uname); 3461: my %names; 3462: if ($tmp[0] =~ m/^error:.*/) { 3463: %names=(); 3464: } else { 3465: %names = @tmp; 3466: } 3467: # 3468: # Make sure to not trash student environment if instructor does not bother 3469: # to supply name and email information 3470: # 3471: if ($first) { $names{'firstname'} = $first; } 3472: if (defined($middle)) { $names{'middlename'} = $middle; } 3473: if ($last) { $names{'lastname'} = $last; } 3474: if (defined($gene)) { $names{'generation'} = $gene; } 3475: if ($email) { 3476: $email=~s/[^\w\@\.\-\,]//gs; 3477: if ($email=~/\@/) { $names{'notification'} = $email; 3478: $names{'critnotification'} = $email; 3479: $names{'permanentemail'} = $email; } 3480: } 3481: my $reply = &put('environment', \%names, $udom,$uname); 3482: if ($reply ne 'ok') { return 'error: '.$reply; } 3483: &logthis('Success modifying user '.$udom.', '.$uname.', '.$uid.', '. 3484: $umode.', '.$first.', '.$middle.', '. 3485: $last.', '.$gene.' by '. 3486: $ENV{'user.name'}.' at '.$ENV{'user.domain'}); 3487: return 'ok'; 3488: } 3489: 3490: # -------------------------------------------------------------- Modify student 3491: 3492: sub modifystudent { 3493: my ($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene,$usec, 3494: $end,$start,$forceid,$desiredhome,$email,$type,$locktype,$cid)=@_; 3495: if (!$cid) { 3496: unless ($cid=$ENV{'request.course.id'}) { 3497: return 'not_in_class'; 3498: } 3499: } 3500: # --------------------------------------------------------------- Make the user 3501: my $reply=&modifyuser 3502: ($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene,$forceid, 3503: $desiredhome,$email); 3504: unless ($reply eq 'ok') { return $reply; } 3505: # This will cause &modify_student_enrollment to get the uid from the 3506: # students environment 3507: $uid = undef if (!$forceid); 3508: $reply = &modify_student_enrollment($udom,$uname,$uid,$first,$middle,$last, 3509: $gene,$usec,$end,$start,$type,$locktype,$cid); 3510: return $reply; 3511: } 3512: 3513: sub modify_student_enrollment { 3514: my ($udom,$uname,$uid,$first,$middle,$last,$gene,$usec,$end,$start,$type,$locktype,$cid) = @_; 3515: my ($cdom,$cnum,$chome); 3516: if (!$cid) { 3517: unless ($cid=$ENV{'request.course.id'}) { 3518: return 'not_in_class'; 3519: } 3520: $cdom=$ENV{'course.'.$cid.'.domain'}; 3521: $cnum=$ENV{'course.'.$cid.'.num'}; 3522: } else { 3523: ($cdom,$cnum)=split(/_/,$cid); 3524: } 3525: $chome=$ENV{'course.'.$cid.'.home'}; 3526: if (!$chome) { 3527: $chome=&homeserver($cnum,$cdom); 3528: } 3529: if (!$chome) { return 'unknown_course'; } 3530: # Make sure the user exists 3531: my $uhome=&homeserver($uname,$udom); 3532: if (($uhome eq '') || ($uhome eq 'no_host')) { 3533: return 'error: no such user'; 3534: } 3535: # Get student data if we were not given enough information 3536: if (!defined($first) || $first eq '' || 3537: !defined($last) || $last eq '' || 3538: !defined($uid) || $uid eq '' || 3539: !defined($middle) || $middle eq '' || 3540: !defined($gene) || $gene eq '') { 3541: # They did not supply us with enough data to enroll the student, so 3542: # we need to pick up more information. 3543: my %tmp = &get('environment', 3544: ['firstname','middlename','lastname', 'generation','id'] 3545: ,$udom,$uname); 3546: 3547: #foreach (keys(%tmp)) { 3548: # &logthis("key $_ = ".$tmp{$_}); 3549: #} 3550: $first = $tmp{'firstname'} if (!defined($first) || $first eq ''); 3551: $middle = $tmp{'middlename'} if (!defined($middle) || $middle eq ''); 3552: $last = $tmp{'lastname'} if (!defined($last) || $last eq ''); 3553: $gene = $tmp{'generation'} if (!defined($gene) || $gene eq ''); 3554: $uid = $tmp{'id'} if (!defined($uid) || $uid eq ''); 3555: } 3556: my $fullname = &format_name($first,$middle,$last,$gene,'lastname'); 3557: my $reply=cput('classlist', 3558: {"$uname:$udom" => 3559: join(':',$end,$start,$uid,$usec,$fullname,$type,$locktype) }, 3560: $cdom,$cnum); 3561: unless (($reply eq 'ok') || ($reply eq 'delayed')) { 3562: return 'error: '.$reply; 3563: } 3564: # Add student role to user 3565: my $uurl='/'.$cid; 3566: $uurl=~s/\_/\//g; 3567: if ($usec) { 3568: $uurl.='/'.$usec; 3569: } 3570: return &assignrole($udom,$uname,$uurl,'st',$end,$start); 3571: } 3572: 3573: sub format_name { 3574: my ($firstname,$middlename,$lastname,$generation,$first)=@_; 3575: my $name; 3576: if ($first ne 'lastname') { 3577: $name=$firstname.' '.$middlename.' '.$lastname.' '.$generation; 3578: } else { 3579: if ($lastname=~/\S/) { 3580: $name.= $lastname.' '.$generation.', '.$firstname.' '.$middlename; 3581: $name=~s/\s+,/,/; 3582: } else { 3583: $name.= $firstname.' '.$middlename.' '.$generation; 3584: } 3585: } 3586: $name=~s/^\s+//; 3587: $name=~s/\s+$//; 3588: $name=~s/\s+/ /g; 3589: return $name; 3590: } 3591: 3592: # ------------------------------------------------- Write to course preferences 3593: 3594: sub writecoursepref { 3595: my ($courseid,%prefs)=@_; 3596: $courseid=~s/^\///; 3597: $courseid=~s/\_/\//g; 3598: my ($cdomain,$cnum)=split(/\//,$courseid); 3599: my $chome=homeserver($cnum,$cdomain); 3600: if (($chome eq '') || ($chome eq 'no_host')) { 3601: return 'error: no such course'; 3602: } 3603: my $cstring=''; 3604: foreach (keys %prefs) { 3605: $cstring.=escape($_).'='.escape($prefs{$_}).'&'; 3606: } 3607: $cstring=~s/\&$//; 3608: return reply('put:'.$cdomain.':'.$cnum.':environment:'.$cstring,$chome); 3609: } 3610: 3611: # ---------------------------------------------------------- Make/modify course 3612: 3613: sub createcourse { 3614: my ($udom,$description,$url,$course_server,$nonstandard,$inst_code,$course_owner)=@_; 3615: $url=&declutter($url); 3616: my $cid=''; 3617: unless (&allowed('ccc',$udom)) { 3618: return 'refused'; 3619: } 3620: # ------------------------------------------------------------------- Create ID 3621: my $uname=substr($$.time,0,5).unpack("H8",pack("I32",time)). 3622: unpack("H2",pack("I32",int(rand(255)))).$perlvar{'lonHostID'}; 3623: # ----------------------------------------------- Make sure that does not exist 3624: my $uhome=&homeserver($uname,$udom,'true'); 3625: unless (($uhome eq '') || ($uhome eq 'no_host')) { 3626: $uname=substr($$.time,0,5).unpack("H8",pack("I32",time)). 3627: unpack("H2",pack("I32",int(rand(255)))).$perlvar{'lonHostID'}; 3628: $uhome=&homeserver($uname,$udom,'true'); 3629: unless (($uhome eq '') || ($uhome eq 'no_host')) { 3630: return 'error: unable to generate unique course-ID'; 3631: } 3632: } 3633: # ------------------------------------------------ Check supplied server name 3634: $course_server = $ENV{'user.homeserver'} if (! defined($course_server)); 3635: if (! exists($libserv{$course_server})) { 3636: return 'error:bad server name '.$course_server; 3637: } 3638: # ------------------------------------------------------------- Make the course 3639: my $reply=&reply('encrypt:makeuser:'.$udom.':'.$uname.':none::', 3640: $course_server); 3641: unless ($reply eq 'ok') { return 'error: '.$reply; } 3642: $uhome=&homeserver($uname,$udom,'true'); 3643: if (($uhome eq '') || ($uhome eq 'no_host')) { 3644: return 'error: no such course'; 3645: } 3646: # ----------------------------------------------------------------- Course made 3647: # log existence 3648: &courseidput($udom,&escape($udom.'_'.$uname).'='.&escape($description). 3649: ':'.&escape($inst_code).':'.&escape($course_owner),$uhome); 3650: &flushcourselogs(); 3651: # set toplevel url 3652: my $topurl=$url; 3653: unless ($nonstandard) { 3654: # ------------------------------------------ For standard courses, make top url 3655: my $mapurl=&clutter($url); 3656: if ($mapurl eq '/res/') { $mapurl=''; } 3657: $ENV{'form.initmap'}=(<<ENDINITMAP); 3658: <map> 3659: <resource id="1" type="start"></resource> 3660: <resource id="2" src="$mapurl"></resource> 3661: <resource id="3" type="finish"></resource> 3662: <link index="1" from="1" to="2"></link> 3663: <link index="2" from="2" to="3"></link> 3664: </map> 3665: ENDINITMAP 3666: $topurl=&declutter( 3667: &finishuserfileupload($uname,$udom,$uhome,'initmap','default.sequence') 3668: ); 3669: } 3670: # ----------------------------------------------------------- Write preferences 3671: &writecoursepref($udom.'_'.$uname, 3672: ('description' => $description, 3673: 'url' => $topurl)); 3674: return '/'.$udom.'/'.$uname; 3675: } 3676: 3677: # ---------------------------------------------------------- Assign Custom Role 3678: 3679: sub assigncustomrole { 3680: my ($udom,$uname,$url,$rdom,$rnam,$rolename,$end,$start,$deleteflag)=@_; 3681: return &assignrole($udom,$uname,$url,'cr/'.$rdom.'/'.$rnam.'/'.$rolename, 3682: $end,$start,$deleteflag); 3683: } 3684: 3685: # ----------------------------------------------------------------- Revoke Role 3686: 3687: sub revokerole { 3688: my ($udom,$uname,$url,$role,$deleteflag)=@_; 3689: my $now=time; 3690: return &assignrole($udom,$uname,$url,$role,$now,$deleteflag); 3691: } 3692: 3693: # ---------------------------------------------------------- Revoke Custom Role 3694: 3695: sub revokecustomrole { 3696: my ($udom,$uname,$url,$rdom,$rnam,$rolename,$deleteflag)=@_; 3697: my $now=time; 3698: return &assigncustomrole($udom,$uname,$url,$rdom,$rnam,$rolename,$now, 3699: $deleteflag); 3700: } 3701: 3702: # ------------------------------------------------------------ Disk usage 3703: sub diskusage { 3704: my ($udom,$uname,$directoryRoot)=@_; 3705: $directoryRoot =~ s/\/$//; 3706: my $listing=&reply('du:'.$directoryRoot,homeserver($uname,$udom)); 3707: return $listing; 3708: } 3709: 3710: sub is_locked { 3711: my ($file_name, $domain, $user) = @_; 3712: my @check; 3713: my $is_locked; 3714: push @check, $file_name; 3715: my %locked = &Apache::lonnet::get('file_permissions',\@check, 3716: $ENV{'user.domain'},$ENV{'user.name'}); 3717: if (ref($locked{$file_name}) eq 'ARRAY') { 3718: $is_locked = 'true'; 3719: } else { 3720: $is_locked = 'false'; 3721: } 3722: } 3723: 3724: # ------------------------------------------------------------- Mark as Read Only 3725: 3726: sub mark_as_readonly { 3727: my ($domain,$user,$files,$what) = @_; 3728: my %current_permissions = &Apache::lonnet::dump('file_permissions',$domain,$user); 3729: foreach my $file (@{$files}) { 3730: push(@{$current_permissions{$file}},$what); 3731: } 3732: &Apache::lonnet::put('file_permissions',\%current_permissions,$domain,$user); 3733: return; 3734: } 3735: 3736: # ------------------------------------------------------------Save Selected Files 3737: 3738: sub save_selected_files { 3739: my ($user, $path, @files) = @_; 3740: my $filename = $user."savedfiles"; 3741: my @other_files = &files_not_in_path($user, $path); 3742: open (OUT, '>'.$Apache::lonnet::perlvar{'lonDaemons'}.'/tmp/'.$filename); 3743: foreach my $file (@files) { 3744: print (OUT $ENV{'form.currentpath'}.$file."\n"); 3745: } 3746: foreach my $file (@other_files) { 3747: print (OUT $file."\n"); 3748: } 3749: close (OUT); 3750: return 'ok'; 3751: } 3752: 3753: sub clear_selected_files { 3754: my ($user) = @_; 3755: my $filename = $user."savedfiles"; 3756: open (OUT, '>'.$Apache::lonnet::perlvar{'lonDaemons'}.'/tmp/'.$filename); 3757: print (OUT undef); 3758: close (OUT); 3759: return ("ok"); 3760: } 3761: 3762: sub files_in_path { 3763: my ($user, $path) = @_; 3764: my $filename = $user."savedfiles"; 3765: my %return_files; 3766: open (IN, '<'.$Apache::lonnet::perlvar{'lonDaemons'}.'/tmp/'.$filename); 3767: while (my $line_in = <IN>) { 3768: chomp ($line_in); 3769: my @paths_and_file = split (m!/!, $line_in); 3770: my $file_part = pop (@paths_and_file); 3771: my $path_part = join ('/', @paths_and_file); 3772: $path_part.='/'; 3773: my $path_and_file = $path_part.$file_part; 3774: if ($path_part eq $path) { 3775: $return_files{$file_part}= 'selected'; 3776: } 3777: } 3778: close (IN); 3779: return (\%return_files); 3780: } 3781: 3782: # called in portfolio select mode, to show files selected NOT in current directory 3783: sub files_not_in_path { 3784: my ($user, $path) = @_; 3785: my $filename = $user."savedfiles"; 3786: my @return_files; 3787: my $path_part; 3788: open (IN, '<'.$Apache::lonnet::perlvar{'lonDaemons'}.'/tmp/'.$filename); 3789: while (<IN>) { 3790: #ok, I know it's clunky, but I want it to work 3791: my @paths_and_file = split m!/!, $_; 3792: my $file_part = pop (@paths_and_file); 3793: chomp ($file_part); 3794: my $path_part = join ('/', @paths_and_file); 3795: $path_part .= '/'; 3796: my $path_and_file = $path_part.$file_part; 3797: if ($path_part ne $path) { 3798: push (@return_files, ($path_and_file)); 3799: } 3800: } 3801: close (OUT); 3802: return (@return_files); 3803: } 3804: 3805: #--------------------------------------------------------------Get Marked as Read Only 3806: 3807: sub get_marked_as_readonly { 3808: my ($domain,$user,$what) = @_; 3809: my %current_permissions = &Apache::lonnet::dump('file_permissions',$domain,$user); 3810: my @readonly_files; 3811: while (my ($file_name,$value) = each(%current_permissions)) { 3812: if (ref($value) eq "ARRAY"){ 3813: foreach my $stored_what (@{$value}) { 3814: if ($stored_what eq $what) { 3815: push(@readonly_files, $file_name); 3816: } elsif (!defined($what)) { 3817: push(@readonly_files, $file_name); 3818: } 3819: } 3820: } 3821: } 3822: return @readonly_files; 3823: } 3824: #-----------------------------------------------------------Get Marked as Read Only Hash 3825: 3826: sub get_marked_as_readonly_hash { 3827: my ($domain,$user,$what) = @_; 3828: my %current_permissions = &Apache::lonnet::dump('file_permissions',$domain,$user); 3829: my %readonly_files; 3830: while (my ($file_name,$value) = each(%current_permissions)) { 3831: if (ref($value) eq "ARRAY"){ 3832: foreach my $stored_what (@{$value}) { 3833: if ($stored_what eq $what) { 3834: $readonly_files{$file_name} = 'locked'; 3835: } elsif (!defined($what)) { 3836: $readonly_files{$file_name} = 'locked'; 3837: } 3838: } 3839: } 3840: } 3841: return %readonly_files; 3842: } 3843: # ------------------------------------------------------------ Unmark as Read Only 3844: 3845: sub unmark_as_readonly { 3846: # unmarks all files locked by $what 3847: # for portfolio submissions, $what contains $crsid and $symb 3848: my ($domain,$user,$what) = @_; 3849: my %current_permissions = &Apache::lonnet::dump('file_permissions',$domain,$user); 3850: my @readonly_files = &Apache::lonnet::get_marked_as_readonly($domain,$user,$what); 3851: foreach my $file(@readonly_files){ 3852: my $current_locks = $current_permissions{$file}; 3853: my @new_locks; 3854: my @del_keys; 3855: if (ref($current_locks) eq "ARRAY"){ 3856: foreach my $locker (@{$current_locks}) { 3857: unless ($locker eq $what) { 3858: push(@new_locks, $what); 3859: } 3860: } 3861: if (@new_locks > 0) { 3862: $current_permissions{$file} = \@new_locks; 3863: } else { 3864: push(@del_keys, $file); 3865: &Apache::lonnet::del('file_permissions',\@del_keys, $domain, $user); 3866: delete $current_permissions{$file}; 3867: } 3868: } 3869: } 3870: &Apache::lonnet::put('file_permissions',\%current_permissions,$domain,$user); 3871: return; 3872: } 3873: 3874: # ------------------------------------------------------------ Directory lister 3875: 3876: sub dirlist { 3877: my ($uri,$userdomain,$username,$alternateDirectoryRoot)=@_; 3878: 3879: $uri=~s/^\///; 3880: $uri=~s/\/$//; 3881: my ($udom, $uname); 3882: (undef,$udom,$uname)=split(/\//,$uri); 3883: if(defined($userdomain)) { 3884: $udom = $userdomain; 3885: } 3886: if(defined($username)) { 3887: $uname = $username; 3888: } 3889: 3890: my $dirRoot = $perlvar{'lonDocRoot'}; 3891: if(defined($alternateDirectoryRoot)) { 3892: $dirRoot = $alternateDirectoryRoot; 3893: $dirRoot =~ s/\/$//; 3894: } 3895: 3896: if($udom) { 3897: if($uname) { 3898: my $listing=reply('ls2:'.$dirRoot.'/'.$uri, 3899: homeserver($uname,$udom)); 3900: my @listing_results; 3901: if ($listing eq 'unknown_cmd') { 3902: $listing=reply('ls:'.$dirRoot.'/'.$uri, 3903: homeserver($uname,$udom)); 3904: @listing_results = split(/:/,$listing); 3905: } else { 3906: @listing_results = map { &unescape($_); } split(/:/,$listing); 3907: } 3908: return @listing_results; 3909: } elsif(!defined($alternateDirectoryRoot)) { 3910: my $tryserver; 3911: my %allusers=(); 3912: foreach $tryserver (keys %libserv) { 3913: if($hostdom{$tryserver} eq $udom) { 3914: my $listing=reply('ls2:'.$perlvar{'lonDocRoot'}.'/res/'. 3915: $udom, $tryserver); 3916: my @listing_results; 3917: if ($listing eq 'unknown_cmd') { 3918: $listing=reply('ls:'.$perlvar{'lonDocRoot'}.'/res/'. 3919: $udom, $tryserver); 3920: @listing_results = split(/:/,$listing); 3921: } else { 3922: @listing_results = 3923: map { &unescape($_); } split(/:/,$listing); 3924: } 3925: if ($listing_results[0] ne 'no_such_dir' && 3926: $listing_results[0] ne 'empty' && 3927: $listing_results[0] ne 'con_lost') { 3928: foreach (@listing_results) { 3929: my ($entry,@stat)=split(/&/,$_); 3930: $allusers{$entry}=1; 3931: } 3932: } 3933: } 3934: } 3935: my $alluserstr=''; 3936: foreach (sort keys %allusers) { 3937: $alluserstr.=$_.'&user:'; 3938: } 3939: $alluserstr=~s/:$//; 3940: return split(/:/,$alluserstr); 3941: } else { 3942: my @emptyResults = (); 3943: push(@emptyResults, 'missing user name'); 3944: return split(':',@emptyResults); 3945: } 3946: } elsif(!defined($alternateDirectoryRoot)) { 3947: my $tryserver; 3948: my %alldom=(); 3949: foreach $tryserver (keys %libserv) { 3950: $alldom{$hostdom{$tryserver}}=1; 3951: } 3952: my $alldomstr=''; 3953: foreach (sort keys %alldom) { 3954: $alldomstr.=$perlvar{'lonDocRoot'}.'/res/'.$_.'/&domain:'; 3955: } 3956: $alldomstr=~s/:$//; 3957: return split(/:/,$alldomstr); 3958: } else { 3959: my @emptyResults = (); 3960: push(@emptyResults, 'missing domain'); 3961: return split(':',@emptyResults); 3962: } 3963: } 3964: 3965: # --------------------------------------------- GetFileTimestamp 3966: # This function utilizes dirlist and returns the date stamp for 3967: # when it was last modified. It will also return an error of -1 3968: # if an error occurs 3969: 3970: ## 3971: ## FIXME: This subroutine assumes its caller knows something about the 3972: ## directory structure of the home server for the student ($root). 3973: ## Not a good assumption to make. Since this is for looking up files 3974: ## in user directories, the full path should be constructed by lond, not 3975: ## whatever machine we request data from. 3976: ## 3977: sub GetFileTimestamp { 3978: my ($studentDomain,$studentName,$filename,$root)=@_; 3979: $studentDomain=~s/\W//g; 3980: $studentName=~s/\W//g; 3981: my $subdir=$studentName.'__'; 3982: $subdir =~ s/(.)(.)(.).*/$1\/$2\/$3/; 3983: my $proname="$studentDomain/$subdir/$studentName"; 3984: $proname .= '/'.$filename; 3985: my ($fileStat) = &Apache::lonnet::dirlist($proname, $studentDomain, 3986: $studentName, $root); 3987: my @stats = split('&', $fileStat); 3988: if($stats[0] ne 'empty' && $stats[0] ne 'no_such_dir') { 3989: # @stats contains first the filename, then the stat output 3990: return $stats[10]; # so this is 10 instead of 9. 3991: } else { 3992: return -1; 3993: } 3994: } 3995: 3996: # -------------------------------------------------------- Value of a Condition 3997: 3998: sub directcondval { 3999: my $number=shift; 4000: if (!defined($ENV{'user.state.'.$ENV{'request.course.id'}})) { 4001: &Apache::lonuserstate::evalstate(); 4002: } 4003: if ($ENV{'user.state.'.$ENV{'request.course.id'}}) { 4004: return substr($ENV{'user.state.'.$ENV{'request.course.id'}},$number,1); 4005: } else { 4006: return 2; 4007: } 4008: } 4009: 4010: sub condval { 4011: my $condidx=shift; 4012: my $result=0; 4013: my $allpathcond=''; 4014: foreach (split(/\|/,$condidx)) { 4015: if (defined($ENV{'acc.cond.'.$ENV{'request.course.id'}.'.'.$_})) { 4016: $allpathcond.= 4017: '('.$ENV{'acc.cond.'.$ENV{'request.course.id'}.'.'.$_}.')|'; 4018: } 4019: } 4020: $allpathcond=~s/\|$//; 4021: if ($ENV{'request.course.id'}) { 4022: if ($allpathcond) { 4023: my $operand='|'; 4024: my @stack; 4025: foreach ($allpathcond=~/(\d+|$|$|\&|\|)/g) { 4026: if ($_ eq '(') { 4027: push @stack,($operand,$result) 4028: } elsif ($_ eq ')') { 4029: my $before=pop @stack; 4030: if (pop @stack eq '&') { 4031: $result=$result>$before?$before:$result; 4032: } else { 4033: $result=$result>$before?$result:$before; 4034: } 4035: } elsif (($_ eq '&') || ($_ eq '|')) { 4036: $operand=$_; 4037: } else { 4038: my $new=directcondval($_); 4039: if ($operand eq '&') { 4040: $result=$result>$new?$new:$result; 4041: } else { 4042: $result=$result>$new?$result:$new; 4043: } 4044: } 4045: } 4046: } 4047: } 4048: return $result; 4049: } 4050: 4051: # ---------------------------------------------------- Devalidate courseresdata 4052: 4053: sub devalidatecourseresdata { 4054: my ($coursenum,$coursedomain)=@_; 4055: my $hashid=$coursenum.':'.$coursedomain; 4056: &devalidate_cache_new('courseres',$hashid); 4057: } 4058: 4059: # --------------------------------------------------- Course Resourcedata Query 4060: 4061: sub courseresdata { 4062: my ($coursenum,$coursedomain,@which)=@_; 4063: my $coursehom=&homeserver($coursenum,$coursedomain); 4064: my $hashid=$coursenum.':'.$coursedomain; 4065: my ($result,$cached)=&is_cached_new('courseres',$hashid); 4066: unless (defined($cached)) { 4067: my %dumpreply=&dump('resourcedata',$coursedomain,$coursenum); 4068: $result=\%dumpreply; 4069: my ($tmp) = keys(%dumpreply); 4070: if ($tmp !~ /^(con_lost|error|no_such_host)/i) { 4071: &do_cache_new('courseres',$hashid,$result,600); 4072: } elsif ($tmp =~ /^(con_lost|no_such_host)/) { 4073: return $tmp; 4074: } elsif ($tmp =~ /^(error)/) { 4075: $result=undef; 4076: &do_cache_new('courseres',$hashid,$result,600); 4077: } 4078: } 4079: foreach my $item (@which) { 4080: if (defined($result->{$item})) { 4081: return $result->{$item}; 4082: } 4083: } 4084: return undef; 4085: } 4086: 4087: # 4088: # EXT resource caching routines 4089: # 4090: 4091: sub clear_EXT_cache_status { 4092: &delenv('cache.EXT.'); 4093: } 4094: 4095: sub EXT_cache_status { 4096: my ($target_domain,$target_user) = @_; 4097: my $cachename = 'cache.EXT.'.$target_user.'.'.$target_domain; 4098: if (exists($ENV{$cachename}) && ($ENV{$cachename}+600) > time) { 4099: # We know already the user has no data 4100: return 1; 4101: } else { 4102: return 0; 4103: } 4104: } 4105: 4106: sub EXT_cache_set { 4107: my ($target_domain,$target_user) = @_; 4108: my $cachename = 'cache.EXT.'.$target_user.'.'.$target_domain; 4109: &appenv($cachename => time); 4110: } 4111: 4112: # --------------------------------------------------------- Value of a Variable 4113: sub EXT { 4114: my ($varname,$symbparm,$udom,$uname,$usection,$recurse)=@_; 4115: 4116: unless ($varname) { return ''; } 4117: #get real user name/domain, courseid and symb 4118: my $courseid; 4119: my $publicuser; 4120: if ($symbparm) { 4121: $symbparm=&get_symb_from_alias($symbparm); 4122: } 4123: if (!($uname && $udom)) { 4124: (my $cursymb,$courseid,$udom,$uname,$publicuser)= 4125: &Apache::lonxml::whichuser($symbparm); 4126: if (!$symbparm) { $symbparm=$cursymb; } 4127: } else { 4128: $courseid=$ENV{'request.course.id'}; 4129: } 4130: my ($realm,$space,$qualifier,@therest)=split(/\./,$varname); 4131: my $rest; 4132: if (defined($therest[0])) { 4133: $rest=join('.',@therest); 4134: } else { 4135: $rest=''; 4136: } 4137: 4138: my $qualifierrest=$qualifier; 4139: if ($rest) { $qualifierrest.='.'.$rest; } 4140: my $spacequalifierrest=$space; 4141: if ($qualifierrest) { $spacequalifierrest.='.'.$qualifierrest; } 4142: if ($realm eq 'user') { 4143: # --------------------------------------------------------------- user.resource 4144: if ($space eq 'resource') { 4145: if (defined($Apache::lonhomework::parsing_a_problem)) { 4146: return $Apache::lonhomework::history{$qualifierrest}; 4147: } else { 4148: my %restored; 4149: if ($publicuser || $ENV{'request.state'} eq 'construct') { 4150: %restored=&tmprestore($symbparm,$courseid,$udom,$uname); 4151: } else { 4152: %restored=&restore($symbparm,$courseid,$udom,$uname); 4153: } 4154: return $restored{$qualifierrest}; 4155: } 4156: # ----------------------------------------------------------------- user.access 4157: } elsif ($space eq 'access') { 4158: # FIXME - not supporting calls for a specific user 4159: return &allowed($qualifier,$rest); 4160: # ------------------------------------------ user.preferences, user.environment 4161: } elsif (($space eq 'preferences') || ($space eq 'environment')) { 4162: if (($uname eq $ENV{'user.name'}) && 4163: ($udom eq $ENV{'user.domain'})) { 4164: return $ENV{join('.',('environment',$qualifierrest))}; 4165: } else { 4166: my %returnhash; 4167: if (!$publicuser) { 4168: %returnhash=&userenvironment($udom,$uname, 4169: $qualifierrest); 4170: } 4171: return $returnhash{$qualifierrest}; 4172: } 4173: # ----------------------------------------------------------------- user.course 4174: } elsif ($space eq 'course') { 4175: # FIXME - not supporting calls for a specific user 4176: return $ENV{join('.',('request.course',$qualifier))}; 4177: # ------------------------------------------------------------------- user.role 4178: } elsif ($space eq 'role') { 4179: # FIXME - not supporting calls for a specific user 4180: my ($role,$where)=split(/\./,$ENV{'request.role'}); 4181: if ($qualifier eq 'value') { 4182: return $role; 4183: } elsif ($qualifier eq 'extent') { 4184: return $where; 4185: } 4186: # ----------------------------------------------------------------- user.domain 4187: } elsif ($space eq 'domain') { 4188: return $udom; 4189: # ------------------------------------------------------------------- user.name 4190: } elsif ($space eq 'name') { 4191: return $uname; 4192: # ---------------------------------------------------- Any other user namespace 4193: } else { 4194: my %reply; 4195: if (!$publicuser) { 4196: %reply=&get($space,[$qualifierrest],$udom,$uname); 4197: } 4198: return $reply{$qualifierrest}; 4199: } 4200: } elsif ($realm eq 'query') { 4201: # ---------------------------------------------- pull stuff out of query string 4202: &Apache::loncommon::get_unprocessed_cgi($ENV{'QUERY_STRING'}, 4203: [$spacequalifierrest]); 4204: return $ENV{'form.'.$spacequalifierrest}; 4205: } elsif ($realm eq 'request') { 4206: # ------------------------------------------------------------- request.browser 4207: if ($space eq 'browser') { 4208: if ($qualifier eq 'textremote') { 4209: if (&mt('textual_remote_display') eq 'on') { 4210: return 1; 4211: } else { 4212: return 0; 4213: } 4214: } else { 4215: return $ENV{'browser.'.$qualifier}; 4216: } 4217: # ------------------------------------------------------------ request.filename 4218: } else { 4219: return $ENV{'request.'.$spacequalifierrest}; 4220: } 4221: } elsif ($realm eq 'course') { 4222: # ---------------------------------------------------------- course.description 4223: return $ENV{'course.'.$courseid.'.'.$spacequalifierrest}; 4224: } elsif ($realm eq 'resource') { 4225: 4226: my $section; 4227: if (defined($courseid) && $courseid eq $ENV{'request.course.id'}) { 4228: if (!$symbparm) { $symbparm=&symbread(); } 4229: } 4230: my ($courselevelm,$courselevel); 4231: if ($symbparm && defined($courseid) && 4232: $courseid eq $ENV{'request.course.id'}) { 4233: 4234: #print ' '.$space.' - '.$qualifier.' - '.$spacequalifierrest; 4235: 4236: # ----------------------------------------------------- Cascading lookup scheme 4237: my $symbp=$symbparm; 4238: my $mapp=(&decode_symb($symbp))[0]; 4239: 4240: my $symbparm=$symbp.'.'.$spacequalifierrest; 4241: my $mapparm=$mapp.'___(all).'.$spacequalifierrest; 4242: 4243: if (($ENV{'user.name'} eq $uname) && 4244: ($ENV{'user.domain'} eq $udom)) { 4245: $section=$ENV{'request.course.sec'}; 4246: } else { 4247: if (! defined($usection)) { 4248: $section=&getsection($udom,$uname,$courseid); 4249: } else { 4250: $section = $usection; 4251: } 4252: } 4253: 4254: my $seclevel=$courseid.'.['.$section.'].'.$spacequalifierrest; 4255: my $seclevelr=$courseid.'.['.$section.'].'.$symbparm; 4256: my $seclevelm=$courseid.'.['.$section.'].'.$mapparm; 4257: 4258: $courselevel=$courseid.'.'.$spacequalifierrest; 4259: my $courselevelr=$courseid.'.'.$symbparm; 4260: $courselevelm=$courseid.'.'.$mapparm; 4261: 4262: # ----------------------------------------------------------- first, check user 4263: #most student don\'t have any data set, check if there is some data 4264: if (! &EXT_cache_status($udom,$uname)) { 4265: my $hashid="$udom:$uname"; 4266: my ($result,$cached)=&is_cached_new('userres',$hashid); 4267: if (!defined($cached)) { 4268: my %resourcedata=&dump('resourcedata',$udom,$uname); 4269: $result=\%resourcedata; 4270: &do_cache_new('userres',$hashid,$result); 4271: } 4272: my ($tmp)=keys(%$result); 4273: if (($tmp!~/^error\:/) && ($tmp!~/^con_lost/)) { 4274: if ($$result{$courselevelr}) { 4275: return $$result{$courselevelr}; } 4276: if ($$result{$courselevelm}) { 4277: return $$result{$courselevelm}; } 4278: if ($$result{$courselevel}) { 4279: return $$result{$courselevel}; } 4280: } else { 4281: #error 2 occurs when the .db doesn't exist 4282: if ($tmp!~/error: 2 /) { 4283: &logthis("WARNING:". 4284: " Trying to get resource data for ". 4285: $uname." at ".$udom.": ". 4286: $tmp.""); 4287: } elsif ($tmp=~/error: 2 /) { 4288: &EXT_cache_set($udom,$uname); 4289: } elsif ($tmp =~ /^(con_lost|no_such_host)/) { 4290: return $tmp; 4291: } 4292: } 4293: } 4294: 4295: # ------------------------------------------------ second, check some of course 4296: 4297: my $coursereply=&courseresdata($ENV{'course.'.$courseid.'.num'}, 4298: $ENV{'course.'.$courseid.'.domain'}, 4299: ($seclevelr,$seclevelm,$seclevel, 4300: $courselevelr)); 4301: if (defined($coursereply)) { return $coursereply; } 4302: 4303: # ------------------------------------------------------ third, check map parms 4304: my %parmhash=(); 4305: my $thisparm=''; 4306: if (tie(%parmhash,'GDBM_File', 4307: $ENV{'request.course.fn'}.'_parms.db', 4308: &GDBM_READER(),0640)) { 4309: $thisparm=$parmhash{$symbparm}; 4310: untie(%parmhash); 4311: } 4312: if ($thisparm) { return $thisparm; } 4313: } 4314: # ------------------------------------------ fourth, look in resource metadata 4315: 4316: $spacequalifierrest=~s/\./\_/; 4317: my $filename; 4318: if (!$symbparm) { $symbparm=&symbread(); } 4319: if ($symbparm) { 4320: $filename=(&decode_symb($symbparm))[2]; 4321: } else { 4322: $filename=$ENV{'request.filename'}; 4323: } 4324: my $metadata=&metadata($filename,$spacequalifierrest); 4325: if (defined($metadata)) { return $metadata; } 4326: $metadata=&metadata($filename,'parameter_'.$spacequalifierrest); 4327: if (defined($metadata)) { return $metadata; } 4328: 4329: # ---------------------------------------------- fourth, look in rest pf course 4330: if ($symbparm && defined($courseid) && 4331: $courseid eq $ENV{'request.course.id'}) { 4332: my $coursereply=&courseresdata($ENV{'course.'.$courseid.'.num'}, 4333: $ENV{'course.'.$courseid.'.domain'}, 4334: ($courselevelm,$courselevel)); 4335: if (defined($coursereply)) { return $coursereply; } 4336: } 4337: # ------------------------------------------------------------------ Cascade up 4338: unless ($space eq '0') { 4339: my @parts=split(/_/,$space); 4340: my $id=pop(@parts); 4341: my $part=join('_',@parts); 4342: if ($part eq '') { $part='0'; } 4343: my $partgeneral=&EXT('resource.'.$part.'.'.$qualifierrest, 4344: $symbparm,$udom,$uname,$section,1); 4345: if (defined($partgeneral)) { return $partgeneral; } 4346: } 4347: if ($recurse) { return undef; } 4348: my $pack_def=&packages_tab_default($filename,$varname); 4349: if (defined($pack_def)) { return $pack_def; } 4350: 4351: # ---------------------------------------------------- Any other user namespace 4352: } elsif ($realm eq 'environment') { 4353: # ----------------------------------------------------------------- environment 4354: if (($uname eq $ENV{'user.name'})&&($udom eq $ENV{'user.domain'})) { 4355: return $ENV{'environment.'.$spacequalifierrest}; 4356: } else { 4357: my %returnhash=&userenvironment($udom,$uname, 4358: $spacequalifierrest); 4359: return $returnhash{$spacequalifierrest}; 4360: } 4361: } elsif ($realm eq 'system') { 4362: # ----------------------------------------------------------------- system.time 4363: if ($space eq 'time') { 4364: return time; 4365: } 4366: } 4367: return ''; 4368: } 4369: 4370: sub packages_tab_default { 4371: my ($uri,$varname)=@_; 4372: my (undef,$part,$name)=split(/\./,$varname); 4373: my $packages=&metadata($uri,'packages'); 4374: foreach my $package (split(/,/,$packages)) { 4375: my ($pack_type,$pack_part)=split(/_/,$package,2); 4376: if (defined($packagetab{"$pack_type&$name&default"})) { 4377: return $packagetab{"$pack_type&$name&default"}; 4378: } 4379: if ($pack_type eq 'part') { $pack_part='0'; } 4380: if (defined($packagetab{$pack_type."_".$pack_part."&$name&default"})) { 4381: return $packagetab{$pack_type."_".$pack_part."&$name&default"}; 4382: } 4383: } 4384: return undef; 4385: } 4386: 4387: sub add_prefix_and_part { 4388: my ($prefix,$part)=@_; 4389: my $keyroot; 4390: if (defined($prefix) && $prefix !~ /^__/) { 4391: # prefix that has a part already 4392: $keyroot=$prefix; 4393: } elsif (defined($prefix)) { 4394: # prefix that is missing a part 4395: if (defined($part)) { $keyroot='_'.$part.substr($prefix,1); } 4396: } else { 4397: # no prefix at all 4398: if (defined($part)) { $keyroot='_'.$part; } 4399: } 4400: return $keyroot; 4401: } 4402: 4403: # ---------------------------------------------------------------- Get metadata 4404: 4405: my %metaentry; 4406: sub metadata { 4407: my ($uri,$what,$liburi,$prefix,$depthcount)=@_; 4408: $uri=&declutter($uri); 4409: # if it is a non metadata possible uri return quickly 4410: if (($uri eq '') || 4411: (($uri =~ m|^/*adm/|) && 4412: ($uri !~ m|^adm/includes|) && ($uri !~ m|/bulletinboard$|)) || 4413: ($uri =~ m|/$|) || ($uri =~ m|/.meta$|) || ($uri =~ /^~/) || 4414: ($uri =~ m|home/[^/]+/public_html/|)) { 4415: return undef; 4416: } 4417: my $filename=$uri; 4418: $uri=~s/\.meta$//; 4419: # 4420: # Is the metadata already cached? 4421: # Look at timestamp of caching 4422: # Everything is cached by the main uri, libraries are never directly cached 4423: # 4424: if (!defined($liburi)) { 4425: my ($result,$cached)=&is_cached_new('meta',$uri); 4426: if (defined($cached)) { return $result->{':'.$what}; } 4427: } 4428: { 4429: # 4430: # Is this a recursive call for a library? 4431: # 4432: # if (! exists($metacache{$uri})) { 4433: # $metacache{$uri}={}; 4434: # } 4435: if ($liburi) { 4436: $liburi=&declutter($liburi); 4437: $filename=$liburi; 4438: } else { 4439: &devalidate_cache_new('meta',$uri); 4440: undef(%metaentry); 4441: } 4442: my %metathesekeys=(); 4443: unless ($filename=~/\.meta$/) { $filename.='.meta'; } 4444: my $metastring; 4445: if ($uri !~ m|^uploaded/|) { 4446: my $file=&filelocation('',&clutter($filename)); 4447: #push(@{$metaentry{$uri.'.file'}},$file); 4448: $metastring=&getfile($file); 4449: } 4450: my $parser=HTML::LCParser->new(\$metastring); 4451: my $token; 4452: undef %metathesekeys; 4453: while ($token=$parser->get_token) { 4454: if ($token->[0] eq 'S') { 4455: if (defined($token->[2]->{'package'})) { 4456: # 4457: # This is a package - get package info 4458: # 4459: my $package=$token->[2]->{'package'}; 4460: my $keyroot=&add_prefix_and_part($prefix,$token->[2]->{'part'}); 4461: if (defined($token->[2]->{'id'})) { 4462: $keyroot.='_'.$token->[2]->{'id'}; 4463: } 4464: if ($metaentry{':packages'}) { 4465: $metaentry{':packages'}.=','.$package.$keyroot; 4466: } else { 4467: $metaentry{':packages'}=$package.$keyroot; 4468: } 4469: foreach (keys %packagetab) { 4470: my $part=$keyroot; 4471: $part=~s/^\_//; 4472: if ($_=~/^\Q$package\E\&/ || 4473: $_=~/^\Q$package\E_0\&/) { 4474: my ($pack,$name,$subp)=split(/\&/,$_); 4475: # ignore package.tab specified default values 4476: # here &package_tab_default() will fetch those 4477: if ($subp eq 'default') { next; } 4478: my $value=$packagetab{$_}; 4479: my $unikey; 4480: if ($pack =~ /_0$/) { 4481: $unikey='parameter_0_'.$name; 4482: $part=0; 4483: } else { 4484: $unikey='parameter'.$keyroot.'_'.$name; 4485: } 4486: if ($subp eq 'display') { 4487: $value.=' [Part: '.$part.']'; 4488: } 4489: $metaentry{':'.$unikey.'.part'}=$part; 4490: $metathesekeys{$unikey}=1; 4491: unless (defined($metaentry{':'.$unikey.'.'.$subp})) { 4492: $metaentry{':'.$unikey.'.'.$subp}=$value; 4493: } 4494: if (defined($metaentry{':'.$unikey.'.default'})) { 4495: $metaentry{':'.$unikey}= 4496: $metaentry{':'.$unikey.'.default'}; 4497: } 4498: } 4499: } 4500: } else { 4501: # 4502: # This is not a package - some other kind of start tag 4503: # 4504: my $entry=$token->[1]; 4505: my $unikey; 4506: if ($entry eq 'import') { 4507: $unikey=''; 4508: } else { 4509: $unikey=$entry; 4510: } 4511: $unikey.=&add_prefix_and_part($prefix,$token->[2]->{'part'}); 4512: 4513: if (defined($token->[2]->{'id'})) { 4514: $unikey.='_'.$token->[2]->{'id'}; 4515: } 4516: 4517: if ($entry eq 'import') { 4518: # 4519: # Importing a library here 4520: # 4521: if ($depthcount<20) { 4522: my $location=$parser->get_text('/import'); 4523: my $dir=$filename; 4524: $dir=~s|[^/]*$||; 4525: $location=&filelocation($dir,$location); 4526: foreach (sort(split(/\,/,&metadata($uri,'keys', 4527: $location,$unikey, 4528: $depthcount+1)))) { 4529: $metaentry{':'.$_}=$metaentry{':'.$_}; 4530: $metathesekeys{$_}=1; 4531: } 4532: } 4533: } else { 4534: 4535: if (defined($token->[2]->{'name'})) { 4536: $unikey.='_'.$token->[2]->{'name'}; 4537: } 4538: $metathesekeys{$unikey}=1; 4539: foreach (@{$token->[3]}) { 4540: $metaentry{':'.$unikey.'.'.$_}=$token->[2]->{$_}; 4541: } 4542: my $internaltext=&HTML::Entities::decode($parser->get_text('/'.$entry)); 4543: my $default=$metaentry{':'.$unikey.'.default'}; 4544: if ( $internaltext =~ /^\s*$/ && $default !~ /^\s*$/) { 4545: # only ws inside the tag, and not in default, so use default 4546: # as value 4547: $metaentry{':'.$unikey}=$default; 4548: } else { 4549: # either something interesting inside the tag or default 4550: # uninteresting 4551: $metaentry{':'.$unikey}=$internaltext; 4552: } 4553: # end of not-a-package not-a-library import 4554: } 4555: # end of not-a-package start tag 4556: } 4557: # the next is the end of "start tag" 4558: } 4559: } 4560: my ($extension) = ($uri =~ /\.(\w+)$/); 4561: foreach my $key (sort(keys(%packagetab))) { 4562: #&logthis("extsion1 $extension $key !!"); 4563: #no specific packages #how's our extension 4564: if ($key!~/^extension_\Q$extension\E&/) { next; } 4565: &metadata_create_package_def($uri,$key,'extension_'.$extension, 4566: \%metathesekeys); 4567: } 4568: if (!exists($metaentry{':packages'})) { 4569: foreach my $key (sort(keys(%packagetab))) { 4570: #no specific packages well let's get default then 4571: if ($key!~/^default&/) { next; } 4572: &metadata_create_package_def($uri,$key,'default', 4573: \%metathesekeys); 4574: } 4575: } 4576: # are there custom rights to evaluate 4577: if ($metaentry{':copyright'} eq 'custom') { 4578: 4579: # 4580: # Importing a rights file here 4581: # 4582: unless ($depthcount) { 4583: my $location=$metaentry{':customdistributionfile'}; 4584: my $dir=$filename; 4585: $dir=~s|[^/]*$||; 4586: $location=&filelocation($dir,$location); 4587: foreach (sort(split(/\,/,&metadata($uri,'keys', 4588: $location,'_rights', 4589: $depthcount+1)))) { 4590: #$metaentry{':'.$_}=$metacache{$uri}->{':'.$_}; 4591: $metathesekeys{$_}=1; 4592: } 4593: } 4594: } 4595: $metaentry{':keys'}=join(',',keys %metathesekeys); 4596: &metadata_generate_part0(\%metathesekeys,\%metaentry,$uri); 4597: $metaentry{':allpossiblekeys'}=join(',',keys %metathesekeys); 4598: &do_cache_new('meta',$uri,\%metaentry); 4599: # this is the end of "was not already recently cached 4600: } 4601: return $metaentry{':'.$what}; 4602: } 4603: 4604: sub metadata_create_package_def { 4605: my ($uri,$key,$package,$metathesekeys)=@_; 4606: my ($pack,$name,$subp)=split(/\&/,$key); 4607: if ($subp eq 'default') { next; } 4608: 4609: if (defined($metaentry{':packages'})) { 4610: $metaentry{':packages'}.=','.$package; 4611: } else { 4612: $metaentry{':packages'}=$package; 4613: } 4614: my $value=$packagetab{$key}; 4615: my $unikey; 4616: $unikey='parameter_0_'.$name; 4617: $metaentry{':'.$unikey.'.part'}=0; 4618: $$metathesekeys{$unikey}=1; 4619: unless (defined($metaentry{':'.$unikey.'.'.$subp})) { 4620: $metaentry{':'.$unikey.'.'.$subp}=$value; 4621: } 4622: if (defined($metaentry{':'.$unikey.'.default'})) { 4623: $metaentry{':'.$unikey}= 4624: $metaentry{':'.$unikey.'.default'}; 4625: } 4626: } 4627: 4628: sub metadata_generate_part0 { 4629: my ($metadata,$metacache,$uri) = @_; 4630: my %allnames; 4631: foreach my $metakey (sort keys %$metadata) { 4632: if ($metakey=~/^parameter\_(.*)/) { 4633: my $part=$$metacache{':'.$metakey.'.part'}; 4634: my $name=$$metacache{':'.$metakey.'.name'}; 4635: if (! exists($$metadata{'parameter_0_'.$name.'.name'})) { 4636: $allnames{$name}=$part; 4637: } 4638: } 4639: } 4640: foreach my $name (keys(%allnames)) { 4641: $$metadata{"parameter_0_$name"}=1; 4642: my $key=":parameter_0_$name"; 4643: $$metacache{"$key.part"}='0'; 4644: $$metacache{"$key.name"}=$name; 4645: $$metacache{"$key.type"}=$$metacache{':parameter_'. 4646: $allnames{$name}.'_'.$name. 4647: '.type'}; 4648: my $olddis=$$metacache{':parameter_'.$allnames{$name}.'_'.$name. 4649: '.display'}; 4650: my $expr='\\[Part: '.$allnames{$name}.'\\]'; 4651: $olddis=~s/\Q$expr\E/\[Part: 0\]/; 4652: $$metacache{"$key.display"}=$olddis; 4653: } 4654: } 4655: 4656: # ------------------------------------------------- Get the title of a resource 4657: 4658: sub gettitle { 4659: my $urlsymb=shift; 4660: my $symb=&symbread($urlsymb); 4661: if ($symb) { 4662: my $key=$ENV{'request.course.id'}."\0".$symb; 4663: my ($result,$cached)=&is_cached_new('title',$key); 4664: if (defined($cached)) { 4665: return $result; 4666: } 4667: my ($map,$resid,$url)=&decode_symb($symb); 4668: my $title=''; 4669: my %bighash; 4670: if (tie(%bighash,'GDBM_File',$ENV{'request.course.fn'}.'.db', 4671: &GDBM_READER(),0640)) { 4672: my $mapid=$bighash{'map_pc_'.&clutter($map)}; 4673: $title=$bighash{'title_'.$mapid.'.'.$resid}; 4674: untie %bighash; 4675: } 4676: $title=~s/\&colon\;/\:/gs; 4677: if ($title) { 4678: return &do_cache_new('title',$key,$title,600); 4679: } 4680: $urlsymb=$url; 4681: } 4682: my $title=&metadata($urlsymb,'title'); 4683: if (!$title) { $title=(split('/',$urlsymb))[-1]; } 4684: return $title; 4685: } 4686: 4687: # ------------------------------------------------- Update symbolic store links 4688: 4689: sub symblist { 4690: my ($mapname,%newhash)=@_; 4691: $mapname=&deversion(&declutter($mapname)); 4692: my %hash; 4693: if (($ENV{'request.course.fn'}) && (%newhash)) { 4694: if (tie(%hash,'GDBM_File',$ENV{'request.course.fn'}.'_symb.db', 4695: &GDBM_WRCREAT(),0640)) { 4696: foreach (keys %newhash) { 4697: $hash{declutter($_)}=&encode_symb($mapname,$newhash{$_}->[1], 4698: $newhash{$_}->[0]); 4699: } 4700: if (untie(%hash)) { 4701: return 'ok'; 4702: } 4703: } 4704: } 4705: return 'error'; 4706: } 4707: 4708: # --------------------------------------------------------------- Verify a symb 4709: 4710: sub symbverify { 4711: my ($symb,$thisurl)=@_; 4712: my $thisfn=$thisurl; 4713: # wrapper not part of symbs 4714: $thisfn=~s/^\/adm\/wrapper//; 4715: $thisfn=&declutter($thisfn); 4716: # direct jump to resource in page or to a sequence - will construct own symbs 4717: if ($thisfn=~/\.(page|sequence)$/) { return 1; } 4718: # check URL part 4719: my ($map,$resid,$url)=&decode_symb($symb); 4720: 4721: unless ($url eq $thisfn) { return 0; } 4722: 4723: $symb=&symbclean($symb); 4724: $thisurl=&deversion($thisurl); 4725: $thisfn=&deversion($thisfn); 4726: 4727: my %bighash; 4728: my $okay=0; 4729: 4730: if (tie(%bighash,'GDBM_File',$ENV{'request.course.fn'}.'.db', 4731: &GDBM_READER(),0640)) { 4732: my $ids=$bighash{'ids_'.&clutter($thisurl)}; 4733: unless ($ids) { 4734: $ids=$bighash{'ids_/'.$thisurl}; 4735: } 4736: if ($ids) { 4737: # ------------------------------------------------------------------- Has ID(s) 4738: foreach (split(/\,/,$ids)) { 4739: my ($mapid,$resid)=split(/\./,$_); 4740: if ( 4741: &symbclean(&declutter($bighash{'map_id_'.$mapid}).'___'.$resid.'___'.$thisfn) 4742: eq $symb) { 4743: if (($ENV{'request.role.adv'}) || 4744: $bighash{'encrypted_'.$_} eq $ENV{'request.enc'}) { 4745: $okay=1; 4746: } 4747: } 4748: } 4749: } 4750: untie(%bighash); 4751: } 4752: return $okay; 4753: } 4754: 4755: # --------------------------------------------------------------- Clean-up symb 4756: 4757: sub symbclean { 4758: my $symb=shift; 4759: if ($symb=~m|^/enc/|) { $symb=&Apache::lonenc::unencrypted($symb); } 4760: # remove version from map 4761: $symb=~s/\.(\d+)\.(\w+)\_\_\_/\.$2\_\_\_/; 4762: 4763: # remove version from URL 4764: $symb=~s/\.(\d+)\.(\w+)$/\.$2/; 4765: 4766: # remove wrapper 4767: 4768: $symb=~s/(\_\_\_\d+\_\_\_)adm\/wrapper\/(res\/)*/$1/; 4769: return $symb; 4770: } 4771: 4772: # ---------------------------------------------- Split symb to find map and url 4773: 4774: sub encode_symb { 4775: my ($map,$resid,$url)=@_; 4776: return &symbclean(&declutter($map).'___'.$resid.'___'.&declutter($url)); 4777: } 4778: 4779: sub decode_symb { 4780: my $symb=shift; 4781: if ($symb=~m|^/enc/|) { $symb=&Apache::lonenc::unencrypted($symb); } 4782: my ($map,$resid,$url)=split(/___/,$symb); 4783: return (&fixversion($map),$resid,&fixversion($url)); 4784: } 4785: 4786: sub fixversion { 4787: my $fn=shift; 4788: if ($fn=~/^(adm|uploaded|public)/) { return $fn; } 4789: my %bighash; 4790: my $uri=&clutter($fn); 4791: my $key=$ENV{'request.course.id'}.'_'.$uri; 4792: # is this cached? 4793: my ($result,$cached)=&is_cached_new('courseresversion',$key); 4794: if (defined($cached)) { return $result; } 4795: # unfortunately not cached, or expired 4796: if (tie(%bighash,'GDBM_File',$ENV{'request.course.fn'}.'.db', 4797: &GDBM_READER(),0640)) { 4798: if ($bighash{'version_'.$uri}) { 4799: my $version=$bighash{'version_'.$uri}; 4800: unless (($version eq 'mostrecent') || 4801: ($version==&getversion($uri))) { 4802: $uri=~s/\.(\w+)$/\.$version\.$1/; 4803: } 4804: } 4805: untie %bighash; 4806: } 4807: return &do_cache_new('courseresversion',$key,&declutter($uri),600); 4808: } 4809: 4810: sub deversion { 4811: my $url=shift; 4812: $url=~s/\.\d+\.(\w+)$/\.$1/; 4813: return $url; 4814: } 4815: 4816: # ------------------------------------------------------ Return symb list entry 4817: 4818: sub symbread { 4819: my ($thisfn,$donotrecurse)=@_; 4820: my $cache_str='request.symbread.cached.'.$thisfn; 4821: if (defined($ENV{$cache_str})) { return $ENV{$cache_str}; } 4822: # no filename provided? try from environment 4823: unless ($thisfn) { 4824: if ($ENV{'request.symb'}) { 4825: return $ENV{$cache_str}=&symbclean($ENV{'request.symb'}); 4826: } 4827: $thisfn=$ENV{'request.filename'}; 4828: } 4829: if ($thisfn=~m|^/enc/|) { $thisfn=&Apache::lonenc::unencrypted($thisfn); } 4830: # is that filename actually a symb? Verify, clean, and return 4831: if ($thisfn=~/\_\_\_\d+\_\_\_(.*)$/) { 4832: if (&symbverify($thisfn,$1)) { 4833: return $ENV{$cache_str}=&symbclean($thisfn); 4834: } 4835: } 4836: $thisfn=declutter($thisfn); 4837: my %hash; 4838: my %bighash; 4839: my $syval=''; 4840: if (($ENV{'request.course.fn'}) && ($thisfn)) { 4841: my $targetfn = $thisfn; 4842: if ( ($thisfn =~ m/^uploaded\//) && ($thisfn !~ m/\.(page|sequence)$/) ) { 4843: $targetfn = 'adm/wrapper/'.$thisfn; 4844: } 4845: if (tie(%hash,'GDBM_File',$ENV{'request.course.fn'}.'_symb.db', 4846: &GDBM_READER(),0640)) { 4847: $syval=$hash{$targetfn}; 4848: untie(%hash); 4849: } 4850: # ---------------------------------------------------------- There was an entry 4851: if ($syval) { 4852: #unless ($syval=~/\_\d+$/) { 4853: #unless ($ENV{'form.request.prefix'}=~/\.(\d+)\_$/) { 4854: #&appenv('request.ambiguous' => $thisfn); 4855: #return $ENV{$cache_str}=''; 4856: #} 4857: #$syval.=$1; 4858: #} 4859: } else { 4860: # ------------------------------------------------------- Was not in symb table 4861: if (tie(%bighash,'GDBM_File',$ENV{'request.course.fn'}.'.db', 4862: &GDBM_READER(),0640)) { 4863: # ---------------------------------------------- Get ID(s) for current resource 4864: my $ids=$bighash{'ids_'.&clutter($thisfn)}; 4865: unless ($ids) { 4866: $ids=$bighash{'ids_/'.$thisfn}; 4867: } 4868: unless ($ids) { 4869: # alias? 4870: $ids=$bighash{'mapalias_'.$thisfn}; 4871: } 4872: if ($ids) { 4873: # ------------------------------------------------------------------- Has ID(s) 4874: my @possibilities=split(/\,/,$ids); 4875: if ($#possibilities==0) { 4876: # ----------------------------------------------- There is only one possibility 4877: my ($mapid,$resid)=split(/\./,$ids); 4878: $syval=declutter($bighash{'map_id_'.$mapid}).'___'.$resid; 4879: } elsif (!$donotrecurse) { 4880: # ------------------------------------------ There is more than one possibility 4881: my $realpossible=0; 4882: foreach (@possibilities) { 4883: my $file=$bighash{'src_'.$_}; 4884: if (&allowed('bre',$file)) { 4885: my ($mapid,$resid)=split(/\./,$_); 4886: if ($bighash{'map_type_'.$mapid} ne 'page') { 4887: $realpossible++; 4888: $syval=declutter($bighash{'map_id_'.$mapid}). 4889: '___'.$resid; 4890: } 4891: } 4892: } 4893: if ($realpossible!=1) { $syval=''; } 4894: } else { 4895: $syval=''; 4896: } 4897: } 4898: untie(%bighash) 4899: } 4900: } 4901: if ($syval) { 4902: return $ENV{$cache_str}=$syval; 4903: #return $ENV{$cache_str}=&symbclean($syval.'___'.$thisfn); 4904: } 4905: } 4906: &appenv('request.ambiguous' => $thisfn); 4907: return $ENV{$cache_str}=''; 4908: } 4909: 4910: # ---------------------------------------------------------- Return random seed 4911: 4912: sub numval { 4913: my $txt=shift; 4914: $txt=~tr/A-J/0-9/; 4915: $txt=~tr/a-j/0-9/; 4916: $txt=~tr/K-T/0-9/; 4917: $txt=~tr/k-t/0-9/; 4918: $txt=~tr/U-Z/0-5/; 4919: $txt=~tr/u-z/0-5/; 4920: $txt=~s/\D//g; 4921: if ($_64bit) { if ($txt > 2**32) { return -1; } } 4922: return int($txt); 4923: } 4924: 4925: sub numval2 { 4926: my $txt=shift; 4927: $txt=~tr/A-J/0-9/; 4928: $txt=~tr/a-j/0-9/; 4929: $txt=~tr/K-T/0-9/; 4930: $txt=~tr/k-t/0-9/; 4931: $txt=~tr/U-Z/0-5/; 4932: $txt=~tr/u-z/0-5/; 4933: $txt=~s/\D//g; 4934: my @txts=split(/(\d\d\d\d\d\d\d\d\d)/,$txt); 4935: my $total; 4936: foreach my $val (@txts) { $total+=$val; } 4937: if ($_64bit) { if ($total > 2**32) { return -1; } } 4938: return int($total); 4939: } 4940: 4941: sub numval3 { 4942: use integer; 4943: my $txt=shift; 4944: $txt=~tr/A-J/0-9/; 4945: $txt=~tr/a-j/0-9/; 4946: $txt=~tr/K-T/0-9/; 4947: $txt=~tr/k-t/0-9/; 4948: $txt=~tr/U-Z/0-5/; 4949: $txt=~tr/u-z/0-5/; 4950: $txt=~s/\D//g; 4951: my @txts=split(/(\d\d\d\d\d\d\d\d\d)/,$txt); 4952: my $total; 4953: foreach my $val (@txts) { $total+=$val; } 4954: if ($_64bit) { $total=(($total<<32)>>32); } 4955: return $total; 4956: } 4957: 4958: sub latest_rnd_algorithm_id { 4959: return '64bit4'; 4960: } 4961: 4962: sub get_rand_alg { 4963: my ($courseid)=@_; 4964: if (!$courseid) { $courseid=(&Apache::lonxml::whichuser())[1]; } 4965: if ($courseid) { 4966: return $ENV{"course.$courseid.rndseed"}; 4967: } 4968: return &latest_rnd_algorithm_id(); 4969: } 4970: 4971: sub validCODE { 4972: my ($CODE)=@_; 4973: if (defined($CODE) && $CODE ne '' && $CODE =~ /^\w+$/) { return 1; } 4974: return 0; 4975: } 4976: 4977: sub getCODE { 4978: if (&validCODE($ENV{'form.CODE'})) { return $ENV{'form.CODE'}; } 4979: if (defined($Apache::lonhomework::parsing_a_problem) && 4980: &validCODE($Apache::lonhomework::history{'resource.CODE'})) { 4981: return $Apache::lonhomework::history{'resource.CODE'}; 4982: } 4983: return undef; 4984: } 4985: 4986: sub rndseed { 4987: my ($symb,$courseid,$domain,$username)=@_; 4988: 4989: my ($wsymb,$wcourseid,$wdomain,$wusername)=&Apache::lonxml::whichuser(); 4990: if (!$symb) { 4991: unless ($symb=$wsymb) { return time; } 4992: } 4993: if (!$courseid) { $courseid=$wcourseid; } 4994: if (!$domain) { $domain=$wdomain; } 4995: if (!$username) { $username=$wusername } 4996: my $which=&get_rand_alg(); 4997: if (defined(&getCODE())) { 4998: if ($which eq '64bit4') { 4999: return &rndseed_CODE_64bit4($symb,$courseid,$domain,$username); 5000: } else { 5001: return &rndseed_CODE_64bit($symb,$courseid,$domain,$username); 5002: } 5003: } elsif ($which eq '64bit4') { 5004: return &rndseed_64bit4($symb,$courseid,$domain,$username); 5005: } elsif ($which eq '64bit3') { 5006: return &rndseed_64bit3($symb,$courseid,$domain,$username); 5007: } elsif ($which eq '64bit2') { 5008: return &rndseed_64bit2($symb,$courseid,$domain,$username); 5009: } elsif ($which eq '64bit') { 5010: return &rndseed_64bit($symb,$courseid,$domain,$username); 5011: } 5012: return &rndseed_32bit($symb,$courseid,$domain,$username); 5013: } 5014: 5015: sub rndseed_32bit { 5016: my ($symb,$courseid,$domain,$username)=@_; 5017: { 5018: use integer; 5019: my $symbchck=unpack("%32C*",$symb) << 27; 5020: my $symbseed=numval($symb) << 22; 5021: my $namechck=unpack("%32C*",$username) << 17; 5022: my $nameseed=numval($username) << 12; 5023: my $domainseed=unpack("%32C*",$domain) << 7; 5024: my $courseseed=unpack("%32C*",$courseid); 5025: my $num=$symbseed+$nameseed+$domainseed+$courseseed+$namechck+$symbchck; 5026: #&Apache::lonxml::debug("$symbseed:$nameseed;$domainseed|$courseseed;$namechck:$symbchck"); 5027: #&Apache::lonxml::debug("rndseed :$num:$symb"); 5028: if ($_64bit) { $num=(($num<<32)>>32); } 5029: return $num; 5030: } 5031: } 5032: 5033: sub rndseed_64bit { 5034: my ($symb,$courseid,$domain,$username)=@_; 5035: { 5036: use integer; 5037: my $symbchck=unpack("%32S*",$symb) << 21; 5038: my $symbseed=numval($symb) << 10; 5039: my $namechck=unpack("%32S*",$username); 5040: 5041: my $nameseed=numval($username) << 21; 5042: my $domainseed=unpack("%32S*",$domain) << 10; 5043: my $courseseed=unpack("%32S*",$courseid); 5044: 5045: my $num1=$symbchck+$symbseed+$namechck; 5046: my $num2=$nameseed+$domainseed+$courseseed; 5047: #&Apache::lonxml::debug("$symbseed:$nameseed;$domainseed|$courseseed;$namechck:$symbchck"); 5048: #&Apache::lonxml::debug("rndseed :$num:$symb"); 5049: if ($_64bit) { $num1=(($num1<<32)>>32); $num2=(($num2<<32)>>32); } 5050: if ($_64bit) { $num1=(($num1<<32)>>32); $num2=(($num2<<32)>>32); } 5051: return "$num1,$num2"; 5052: } 5053: } 5054: 5055: sub rndseed_64bit2 { 5056: my ($symb,$courseid,$domain,$username)=@_; 5057: { 5058: use integer; 5059: # strings need to be an even # of cahracters long, it it is odd the 5060: # last characters gets thrown away 5061: my $symbchck=unpack("%32S*",$symb.' ') << 21; 5062: my $symbseed=numval($symb) << 10; 5063: my $namechck=unpack("%32S*",$username.' '); 5064: 5065: my $nameseed=numval($username) << 21; 5066: my $domainseed=unpack("%32S*",$domain.' ') << 10; 5067: my $courseseed=unpack("%32S*",$courseid.' '); 5068: 5069: my $num1=$symbchck+$symbseed+$namechck; 5070: my $num2=$nameseed+$domainseed+$courseseed; 5071: #&Apache::lonxml::debug("$symbseed:$nameseed;$domainseed|$courseseed;$namechck:$symbchck"); 5072: #&Apache::lonxml::debug("rndseed :$num:$symb"); 5073: return "$num1,$num2"; 5074: } 5075: } 5076: 5077: sub rndseed_64bit3 { 5078: my ($symb,$courseid,$domain,$username)=@_; 5079: { 5080: use integer; 5081: # strings need to be an even # of cahracters long, it it is odd the 5082: # last characters gets thrown away 5083: my $symbchck=unpack("%32S*",$symb.' ') << 21; 5084: my $symbseed=numval2($symb) << 10; 5085: my $namechck=unpack("%32S*",$username.' '); 5086: 5087: my $nameseed=numval2($username) << 21; 5088: my $domainseed=unpack("%32S*",$domain.' ') << 10; 5089: my $courseseed=unpack("%32S*",$courseid.' '); 5090: 5091: my $num1=$symbchck+$symbseed+$namechck; 5092: my $num2=$nameseed+$domainseed+$courseseed; 5093: #&Apache::lonxml::debug("$symbseed:$nameseed;$domainseed|$courseseed;$namechck:$symbchck"); 5094: #&Apache::lonxml::debug("rndseed :$num1:$num2:$_64bit"); 5095: if ($_64bit) { $num1=(($num1<<32)>>32); $num2=(($num2<<32)>>32); } 5096: 5097: return "$num1:$num2"; 5098: } 5099: } 5100: 5101: sub rndseed_64bit4 { 5102: my ($symb,$courseid,$domain,$username)=@_; 5103: { 5104: use integer; 5105: # strings need to be an even # of cahracters long, it it is odd the 5106: # last characters gets thrown away 5107: my $symbchck=unpack("%32S*",$symb.' ') << 21; 5108: my $symbseed=numval3($symb) << 10; 5109: my $namechck=unpack("%32S*",$username.' '); 5110: 5111: my $nameseed=numval3($username) << 21; 5112: my $domainseed=unpack("%32S*",$domain.' ') << 10; 5113: my $courseseed=unpack("%32S*",$courseid.' '); 5114: 5115: my $num1=$symbchck+$symbseed+$namechck; 5116: my $num2=$nameseed+$domainseed+$courseseed; 5117: #&Apache::lonxml::debug("$symbseed:$nameseed;$domainseed|$courseseed;$namechck:$symbchck"); 5118: #&Apache::lonxml::debug("rndseed :$num1:$num2:$_64bit"); 5119: if ($_64bit) { $num1=(($num1<<32)>>32); $num2=(($num2<<32)>>32); } 5120: 5121: return "$num1:$num2"; 5122: } 5123: } 5124: 5125: sub rndseed_CODE_64bit { 5126: my ($symb,$courseid,$domain,$username)=@_; 5127: { 5128: use integer; 5129: my $symbchck=unpack("%32S*",$symb.' ') << 16; 5130: my $symbseed=numval2($symb); 5131: my $CODEchck=unpack("%32S*",&getCODE().' ') << 16; 5132: my $CODEseed=numval(&getCODE()); 5133: my $courseseed=unpack("%32S*",$courseid.' '); 5134: my $num1=$symbseed+$CODEchck; 5135: my $num2=$CODEseed+$courseseed+$symbchck; 5136: #&Apache::lonxml::debug("$symbseed:$CODEchck|$CODEseed:$courseseed:$symbchck"); 5137: #&Apache::lonxml::debug("rndseed :$num1:$num2:$symb"); 5138: if ($_64bit) { $num1=(($num1<<32)>>32); } 5139: if ($_64bit) { $num2=(($num2<<32)>>32); } 5140: return "$num1:$num2"; 5141: } 5142: } 5143: 5144: sub rndseed_CODE_64bit4 { 5145: my ($symb,$courseid,$domain,$username)=@_; 5146: { 5147: use integer; 5148: my $symbchck=unpack("%32S*",$symb.' ') << 16; 5149: my $symbseed=numval3($symb); 5150: my $CODEchck=unpack("%32S*",&getCODE().' ') << 16; 5151: my $CODEseed=numval3(&getCODE()); 5152: my $courseseed=unpack("%32S*",$courseid.' '); 5153: my $num1=$symbseed+$CODEchck; 5154: my $num2=$CODEseed+$courseseed+$symbchck; 5155: #&Apache::lonxml::debug("$symbseed:$CODEchck|$CODEseed:$courseseed:$symbchck"); 5156: #&Apache::lonxml::debug("rndseed :$num1:$num2:$symb"); 5157: if ($_64bit) { $num1=(($num1<<32)>>32); } 5158: if ($_64bit) { $num2=(($num2<<32)>>32); } 5159: return "$num1:$num2"; 5160: } 5161: } 5162: 5163: sub setup_random_from_rndseed { 5164: my ($rndseed)=@_; 5165: if ($rndseed =~/([,:])/) { 5166: my ($num1,$num2)=split(/[,:]/,$rndseed); 5167: &Math::Random::random_set_seed(abs($num1),abs($num2)); 5168: } else { 5169: &Math::Random::random_set_seed_from_phrase($rndseed); 5170: } 5171: } 5172: 5173: sub latest_receipt_algorithm_id { 5174: return 'receipt2'; 5175: } 5176: 5177: sub recunique { 5178: my $fucourseid=shift; 5179: my $unique; 5180: if ($ENV{"course.$fucourseid.receiptalg"} eq 'receipt2') { 5181: $unique=$ENV{"course.$fucourseid.internal.encseed"}; 5182: } else { 5183: $unique=$perlvar{'lonReceipt'}; 5184: } 5185: return unpack("%32C*",$unique); 5186: } 5187: 5188: sub recprefix { 5189: my $fucourseid=shift; 5190: my $prefix; 5191: if ($ENV{"course.$fucourseid.receiptalg"} eq 'receipt2') { 5192: $prefix=$ENV{"course.$fucourseid.internal.encpref"}; 5193: } else { 5194: $prefix=$perlvar{'lonHostID'}; 5195: } 5196: return unpack("%32C*",$prefix); 5197: } 5198: 5199: sub ireceipt { 5200: my ($funame,$fudom,$fucourseid,$fusymb,$part)=@_; 5201: my $cuname=unpack("%32C*",$funame); 5202: my $cudom=unpack("%32C*",$fudom); 5203: my $cucourseid=unpack("%32C*",$fucourseid); 5204: my $cusymb=unpack("%32C*",$fusymb); 5205: my $cunique=&recunique($fucourseid); 5206: my $cpart=unpack("%32S*",$part); 5207: my $return =&recprefix($fucourseid).'-'; 5208: if ($ENV{"course.$fucourseid.receiptalg"} eq 'receipt2' || 5209: $ENV{'request.state'} eq 'construct') { 5210: &Apache::lonxml::debug("doing receipt2 using parts $cpart, uname $cuname and udom $cudom gets ".($cpart%$cuname). 5211: " and ".($cpart%$cudom)); 5212: 5213: $return.= ($cunique%$cuname+ 5214: $cunique%$cudom+ 5215: $cusymb%$cuname+ 5216: $cusymb%$cudom+ 5217: $cucourseid%$cuname+ 5218: $cucourseid%$cudom+ 5219: $cpart%$cuname+ 5220: $cpart%$cudom); 5221: } else { 5222: $return.= ($cunique%$cuname+ 5223: $cunique%$cudom+ 5224: $cusymb%$cuname+ 5225: $cusymb%$cudom+ 5226: $cucourseid%$cuname+ 5227: $cucourseid%$cudom); 5228: } 5229: return $return; 5230: } 5231: 5232: sub receipt { 5233: my ($part)=@_; 5234: my ($symb,$courseid,$domain,$name) = &Apache::lonxml::whichuser(); 5235: return &ireceipt($name,$domain,$courseid,$symb,$part); 5236: } 5237: 5238: # ------------------------------------------------------------ Serves up a file 5239: # returns either the contents of the file or 5240: # -1 if the file doesn't exist 5241: # 5242: # if the target is a file that was uploaded via DOCS, 5243: # a check will be made to see if a current copy exists on the local server, 5244: # if it does this will be served, otherwise a copy will be retrieved from 5245: # the home server for the course and stored in /home/httpd/html/userfiles on 5246: # the local server. 5247: 5248: sub getfile { 5249: my ($file) = @_; 5250: 5251: if ($file =~ m|^/*uploaded/|) { $file=&filelocation("",$file); } 5252: &repcopy($file); 5253: return &readfile($file); 5254: } 5255: 5256: sub repcopy_userfile { 5257: my ($file)=@_; 5258: if ($file =~ m|^/*uploaded/|) { $file=&filelocation("",$file); } 5259: if ($file =~ m|^/home/httpd/html/lonUsers/|) { return 'OK'; } 5260: my ($cdom,$cnum,$filename) = 5261: ($file=~m|^\Q$perlvar{'lonDocRoot'}\E/+userfiles/+([^/]+)/+([^/]+)/+(.*)|); 5262: my ($info,$rtncode); 5263: my $uri="/uploaded/$cdom/$cnum/$filename"; 5264: if (-e "$file") { 5265: my @fileinfo = stat($file); 5266: my $lwpresp = &getuploaded('HEAD',$uri,$cdom,$cnum,\$info,\$rtncode); 5267: if ($lwpresp ne 'ok') { 5268: if ($rtncode eq '404') { 5269: unlink($file); 5270: } 5271: #my $ua=new LWP::UserAgent; 5272: #my $request=new HTTP::Request('GET',&tokenwrapper($uri)); 5273: #my $response=$ua->request($request); 5274: #if ($response->is_success()) { 5275: # return $response->content; 5276: # } else { 5277: # return -1; 5278: # } 5279: return -1; 5280: } 5281: if ($info < $fileinfo[9]) { 5282: return 'OK'; 5283: } 5284: $info = ''; 5285: $lwpresp = &getuploaded('GET',$uri,$cdom,$cnum,\$info,\$rtncode); 5286: if ($lwpresp ne 'ok') { 5287: return -1; 5288: } 5289: } else { 5290: my $lwpresp = &getuploaded('GET',$uri,$cdom,$cnum,\$info,\$rtncode); 5291: if ($lwpresp ne 'ok') { 5292: my $ua=new LWP::UserAgent; 5293: my $request=new HTTP::Request('GET',&tokenwrapper($uri)); 5294: my $response=$ua->request($request); 5295: if ($response->is_success()) { 5296: $info=$response->content; 5297: } else { 5298: return -1; 5299: } 5300: } 5301: my @parts = ($cdom,$cnum); 5302: if ($filename =~ m|^(.+)/[^/]+$|) { 5303: push @parts, split(/\//,$1); 5304: } 5305: my $path = $perlvar{'lonDocRoot'}.'/userfiles'; 5306: foreach my $part (@parts) { 5307: $path .= '/'.$part; 5308: if (!-e $path) { 5309: mkdir($path,0770); 5310: } 5311: } 5312: } 5313: open(FILE,">$file"); 5314: print FILE $info; 5315: close(FILE); 5316: return 'OK'; 5317: } 5318: 5319: sub tokenwrapper { 5320: my $uri=shift; 5321: $uri=~s|^http\://([^/]+)||; 5322: $uri=~s|^/||; 5323: $ENV{'user.environment'}=~/\/([^\/]+)\.id/; 5324: my $token=$1; 5325: my (undef,$udom,$uname,$file)=split('/',$uri,4); 5326: if ($udom && $uname && $file) { 5327: $file=~s|(\?\.*)*$||; 5328: &appenv("userfile.$udom/$uname/$file" => $ENV{'request.course.id'}); 5329: return 'http://'.$hostname{ &homeserver($uname,$udom)}.'/'.$uri. 5330: (($uri=~/\?/)?'&':'?').'token='.$token. 5331: '&tokenissued='.$perlvar{'lonHostID'}; 5332: } else { 5333: return '/adm/notfound.html'; 5334: } 5335: } 5336: 5337: sub getuploaded { 5338: my ($reqtype,$uri,$cdom,$cnum,$info,$rtncode) = @_; 5339: $uri=~s/^\///; 5340: $uri = 'http://'.$hostname{ &homeserver($cnum,$cdom)}.'/raw/'.$uri; 5341: my $ua=new LWP::UserAgent; 5342: my $request=new HTTP::Request($reqtype,$uri); 5343: my $response=$ua->request($request); 5344: $$rtncode = $response->code; 5345: if (! $response->is_success()) { 5346: return 'failed'; 5347: } 5348: if ($reqtype eq 'HEAD') { 5349: $$info = &HTTP::Date::str2time( $response->header('Last-modified') ); 5350: } elsif ($reqtype eq 'GET') { 5351: $$info = $response->content; 5352: } 5353: return 'ok'; 5354: } 5355: 5356: sub readfile { 5357: my $file = shift; 5358: if ( (! -e $file ) || ($file eq '') ) { return -1; }; 5359: my $fh; 5360: open($fh,"<$file"); 5361: my $a=''; 5362: while (<$fh>) { $a .=$_; } 5363: return $a; 5364: } 5365: 5366: sub filelocation { 5367: my ($dir,$file) = @_; 5368: my $location; 5369: $file=~ s/^\s*(\S+)\s*$/$1/; ## strip off leading and trailing spaces 5370: if ($file=~m:^/~:) { # is a contruction space reference 5371: $location = $file; 5372: $location =~ s:/~(.*?)/(.*):/home/$1/public_html/$2:; 5373: } elsif ($file=~/^\/*uploaded/) { # is an uploaded file 5374: my ($udom,$uname,$filename)= 5375: ($file=~m|^/+uploaded/+([^/]+)/+([^/]+)/+(.*)$|); 5376: my $home=&homeserver($uname,$udom); 5377: my $is_me=0; 5378: my @ids=&current_machine_ids(); 5379: foreach my $id (@ids) { if ($id eq $home) { $is_me=1; } } 5380: if ($is_me) { 5381: $location=&Apache::loncommon::propath($udom,$uname). 5382: '/userfiles/'.$filename; 5383: } else { 5384: $location=$Apache::lonnet::perlvar{'lonDocRoot'}.'/userfiles/'. 5385: $udom.'/'.$uname.'/'.$filename; 5386: } 5387: } else { 5388: $file=~s/^\Q$perlvar{'lonDocRoot'}\E//; 5389: $file=~s:^/res/:/:; 5390: if ( !( $file =~ m:^/:) ) { 5391: $location = $dir. '/'.$file; 5392: } else { 5393: $location = '/home/httpd/html/res'.$file; 5394: } 5395: } 5396: $location=~s://+:/:g; # remove duplicate / 5397: while ($location=~m:/\.\./:) {$location=~ s:/[^/]+/\.\./:/:g;} #remove dir/.. 5398: while ($location=~m:/\./:) {$location=~ s:/\./:/:g;} #remove /./ 5399: return $location; 5400: } 5401: 5402: sub hreflocation { 5403: my ($dir,$file)=@_; 5404: unless (($file=~m-^http://-i) || ($file=~m-^/-)) { 5405: my $finalpath=filelocation($dir,$file); 5406: $finalpath=~s-^/home/httpd/html--; 5407: $finalpath=~s-^/home/(\w+)/public_html/-/~$1/-; 5408: return $finalpath; 5409: } elsif ($file=~m-^/home-) { 5410: $file=~s-^/home/httpd/html--; 5411: $file=~s-^/home/(\w+)/public_html/-/~$1/-; 5412: return $file; 5413: } 5414: return $file; 5415: } 5416: 5417: sub current_machine_domains { 5418: my $hostname=$hostname{$perlvar{'lonHostID'}}; 5419: my @domains; 5420: while( my($id, $name) = each(%hostname)) { 5421: # &logthis("-$id-$name-$hostname-"); 5422: if ($hostname eq $name) { 5423: push(@domains,$hostdom{$id}); 5424: } 5425: } 5426: return @domains; 5427: } 5428: 5429: sub current_machine_ids { 5430: my $hostname=$hostname{$perlvar{'lonHostID'}}; 5431: my @ids; 5432: while( my($id, $name) = each(%hostname)) { 5433: # &logthis("-$id-$name-$hostname-"); 5434: if ($hostname eq $name) { 5435: push(@ids,$id); 5436: } 5437: } 5438: return @ids; 5439: } 5440: 5441: # ------------------------------------------------------------- Declutters URLs 5442: 5443: sub declutter { 5444: my $thisfn=shift; 5445: if ($thisfn=~m|^/enc/|) { $thisfn=&Apache::lonenc::unencrypted($thisfn); } 5446: $thisfn=~s/^\Q$perlvar{'lonDocRoot'}\E//; 5447: $thisfn=~s/^\///; 5448: $thisfn=~s/^res\///; 5449: $thisfn=~s/\?.+$//; 5450: return $thisfn; 5451: } 5452: 5453: # ------------------------------------------------------------- Clutter up URLs 5454: 5455: sub clutter { 5456: my $thisfn='/'.&declutter(shift); 5457: unless ($thisfn=~/^\/(uploaded|adm|userfiles|ext|raw|priv|public)\//) { 5458: $thisfn='/res'.$thisfn; 5459: } 5460: return $thisfn; 5461: } 5462: 5463: sub freeze_escape { 5464: my ($value)=@_; 5465: if (ref($value)) { 5466: $value=&nfreeze($value); 5467: return '__FROZEN__'.&escape($value); 5468: } 5469: return &escape($value); 5470: } 5471: 5472: # -------------------------------------------------------- Escape Special Chars 5473: 5474: sub escape { 5475: my $str=shift; 5476: $str =~ s/(\W)/"%".unpack('H2',$1)/eg; 5477: return $str; 5478: } 5479: 5480: # ----------------------------------------------------- Un-Escape Special Chars 5481: 5482: sub unescape { 5483: my $str=shift; 5484: $str =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C",hex($1))/eg; 5485: return $str; 5486: } 5487: 5488: sub thaw_unescape { 5489: my ($value)=@_; 5490: if ($value =~ /^__FROZEN__/) { 5491: substr($value,0,10,undef); 5492: $value=&unescape($value); 5493: return &thaw($value); 5494: } 5495: return &unescape($value); 5496: } 5497: 5498: sub mod_perl_version { 5499: return 1; 5500: if (defined($perlvar{'MODPERL2'})) { 5501: return 2; 5502: } 5503: } 5504: 5505: sub correct_line_ends { 5506: my ($result)=@_; 5507: $$result =~s/\r\n/\n/mg; 5508: $$result =~s/\r/\n/mg; 5509: } 5510: # ================================================================ Main Program 5511: 5512: sub goodbye { 5513: &logthis("Starting Shut down"); 5514: #not converted to using infrastruture and probably shouldn't be 5515: &logthis(sprintf("%-20s is %s",'%badServerCache',length(&freeze(\%badServerCache)))); 5516: #converted 5517: # &logthis(sprintf("%-20s is %s",'%metacache',scalar(%metacache))); 5518: &logthis(sprintf("%-20s is %s",'%homecache',length(&freeze(\%homecache)))); 5519: # &logthis(sprintf("%-20s is %s",'%titlecache',length(&freeze(\%titlecache)))); 5520: # &logthis(sprintf("%-20s is %s",'%courseresdatacache',length(&freeze(\%courseresdatacache)))); 5521: #1.1 only 5522: # &logthis(sprintf("%-20s is %s",'%userresdatacache',length(&freeze(\%userresdatacache)))); 5523: # &logthis(sprintf("%-20s is %s",'%getsectioncache',length(&freeze(\%getsectioncache)))); 5524: # &logthis(sprintf("%-20s is %s",'%courseresversioncache',length(&freeze(\%courseresversioncache)))); 5525: # &logthis(sprintf("%-20s is %s",'%resversioncache',length(&freeze(\%resversioncache)))); 5526: &logthis(sprintf("%-20s is %s",'%remembered',length(&freeze(\%remembered)))); 5527: &logthis(sprintf("%-20s is %s",'kicks',$kicks)); 5528: &logthis(sprintf("%-20s is %s",'hits',$hits)); 5529: &flushcourselogs(); 5530: &logthis("Shutting down"); 5531: return DONE; 5532: } 5533: 5534: BEGIN { 5535: # ----------------------------------- Read loncapa.conf and loncapa_apache.conf 5536: unless ($readit) { 5537: { 5538: # FIXME: Use LONCAPA::Configuration::read_conf here and omit next block 5539: open(my $config,"</etc/httpd/conf/loncapa.conf"); 5540: 5541: while (my $configline=<$config>) { 5542: if ($configline=~/\S/ && $configline =~ /^[^\#]*PerlSetVar/) { 5543: my ($dummy,$varname,$varvalue)=split(/\s+/,$configline); 5544: chomp($varvalue); 5545: $perlvar{$varname}=$varvalue; 5546: } 5547: } 5548: close($config); 5549: } 5550: { 5551: open(my $config,"</etc/httpd/conf/loncapa_apache.conf"); 5552: 5553: while (my $configline=<$config>) { 5554: if ($configline =~ /^[^\#]*PerlSetVar/) { 5555: my ($dummy,$varname,$varvalue)=split(/\s+/,$configline); 5556: chomp($varvalue); 5557: $perlvar{$varname}=$varvalue; 5558: } 5559: } 5560: close($config); 5561: } 5562: 5563: # ------------------------------------------------------------ Read domain file 5564: { 5565: %domaindescription = (); 5566: %domain_auth_def = (); 5567: %domain_auth_arg_def = (); 5568: my $fh; 5569: if (open($fh,"<".$Apache::lonnet::perlvar{'lonTabDir'}.'/domain.tab')) { 5570: while (<$fh>) { 5571: next if (/^(\#|\s*$)/); 5572: # next if /^\#/; 5573: chomp; 5574: my ($domain, $domain_description, $def_auth, $def_auth_arg, 5575: $def_lang, $city, $longi, $lati) = split(/:/,$_); 5576: $domain_auth_def{$domain}=$def_auth; 5577: $domain_auth_arg_def{$domain}=$def_auth_arg; 5578: $domaindescription{$domain}=$domain_description; 5579: $domain_lang_def{$domain}=$def_lang; 5580: $domain_city{$domain}=$city; 5581: $domain_longi{$domain}=$longi; 5582: $domain_lati{$domain}=$lati; 5583: 5584: # &logthis("Domain.tab: $domain, $domain_auth_def{$domain}, $domain_auth_arg_def{$domain},$domaindescription{$domain}"); 5585: # &logthis("Domain.tab: $domain ".$domaindescription{$domain} ); 5586: } 5587: } 5588: close ($fh); 5589: } 5590: 5591: 5592: # ------------------------------------------------------------- Read hosts file 5593: { 5594: open(my $config,"<$perlvar{'lonTabDir'}/hosts.tab"); 5595: 5596: while (my $configline=<$config>) { 5597: next if ($configline =~ /^(\#|\s*$)/); 5598: chomp($configline); 5599: my ($id,$domain,$role,$name)=split(/:/,$configline); 5600: $name=~s/\s//g; 5601: if ($id && $domain && $role && $name) { 5602: $hostname{$id}=$name; 5603: $hostdom{$id}=$domain; 5604: if ($role eq 'library') { $libserv{$id}=$name; } 5605: } 5606: } 5607: close($config); 5608: } 5609: 5610: sub get_iphost { 5611: if (%iphost) { return %iphost; } 5612: foreach my $id (keys(%hostname)) { 5613: my $name=$hostname{$id}; 5614: my $ip = gethostbyname($name); 5615: if (!$ip || length($ip) ne 4) { 5616: &logthis("Skipping host $id name $name no IP found\n"); 5617: next; 5618: } 5619: $ip=inet_ntoa($ip); 5620: push(@{$iphost{$ip}},$id); 5621: } 5622: return %iphost; 5623: } 5624: 5625: # ------------------------------------------------------ Read spare server file 5626: { 5627: open(my $config,"<$perlvar{'lonTabDir'}/spare.tab"); 5628: 5629: while (my $configline=<$config>) { 5630: chomp($configline); 5631: if ($configline) { 5632: $spareid{$configline}=1; 5633: } 5634: } 5635: close($config); 5636: } 5637: # ------------------------------------------------------------ Read permissions 5638: { 5639: open(my $config,"<$perlvar{'lonTabDir'}/roles.tab"); 5640: 5641: while (my $configline=<$config>) { 5642: chomp($configline); 5643: if ($configline) { 5644: my ($role,$perm)=split(/ /,$configline); 5645: if ($perm ne '') { $pr{$role}=$perm; } 5646: } 5647: } 5648: close($config); 5649: } 5650: 5651: # -------------------------------------------- Read plain texts for permissions 5652: { 5653: open(my $config,"<$perlvar{'lonTabDir'}/rolesplain.tab"); 5654: 5655: while (my $configline=<$config>) { 5656: chomp($configline); 5657: if ($configline) { 5658: my ($short,$plain)=split(/:/,$configline); 5659: if ($plain ne '') { $prp{$short}=$plain; } 5660: } 5661: } 5662: close($config); 5663: } 5664: 5665: # ---------------------------------------------------------- Read package table 5666: { 5667: open(my $config,"<$perlvar{'lonTabDir'}/packages.tab"); 5668: 5669: while (my $configline=<$config>) { 5670: if ($configline !~ /\S/ || $configline=~/^#/) { next; } 5671: chomp($configline); 5672: my ($short,$plain)=split(/:/,$configline); 5673: my ($pack,$name)=split(/\&/,$short); 5674: if ($plain ne '') { 5675: $packagetab{$pack.'&'.$name.'&name'}=$name; 5676: $packagetab{$short}=$plain; 5677: } 5678: } 5679: close($config); 5680: } 5681: 5682: # ------------- set up temporary directory 5683: { 5684: $tmpdir = $perlvar{'lonDaemons'}.'/tmp/'; 5685: 5686: } 5687: 5688: $memcache=new Cache::Memcached({'servers'=>['127.0.0.1:11211']}); 5689: 5690: $processmarker='_'.time.'_'.$perlvar{'lonHostID'}; 5691: $dumpcount=0; 5692: 5693: &logtouch(); 5694: &logthis('INFO: Read configuration'); 5695: $readit=1; 5696: { 5697: use integer; 5698: my $test=(2**32)+1; 5699: if ($test != 0) { $_64bit=1; } else { $_64bit=0; } 5700: &logthis(" Detected 64bit platform ($_64bit)"); 5701: } 5702: } 5703: } 5704: 5705: 1; 5706: __END__ 5707: 5708: =pod 5709: 5710: =head1 NAME 5711: 5712: Apache::lonnet - Subroutines to ask questions about things in the network. 5713: 5714: =head1 SYNOPSIS 5715: 5716: Invoked by other LON-CAPA modules, when they need to talk to or about objects in the network. 5717: 5718: &Apache::lonnet::SUBROUTINENAME(ARGUMENTS); 5719: 5720: Common parameters: 5721: 5722: =over 4 5723: 5724: =item * 5725: 5726: $uname : an internal username (if $cname expecting a course Id specifically) 5727: 5728: =item * 5729: 5730: $udom : a domain (if $cdom expecting a course's domain specifically) 5731: 5732: =item * 5733: 5734: $symb : a resource instance identifier 5735: 5736: =item * 5737: 5738: $namespace : the name of a .db file that contains the data needed or 5739: being set. 5740: 5741: =back 5742: 5743: =head1 OVERVIEW 5744: 5745: lonnet provides subroutines which interact with the 5746: lonc/lond (TCP) network layer of LON-CAPA. They can be used to ask 5747: about classes, users, and resources. 5748: 5749: For many of these objects you can also use this to store data about 5750: them or modify them in various ways. 5751: 5752: =head2 Symbs 5753: 5754: To identify a specific instance of a resource, LON-CAPA uses symbols 5755: or "symbs"X<symb>. These identifiers are built from the URL of the 5756: map, the resource number of the resource in the map, and the URL of 5757: the resource itself. The latter is somewhat redundant, but might help 5758: if maps change. 5759: 5760: An example is 5761: 5762: msu/korte/parts/part1.sequence___19___msu/korte/tests/part12.problem 5763: 5764: The respective map entry is 5765: 5766: <resource id="19" src="/res/msu/korte/tests/part12.problem" 5767: title="Problem 2"> 5768: </resource> 5769: 5770: Symbs are used by the random number generator, as well as to store and 5771: restore data specific to a certain instance of for example a problem. 5772: 5773: =head2 Storing And Retrieving Data 5774: 5775: X<store()>X<cstore()>X<restore()>Three of the most important functions 5776: in C<lonnet.pm> are C<&Apache::lonnet::cstore()>, 5777: C<&Apache::lonnet:restore()>, and C<&Apache::lonnet::store()>, which 5778: is is the non-critical message twin of cstore. These functions are for 5779: handlers to store a perl hash to a user's permanent data space in an 5780: easy manner, and to retrieve it again on another call. It is expected 5781: that a handler would use this once at the beginning to retrieve data, 5782: and then again once at the end to send only the new data back. 5783: 5784: The data is stored in the user's data directory on the user's 5785: homeserver under the ID of the course. 5786: 5787: The hash that is returned by restore will have all of the previous 5788: value for all of the elements of the hash. 5789: 5790: Example: 5791: 5792: #creating a hash 5793: my %hash; 5794: $hash{'foo'}='bar'; 5795: 5796: #storing it 5797: &Apache::lonnet::cstore(\%hash); 5798: 5799: #changing a value 5800: $hash{'foo'}='notbar'; 5801: 5802: #adding a new value 5803: $hash{'bar'}='foo'; 5804: &Apache::lonnet::cstore(\%hash); 5805: 5806: #retrieving the hash 5807: my %history=&Apache::lonnet::restore(); 5808: 5809: #print the hash 5810: foreach my $key (sort(keys(%history))) { 5811: print("\%history{$key} = $history{$key}"); 5812: } 5813: 5814: Will print out: 5815: 5816: %history{1:foo} = bar 5817: %history{1:keys} = foo:timestamp 5818: %history{1:timestamp} = 990455579 5819: %history{2:bar} = foo 5820: %history{2:foo} = notbar 5821: %history{2:keys} = foo:bar:timestamp 5822: %history{2:timestamp} = 990455580 5823: %history{bar} = foo 5824: %history{foo} = notbar 5825: %history{timestamp} = 990455580 5826: %history{version} = 2 5827: 5828: Note that the special hash entries C<keys>, C<version> and 5829: C<timestamp> were added to the hash. C<version> will be equal to the 5830: total number of versions of the data that have been stored. The 5831: C<timestamp> attribute will be the UNIX time the hash was 5832: stored. C<keys> is available in every historical section to list which 5833: keys were added or changed at a specific historical revision of a 5834: hash. 5835: 5836: B<Warning>: do not store the hash that restore returns directly. This 5837: will cause a mess since it will restore the historical keys as if the 5838: were new keys. I.E. 1:foo will become 1:1:foo etc. 5839: 5840: Calling convention: 5841: 5842: my %record=&Apache::lonnet::restore($symb,$courseid,$domain,$uname,$home); 5843: &Apache::lonnet::cstore(\%newrecord,$symb,$courseid,$domain,$uname,$home); 5844: 5845: For more detailed information, see lonnet specific documentation. 5846: 5847: =head1 RETURN MESSAGES 5848: 5849: =over 4 5850: 5851: =item * B<con_lost>: unable to contact remote host 5852: 5853: =item * B<con_delayed>: unable to contact remote host, message will be delivered 5854: when the connection is brought back up 5855: 5856: =item * B<con_failed>: unable to contact remote host and unable to save message 5857: for later delivery 5858: 5859: =item * B<error:>: an error a occured, a description of the error follows the : 5860: 5861: =item * B<no_such_host>: unable to fund a host associated with the user/domain 5862: that was requested 5863: 5864: =back 5865: 5866: =head1 PUBLIC SUBROUTINES 5867: 5868: =head2 Session Environment Functions 5869: 5870: =over 4 5871: 5872: =item * 5873: X<appenv()> 5874: B<appenv(%hash)>: the value of %hash is written to 5875: the user envirnoment file, and will be restored for each access this 5876: user makes during this session, also modifies the %ENV for the current 5877: process 5878: 5879: =item * 5880: X<delenv()> 5881: B<delenv($regexp)>: removes all items from the session 5882: environment file that matches the regular expression in $regexp. The 5883: values are also delted from the current processes %ENV. 5884: 5885: =back 5886: 5887: =head2 User Information 5888: 5889: =over 4 5890: 5891: =item * 5892: X<queryauthenticate()> 5893: B<queryauthenticate($uname,$udom)>: try to determine user's current 5894: authentication scheme 5895: 5896: =item * 5897: X<authenticate()> 5898: B<authenticate($uname,$upass,$udom)>: try to 5899: authenticate user from domain's lib servers (first use the current 5900: one). C<$upass> should be the users password. 5901: 5902: =item * 5903: X<homeserver()> 5904: B<homeserver($uname,$udom)>: find the server which has 5905: the user's directory and files (there must be only one), this caches 5906: the answer, and also caches if there is a borken connection. 5907: 5908: =item * 5909: X<idget()> 5910: B<idget($udom,@ids)>: find the usernames behind a list of IDs 5911: (IDs are a unique resource in a domain, there must be only 1 ID per 5912: username, and only 1 username per ID in a specific domain) (returns 5913: hash: id=>name,id=>name) 5914: 5915: =item * 5916: X<idrget()> 5917: B<idrget($udom,@unames)>: find the IDs behind a list of 5918: usernames (returns hash: name=>id,name=>id) 5919: 5920: =item * 5921: X<idput()> 5922: B<idput($udom,%ids)>: store away a list of names and associated IDs 5923: 5924: =item * 5925: X<rolesinit()> 5926: B<rolesinit($udom,$username,$authhost)>: get user privileges 5927: 5928: =item * 5929: X<getsection()> 5930: B<getsection($udom,$uname,$cname)>: finds the section of student in the 5931: course $cname, return section name/number or '' for "not in course" 5932: and '-1' for "no section" 5933: 5934: =item * 5935: X<userenvironment()> 5936: B<userenvironment($udom,$uname,@what)>: gets the values of the keys 5937: passed in @what from the requested user's environment, returns a hash 5938: 5939: =back 5940: 5941: =head2 User Roles 5942: 5943: =over 4 5944: 5945: =item * 5946: 5947: allowed($priv,$uri) : check for a user privilege; returns codes for allowed 5948: actions 5949: F: full access 5950: U,I,K: authentication modes (cxx only) 5951: '': forbidden 5952: 1: user needs to choose course 5953: 2: browse allowed 5954: 5955: =item * 5956: 5957: definerole($rolename,$sysrole,$domrole,$courole) : define role; define a custom 5958: role rolename set privileges in format of lonTabs/roles.tab for system, domain, 5959: and course level 5960: 5961: =item * 5962: 5963: plaintext($short) : return value in %prp hash (rolesplain.tab); plain text 5964: explanation of a user role term 5965: 5966: =back 5967: 5968: =head2 User Modification 5969: 5970: =over 4 5971: 5972: =item * 5973: 5974: assignrole($udom,$uname,$url,$role,$end,$start) : assign role; give a role to a 5975: user for the level given by URL. Optional start and end dates (leave empty 5976: string or zero for "no date") 5977: 5978: =item * 5979: 5980: changepass($uname,$udom,$currentpass,$newpass,$server) : attempts to 5981: change a users, password, possible return values are: ok, 5982: pwchange_failure, non_authorized, auth_mode_error, unknown_user, 5983: refused 5984: 5985: =item * 5986: 5987: modifyuserauth($udom,$uname,$umode,$upass) : modify user authentication 5988: 5989: =item * 5990: 5991: modifyuser($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene) : 5992: modify user 5993: 5994: =item * 5995: 5996: modifystudent 5997: 5998: modify a students enrollment and identification information. 5999: The course id is resolved based on the current users environment. 6000: This means the envoking user must be a course coordinator or otherwise 6001: associated with a course. 6002: 6003: This call is essentially a wrapper for lonnet::modifyuser and 6004: lonnet::modify_student_enrollment 6005: 6006: Inputs: 6007: 6008: =over 4 6009: 6010: =item B<$udom> Students loncapa domain 6011: 6012: =item B<$uname> Students loncapa login name 6013: 6014: =item B<$uid> Students id/student number 6015: 6016: =item B<$umode> Students authentication mode 6017: 6018: =item B<$upass> Students password 6019: 6020: =item B<$first> Students first name 6021: 6022: =item B<$middle> Students middle name 6023: 6024: =item B<$last> Students last name 6025: 6026: =item B<$gene> Students generation 6027: 6028: =item B<$usec> Students section in course 6029: 6030: =item B<$end> Unix time of the roles expiration 6031: 6032: =item B<$start> Unix time of the roles start date 6033: 6034: =item B<$forceid> If defined, allow $uid to be changed 6035: 6036: =item B<$desiredhome> server to use as home server for student 6037: 6038: =back 6039: 6040: =item * 6041: 6042: modify_student_enrollment 6043: 6044: Change a students enrollment status in a class. The environment variable 6045: 'role.request.course' must be defined for this function to proceed. 6046: 6047: Inputs: 6048: 6049: =over 4 6050: 6051: =item $udom, students domain 6052: 6053: =item $uname, students name 6054: 6055: =item $uid, students user id 6056: 6057: =item $first, students first name 6058: 6059: =item $middle 6060: 6061: =item $last 6062: 6063: =item $gene 6064: 6065: =item $usec 6066: 6067: =item $end 6068: 6069: =item $start 6070: 6071: =back 6072: 6073: 6074: =item * 6075: 6076: assigncustomrole($udom,$uname,$url,$rdom,$rnam,$rolename,$end,$start) : assign 6077: custom role; give a custom role to a user for the level given by URL. Specify 6078: name and domain of role author, and role name 6079: 6080: =item * 6081: 6082: revokerole($udom,$uname,$url,$role) : revoke a role for url 6083: 6084: =item * 6085: 6086: revokecustomrole($udom,$uname,$url,$role) : revoke a custom role 6087: 6088: =back 6089: 6090: =head2 Course Infomation 6091: 6092: =over 4 6093: 6094: =item * 6095: 6096: coursedescription($courseid) : course description 6097: 6098: =item * 6099: 6100: courseresdata($coursenum,$coursedomain,@which) : request for current 6101: parameter setting for a specific course, @what should be a list of 6102: parameters to ask about. This routine caches answers for 5 minutes. 6103: 6104: =back 6105: 6106: =head2 Course Modification 6107: 6108: =over 4 6109: 6110: =item * 6111: 6112: writecoursepref($courseid,%prefs) : write preferences (environment 6113: database) for a course 6114: 6115: =item * 6116: 6117: createcourse($udom,$description,$url) : make/modify course 6118: 6119: =back 6120: 6121: =head2 Resource Subroutines 6122: 6123: =over 4 6124: 6125: =item * 6126: 6127: subscribe($fname) : subscribe to a resource, returns URL if possible (probably should use repcopy instead) 6128: 6129: =item * 6130: 6131: repcopy($filename) : subscribes to the requested file, and attempts to 6132: replicate from the owning library server, Might return 6133: 'HTTP_SERVICE_UNAVAILABLE', 'HTTP_NOT_FOUND', 'FORBIDDEN', 'OK', or 6134: 'HTTP_BAD_REQUEST', also attempts to grab the metadata for the 6135: resource. Expects the local filesystem pathname 6136: (/home/httpd/html/res/....) 6137: 6138: =back 6139: 6140: =head2 Resource Information 6141: 6142: =over 4 6143: 6144: =item * 6145: 6146: EXT($varname,$symb,$udom,$uname) : evaluates and returns the value of 6147: a vairety of different possible values, $varname should be a request 6148: string, and the other parameters can be used to specify who and what 6149: one is asking about. 6150: 6151: Possible values for $varname are environment.lastname (or other item 6152: from the envirnment hash), user.name (or someother aspect about the 6153: user), resource.0.maxtries (or some other part and parameter of a 6154: resource) 6155: 6156: =item * 6157: 6158: directcondval($number) : get current value of a condition; reads from a state 6159: string 6160: 6161: =item * 6162: 6163: condval($condidx) : value of condition index based on state 6164: 6165: =item * 6166: 6167: metadata($uri,$what,$liburi,$prefix,$depthcount) : request a 6168: resource's metadata, $what should be either a specific key, or either 6169: 'keys' (to get a list of possible keys) or 'packages' to get a list of 6170: packages that this resource currently uses, the last 3 arguments are only used internally for recursive metadata. 6171: 6172: this function automatically caches all requests 6173: 6174: =item * 6175: 6176: metadata_query($query,$custom,$customshow) : make a metadata query against the 6177: network of library servers; returns file handle of where SQL and regex results 6178: will be stored for query 6179: 6180: =item * 6181: 6182: symbread($filename) : return symbolic list entry (filename argument optional); 6183: returns the data handle 6184: 6185: =item * 6186: 6187: symbverify($symb,$thisfn) : verifies that $symb actually exists and is 6188: a possible symb for the URL in $thisfn, and if is an encryypted 6189: resource that the user accessed using /enc/ returns a 1 on success, 0 6190: on failure, user must be in a course, as it assumes the existance of 6191: the course initial hash, and uses $ENV('request.course.id'} 6192: 6193: 6194: =item * 6195: 6196: symbclean($symb) : removes versions numbers from a symb, returns the 6197: cleaned symb 6198: 6199: =item * 6200: 6201: is_on_map($uri) : checks if the $uri is somewhere on the current 6202: course map, user must be in a course for it to work. 6203: 6204: =item * 6205: 6206: numval($salt) : return random seed value (addend for rndseed) 6207: 6208: =item * 6209: 6210: rndseed($symb,$courseid,$udom,$uname) : create a random sum; returns 6211: a random seed, all arguments are optional, if they aren't sent it uses the 6212: environment to derive them. Note: if symb isn't sent and it can't get one 6213: from &symbread it will use the current time as its return value 6214: 6215: =item * 6216: 6217: ireceipt($funame,$fudom,$fucourseid,$fusymb) : return unique, 6218: unfakeable, receipt 6219: 6220: =item * 6221: 6222: receipt() : API to ireceipt working off of ENV values; given out to users 6223: 6224: =item * 6225: 6226: countacc($url) : count the number of accesses to a given URL 6227: 6228: =item * 6229: 6230: 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 6231: 6232: =item * 6233: 6234: 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) 6235: 6236: =item * 6237: 6238: expirespread($uname,$udom,$stype,$usymb) : set expire date for spreadsheet 6239: 6240: =item * 6241: 6242: devalidate($symb) : devalidate temporary spreadsheet calculations, 6243: forcing spreadsheet to reevaluate the resource scores next time. 6244: 6245: =back 6246: 6247: =head2 Storing/Retreiving Data 6248: 6249: =over 4 6250: 6251: =item * 6252: 6253: store($storehash,$symb,$namespace,$udom,$uname) : stores hash permanently 6254: for this url; hashref needs to be given and should be a \%hashname; the 6255: remaining args aren't required and if they aren't passed or are '' they will 6256: be derived from the ENV 6257: 6258: =item * 6259: 6260: cstore($storehash,$symb,$namespace,$udom,$uname) : same as store but 6261: uses critical subroutine 6262: 6263: =item * 6264: 6265: restore($symb,$namespace,$udom,$uname) : returns hash for this symb; 6266: all args are optional 6267: 6268: =item * 6269: 6270: tmpstore($storehash,$symb,$namespace,$udom,$uname) : storage that 6271: works very similar to store/cstore, but all data is stored in a 6272: temporary location and can be reset using tmpreset, $storehash should 6273: be a hash reference, returns nothing on success 6274: 6275: =item * 6276: 6277: tmprestore($symb,$namespace,$udom,$uname) : storage that works very 6278: similar to restore, but all data is stored in a temporary location and 6279: can be reset using tmpreset. Returns a hash of values on success, 6280: error string otherwise. 6281: 6282: =item * 6283: 6284: tmpreset($symb,$namespace,$udom,$uname) : temporary storage reset, 6285: deltes all keys for $symb form the temporary storage hash. 6286: 6287: =item * 6288: 6289: get($namespace,$storearr,$udom,$uname) : returns hash with keys from array 6290: reference filled in from namesp ($udom and $uname are optional) 6291: 6292: =item * 6293: 6294: del($namespace,$storearr,$udom,$uname) : deletes keys out of array from 6295: namesp ($udom and $uname are optional) 6296: 6297: =item * 6298: 6299: dump($namespace,$udom,$uname,$regexp) : 6300: dumps the complete (or key matching regexp) namespace into a hash 6301: ($udom, $uname and $regexp are optional) 6302: 6303: =item * 6304: 6305: inc($namespace,$store,$udom,$uname) : increments $store in $namespace. 6306: $store can be a scalar, an array reference, or if the amount to be 6307: incremented is > 1, a hash reference. 6308: 6309: ($udom and $uname are optional) 6310: 6311: =item * 6312: 6313: put($namespace,$storehash,$udom,$uname) : stores hash in namesp 6314: ($udom and $uname are optional) 6315: 6316: =item * 6317: 6318: putstore($namespace,$storehash,$udomain,$uname) : stores hash in namesp 6319: keys used in storehash include version information (e.g., 1:$symb:message etc.) as 6320: used in records written by &store and retrieved by &restore. This function 6321: was created for use in editing discussion posts, without incrementing the 6322: version number included in the key for a particular post. The colon 6323: separated list of attribute names (e.g., the value associated with the key 6324: 1:keys:$symb) is also generated and passed in the ampersand separated 6325: items sent to lonnet::reply(). 6326: 6327: =item * 6328: 6329: cput($namespace,$storehash,$udom,$uname) : critical put 6330: ($udom and $uname are optional) 6331: 6332: =item * 6333: 6334: eget($namespace,$storearr,$udom,$uname) : returns hash with keys from array 6335: reference filled in from namesp (encrypts the return communication) 6336: ($udom and $uname are optional) 6337: 6338: =item * 6339: 6340: log($udom,$name,$home,$message) : write to permanent log for user; use 6341: critical subroutine 6342: 6343: =back 6344: 6345: =head2 Network Status Functions 6346: 6347: =over 4 6348: 6349: =item * 6350: 6351: dirlist($uri) : return directory list based on URI 6352: 6353: =item * 6354: 6355: spareserver() : find server with least workload from spare.tab 6356: 6357: =back 6358: 6359: =head2 Apache Request 6360: 6361: =over 4 6362: 6363: =item * 6364: 6365: ssi($url,%hash) : server side include, does a complete request cycle on url to 6366: localhost, posts hash 6367: 6368: =back 6369: 6370: =head2 Data to String to Data 6371: 6372: =over 4 6373: 6374: =item * 6375: 6376: hash2str(%hash) : convert a hash into a string complete with escaping and '=' 6377: and '&' separators, supports elements that are arrayrefs and hashrefs 6378: 6379: =item * 6380: 6381: hashref2str($hashref) : convert a hashref into a string complete with 6382: escaping and '=' and '&' separators, supports elements that are 6383: arrayrefs and hashrefs 6384: 6385: =item * 6386: 6387: arrayref2str($arrayref) : convert an arrayref into a string complete 6388: with escaping and '&' separators, supports elements that are arrayrefs 6389: and hashrefs 6390: 6391: =item * 6392: 6393: str2hash($string) : convert string to hash using unescaping and 6394: splitting on '=' and '&', supports elements that are arrayrefs and 6395: hashrefs 6396: 6397: =item * 6398: 6399: str2array($string) : convert string to hash using unescaping and 6400: splitting on '&', supports elements that are arrayrefs and hashrefs 6401: 6402: =back 6403: 6404: =head2 Logging Routines 6405: 6406: =over 4 6407: 6408: These routines allow one to make log messages in the lonnet.log and 6409: lonnet.perm logfiles. 6410: 6411: =item * 6412: 6413: logtouch() : make sure the logfile, lonnet.log, exists 6414: 6415: =item * 6416: 6417: logthis() : append message to the normal lonnet.log file, it gets 6418: preiodically rolled over and deleted. 6419: 6420: =item * 6421: 6422: logperm() : append a permanent message to lonnet.perm.log, this log 6423: file never gets deleted by any automated portion of the system, only 6424: messages of critical importance should go in here. 6425: 6426: =back 6427: 6428: =head2 General File Helper Routines 6429: 6430: =over 4 6431: 6432: =item * 6433: 6434: getfile($file,$caller) : two cases - requests for files in /res or in /uploaded. 6435: (a) files in /uploaded 6436: (i) If a local copy of the file exists - 6437: compares modification date of local copy with last-modified date for 6438: definitive version stored on home server for course. If local copy is 6439: stale, requests a new version from the home server and stores it. 6440: If the original has been removed from the home server, then local copy 6441: is unlinked. 6442: (ii) If local copy does not exist - 6443: requests the file from the home server and stores it. 6444: 6445: If $caller is 'uploadrep': 6446: This indicates a call from lonuploadrep.pm (PerlHeaderParserHandler phase) 6447: for request for files originally uploaded via DOCS. 6448: - returns 'ok' if fresh local copy now available, -1 otherwise. 6449: 6450: Otherwise: 6451: This indicates a call from the content generation phase of the request. 6452: - returns the entire contents of the file or -1. 6453: 6454: (b) files in /res 6455: - returns the entire contents of a file or -1; 6456: it properly subscribes to and replicates the file if neccessary. 6457: 6458: =item * 6459: 6460: filelocation($dir,$file) : returns file system location of a file 6461: based on URI; meant to be "fairly clean" absolute reference, $dir is a 6462: directory that relative $file lookups are to looked in ($dir of /a/dir 6463: and a file of ../bob will become /a/bob) 6464: 6465: =item * 6466: 6467: hreflocation($dir,$file) : returns file system location or a URL; same as 6468: filelocation except for hrefs 6469: 6470: =item * 6471: 6472: declutter() : declutters URLs (remove docroot, beginning slashes, 'res' etc) 6473: 6474: =back 6475: 6476: =head2 HTTP Helper Routines 6477: 6478: =over 4 6479: 6480: =item * 6481: 6482: escape() : unpack non-word characters into CGI-compatible hex codes 6483: 6484: =item * 6485: 6486: unescape() : pack CGI-compatible hex codes into actual non-word ASCII character 6487: 6488: =back 6489: 6490: =head1 PRIVATE SUBROUTINES 6491: 6492: =head2 Underlying communication routines (Shouldn't call) 6493: 6494: =over 4 6495: 6496: =item * 6497: 6498: subreply() : tries to pass a message to lonc, returns con_lost if incapable 6499: 6500: =item * 6501: 6502: reply() : uses subreply to send a message to remote machine, logs all failures 6503: 6504: =item * 6505: 6506: critical() : passes a critical message to another server; if cannot 6507: get through then place message in connection buffer directory and 6508: returns con_delayed, if incapable of saving message, returns 6509: con_failed 6510: 6511: =item * 6512: 6513: reconlonc() : tries to reconnect lonc client processes. 6514: 6515: =back 6516: 6517: =head2 Resource Access Logging 6518: 6519: =over 4 6520: 6521: =item * 6522: 6523: flushcourselogs() : flush (save) buffer logs and access logs 6524: 6525: =item * 6526: 6527: courselog($what) : save message for course in hash 6528: 6529: =item * 6530: 6531: courseacclog($what) : save message for course using &courselog(). Perform 6532: special processing for specific resource types (problems, exams, quizzes, etc). 6533: 6534: =item * 6535: 6536: goodbye() : flush course logs and log shutting down; it is called in srm.conf 6537: as a PerlChildExitHandler 6538: 6539: =back 6540: 6541: =head2 Other 6542: 6543: =over 4 6544: 6545: =item * 6546: 6547: symblist($mapname,%newhash) : update symbolic storage links 6548: 6549: =back 6550: 6551: =cut