loncom/lonnet/perl/lonnet.pm - view

File: [LON-CAPA] / loncom / lonnet / perl / lonnet.pm
Revision 1.411: download - view: text, annotated - select for diffs
Thu Sep 11 07:57:03 2003 UTC (20 years, 11 months ago) by albertel
Branches: MAIN
CVS tags: HEAD

- yes if the other machine is down, it has a load of zero, this doesn't mean we should send the user over to it :-)
- I need to do a bit more testing with this to make sure it is all good

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