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