loncom/lonnet/perl/lonnet.pm - view

File: [LON-CAPA] / loncom / lonnet / perl / lonnet.pm
Revision 1.541: download - view: text, annotated - select for diffs
Wed Sep 15 20:08:34 2004 UTC (19 years, 10 months ago) by albertel
Branches: MAIN
CVS tags: HEAD

- disk based caching rises from the dead, this I think it's right thanks to mattthew
   - just remeber what items are to be saved to the disk cache and save them after done with the student
   - disable devalidatation for now, it's slo and doesn't gain us much
       (will add a cleansing pass to save_cache?)

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