loncom/lonnet/perl/lonnet.pm - view

File: [LON-CAPA] / loncom / lonnet / perl / lonnet.pm
Revision 1.489: download - view: text, annotated - select for diffs
Fri Apr 23 23:01:36 2004 UTC (20 years, 2 months ago) by albertel
Branches: MAIN
CVS tags: HEAD

- Somewhat amazed at how easy this was should with these changes
   - uploaded .html/.page (all ssi type docs) now
       - get parsed
       - can be printed
       - get default parameters
       - are no longer wrapper ed

- .problems are still somewhat issue oriented though (need real metadata support for uploaded)

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