loncom/lonnet/perl/lonnet.pm - view

File: [LON-CAPA] / loncom / lonnet / perl / lonnet.pm
Revision 1.477: download - view: text, annotated - select for diffs
Tue Mar 16 20:15:08 2004 UTC (20 years, 3 months ago) by raeburn
Branches: MAIN
CVS tags: HEAD

Method used by lonnet to support upload of structure into userfiles directory changed.
lonnet::userfileupload() and lonnet::finishuserfileupload() revert to versions in 1.475.

New lonnet::process_coursefile routine added.

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