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