![]() ![]() | ![]() |
also looking in loncapa.conf for PerlSetVAr
1: # The LearningOnline Network 2: # TCP networking package 3: # 4: # $Id: lonnet.pm,v 1.217 2002/05/11 20:42:00 harris41 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: # 02/27/01 Scott Harrison 51: # 3/2 Gerd Kortemeyer 52: # 3/15,3/19 Scott Harrison 53: # 3/19,3/20 Gerd Kortemeyer 54: # 3/22,3/27,4/2,4/16,4/17 Scott Harrison 55: # 5/26,5/28 Gerd Kortemeyer 56: # 5/30 H. K. Ng 57: # 6/1 Gerd Kortemeyer 58: # July Guy Albertelli 59: # 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, 60: # 10/2 Gerd Kortemeyer 61: # 10/5,10/10,11/13,11/15 Scott Harrison 62: # 11/17,11/20,11/22,11/29 Gerd Kortemeyer 63: # 12/5 Matthew Hall 64: # 12/5 Guy Albertelli 65: # 12/6,12/7,12/12 Gerd Kortemeyer 66: # 12/18 Scott Harrison 67: # 12/21,12/22,12/27,12/28 Gerd Kortemeyer 68: # YEAR=2002 69: # 1/4,2/4,2/7 Gerd Kortemeyer 70: # 71: ### 72: 73: package Apache::lonnet; 74: 75: use strict; 76: use Apache::File; 77: use LWP::UserAgent(); 78: use HTTP::Headers; 79: use vars 80: qw(%perlvar %hostname %homecache %hostip %spareid %hostdom 81: %libserv %pr %prp %metacache %packagetab 82: %courselogs %accesshash $processmarker $dumpcount 83: %coursedombuf %coursehombuf %courseresdatacache); 84: use IO::Socket; 85: use GDBM_File; 86: use Apache::Constants qw(:common :http); 87: use HTML::LCParser; 88: use Fcntl qw(:flock); 89: my $readit; 90: 91: # --------------------------------------------------------------------- Logging 92: 93: sub logtouch { 94: my $execdir=$perlvar{'lonDaemons'}; 95: unless (-e "$execdir/logs/lonnet.log") { 96: my $fh=Apache::File->new(">>$execdir/logs/lonnet.log"); 97: close $fh; 98: } 99: my ($wwwuid,$wwwgid)=(getpwnam('www'))[2,3]; 100: chown($wwwuid,$wwwgid,$execdir.'/logs/lonnet.log'); 101: } 102: 103: sub logthis { 104: my $message=shift; 105: my $execdir=$perlvar{'lonDaemons'}; 106: my $now=time; 107: my $local=localtime($now); 108: my $fh=Apache::File->new(">>$execdir/logs/lonnet.log"); 109: print $fh "$local ($$): $message\n"; 110: return 1; 111: } 112: 113: sub logperm { 114: my $message=shift; 115: my $execdir=$perlvar{'lonDaemons'}; 116: my $now=time; 117: my $local=localtime($now); 118: my $fh=Apache::File->new(">>$execdir/logs/lonnet.perm.log"); 119: print $fh "$now:$message:$local\n"; 120: return 1; 121: } 122: 123: # -------------------------------------------------- Non-critical communication 124: sub subreply { 125: my ($cmd,$server)=@_; 126: my $peerfile="$perlvar{'lonSockDir'}/$server"; 127: my $client=IO::Socket::UNIX->new(Peer =>"$peerfile", 128: Type => SOCK_STREAM, 129: Timeout => 10) 130: or return "con_lost"; 131: print $client "$cmd\n"; 132: my $answer=<$client>; 133: if (!$answer) { $answer="con_lost"; } 134: chomp($answer); 135: return $answer; 136: } 137: 138: sub reply { 139: my ($cmd,$server)=@_; 140: unless (defined($hostname{$server})) { return 'no_such_host'; } 141: my $answer=subreply($cmd,$server); 142: if ($answer eq 'con_lost') { 143: sleep 5; 144: $answer=subreply($cmd,$server); 145: if ($answer eq 'con_lost') { 146: &logthis("Second attempt con_lost on $server"); 147: my $peerfile="$perlvar{'lonSockDir'}/$server"; 148: my $client=IO::Socket::UNIX->new(Peer =>"$peerfile", 149: Type => SOCK_STREAM, 150: Timeout => 10) 151: or return "con_lost"; 152: &logthis("Killing socket"); 153: print $client "close_connection_exit\n"; 154: sleep 5; 155: $answer=subreply($cmd,$server); 156: } 157: } 158: if (($answer=~/^refused/) || ($answer=~/^rejected/)) { 159: &logthis("<font color=blue>WARNING:". 160: " $cmd to $server returned $answer</font>"); 161: } 162: return $answer; 163: } 164: 165: # ----------------------------------------------------------- Send USR1 to lonc 166: 167: sub reconlonc { 168: my $peerfile=shift; 169: &logthis("Trying to reconnect for $peerfile"); 170: my $loncfile="$perlvar{'lonDaemons'}/logs/lonc.pid"; 171: if (my $fh=Apache::File->new("$loncfile")) { 172: my $loncpid=<$fh>; 173: chomp($loncpid); 174: if (kill 0 => $loncpid) { 175: &logthis("lonc at pid $loncpid responding, sending USR1"); 176: kill USR1 => $loncpid; 177: sleep 1; 178: if (-e "$peerfile") { return; } 179: &logthis("$peerfile still not there, give it another try"); 180: sleep 5; 181: if (-e "$peerfile") { return; } 182: &logthis( 183: "<font color=blue>WARNING: $peerfile still not there, giving up</font>"); 184: } else { 185: &logthis( 186: "<font color=blue>WARNING:". 187: " lonc at pid $loncpid not responding, giving up</font>"); 188: } 189: } else { 190: &logthis('<font color=blue>WARNING: lonc not running, giving up</font>'); 191: } 192: } 193: 194: # ------------------------------------------------------ Critical communication 195: 196: sub critical { 197: my ($cmd,$server)=@_; 198: unless ($hostname{$server}) { 199: &logthis("<font color=blue>WARNING:". 200: " Critical message to unknown server ($server)</font>"); 201: return 'no_such_host'; 202: } 203: my $answer=reply($cmd,$server); 204: if ($answer eq 'con_lost') { 205: my $pingreply=reply('ping',$server); 206: &reconlonc("$perlvar{'lonSockDir'}/$server"); 207: my $pongreply=reply('pong',$server); 208: &logthis("Ping/Pong for $server: $pingreply/$pongreply"); 209: $answer=reply($cmd,$server); 210: if ($answer eq 'con_lost') { 211: my $now=time; 212: my $middlename=$cmd; 213: $middlename=substr($middlename,0,16); 214: $middlename=~s/\W//g; 215: my $dfilename= 216: "$perlvar{'lonSockDir'}/delayed/$now.$middlename.$server"; 217: { 218: my $dfh; 219: if ($dfh=Apache::File->new(">$dfilename")) { 220: print $dfh "$cmd\n"; 221: } 222: } 223: sleep 2; 224: my $wcmd=''; 225: { 226: my $dfh; 227: if ($dfh=Apache::File->new("$dfilename")) { 228: $wcmd=<$dfh>; 229: } 230: } 231: chomp($wcmd); 232: if ($wcmd eq $cmd) { 233: &logthis("<font color=blue>WARNING: ". 234: "Connection buffer $dfilename: $cmd</font>"); 235: &logperm("D:$server:$cmd"); 236: return 'con_delayed'; 237: } else { 238: &logthis("<font color=red>CRITICAL:" 239: ." Critical connection failed: $server $cmd</font>"); 240: &logperm("F:$server:$cmd"); 241: return 'con_failed'; 242: } 243: } 244: } 245: return $answer; 246: } 247: 248: # ---------------------------------------------------------- Append Environment 249: 250: sub appenv { 251: my %newenv=@_; 252: foreach (keys %newenv) { 253: if (($newenv{$_}=~/^user\.role/) || ($newenv{$_}=~/^user\.priv/)) { 254: &logthis("<font color=blue>WARNING: ". 255: "Attempt to modify environment ".$_." to ".$newenv{$_} 256: .'</font>'); 257: delete($newenv{$_}); 258: } else { 259: $ENV{$_}=$newenv{$_}; 260: } 261: } 262: 263: my $lockfh; 264: unless ($lockfh=Apache::File->new("$ENV{'user.environment'}")) { 265: return 'error: '.$!; 266: } 267: unless (flock($lockfh,LOCK_EX)) { 268: &logthis("<font color=blue>WARNING: ". 269: 'Could not obtain exclusive lock in appenv: '.$!); 270: $lockfh->close(); 271: return 'error: '.$!; 272: } 273: 274: my @oldenv; 275: { 276: my $fh; 277: unless ($fh=Apache::File->new("$ENV{'user.environment'}")) { 278: return 'error: '.$!; 279: } 280: @oldenv=<$fh>; 281: $fh->close(); 282: } 283: for (my $i=0; $i<=$#oldenv; $i++) { 284: chomp($oldenv[$i]); 285: if ($oldenv[$i] ne '') { 286: my ($name,$value)=split(/=/,$oldenv[$i]); 287: unless (defined($newenv{$name})) { 288: $newenv{$name}=$value; 289: } 290: } 291: } 292: { 293: my $fh; 294: unless ($fh=Apache::File->new(">$ENV{'user.environment'}")) { 295: return 'error'; 296: } 297: my $newname; 298: foreach $newname (keys %newenv) { 299: print $fh "$newname=$newenv{$newname}\n"; 300: } 301: $fh->close(); 302: } 303: 304: $lockfh->close(); 305: return 'ok'; 306: } 307: # ----------------------------------------------------- Delete from Environment 308: 309: sub delenv { 310: my $delthis=shift; 311: my %newenv=(); 312: if (($delthis=~/user\.role/) || ($delthis=~/user\.priv/)) { 313: &logthis("<font color=blue>WARNING: ". 314: "Attempt to delete from environment ".$delthis); 315: return 'error'; 316: } 317: my @oldenv; 318: { 319: my $fh; 320: unless ($fh=Apache::File->new("$ENV{'user.environment'}")) { 321: return 'error'; 322: } 323: unless (flock($fh,LOCK_SH)) { 324: &logthis("<font color=blue>WARNING: ". 325: 'Could not obtain shared lock in delenv: '.$!); 326: $fh->close(); 327: return 'error: '.$!; 328: } 329: @oldenv=<$fh>; 330: $fh->close(); 331: } 332: { 333: my $fh; 334: unless ($fh=Apache::File->new(">$ENV{'user.environment'}")) { 335: return 'error'; 336: } 337: unless (flock($fh,LOCK_EX)) { 338: &logthis("<font color=blue>WARNING: ". 339: 'Could not obtain exclusive lock in delenv: '.$!); 340: $fh->close(); 341: return 'error: '.$!; 342: } 343: foreach (@oldenv) { 344: unless ($_=~/^$delthis/) { print $fh $_; } 345: } 346: $fh->close(); 347: } 348: return 'ok'; 349: } 350: 351: # ------------------------------ Find server with least workload from spare.tab 352: 353: sub spareserver { 354: my $tryserver; 355: my $spareserver=''; 356: my $lowestserver=100; 357: foreach $tryserver (keys %spareid) { 358: my $answer=reply('load',$tryserver); 359: if (($answer =~ /\d/) && ($answer<$lowestserver)) { 360: $spareserver="http://$hostname{$tryserver}"; 361: $lowestserver=$answer; 362: } 363: } 364: return $spareserver; 365: } 366: 367: # --------------------------------------------- Try to change a user's password 368: 369: sub changepass { 370: my ($uname,$udom,$currentpass,$newpass,$server)=@_; 371: $currentpass = &escape($currentpass); 372: $newpass = &escape($newpass); 373: my $answer = reply("encrypt:passwd:$udom:$uname:$currentpass:$newpass", 374: $server); 375: if (! $answer) { 376: &logthis("No reply on password change request to $server ". 377: "by $uname in domain $udom."); 378: } elsif ($answer =~ "^ok") { 379: &logthis("$uname in $udom successfully changed their password ". 380: "on $server."); 381: } elsif ($answer =~ "^pwchange_failure") { 382: &logthis("$uname in $udom was unable to change their password ". 383: "on $server. The action was blocked by either lcpasswd ". 384: "or pwchange"); 385: } elsif ($answer =~ "^non_authorized") { 386: &logthis("$uname in $udom did not get their password correct when ". 387: "attempting to change it on $server."); 388: } elsif ($answer =~ "^auth_mode_error") { 389: &logthis("$uname in $udom attempted to change their password despite ". 390: "not being locally or internally authenticated on $server."); 391: } elsif ($answer =~ "^unknown_user") { 392: &logthis("$uname in $udom attempted to change their password ". 393: "on $server but were unable to because $server is not ". 394: "their home server."); 395: } elsif ($answer =~ "^refused") { 396: &logthis("$server refused to change $uname in $udom password because ". 397: "it was sent an unencrypted request to change the password."); 398: } 399: return $answer; 400: } 401: 402: # ----------------------- Try to determine user's current authentication scheme 403: 404: sub queryauthenticate { 405: my ($uname,$udom)=@_; 406: if (($perlvar{'lonRole'} eq 'library') && 407: ($udom eq $perlvar{'lonDefDomain'})) { 408: my $answer=reply("encrypt:currentauth:$udom:$uname", 409: $perlvar{'lonHostID'}); 410: unless ($answer eq 'unknown_user' or $answer eq 'refused') { 411: if (length($answer)) { 412: return $answer; 413: } 414: else { 415: &logthis("User $uname at $udom lacks an authentication mechanism"); 416: return 'no_host'; 417: } 418: } 419: } 420: 421: my $tryserver; 422: foreach $tryserver (keys %libserv) { 423: if ($hostdom{$tryserver} eq $udom) { 424: my $answer=reply("encrypt:currentauth:$udom:$uname",$tryserver); 425: unless ($answer eq 'unknown_user' or $answer eq 'refused') { 426: if (length($answer)) { 427: return $answer; 428: } 429: else { 430: &logthis("User $uname at $udom lacks an authentication mechanism"); 431: return 'no_host'; 432: } 433: } 434: } 435: } 436: &logthis("User $uname at $udom lacks an authentication mechanism"); 437: return 'no_host'; 438: } 439: 440: # --------- Try to authenticate user from domain's lib servers (first this one) 441: 442: sub authenticate { 443: my ($uname,$upass,$udom)=@_; 444: $upass=escape($upass); 445: $uname=~s/\W//g; 446: if (($perlvar{'lonRole'} eq 'library') && 447: ($udom eq $perlvar{'lonDefDomain'})) { 448: my $answer=reply("encrypt:auth:$udom:$uname:$upass",$perlvar{'lonHostID'}); 449: if ($answer =~ /authorized/) { 450: if ($answer eq 'authorized') { 451: &logthis("User $uname at $udom authorized by local server"); 452: return $perlvar{'lonHostID'}; 453: } 454: if ($answer eq 'non_authorized') { 455: &logthis("User $uname at $udom rejected by local server"); 456: return 'no_host'; 457: } 458: } 459: } 460: 461: my $tryserver; 462: foreach $tryserver (keys %libserv) { 463: if ($hostdom{$tryserver} eq $udom) { 464: my $answer=reply("encrypt:auth:$udom:$uname:$upass",$tryserver); 465: if ($answer =~ /authorized/) { 466: if ($answer eq 'authorized') { 467: &logthis("User $uname at $udom authorized by $tryserver"); 468: return $tryserver; 469: } 470: if ($answer eq 'non_authorized') { 471: &logthis("User $uname at $udom rejected by $tryserver"); 472: return 'no_host'; 473: } 474: } 475: } 476: } 477: &logthis("User $uname at $udom could not be authenticated"); 478: return 'no_host'; 479: } 480: 481: # ---------------------- Find the homebase for a user from domain's lib servers 482: 483: sub homeserver { 484: my ($uname,$udom)=@_; 485: 486: my $index="$uname:$udom"; 487: if ($homecache{$index}) { return "$homecache{$index}"; } 488: 489: my $tryserver; 490: foreach $tryserver (keys %libserv) { 491: if ($hostdom{$tryserver} eq $udom) { 492: my $answer=reply("home:$udom:$uname",$tryserver); 493: if ($answer eq 'found') { 494: $homecache{$index}=$tryserver; 495: return $tryserver; 496: } 497: } 498: } 499: return 'no_host'; 500: } 501: 502: # ------------------------------------- Find the usernames behind a list of IDs 503: 504: sub idget { 505: my ($udom,@ids)=@_; 506: my %returnhash=(); 507: 508: my $tryserver; 509: foreach $tryserver (keys %libserv) { 510: if ($hostdom{$tryserver} eq $udom) { 511: my $idlist=join('&',@ids); 512: $idlist=~tr/A-Z/a-z/; 513: my $reply=&reply("idget:$udom:".$idlist,$tryserver); 514: my @answer=(); 515: if (($reply ne 'con_lost') && ($reply!~/^error\:/)) { 516: @answer=split(/\&/,$reply); 517: } ; 518: my $i; 519: for ($i=0;$i<=$#ids;$i++) { 520: if ($answer[$i]) { 521: $returnhash{$ids[$i]}=$answer[$i]; 522: } 523: } 524: } 525: } 526: return %returnhash; 527: } 528: 529: # ------------------------------------- Find the IDs behind a list of usernames 530: 531: sub idrget { 532: my ($udom,@unames)=@_; 533: my %returnhash=(); 534: foreach (@unames) { 535: $returnhash{$_}=(&userenvironment($udom,$_,'id'))[1]; 536: } 537: return %returnhash; 538: } 539: 540: # ------------------------------- Store away a list of names and associated IDs 541: 542: sub idput { 543: my ($udom,%ids)=@_; 544: my %servers=(); 545: foreach (keys %ids) { 546: my $uhom=&homeserver($_,$udom); 547: if ($uhom ne 'no_host') { 548: my $id=&escape($ids{$_}); 549: $id=~tr/A-Z/a-z/; 550: my $unam=&escape($_); 551: if ($servers{$uhom}) { 552: $servers{$uhom}.='&'.$id.'='.$unam; 553: } else { 554: $servers{$uhom}=$id.'='.$unam; 555: } 556: &critical('put:'.$udom.':'.$unam.':environment:id='.$id,$uhom); 557: } 558: } 559: foreach (keys %servers) { 560: &critical('idput:'.$udom.':'.$servers{$_},$_); 561: } 562: } 563: 564: # ------------------------------------- Find the section of student in a course 565: 566: sub usection { 567: my ($udom,$unam,$courseid)=@_; 568: $courseid=~s/\_/\//g; 569: $courseid=~s/^(\w)/\/$1/; 570: foreach (split(/\&/,&reply('dump:'.$udom.':'.$unam.':roles', 571: &homeserver($unam,$udom)))) { 572: my ($key,$value)=split(/\=/,$_); 573: $key=&unescape($key); 574: if ($key=~/^$courseid(?:\/)*(\w+)*\_st$/) { 575: my $section=$1; 576: if ($key eq $courseid.'_st') { $section=''; } 577: my ($dummy,$end,$start)=split(/\_/,&unescape($value)); 578: my $now=time; 579: my $notactive=0; 580: if ($start) { 581: if ($now<$start) { $notactive=1; } 582: } 583: if ($end) { 584: if ($now>$end) { $notactive=1; } 585: } 586: unless ($notactive) { return $section; } 587: } 588: } 589: return '-1'; 590: } 591: 592: # ------------------------------------- Read an entry from a user's environment 593: 594: sub userenvironment { 595: my ($udom,$unam,@what)=@_; 596: my %returnhash=(); 597: my @answer=split(/\&/, 598: &reply('get:'.$udom.':'.$unam.':environment:'.join('&',@what), 599: &homeserver($unam,$udom))); 600: my $i; 601: for ($i=0;$i<=$#what;$i++) { 602: $returnhash{$what[$i]}=&unescape($answer[$i]); 603: } 604: return %returnhash; 605: } 606: 607: # ----------------------------- Subscribe to a resource, return URL if possible 608: 609: sub subscribe { 610: my $fname=shift; 611: my $author=$fname; 612: $author=~s/\/home\/httpd\/html\/res\/([^\/]*)\/([^\/]*).*/$1\/$2/; 613: my ($udom,$uname)=split(/\//,$author); 614: my $home=homeserver($uname,$udom); 615: if (($home eq 'no_host') || ($home eq $perlvar{'lonHostID'})) { 616: return 'not_found'; 617: } 618: my $answer=reply("sub:$fname",$home); 619: if (($answer eq 'con_lost') || ($answer eq 'rejected')) { 620: $answer.=' by '.$home; 621: } 622: return $answer; 623: } 624: 625: # -------------------------------------------------------------- Replicate file 626: 627: sub repcopy { 628: my $filename=shift; 629: $filename=~s/\/+/\//g; 630: if ($filename=~/^\/home\/httpd\/html\/adm\//) { return OK; } 631: my $transname="$filename.in.transfer"; 632: if ((-e $filename) || (-e $transname)) { return OK; } 633: my $remoteurl=subscribe($filename); 634: if ($remoteurl =~ /^con_lost by/) { 635: &logthis("Subscribe returned $remoteurl: $filename"); 636: return HTTP_SERVICE_UNAVAILABLE; 637: } elsif ($remoteurl eq 'not_found') { 638: &logthis("Subscribe returned not_found: $filename"); 639: return HTTP_NOT_FOUND; 640: } elsif ($remoteurl =~ /^rejected by/) { 641: &logthis("Subscribe returned $remoteurl: $filename"); 642: return FORBIDDEN; 643: } elsif ($remoteurl eq 'directory') { 644: return OK; 645: } else { 646: my @parts=split(/\//,$filename); 647: my $path="/$parts[1]/$parts[2]/$parts[3]/$parts[4]"; 648: if ($path ne "$perlvar{'lonDocRoot'}/res") { 649: &logthis("Malconfiguration for replication: $filename"); 650: return HTTP_BAD_REQUEST; 651: } 652: my $count; 653: for ($count=5;$count<$#parts;$count++) { 654: $path.="/$parts[$count]"; 655: if ((-e $path)!=1) { 656: mkdir($path,0777); 657: } 658: } 659: my $ua=new LWP::UserAgent; 660: my $request=new HTTP::Request('GET',"$remoteurl"); 661: my $response=$ua->request($request,$transname); 662: if ($response->is_error()) { 663: unlink($transname); 664: my $message=$response->status_line; 665: &logthis("<font color=blue>WARNING:" 666: ." LWP get: $message: $filename</font>"); 667: return HTTP_SERVICE_UNAVAILABLE; 668: } else { 669: if ($remoteurl!~/\.meta$/) { 670: my $mrequest=new HTTP::Request('GET',$remoteurl.'.meta'); 671: my $mresponse=$ua->request($mrequest,$filename.'.meta'); 672: if ($mresponse->is_error()) { 673: unlink($filename.'.meta'); 674: &logthis( 675: "<font color=yellow>INFO: No metadata: $filename</font>"); 676: } 677: } 678: rename($transname,$filename); 679: return OK; 680: } 681: } 682: } 683: 684: # --------------------------------------------------------- Server Side Include 685: 686: sub ssi { 687: 688: my ($fn,%form)=@_; 689: 690: my $ua=new LWP::UserAgent; 691: 692: my $request; 693: 694: if (%form) { 695: $request=new HTTP::Request('POST',"http://".$ENV{'HTTP_HOST'}.$fn); 696: $request->content(join('&',map { &escape($_).'='.&escape($form{$_}) } keys %form)); 697: } else { 698: $request=new HTTP::Request('GET',"http://".$ENV{'HTTP_HOST'}.$fn); 699: } 700: 701: $request->header(Cookie => $ENV{'HTTP_COOKIE'}); 702: my $response=$ua->request($request); 703: 704: return $response->content; 705: } 706: 707: # ------------------------------------------------------------------------- Log 708: 709: sub log { 710: my ($dom,$nam,$hom,$what)=@_; 711: return critical("log:$dom:$nam:$what",$hom); 712: } 713: 714: # ------------------------------------------------------------------ Course Log 715: 716: sub flushcourselogs { 717: &logthis('Flushing course log buffers'); 718: foreach (keys %courselogs) { 719: my $crsid=$_; 720: if (&reply('log:'.$coursedombuf{$crsid}.':'. 721: &escape($courselogs{$crsid}), 722: $coursehombuf{$crsid}) eq 'ok') { 723: delete $courselogs{$crsid}; 724: } else { 725: &logthis('Failed to flush log buffer for '.$crsid); 726: if (length($courselogs{$crsid})>40000) { 727: &logthis("<font color=blue>WARNING: Buffer for ".$crsid. 728: " exceeded maximum size, deleting.</font>"); 729: delete $courselogs{$crsid}; 730: } 731: } 732: } 733: &logthis('Flushing access logs'); 734: foreach (keys %accesshash) { 735: my $entry=$_; 736: $entry=~/\_\_\_(\w+)\/(\w+)\/(.*)\_\_\_(\w+)$/; 737: my %temphash=($entry => $accesshash{$entry}); 738: if (&Apache::lonnet::put('resevaldata',\%temphash,$1,$2) eq 'ok') { 739: delete $accesshash{$entry}; 740: } 741: } 742: $dumpcount++; 743: } 744: 745: sub courselog { 746: my $what=shift; 747: $what=time.':'.$what; 748: unless ($ENV{'request.course.id'}) { return ''; } 749: $coursedombuf{$ENV{'request.course.id'}}= 750: $ENV{'course.'.$ENV{'request.course.id'}.'.domain'}.':'. 751: $ENV{'course.'.$ENV{'request.course.id'}.'.num'}; 752: $coursehombuf{$ENV{'request.course.id'}}= 753: $ENV{'course.'.$ENV{'request.course.id'}.'.home'}; 754: if (defined $courselogs{$ENV{'request.course.id'}}) { 755: $courselogs{$ENV{'request.course.id'}}.='&'.$what; 756: } else { 757: $courselogs{$ENV{'request.course.id'}}.=$what; 758: } 759: if (length($courselogs{$ENV{'request.course.id'}})>4048) { 760: &flushcourselogs(); 761: } 762: } 763: 764: sub courseacclog { 765: my $fnsymb=shift; 766: unless ($ENV{'request.course.id'}) { return ''; } 767: my $what=$fnsymb.':'.$ENV{'user.name'}.':'.$ENV{'user.domain'}; 768: if ($fnsymb=~/(problem|exam|quiz|assess|survey|form)$/) { 769: $what.=':POST'; 770: foreach (keys %ENV) { 771: if ($_=~/^form\.(.*)/) { 772: $what.=':'.$1.'='.$ENV{$_}; 773: } 774: } 775: } 776: &courselog($what); 777: } 778: 779: sub countacc { 780: my $url=&declutter(shift); 781: unless ($ENV{'request.course.id'}) { return ''; } 782: $accesshash{$ENV{'request.course.id'}.'___'.$url.'___course'}=1; 783: my $key=$processmarker.'_'.$dumpcount.'___'.$url.'___count'; 784: if (defined($accesshash{$key})) { 785: $accesshash{$key}++; 786: } else { 787: $accesshash{$key}=1; 788: } 789: } 790: 791: # ----------------------------------------------------------- Check out an item 792: 793: sub checkout { 794: my ($symb,$tuname,$tudom,$tcrsid)=@_; 795: my $now=time; 796: my $lonhost=$perlvar{'lonHostID'}; 797: my $infostr=&escape( 798: $tuname.'&'. 799: $tudom.'&'. 800: $tcrsid.'&'. 801: $symb.'&'. 802: $now.'&'.$ENV{'REMOTE_ADDR'}); 803: my $token=&reply('tmpput:'.$infostr,$lonhost); 804: if ($token=~/^error\:/) { 805: &logthis("<font color=blue>WARNING: ". 806: "Checkout tmpput failed ".$tudom.' - '.$tuname.' - '.$symb. 807: "</font>"); 808: return ''; 809: } 810: 811: $token=~s/^(\d+)\_.*\_(\d+)$/$1\*$2\*$lonhost/; 812: $token=~tr/a-z/A-Z/; 813: 814: my %infohash=('resource.0.outtoken' => $token, 815: 'resource.0.checkouttime' => $now, 816: 'resource.0.outremote' => $ENV{'REMOTE_ADDR'}); 817: 818: unless (&cstore(\%infohash,$symb,$tcrsid,$tudom,$tuname) eq 'ok') { 819: return ''; 820: } else { 821: &logthis("<font color=blue>WARNING: ". 822: "Checkout cstore failed ".$tudom.' - '.$tuname.' - '.$symb. 823: "</font>"); 824: } 825: 826: if (&log($tudom,$tuname,&homeserver($tuname,$tudom), 827: &escape('Checkout '.$infostr.' - '. 828: $token)) ne 'ok') { 829: return ''; 830: } else { 831: &logthis("<font color=blue>WARNING: ". 832: "Checkout log failed ".$tudom.' - '.$tuname.' - '.$symb. 833: "</font>"); 834: } 835: return $token; 836: } 837: 838: # ------------------------------------------------------------ Check in an item 839: 840: sub checkin { 841: my $token=shift; 842: my $now=time; 843: my ($ta,$tb,$lonhost)=split(/\*/,$token); 844: $lonhost=~tr/A-Z/a-z/; 845: my $dtoken=$ta.'_'.$hostip{$lonhost}.'_'.$tb; 846: $dtoken=~s/\W/\_/g; 847: my ($tuname,$tudom,$tcrsid,$symb,$chtim,$rmaddr)= 848: split(/\&/,&unescape(&reply('tmpget:'.$dtoken,$lonhost))); 849: 850: unless (($tuname) && ($tudom)) { 851: &logthis('Check in '.$token.' ('.$dtoken.') failed'); 852: return ''; 853: } 854: 855: unless (&allowed('mgr',$tcrsid)) { 856: &logthis('Check in '.$token.' ('.$dtoken.') unauthorized: '. 857: $ENV{'user.name'}.' - '.$ENV{'user.domain'}); 858: return ''; 859: } 860: 861: my %infohash=('resource.0.intoken' => $token, 862: 'resource.0.checkintime' => $now, 863: 'resource.0.inremote' => $ENV{'REMOTE_ADDR'}); 864: 865: unless (&cstore(\%infohash,$symb,$tcrsid,$tudom,$tuname) eq 'ok') { 866: return ''; 867: } 868: 869: if (&log($tudom,$tuname,&homeserver($tuname,$tudom), 870: &escape('Checkin - '.$token)) ne 'ok') { 871: return ''; 872: } 873: 874: return ($symb,$tuname,$tudom,$tcrsid); 875: } 876: 877: # --------------------------------------------- Set Expire Date for Spreadsheet 878: 879: sub expirespread { 880: my ($uname,$udom,$stype,$usymb)=@_; 881: my $cid=$ENV{'request.course.id'}; 882: if ($cid) { 883: my $now=time; 884: my $key=$uname.':'.$udom.':'.$stype.':'.$usymb; 885: return &reply('put:'.$ENV{'course.'.$cid.'.domain'}.':'. 886: $ENV{'course.'.$cid.'.num'}. 887: ':nohist_expirationdates:'. 888: &escape($key).'='.$now, 889: $ENV{'course.'.$cid.'.home'}) 890: } 891: return 'ok'; 892: } 893: 894: # ----------------------------------------------------- Devalidate Spreadsheets 895: 896: sub devalidate { 897: my $symb=shift; 898: my $cid=$ENV{'request.course.id'}; 899: if ($cid) { 900: my $key=$ENV{'user.name'}.':'.$ENV{'user.domain'}.':'; 901: my $status= 902: &del('nohist_calculatedsheet', 903: [$key.'studentcalc'], 904: $ENV{'course.'.$cid.'.domain'}, 905: $ENV{'course.'.$cid.'.num'}) 906: .' '. 907: &del('nohist_calculatedsheets_'.$cid, 908: [$key.'assesscalc:'.$symb]); 909: unless ($status eq 'ok ok') { 910: &logthis('Could not devalidate spreadsheet '. 911: $ENV{'user.name'}.' at '.$ENV{'user.domain'}.' for '. 912: $symb.': '.$status); 913: } 914: } 915: } 916: 917: sub arrayref2str { 918: my ($arrayref) = @_; 919: my $result='_ARRAY_REF__'; 920: foreach my $elem (@$arrayref) { 921: if (ref($elem) eq 'ARRAY') { 922: $result.=&escape(&arrayref2str($elem)).'&'; 923: } elsif (ref($elem) eq 'HASH') { 924: $result.=&escape(&hashref2str($elem)).'&'; 925: } elsif (ref($elem)) { 926: &logthis("Got a ref of ".(ref($elem))." skipping."); 927: } else { 928: $result.=&escape($elem).'&'; 929: } 930: } 931: $result=~s/\&$//; 932: return $result; 933: } 934: 935: sub hash2str { 936: my (%hash) = @_; 937: my $result=&hashref2str(\%hash); 938: $result=~s/^_HASH_REF__//; 939: return $result; 940: } 941: 942: sub hashref2str { 943: my ($hashref)=@_; 944: my $result='_HASH_REF__'; 945: foreach (keys(%$hashref)) { 946: if (ref($_) eq 'ARRAY') { 947: $result.=&escape(&arrayref2str($_)).'='; 948: } elsif (ref($_) eq 'HASH') { 949: $result.=&escape(&hashref2str($_)).'='; 950: } elsif (ref($_)) { 951: &logthis("Got a ref of ".(ref($_))." skipping."); 952: } else { 953: $result.=&escape($_).'='; 954: } 955: 956: if (ref($$hashref{$_}) eq 'ARRAY') { 957: $result.=&escape(&arrayref2str($$hashref{$_})).'&'; 958: } elsif (ref($$hashref{$_}) eq 'HASH') { 959: $result.=&escape(&hashref2str($$hashref{$_})).'&'; 960: } elsif (ref($$hashref{$_})) { 961: &logthis("Got a ref of ".(ref($$hashref{$_}))." skipping."); 962: } else { 963: $result.=&escape($$hashref{$_}).'&'; 964: } 965: } 966: $result=~s/\&$//; 967: return $result; 968: } 969: 970: sub str2hash { 971: my ($string) = @_; 972: my %returnhash; 973: foreach (split(/\&/,$string)) { 974: my ($name,$value)=split(/\=/,$_); 975: $name=&unescape($name); 976: $value=&unescape($value); 977: if ($value =~ /^_HASH_REF__/) { 978: $value =~ s/^_HASH_REF__//; 979: my %hash=&str2hash($value); 980: $value=\%hash; 981: } elsif ($value =~ /^_ARRAY_REF__/) { 982: $value =~ s/^_ARRAY_REF__//; 983: my @array=&str2array($value); 984: $value=\@array; 985: } 986: $returnhash{$name}=$value; 987: } 988: return (%returnhash); 989: } 990: 991: sub str2array { 992: my ($string) = @_; 993: my @returnarray; 994: foreach my $value (split(/\&/,$string)) { 995: $value=&unescape($value); 996: if ($value =~ /^_HASH_REF__/) { 997: $value =~ s/^_HASH_REF__//; 998: my %hash=&str2hash($value); 999: $value=\%hash; 1000: } elsif ($value =~ /^_ARRAY_REF__/) { 1001: $value =~ s/^_ARRAY_REF__//; 1002: my @array=&str2array($value); 1003: $value=\@array; 1004: } 1005: push(@returnarray,$value); 1006: } 1007: return (@returnarray); 1008: } 1009: 1010: # -------------------------------------------------------------------Temp Store 1011: 1012: sub tmpreset { 1013: my ($symb,$namespace,$domain,$stuname) = @_; 1014: if (!$symb) { 1015: $symb=&symbread(); 1016: if (!$symb) { $symb= $ENV{'REQUEST_URI'}; } 1017: } 1018: $symb=escape($symb); 1019: 1020: if (!$namespace) { $namespace=$ENV{'request.state'}; } 1021: $namespace=~s/\//\_/g; 1022: $namespace=~s/\W//g; 1023: 1024: #FIXME needs to do something for /pub resources 1025: if (!$domain) { $domain=$ENV{'user.domain'}; } 1026: if (!$stuname) { $stuname=$ENV{'user.name'}; } 1027: my $path=$perlvar{'lonDaemons'}.'/tmp'; 1028: my %hash; 1029: if (tie(%hash,'GDBM_File', 1030: $path.'/tmpstore_'.$stuname.'_'.$domain.'_'.$namespace.'.db', 1031: &GDBM_WRCREAT,0640)) { 1032: foreach my $key (keys %hash) { 1033: if ($key=~ /:$symb/) { 1034: delete($hash{$key}); 1035: } 1036: } 1037: } 1038: } 1039: 1040: sub tmpstore { 1041: my ($storehash,$symb,$namespace,$domain,$stuname) = @_; 1042: 1043: if (!$symb) { 1044: $symb=&symbread(); 1045: if (!$symb) { $symb= $ENV{'request.url'}; } 1046: } 1047: $symb=escape($symb); 1048: 1049: if (!$namespace) { 1050: # I don't think we would ever want to store this for a course. 1051: # it seems this will only be used if we don't have a course. 1052: #$namespace=$ENV{'request.course.id'}; 1053: #if (!$namespace) { 1054: $namespace=$ENV{'request.state'}; 1055: #} 1056: } 1057: $namespace=~s/\//\_/g; 1058: $namespace=~s/\W//g; 1059: #FIXME needs to do something for /pub resources 1060: if (!$domain) { $domain=$ENV{'user.domain'}; } 1061: if (!$stuname) { $stuname=$ENV{'user.name'}; } 1062: my $now=time; 1063: my %hash; 1064: my $path=$perlvar{'lonDaemons'}.'/tmp'; 1065: if (tie(%hash,'GDBM_File', 1066: $path.'/tmpstore_'.$stuname.'_'.$domain.'_'.$namespace.'.db', 1067: &GDBM_WRCREAT,0640)) { 1068: $hash{"version:$symb"}++; 1069: my $version=$hash{"version:$symb"}; 1070: my $allkeys=''; 1071: foreach my $key (keys(%$storehash)) { 1072: $allkeys.=$key.':'; 1073: $hash{"$version:$symb:$key"}=$$storehash{$key}; 1074: } 1075: $hash{"$version:$symb:timestamp"}=$now; 1076: $allkeys.='timestamp'; 1077: $hash{"$version:keys:$symb"}=$allkeys; 1078: if (untie(%hash)) { 1079: return 'ok'; 1080: } else { 1081: return "error:$!"; 1082: } 1083: } else { 1084: return "error:$!"; 1085: } 1086: } 1087: 1088: # -----------------------------------------------------------------Temp Restore 1089: 1090: sub tmprestore { 1091: my ($symb,$namespace,$domain,$stuname) = @_; 1092: 1093: if (!$symb) { 1094: $symb=&symbread(); 1095: if (!$symb) { $symb= $ENV{'request.url'}; } 1096: } 1097: $symb=escape($symb); 1098: 1099: if (!$namespace) { $namespace=$ENV{'request.state'}; } 1100: #FIXME needs to do something for /pub resources 1101: if (!$domain) { $domain=$ENV{'user.domain'}; } 1102: if (!$stuname) { $stuname=$ENV{'user.name'}; } 1103: 1104: my %returnhash; 1105: $namespace=~s/\//\_/g; 1106: $namespace=~s/\W//g; 1107: my %hash; 1108: my $path=$perlvar{'lonDaemons'}.'/tmp'; 1109: if (tie(%hash,'GDBM_File', 1110: $path.'/tmpstore_'.$stuname.'_'.$domain.'_'.$namespace.'.db', 1111: &GDBM_READER,0640)) { 1112: my $version=$hash{"version:$symb"}; 1113: $returnhash{'version'}=$version; 1114: my $scope; 1115: for ($scope=1;$scope<=$version;$scope++) { 1116: my $vkeys=$hash{"$scope:keys:$symb"}; 1117: my @keys=split(/:/,$vkeys); 1118: my $key; 1119: $returnhash{"$scope:keys"}=$vkeys; 1120: foreach $key (@keys) { 1121: $returnhash{"$scope:$key"}=$hash{"$scope:$symb:$key"}; 1122: $returnhash{"$key"}=$hash{"$scope:$symb:$key"}; 1123: } 1124: } 1125: if (!(untie(%hash))) { 1126: return "error:$!"; 1127: } 1128: } else { 1129: return "error:$!"; 1130: } 1131: return %returnhash; 1132: } 1133: 1134: # ----------------------------------------------------------------------- Store 1135: 1136: sub store { 1137: my ($storehash,$symb,$namespace,$domain,$stuname) = @_; 1138: my $home=''; 1139: 1140: if ($stuname) { $home=&homeserver($stuname,$domain); } 1141: 1142: $symb=&symbclean($symb); 1143: if (!$symb) { unless ($symb=&symbread()) { return ''; } } 1144: 1145: &devalidate($symb); 1146: 1147: $symb=escape($symb); 1148: if (!$namespace) { 1149: unless ($namespace=$ENV{'request.course.id'}) { 1150: return ''; 1151: } 1152: } 1153: if (!$domain) { $domain=$ENV{'user.domain'}; } 1154: if (!$stuname) { $stuname=$ENV{'user.name'}; } 1155: if (!$home) { $home=$ENV{'user.home'}; } 1156: my $namevalue=''; 1157: foreach (keys %$storehash) { 1158: $namevalue.=escape($_).'='.escape($$storehash{$_}).'&'; 1159: } 1160: $namevalue=~s/\&$//; 1161: &courselog($symb.':'.$stuname.':'.$domain.':STORE:'.$namevalue); 1162: return reply("store:$domain:$stuname:$namespace:$symb:$namevalue","$home"); 1163: } 1164: 1165: # -------------------------------------------------------------- Critical Store 1166: 1167: sub cstore { 1168: my ($storehash,$symb,$namespace,$domain,$stuname) = @_; 1169: my $home=''; 1170: 1171: if ($stuname) { $home=&homeserver($stuname,$domain); } 1172: 1173: $symb=&symbclean($symb); 1174: if (!$symb) { unless ($symb=&symbread()) { return ''; } } 1175: 1176: &devalidate($symb); 1177: 1178: $symb=escape($symb); 1179: if (!$namespace) { 1180: unless ($namespace=$ENV{'request.course.id'}) { 1181: return ''; 1182: } 1183: } 1184: if (!$domain) { $domain=$ENV{'user.domain'}; } 1185: if (!$stuname) { $stuname=$ENV{'user.name'}; } 1186: if (!$home) { $home=$ENV{'user.home'}; } 1187: 1188: my $namevalue=''; 1189: foreach (keys %$storehash) { 1190: $namevalue.=escape($_).'='.escape($$storehash{$_}).'&'; 1191: } 1192: $namevalue=~s/\&$//; 1193: &courselog($symb.':'.$stuname.':'.$domain.':CSTORE:'.$namevalue); 1194: return critical 1195: ("store:$domain:$stuname:$namespace:$symb:$namevalue","$home"); 1196: } 1197: 1198: # --------------------------------------------------------------------- Restore 1199: 1200: sub restore { 1201: my ($symb,$namespace,$domain,$stuname) = @_; 1202: my $home=''; 1203: 1204: if ($stuname) { $home=&homeserver($stuname,$domain); } 1205: 1206: if (!$symb) { 1207: unless ($symb=escape(&symbread())) { return ''; } 1208: } else { 1209: $symb=&escape(&symbclean($symb)); 1210: } 1211: if (!$namespace) { 1212: unless ($namespace=$ENV{'request.course.id'}) { 1213: return ''; 1214: } 1215: } 1216: if (!$domain) { $domain=$ENV{'user.domain'}; } 1217: if (!$stuname) { $stuname=$ENV{'user.name'}; } 1218: if (!$home) { $home=$ENV{'user.home'}; } 1219: my $answer=&reply("restore:$domain:$stuname:$namespace:$symb","$home"); 1220: 1221: my %returnhash=(); 1222: foreach (split(/\&/,$answer)) { 1223: my ($name,$value)=split(/\=/,$_); 1224: $returnhash{&unescape($name)}=&unescape($value); 1225: } 1226: my $version; 1227: for ($version=1;$version<=$returnhash{'version'};$version++) { 1228: foreach (split(/\:/,$returnhash{$version.':keys'})) { 1229: $returnhash{$_}=$returnhash{$version.':'.$_}; 1230: } 1231: } 1232: return %returnhash; 1233: } 1234: 1235: # ---------------------------------------------------------- Course Description 1236: 1237: sub coursedescription { 1238: my $courseid=shift; 1239: $courseid=~s/^\///; 1240: $courseid=~s/\_/\//g; 1241: my ($cdomain,$cnum)=split(/\//,$courseid); 1242: my $chome=&homeserver($cnum,$cdomain); 1243: if ($chome ne 'no_host') { 1244: my %returnhash=&dump('environment',$cdomain,$cnum); 1245: if (!exists($returnhash{'con_lost'})) { 1246: my $normalid=$cdomain.'_'.$cnum; 1247: my %envhash=(); 1248: $returnhash{'home'}= $chome; 1249: $returnhash{'domain'} = $cdomain; 1250: $returnhash{'num'} = $cnum; 1251: while (my ($name,$value) = each %returnhash) { 1252: $envhash{'course.'.$normalid.'.'.$name}=$value; 1253: } 1254: $returnhash{'url'}='/res/'.declutter($returnhash{'url'}); 1255: $returnhash{'fn'}=$perlvar{'lonDaemons'}.'/tmp/'. 1256: $ENV{'user.name'}.'_'.$cdomain.'_'.$cnum; 1257: $envhash{'course.'.$normalid.'.last_cache'}=time; 1258: $envhash{'course.'.$normalid.'.home'}=$chome; 1259: $envhash{'course.'.$normalid.'.domain'}=$cdomain; 1260: $envhash{'course.'.$normalid.'.num'}=$cnum; 1261: &appenv(%envhash); 1262: return %returnhash; 1263: } 1264: } 1265: return (); 1266: } 1267: 1268: # -------------------------------------------------------- Get user privileges 1269: 1270: sub rolesinit { 1271: my ($domain,$username,$authhost)=@_; 1272: my $rolesdump=reply("dump:$domain:$username:roles",$authhost); 1273: if (($rolesdump eq 'con_lost') || ($rolesdump eq '')) { return ''; } 1274: my %allroles=(); 1275: my %thesepriv=(); 1276: my $now=time; 1277: my $userroles="user.login.time=$now\n"; 1278: my $thesestr; 1279: 1280: if ($rolesdump ne '') { 1281: foreach (split(/&/,$rolesdump)) { 1282: if ($_!~/^rolesdef\&/) { 1283: my ($area,$role)=split(/=/,$_); 1284: $area=~s/\_\w\w$//; 1285: my ($trole,$tend,$tstart)=split(/_/,$role); 1286: $userroles.='user.role.'.$trole.'.'.$area.'='. 1287: $tstart.'.'.$tend."\n"; 1288: if ($tend!=0) { 1289: if ($tend<$now) { 1290: $trole=''; 1291: } 1292: } 1293: if ($tstart!=0) { 1294: if ($tstart>$now) { 1295: $trole=''; 1296: } 1297: } 1298: if (($area ne '') && ($trole ne '')) { 1299: my $spec=$trole.'.'.$area; 1300: my ($tdummy,$tdomain,$trest)=split(/\//,$area); 1301: if ($trole =~ /^cr\//) { 1302: my ($rdummy,$rdomain,$rauthor,$rrole)=split(/\//,$trole); 1303: my $homsvr=homeserver($rauthor,$rdomain); 1304: if ($hostname{$homsvr} ne '') { 1305: my $roledef= 1306: reply("get:$rdomain:$rauthor:roles:rolesdef_$rrole", 1307: $homsvr); 1308: if (($roledef ne 'con_lost') && ($roledef ne '')) { 1309: my ($syspriv,$dompriv,$coursepriv)= 1310: split(/\_/,unescape($roledef)); 1311: $allroles{'cm./'}.=':'.$syspriv; 1312: $allroles{$spec.'./'}.=':'.$syspriv; 1313: if ($tdomain ne '') { 1314: $allroles{'cm./'.$tdomain.'/'}.=':'.$dompriv; 1315: $allroles{$spec.'./'.$tdomain.'/'}.=':'.$dompriv; 1316: if ($trest ne '') { 1317: $allroles{'cm.'.$area}.=':'.$coursepriv; 1318: $allroles{$spec.'.'.$area}.=':'.$coursepriv; 1319: } 1320: } 1321: } 1322: } 1323: } else { 1324: $allroles{'cm./'}.=':'.$pr{$trole.':s'}; 1325: $allroles{$spec.'./'}.=':'.$pr{$trole.':s'}; 1326: if ($tdomain ne '') { 1327: $allroles{'cm./'.$tdomain.'/'}.=':'.$pr{$trole.':d'}; 1328: $allroles{$spec.'./'.$tdomain.'/'}.=':'.$pr{$trole.':d'}; 1329: if ($trest ne '') { 1330: $allroles{'cm.'.$area}.=':'.$pr{$trole.':c'}; 1331: $allroles{$spec.'.'.$area}.=':'.$pr{$trole.':c'}; 1332: } 1333: } 1334: } 1335: } 1336: } 1337: } 1338: my $adv=0; 1339: my $author=0; 1340: foreach (keys %allroles) { 1341: %thesepriv=(); 1342: if (($_!~/^st/) && ($_!~/^ta/) && ($_!~/^cm/)) { $adv=1; } 1343: if (($_=~/^au/) || ($_=~/^ca/)) { $author=1; } 1344: foreach (split(/:/,$allroles{$_})) { 1345: if ($_ ne '') { 1346: my ($privilege,$restrictions)=split(/&/,$_); 1347: if ($restrictions eq '') { 1348: $thesepriv{$privilege}='F'; 1349: } else { 1350: if ($thesepriv{$privilege} ne 'F') { 1351: $thesepriv{$privilege}.=$restrictions; 1352: } 1353: } 1354: } 1355: } 1356: $thesestr=''; 1357: foreach (keys %thesepriv) { $thesestr.=':'.$_.'&'.$thesepriv{$_}; } 1358: $userroles.='user.priv.'.$_.'='.$thesestr."\n"; 1359: } 1360: $userroles.='user.adv='.$adv."\n". 1361: 'user.author='.$author."\n"; 1362: $ENV{'user.adv'}=$adv; 1363: } 1364: return $userroles; 1365: } 1366: 1367: # --------------------------------------------------------------- get interface 1368: 1369: sub get { 1370: my ($namespace,$storearr,$udomain,$uname)=@_; 1371: my $items=''; 1372: foreach (@$storearr) { 1373: $items.=escape($_).'&'; 1374: } 1375: $items=~s/\&$//; 1376: if (!$udomain) { $udomain=$ENV{'user.domain'}; } 1377: if (!$uname) { $uname=$ENV{'user.name'}; } 1378: my $uhome=&homeserver($uname,$udomain); 1379: 1380: my $rep=&reply("get:$udomain:$uname:$namespace:$items",$uhome); 1381: my @pairs=split(/\&/,$rep); 1382: my %returnhash=(); 1383: my $i=0; 1384: foreach (@$storearr) { 1385: $returnhash{$_}=unescape($pairs[$i]); 1386: $i++; 1387: } 1388: return %returnhash; 1389: } 1390: 1391: # --------------------------------------------------------------- del interface 1392: 1393: sub del { 1394: my ($namespace,$storearr,$udomain,$uname)=@_; 1395: my $items=''; 1396: foreach (@$storearr) { 1397: $items.=escape($_).'&'; 1398: } 1399: $items=~s/\&$//; 1400: if (!$udomain) { $udomain=$ENV{'user.domain'}; } 1401: if (!$uname) { $uname=$ENV{'user.name'}; } 1402: my $uhome=&homeserver($uname,$udomain); 1403: 1404: return &reply("del:$udomain:$uname:$namespace:$items",$uhome); 1405: } 1406: 1407: # -------------------------------------------------------------- dump interface 1408: 1409: sub dump { 1410: my ($namespace,$udomain,$uname,$regexp)=@_; 1411: if (!$udomain) { $udomain=$ENV{'user.domain'}; } 1412: if (!$uname) { $uname=$ENV{'user.name'}; } 1413: my $uhome=&homeserver($uname,$udomain); 1414: if ($regexp) { 1415: $regexp=&escape($regexp); 1416: } else { 1417: $regexp='.'; 1418: } 1419: my $rep=reply("dump:$udomain:$uname:$namespace:$regexp",$uhome); 1420: my @pairs=split(/\&/,$rep); 1421: my %returnhash=(); 1422: foreach (@pairs) { 1423: my ($key,$value)=split(/=/,$_); 1424: $returnhash{unescape($key)}=unescape($value); 1425: } 1426: return %returnhash; 1427: } 1428: 1429: # --------------------------------------------------------------- put interface 1430: 1431: sub put { 1432: my ($namespace,$storehash,$udomain,$uname)=@_; 1433: if (!$udomain) { $udomain=$ENV{'user.domain'}; } 1434: if (!$uname) { $uname=$ENV{'user.name'}; } 1435: my $uhome=&homeserver($uname,$udomain); 1436: my $items=''; 1437: foreach (keys %$storehash) { 1438: $items.=&escape($_).'='.&escape($$storehash{$_}).'&'; 1439: } 1440: $items=~s/\&$//; 1441: return &reply("put:$udomain:$uname:$namespace:$items",$uhome); 1442: } 1443: 1444: # ------------------------------------------------------ critical put interface 1445: 1446: sub cput { 1447: my ($namespace,$storehash,$udomain,$uname)=@_; 1448: if (!$udomain) { $udomain=$ENV{'user.domain'}; } 1449: if (!$uname) { $uname=$ENV{'user.name'}; } 1450: my $uhome=&homeserver($uname,$udomain); 1451: my $items=''; 1452: foreach (keys %$storehash) { 1453: $items.=escape($_).'='.escape($$storehash{$_}).'&'; 1454: } 1455: $items=~s/\&$//; 1456: return &critical("put:$udomain:$uname:$namespace:$items",$uhome); 1457: } 1458: 1459: # -------------------------------------------------------------- eget interface 1460: 1461: sub eget { 1462: my ($namespace,$storearr,$udomain,$uname)=@_; 1463: my $items=''; 1464: foreach (@$storearr) { 1465: $items.=escape($_).'&'; 1466: } 1467: $items=~s/\&$//; 1468: if (!$udomain) { $udomain=$ENV{'user.domain'}; } 1469: if (!$uname) { $uname=$ENV{'user.name'}; } 1470: my $uhome=&homeserver($uname,$udomain); 1471: my $rep=&reply("eget:$udomain:$uname:$namespace:$items",$uhome); 1472: my @pairs=split(/\&/,$rep); 1473: my %returnhash=(); 1474: my $i=0; 1475: foreach (@$storearr) { 1476: $returnhash{$_}=unescape($pairs[$i]); 1477: $i++; 1478: } 1479: return %returnhash; 1480: } 1481: 1482: # ------------------------------------------------- Check for a user privilege 1483: 1484: sub allowed { 1485: my ($priv,$uri)=@_; 1486: 1487: my $orguri=$uri; 1488: $uri=&declutter($uri); 1489: 1490: # Free bre access to adm and meta resources 1491: 1492: if ((($uri=~/^adm\//) || ($uri=~/\.meta$/)) && ($priv eq 'bre')) { 1493: return 'F'; 1494: } 1495: 1496: # Free bre to public access 1497: 1498: if ($priv eq 'bre') { 1499: if (&metadata($uri,'copyright') eq 'public') { return 'F'; } 1500: } 1501: 1502: my $thisallowed=''; 1503: my $statecond=0; 1504: my $courseprivid=''; 1505: 1506: # Course 1507: 1508: if ($ENV{'user.priv.'.$ENV{'request.role'}.'./'}=~/$priv\&([^\:]*)/) { 1509: $thisallowed.=$1; 1510: } 1511: 1512: # Domain 1513: 1514: if ($ENV{'user.priv.'.$ENV{'request.role'}.'./'.(split(/\//,$uri))[0].'/'} 1515: =~/$priv\&([^\:]*)/) { 1516: $thisallowed.=$1; 1517: } 1518: 1519: # Course: uri itself is a course 1520: my $courseuri=$uri; 1521: $courseuri=~s/\_(\d)/\/$1/; 1522: $courseuri=~s/^([^\/])/\/$1/; 1523: 1524: if ($ENV{'user.priv.'.$ENV{'request.role'}.'.'.$courseuri} 1525: =~/$priv\&([^\:]*)/) { 1526: $thisallowed.=$1; 1527: } 1528: 1529: # Full access at system, domain or course-wide level? Exit. 1530: 1531: if ($thisallowed=~/F/) { 1532: return 'F'; 1533: } 1534: 1535: # If this is generating or modifying users, exit with special codes 1536: 1537: if (':csu:cdc:ccc:cin:cta:cep:ccr:cst:cad:cli:cau:cdg:cca:'=~/\:$priv\:/) { 1538: return $thisallowed; 1539: } 1540: # 1541: # Gathered so far: system, domain and course wide privileges 1542: # 1543: # Course: See if uri or referer is an individual resource that is part of 1544: # the course 1545: 1546: if ($ENV{'request.course.id'}) { 1547: $courseprivid=$ENV{'request.course.id'}; 1548: if ($ENV{'request.course.sec'}) { 1549: $courseprivid.='/'.$ENV{'request.course.sec'}; 1550: } 1551: $courseprivid=~s/\_/\//; 1552: my $checkreferer=1; 1553: my @uriparts=split(/\//,$uri); 1554: my $filename=$uriparts[$#uriparts]; 1555: my $pathname=$uri; 1556: $pathname=~s/\/$filename$//; 1557: if ($ENV{'acc.res.'.$ENV{'request.course.id'}.'.'.$pathname}=~ 1558: /\&$filename\:([\d\|]+)\&/) { 1559: $statecond=$1; 1560: if ($ENV{'user.priv.'.$ENV{'request.role'}.'./'.$courseprivid} 1561: =~/$priv\&([^\:]*)/) { 1562: $thisallowed.=$1; 1563: $checkreferer=0; 1564: } 1565: } 1566: 1567: if ($checkreferer) { 1568: my $refuri=$ENV{'httpref.'.$orguri}; 1569: 1570: unless ($refuri) { 1571: foreach (keys %ENV) { 1572: if ($_=~/^httpref\..*\*/) { 1573: my $pattern=$_; 1574: $pattern=~s/^httpref\.\/res\///; 1575: $pattern=~s/\*/\[\^\/\]\+/g; 1576: $pattern=~s/\//\\\//g; 1577: if ($orguri=~/$pattern/) { 1578: $refuri=$ENV{$_}; 1579: } 1580: } 1581: } 1582: } 1583: if ($refuri) { 1584: $refuri=&declutter($refuri); 1585: my @uriparts=split(/\//,$refuri); 1586: my $filename=$uriparts[$#uriparts]; 1587: my $pathname=$refuri; 1588: $pathname=~s/\/$filename$//; 1589: if ($ENV{'acc.res.'.$ENV{'request.course.id'}.'.'.$pathname}=~ 1590: /\&$filename\:([\d\|]+)\&/) { 1591: my $refstatecond=$1; 1592: if ($ENV{'user.priv.'.$ENV{'request.role'}.'./'.$courseprivid} 1593: =~/$priv\&([^\:]*)/) { 1594: $thisallowed.=$1; 1595: $uri=$refuri; 1596: $statecond=$refstatecond; 1597: } 1598: } 1599: } 1600: } 1601: } 1602: 1603: # 1604: # Gathered now: all privileges that could apply, and condition number 1605: # 1606: # 1607: # Full or no access? 1608: # 1609: 1610: if ($thisallowed=~/F/) { 1611: return 'F'; 1612: } 1613: 1614: unless ($thisallowed) { 1615: return ''; 1616: } 1617: 1618: # Restrictions exist, deal with them 1619: # 1620: # C:according to course preferences 1621: # R:according to resource settings 1622: # L:unless locked 1623: # X:according to user session state 1624: # 1625: 1626: # Possibly locked functionality, check all courses 1627: # Locks might take effect only after 10 minutes cache expiration for other 1628: # courses, and 2 minutes for current course 1629: 1630: my $envkey; 1631: if ($thisallowed=~/L/) { 1632: foreach $envkey (keys %ENV) { 1633: if ($envkey=~/^user\.role\.(st|ta)\.([^\.]*)/) { 1634: my $courseid=$2; 1635: my $roleid=$1.'.'.$2; 1636: $courseid=~s/^\///; 1637: my $expiretime=600; 1638: if ($ENV{'request.role'} eq $roleid) { 1639: $expiretime=120; 1640: } 1641: my ($cdom,$cnum,$csec)=split(/\//,$courseid); 1642: my $prefix='course.'.$cdom.'_'.$cnum.'.'; 1643: if ((time-$ENV{$prefix.'last_cache'})>$expiretime) { 1644: &coursedescription($courseid); 1645: } 1646: if (($ENV{$prefix.'res.'.$uri.'.lock.sections'}=~/\,$csec\,/) 1647: || ($ENV{$prefix.'res.'.$uri.'.lock.sections'} eq 'all')) { 1648: if ($ENV{$prefix.'res.'.$uri.'.lock.expire'}>time) { 1649: &log($ENV{'user.domain'},$ENV{'user.name'}, 1650: $ENV{'user.host'}, 1651: 'Locked by res: '.$priv.' for '.$uri.' due to '. 1652: $cdom.'/'.$cnum.'/'.$csec.' expire '. 1653: $ENV{$prefix.'priv.'.$priv.'.lock.expire'}); 1654: return ''; 1655: } 1656: } 1657: if (($ENV{$prefix.'priv.'.$priv.'.lock.sections'}=~/\,$csec\,/) 1658: || ($ENV{$prefix.'priv.'.$priv.'.lock.sections'} eq 'all')) { 1659: if ($ENV{'priv.'.$priv.'.lock.expire'}>time) { 1660: &log($ENV{'user.domain'},$ENV{'user.name'}, 1661: $ENV{'user.host'}, 1662: 'Locked by priv: '.$priv.' for '.$uri.' due to '. 1663: $cdom.'/'.$cnum.'/'.$csec.' expire '. 1664: $ENV{$prefix.'priv.'.$priv.'.lock.expire'}); 1665: return ''; 1666: } 1667: } 1668: } 1669: } 1670: } 1671: 1672: # 1673: # Rest of the restrictions depend on selected course 1674: # 1675: 1676: unless ($ENV{'request.course.id'}) { 1677: return '1'; 1678: } 1679: 1680: # 1681: # Now user is definitely in a course 1682: # 1683: 1684: 1685: # Course preferences 1686: 1687: if ($thisallowed=~/C/) { 1688: my $rolecode=(split(/\./,$ENV{'request.role'}))[0]; 1689: if ($ENV{'course.'.$ENV{'request.course.id'}.'.'.$priv.'.roles.denied'} 1690: =~/$rolecode/) { 1691: &log($ENV{'user.domain'},$ENV{'user.name'},$ENV{'user.host'}, 1692: 'Denied by role: '.$priv.' for '.$uri.' as '.$rolecode.' in '. 1693: $ENV{'request.course.id'}); 1694: return ''; 1695: } 1696: } 1697: 1698: # Resource preferences 1699: 1700: if ($thisallowed=~/R/) { 1701: my $rolecode=(split(/\./,$ENV{'request.role'}))[0]; 1702: my $filename=$perlvar{'lonDocRoot'}.'/res/'.$uri.'.meta'; 1703: if (-e $filename) { 1704: my @content; 1705: { 1706: my $fh=Apache::File->new($filename); 1707: @content=<$fh>; 1708: } 1709: if (join('',@content)=~ 1710: /\<roledeny[^\>]*\>[^\<]*$rolecode[^\<]*\<\/roledeny\>/) { 1711: &log($ENV{'user.domain'},$ENV{'user.name'},$ENV{'user.host'}, 1712: 'Denied by role: '.$priv.' for '.$uri.' as '.$rolecode); 1713: return ''; 1714: 1715: } 1716: } 1717: } 1718: 1719: # Restricted by state? 1720: 1721: if ($thisallowed=~/X/) { 1722: if (&condval($statecond)) { 1723: return '2'; 1724: } else { 1725: return ''; 1726: } 1727: } 1728: 1729: return 'F'; 1730: } 1731: 1732: # ----------------------------------------------------------------- Define Role 1733: 1734: sub definerole { 1735: if (allowed('mcr','/')) { 1736: my ($rolename,$sysrole,$domrole,$courole)=@_; 1737: foreach (split('/',$sysrole)) { 1738: my ($crole,$cqual)=split(/\&/,$_); 1739: if ($pr{'cr:s'}!~/$crole/) { return "refused:s:$crole"; } 1740: if ($pr{'cr:s'}=~/$crole\&/) { 1741: if ($pr{'cr:s'}!~/$crole\&\w*$cqual/) { 1742: return "refused:s:$crole&$cqual"; 1743: } 1744: } 1745: } 1746: foreach (split('/',$domrole)) { 1747: my ($crole,$cqual)=split(/\&/,$_); 1748: if ($pr{'cr:d'}!~/$crole/) { return "refused:d:$crole"; } 1749: if ($pr{'cr:d'}=~/$crole\&/) { 1750: if ($pr{'cr:d'}!~/$crole\&\w*$cqual/) { 1751: return "refused:d:$crole&$cqual"; 1752: } 1753: } 1754: } 1755: foreach (split('/',$courole)) { 1756: my ($crole,$cqual)=split(/\&/,$_); 1757: if ($pr{'cr:c'}!~/$crole/) { return "refused:c:$crole"; } 1758: if ($pr{'cr:c'}=~/$crole\&/) { 1759: if ($pr{'cr:c'}!~/$crole\&\w*$cqual/) { 1760: return "refused:c:$crole&$cqual"; 1761: } 1762: } 1763: } 1764: my $command="encrypt:rolesput:$ENV{'user.domain'}:$ENV{'user.name'}:". 1765: "$ENV{'user.domain'}:$ENV{'user.name'}:". 1766: "rolesdef_$rolename=". 1767: escape($sysrole.'_'.$domrole.'_'.$courole); 1768: return reply($command,$ENV{'user.home'}); 1769: } else { 1770: return 'refused'; 1771: } 1772: } 1773: 1774: # ---------------- Make a metadata query against the network of library servers 1775: 1776: sub metadata_query { 1777: my ($query,$custom,$customshow)=@_; 1778: my %rhash; 1779: for my $server (keys %libserv) { 1780: unless ($custom or $customshow) { 1781: my $reply=&reply("querysend:".&escape($query),$server); 1782: $rhash{$server}=$reply; 1783: } 1784: else { 1785: my $reply=&reply("querysend:".&escape($query).':'. 1786: &escape($custom).':'.&escape($customshow), 1787: $server); 1788: $rhash{$server}=$reply; 1789: } 1790: } 1791: return \%rhash; 1792: } 1793: 1794: # ------------------------------------------------------------------ Plain Text 1795: 1796: sub plaintext { 1797: my $short=shift; 1798: return $prp{$short}; 1799: } 1800: 1801: # ----------------------------------------------------------------- Assign Role 1802: 1803: sub assignrole { 1804: my ($udom,$uname,$url,$role,$end,$start)=@_; 1805: my $mrole; 1806: if ($role =~ /^cr\//) { 1807: unless (&allowed('ccr',$url)) { 1808: &logthis('Refused custom assignrole: '. 1809: $udom.' '.$uname.' '.$url.' '.$role.' '.$end.' '.$start.' by '. 1810: $ENV{'user.name'}.' at '.$ENV{'user.domain'}); 1811: return 'refused'; 1812: } 1813: $mrole='cr'; 1814: } else { 1815: my $cwosec=$url; 1816: $cwosec=~s/^\/(\w+)\/(\w+)\/.*/$1\/$2/; 1817: unless (&allowed('c'.$role,$cwosec)) { 1818: &logthis('Refused assignrole: '. 1819: $udom.' '.$uname.' '.$url.' '.$role.' '.$end.' '.$start.' by '. 1820: $ENV{'user.name'}.' at '.$ENV{'user.domain'}); 1821: return 'refused'; 1822: } 1823: $mrole=$role; 1824: } 1825: my $command="encrypt:rolesput:$ENV{'user.domain'}:$ENV{'user.name'}:". 1826: "$udom:$uname:$url".'_'."$mrole=$role"; 1827: if ($end) { $command.='_'.$end; } 1828: if ($start) { 1829: if ($end) { 1830: $command.='_'.$start; 1831: } else { 1832: $command.='_0_'.$start; 1833: } 1834: } 1835: return &reply($command,&homeserver($uname,$udom)); 1836: } 1837: 1838: # -------------------------------------------------- Modify user authentication 1839: # Overrides without validation 1840: 1841: sub modifyuserauth { 1842: my ($udom,$uname,$umode,$upass)=@_; 1843: my $uhome=&homeserver($uname,$udom); 1844: unless (&allowed('mau',$udom)) { return 'refused'; } 1845: &logthis('Call to modify user authentication '.$udom.', '.$uname.', '. 1846: $umode.' by '.$ENV{'user.name'}.' at '.$ENV{'user.domain'}); 1847: my $reply=&reply('encrypt:changeuserauth:'.$udom.':'.$uname.':'.$umode.':'. 1848: &escape($upass),$uhome); 1849: &log($ENV{'user.domain'},$ENV{'user.name'},$ENV{'user.home'}, 1850: 'Authentication changed for '.$udom.', '.$uname.', '.$umode. 1851: '(Remote '.$ENV{'REMOTE_ADDR'}.'): '.$reply); 1852: &log($udom,,$uname,$uhome, 1853: 'Authentication changed by '.$ENV{'user.domain'}.', '. 1854: $ENV{'user.name'}.', '.$umode. 1855: '(Remote '.$ENV{'REMOTE_ADDR'}.'): '.$reply); 1856: unless ($reply eq 'ok') { 1857: &logthis('Authentication mode error: '.$reply); 1858: return 'error: '.$reply; 1859: } 1860: return 'ok'; 1861: } 1862: 1863: # --------------------------------------------------------------- Modify a user 1864: 1865: sub modifyuser { 1866: my ($udom, $uname, $uid, 1867: $umode, $upass, $first, 1868: $middle, $last, $gene, 1869: $forceid, $desiredhome)=@_; 1870: $udom=~s/\W//g; 1871: $uname=~s/\W//g; 1872: &logthis('Call to modify user '.$udom.', '.$uname.', '.$uid.', '. 1873: $umode.', '.$first.', '.$middle.', '. 1874: $last.', '.$gene.'(forceid: '.$forceid.')'. 1875: (defined($desiredhome) ? ' desiredhome = '.$desiredhome : 1876: ' desiredhome not specified'). 1877: ' by '.$ENV{'user.name'}.' at '.$ENV{'user.domain'}); 1878: my $uhome=&homeserver($uname,$udom); 1879: # ----------------------------------------------------------------- Create User 1880: if (($uhome eq 'no_host') && ($umode) && ($upass)) { 1881: my $unhome=''; 1882: if (defined($desiredhome) && $hostdom{$desiredhome} eq $udom) { 1883: $unhome = $desiredhome; 1884: } elsif($ENV{'course.'.$ENV{'request.course.id'}.'.domain'} eq $udom) { 1885: $unhome=$ENV{'course.'.$ENV{'request.course.id'}.'.home'}; 1886: } else { # load balancing routine for determining $unhome 1887: my $tryserver; 1888: my $loadm=10000000; 1889: foreach $tryserver (keys %libserv) { 1890: if ($hostdom{$tryserver} eq $udom) { 1891: my $answer=reply('load',$tryserver); 1892: if (($answer=~/\d+/) && ($answer<$loadm)) { 1893: $loadm=$answer; 1894: $unhome=$tryserver; 1895: } 1896: } 1897: } 1898: } 1899: if (($unhome eq '') || ($unhome eq 'no_host')) { 1900: return 'error: unable to find a home server for '.$uname. 1901: ' in domain '.$udom; 1902: } 1903: my $reply=&reply('encrypt:makeuser:'.$udom.':'.$uname.':'.$umode.':'. 1904: &escape($upass),$unhome); 1905: unless ($reply eq 'ok') { 1906: return 'error: '.$reply; 1907: } 1908: $uhome=&homeserver($uname,$udom); 1909: if (($uhome eq '') || ($uhome eq 'no_host') || ($uhome ne $unhome)) { 1910: return 'error: verify home'; 1911: } 1912: } # End of creation of new user 1913: # ---------------------------------------------------------------------- Add ID 1914: if ($uid) { 1915: $uid=~tr/A-Z/a-z/; 1916: my %uidhash=&idrget($udom,$uname); 1917: if (($uidhash{$uname}) && ($uidhash{$uname}!~/error\:/) 1918: && (!$forceid)) { 1919: unless ($uid eq $uidhash{$uname}) { 1920: return 'error: mismatch '.$uidhash{$uname}.' versus '.$uid; 1921: } 1922: } else { 1923: &idput($udom,($uname => $uid)); 1924: } 1925: } 1926: # -------------------------------------------------------------- Add names, etc 1927: my %names=&get('environment', 1928: ['firstname','middlename','lastname','generation'], 1929: $udom,$uname); 1930: if ($names{'firstname'} =~ m/^error:.*/) { %names=(); } 1931: if ($first) { $names{'firstname'} = $first; } 1932: if ($middle) { $names{'middlename'} = $middle; } 1933: if ($last) { $names{'lastname'} = $last; } 1934: if ($gene) { $names{'generation'} = $gene; } 1935: my $reply = &put('environment', \%names, $udom,$uname); 1936: if ($reply ne 'ok') { return 'error: '.$reply; } 1937: &logthis('Success modifying user '.$udom.', '.$uname.', '.$uid.', '. 1938: $umode.', '.$first.', '.$middle.', '. 1939: $last.', '.$gene.' by '. 1940: $ENV{'user.name'}.' at '.$ENV{'user.domain'}); 1941: return 'ok'; 1942: } 1943: 1944: # -------------------------------------------------------------- Modify student 1945: 1946: sub modifystudent { 1947: my ($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene,$usec, 1948: $end,$start,$forceid,$desiredhome)=@_; 1949: my $cid=''; 1950: unless ($cid=$ENV{'request.course.id'}) { 1951: return 'not_in_class'; 1952: } 1953: # --------------------------------------------------------------- Make the user 1954: my $reply=&modifyuser 1955: ($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene,$forceid, 1956: $desiredhome); 1957: unless ($reply eq 'ok') { return $reply; } 1958: my $uhome=&homeserver($uname,$udom); 1959: if (($uhome eq '') || ($uhome eq 'no_host')) { 1960: return 'error: no such user'; 1961: } 1962: # -------------------------------------------------- Add student to course list 1963: $reply=critical('put:'.$ENV{'course.'.$cid.'.domain'}.':'. 1964: $ENV{'course.'.$cid.'.num'}.':classlist:'. 1965: &escape($uname.':'.$udom).'='. 1966: &escape($end.':'.$start), 1967: $ENV{'course.'.$cid.'.home'}); 1968: unless (($reply eq 'ok') || ($reply eq 'delayed')) { 1969: return 'error: '.$reply; 1970: } 1971: # ---------------------------------------------------- Add student role to user 1972: my $uurl='/'.$cid; 1973: $uurl=~s/\_/\//g; 1974: if ($usec) { 1975: $uurl.='/'.$usec; 1976: } 1977: return &assignrole($udom,$uname,$uurl,'st',$end,$start); 1978: } 1979: 1980: # ------------------------------------------------- Write to course preferences 1981: 1982: sub writecoursepref { 1983: my ($courseid,%prefs)=@_; 1984: $courseid=~s/^\///; 1985: $courseid=~s/\_/\//g; 1986: my ($cdomain,$cnum)=split(/\//,$courseid); 1987: my $chome=homeserver($cnum,$cdomain); 1988: if (($chome eq '') || ($chome eq 'no_host')) { 1989: return 'error: no such course'; 1990: } 1991: my $cstring=''; 1992: foreach (keys %prefs) { 1993: $cstring.=escape($_).'='.escape($prefs{$_}).'&'; 1994: } 1995: $cstring=~s/\&$//; 1996: return reply('put:'.$cdomain.':'.$cnum.':environment:'.$cstring,$chome); 1997: } 1998: 1999: # ---------------------------------------------------------- Make/modify course 2000: 2001: sub createcourse { 2002: my ($udom,$description,$url)=@_; 2003: $url=&declutter($url); 2004: my $cid=''; 2005: unless (&allowed('ccc',$ENV{'user.domain'})) { 2006: return 'refused'; 2007: } 2008: unless ($udom eq $ENV{'user.domain'}) { 2009: return 'refused'; 2010: } 2011: # ------------------------------------------------------------------- Create ID 2012: my $uname=substr($$.time,0,5).unpack("H8",pack("I32",time)). 2013: unpack("H2",pack("I32",int(rand(255)))).$perlvar{'lonHostID'}; 2014: # ----------------------------------------------- Make sure that does not exist 2015: my $uhome=&homeserver($uname,$udom); 2016: unless (($uhome eq '') || ($uhome eq 'no_host')) { 2017: $uname=substr($$.time,0,5).unpack("H8",pack("I32",time)). 2018: unpack("H2",pack("I32",int(rand(255)))).$perlvar{'lonHostID'}; 2019: $uhome=&homeserver($uname,$udom); 2020: unless (($uhome eq '') || ($uhome eq 'no_host')) { 2021: return 'error: unable to generate unique course-ID'; 2022: } 2023: } 2024: # ------------------------------------------------------------- Make the course 2025: my $reply=&reply('encrypt:makeuser:'.$udom.':'.$uname.':none::', 2026: $ENV{'user.home'}); 2027: unless ($reply eq 'ok') { return 'error: '.$reply; } 2028: $uhome=&homeserver($uname,$udom); 2029: if (($uhome eq '') || ($uhome eq 'no_host')) { 2030: return 'error: no such course'; 2031: } 2032: &writecoursepref($udom.'_'.$uname, 2033: ('description' => $description, 2034: 'url' => $url)); 2035: return '/'.$udom.'/'.$uname; 2036: } 2037: 2038: # ---------------------------------------------------------- Assign Custom Role 2039: 2040: sub assigncustomrole { 2041: my ($udom,$uname,$url,$rdom,$rnam,$rolename,$end,$start)=@_; 2042: return &assignrole($udom,$uname,$url,'cr/'.$rdom.'/'.$rnam.'/'.$rolename, 2043: $end,$start); 2044: } 2045: 2046: # ----------------------------------------------------------------- Revoke Role 2047: 2048: sub revokerole { 2049: my ($udom,$uname,$url,$role)=@_; 2050: my $now=time; 2051: return &assignrole($udom,$uname,$url,$role,$now); 2052: } 2053: 2054: # ---------------------------------------------------------- Revoke Custom Role 2055: 2056: sub revokecustomrole { 2057: my ($udom,$uname,$url,$rdom,$rnam,$rolename)=@_; 2058: my $now=time; 2059: return &assigncustomrole($udom,$uname,$url,$rdom,$rnam,$rolename,$now); 2060: } 2061: 2062: # ------------------------------------------------------------ Directory lister 2063: 2064: sub dirlist { 2065: my $uri=shift; 2066: $uri=~s/^\///; 2067: $uri=~s/\/$//; 2068: my ($res,$udom,$uname,@rest)=split(/\//,$uri); 2069: if ($udom) { 2070: if ($uname) { 2071: my $listing=reply('ls:'.$perlvar{'lonDocRoot'}.'/'.$uri, 2072: homeserver($uname,$udom)); 2073: return split(/:/,$listing); 2074: } else { 2075: my $tryserver; 2076: my %allusers=(); 2077: foreach $tryserver (keys %libserv) { 2078: if ($hostdom{$tryserver} eq $udom) { 2079: my $listing=reply('ls:'.$perlvar{'lonDocRoot'}.'/res/'.$udom, 2080: $tryserver); 2081: if (($listing ne 'no_such_dir') && ($listing ne 'empty') 2082: && ($listing ne 'con_lost')) { 2083: foreach (split(/:/,$listing)) { 2084: my ($entry,@stat)=split(/&/,$_); 2085: $allusers{$entry}=1; 2086: } 2087: } 2088: } 2089: } 2090: my $alluserstr=''; 2091: foreach (sort keys %allusers) { 2092: $alluserstr.=$_.'&user:'; 2093: } 2094: $alluserstr=~s/:$//; 2095: return split(/:/,$alluserstr); 2096: } 2097: } else { 2098: my $tryserver; 2099: my %alldom=(); 2100: foreach $tryserver (keys %libserv) { 2101: $alldom{$hostdom{$tryserver}}=1; 2102: } 2103: my $alldomstr=''; 2104: foreach (sort keys %alldom) { 2105: $alldomstr.=$perlvar{'lonDocRoot'}.'/res/'.$_.'&domain:'; 2106: } 2107: $alldomstr=~s/:$//; 2108: return split(/:/,$alldomstr); 2109: } 2110: } 2111: 2112: # -------------------------------------------------------- Value of a Condition 2113: 2114: sub directcondval { 2115: my $number=shift; 2116: if ($ENV{'user.state.'.$ENV{'request.course.id'}}) { 2117: return substr($ENV{'user.state.'.$ENV{'request.course.id'}},$number,1); 2118: } else { 2119: return 2; 2120: } 2121: } 2122: 2123: sub condval { 2124: my $condidx=shift; 2125: my $result=0; 2126: my $allpathcond=''; 2127: foreach (split(/\|/,$condidx)) { 2128: if (defined($ENV{'acc.cond.'.$ENV{'request.course.id'}.'.'.$_})) { 2129: $allpathcond.= 2130: '('.$ENV{'acc.cond.'.$ENV{'request.course.id'}.'.'.$_}.')|'; 2131: } 2132: } 2133: $allpathcond=~s/\|$//; 2134: if ($ENV{'request.course.id'}) { 2135: if ($allpathcond) { 2136: my $operand='|'; 2137: my @stack; 2138: foreach ($allpathcond=~/(\d+|\(|\)|\&|\|)/g) { 2139: if ($_ eq '(') { 2140: push @stack,($operand,$result) 2141: } elsif ($_ eq ')') { 2142: my $before=pop @stack; 2143: if (pop @stack eq '&') { 2144: $result=$result>$before?$before:$result; 2145: } else { 2146: $result=$result>$before?$result:$before; 2147: } 2148: } elsif (($_ eq '&') || ($_ eq '|')) { 2149: $operand=$_; 2150: } else { 2151: my $new=directcondval($_); 2152: if ($operand eq '&') { 2153: $result=$result>$new?$new:$result; 2154: } else { 2155: $result=$result>$new?$result:$new; 2156: } 2157: } 2158: } 2159: } 2160: } 2161: return $result; 2162: } 2163: 2164: # --------------------------------------------------- Course Resourcedata Query 2165: 2166: sub courseresdata { 2167: my ($coursenum,$coursedomain,@which)=@_; 2168: my $coursehom=&homeserver($coursenum,$coursedomain); 2169: my $hashid=$coursenum.':'.$coursedomain; 2170: unless (defined($courseresdatacache{$hashid.'.time'})) { 2171: unless (time-$courseresdatacache{$hashid.'.time'}<300) { 2172: my $coursehom=&homeserver($coursenum,$coursedomain); 2173: if ($coursehom) { 2174: my $dumpreply=&reply('dump:'.$coursedomain.':'.$coursenum. 2175: ':resourcedata:.',$coursehom); 2176: unless ($dumpreply=~/^error\:/) { 2177: $courseresdatacache{$hashid.'.time'}=time; 2178: $courseresdatacache{$hashid}=$dumpreply; 2179: } 2180: } 2181: } 2182: } 2183: my @pairs=split(/\&/,$courseresdatacache{$hashid}); 2184: my %returnhash=(); 2185: foreach (@pairs) { 2186: my ($key,$value)=split(/=/,$_); 2187: $returnhash{unescape($key)}=unescape($value); 2188: } 2189: my $item; 2190: foreach $item (@which) { 2191: if ($returnhash{$item}) { return $returnhash{$item}; } 2192: } 2193: return ''; 2194: } 2195: 2196: # --------------------------------------------------------- Value of a Variable 2197: 2198: sub EXT { 2199: my ($varname,$symbparm)=@_; 2200: unless ($varname) { return ''; } 2201: my ($realm,$space,$qualifier,@therest)=split(/\./,$varname); 2202: my $rest; 2203: if ($therest[0]) { 2204: $rest=join('.',@therest); 2205: } else { 2206: $rest=''; 2207: } 2208: my $qualifierrest=$qualifier; 2209: if ($rest) { $qualifierrest.='.'.$rest; } 2210: my $spacequalifierrest=$space; 2211: if ($qualifierrest) { $spacequalifierrest.='.'.$qualifierrest; } 2212: if ($realm eq 'user') { 2213: # --------------------------------------------------------------- user.resource 2214: if ($space eq 'resource') { 2215: my %restored=&restore(); 2216: return $restored{$qualifierrest}; 2217: # ----------------------------------------------------------------- user.access 2218: } elsif ($space eq 'access') { 2219: return &allowed($qualifier,$rest); 2220: # ------------------------------------------ user.preferences, user.environment 2221: } elsif (($space eq 'preferences') || ($space eq 'environment')) { 2222: return $ENV{join('.',('environment',$qualifierrest))}; 2223: # ----------------------------------------------------------------- user.course 2224: } elsif ($space eq 'course') { 2225: return $ENV{join('.',('request.course',$qualifier))}; 2226: # ------------------------------------------------------------------- user.role 2227: } elsif ($space eq 'role') { 2228: my ($role,$where)=split(/\./,$ENV{'request.role'}); 2229: if ($qualifier eq 'value') { 2230: return $role; 2231: } elsif ($qualifier eq 'extent') { 2232: return $where; 2233: } 2234: # ----------------------------------------------------------------- user.domain 2235: } elsif ($space eq 'domain') { 2236: return $ENV{'user.domain'}; 2237: # ------------------------------------------------------------------- user.name 2238: } elsif ($space eq 'name') { 2239: return $ENV{'user.name'}; 2240: # ---------------------------------------------------- Any other user namespace 2241: } else { 2242: my $item=($rest)?$qualifier.'.'.$rest:$qualifier; 2243: my %reply=&get($space,[$item]); 2244: return $reply{$item}; 2245: } 2246: } elsif ($realm eq 'request') { 2247: # ------------------------------------------------------------- request.browser 2248: if ($space eq 'browser') { 2249: return $ENV{'browser.'.$qualifier}; 2250: # ------------------------------------------------------------ request.filename 2251: } else { 2252: return $ENV{'request.'.$spacequalifierrest}; 2253: } 2254: } elsif ($realm eq 'course') { 2255: # ---------------------------------------------------------- course.description 2256: return $ENV{'course.'.$ENV{'request.course.id'}.'.'. 2257: $spacequalifierrest}; 2258: } elsif ($realm eq 'resource') { 2259: if ($ENV{'request.course.id'}) { 2260: 2261: # print '<br>'.$space.' - '.$qualifier.' - '.$spacequalifierrest; 2262: 2263: 2264: # ----------------------------------------------------- Cascading lookup scheme 2265: my $symbp; 2266: if ($symbparm) { 2267: $symbp=$symbparm; 2268: } else { 2269: $symbp=&symbread(); 2270: } 2271: my $mapp=(split(/\_\_\_/,$symbp))[0]; 2272: 2273: my $symbparm=$symbp.'.'.$spacequalifierrest; 2274: my $mapparm=$mapp.'___(all).'.$spacequalifierrest; 2275: 2276: my $seclevel= 2277: $ENV{'request.course.id'}.'.['. 2278: $ENV{'request.course.sec'}.'].'.$spacequalifierrest; 2279: my $seclevelr= 2280: $ENV{'request.course.id'}.'.['. 2281: $ENV{'request.course.sec'}.'].'.$symbparm; 2282: my $seclevelm= 2283: $ENV{'request.course.id'}.'.['. 2284: $ENV{'request.course.sec'}.'].'.$mapparm; 2285: 2286: my $courselevel= 2287: $ENV{'request.course.id'}.'.'.$spacequalifierrest; 2288: my $courselevelr= 2289: $ENV{'request.course.id'}.'.'.$symbparm; 2290: my $courselevelm= 2291: $ENV{'request.course.id'}.'.'.$mapparm; 2292: 2293: # ----------------------------------------------------------- first, check user 2294: my %resourcedata=get('resourcedata', 2295: [$courselevelr,$courselevelm,$courselevel]); 2296: if (($resourcedata{$courselevelr}!~/^error\:/) && 2297: ($resourcedata{$courselevelr}!~/^con_lost/)) { 2298: 2299: if ($resourcedata{$courselevelr}) { 2300: return $resourcedata{$courselevelr}; } 2301: if ($resourcedata{$courselevelm}) { 2302: return $resourcedata{$courselevelm}; } 2303: if ($resourcedata{$courselevel}) { return $resourcedata{$courselevel}; } 2304: 2305: } else { 2306: if ($resourcedata{$courselevelr}!~/No such file/) { 2307: &logthis("<font color=blue>WARNING:". 2308: " Trying to get resource data for ".$ENV{'user.name'}." at " 2309: .$ENV{'user.domain'}.": ".$resourcedata{$courselevelr}. 2310: "</font>"); 2311: } 2312: } 2313: 2314: # -------------------------------------------------------- second, check course 2315: 2316: my $coursereply=&courseresdata( 2317: $ENV{'course.'.$ENV{'request.course.id'}.'.num'}, 2318: $ENV{'course.'.$ENV{'request.course.id'}.'.domain'}, 2319: ($seclevelr,$seclevelm,$seclevel, 2320: $courselevelr,$courselevelm,$courselevel)); 2321: if ($coursereply) { return $coursereply; } 2322: 2323: # ------------------------------------------------------ third, check map parms 2324: my %parmhash=(); 2325: my $thisparm=''; 2326: if (tie(%parmhash,'GDBM_File', 2327: $ENV{'request.course.fn'}.'_parms.db',&GDBM_READER,0640)) { 2328: $thisparm=$parmhash{$symbparm}; 2329: untie(%parmhash); 2330: } 2331: if ($thisparm) { return $thisparm; } 2332: } 2333: 2334: # --------------------------------------------- last, look in resource metadata 2335: 2336: $spacequalifierrest=~s/\./\_/; 2337: my $metadata=&metadata($ENV{'request.filename'},$spacequalifierrest); 2338: if ($metadata) { return $metadata; } 2339: $metadata=&metadata($ENV{'request.filename'}, 2340: 'parameter_'.$spacequalifierrest); 2341: if ($metadata) { return $metadata; } 2342: 2343: # ------------------------------------------------------------------ Cascade up 2344: 2345: unless ($space eq '0') { 2346: my ($part,$id)=split(/\_/,$space); 2347: if ($id) { 2348: my $partgeneral=&EXT('resource.'.$part.'.'.$qualifierrest, 2349: $symbparm); 2350: if ($partgeneral) { return $partgeneral; } 2351: } else { 2352: my $resourcegeneral=&EXT('resource.0.'.$qualifierrest, 2353: $symbparm); 2354: if ($resourcegeneral) { return $resourcegeneral; } 2355: } 2356: } 2357: 2358: # ---------------------------------------------------- Any other user namespace 2359: } elsif ($realm eq 'environment') { 2360: # ----------------------------------------------------------------- environment 2361: return $ENV{'environment.'.$spacequalifierrest}; 2362: } elsif ($realm eq 'system') { 2363: # ----------------------------------------------------------------- system.time 2364: if ($space eq 'time') { 2365: return time; 2366: } 2367: } 2368: return ''; 2369: } 2370: 2371: # ---------------------------------------------------------------- Get metadata 2372: 2373: sub metadata { 2374: my ($uri,$what,$liburi,$prefix,$depthcount)=@_; 2375: 2376: $uri=&declutter($uri); 2377: my $filename=$uri; 2378: $uri=~s/\.meta$//; 2379: # 2380: # Is the metadata already cached? 2381: # Look at timestamp of caching 2382: # Everything is cached by the main uri, libraries are never directly cached 2383: # 2384: unless (abs($metacache{$uri.':cachedtimestamp'}-time)<600) { 2385: # 2386: # Is this a recursive call for a library? 2387: # 2388: if ($liburi) { 2389: $liburi=&declutter($liburi); 2390: $filename=$liburi; 2391: } 2392: my %metathesekeys=(); 2393: unless ($filename=~/\.meta$/) { $filename.='.meta'; } 2394: my $metastring=&getfile($perlvar{'lonDocRoot'}.'/res/'.$filename); 2395: my $parser=HTML::LCParser->new(\$metastring); 2396: my $token; 2397: undef %metathesekeys; 2398: while ($token=$parser->get_token) { 2399: if ($token->[0] eq 'S') { 2400: if (defined($token->[2]->{'package'})) { 2401: # 2402: # This is a package - get package info 2403: # 2404: my $package=$token->[2]->{'package'}; 2405: my $keyroot=''; 2406: if ($prefix) { 2407: $keyroot.='_'.$prefix; 2408: } else { 2409: if (defined($token->[2]->{'part'})) { 2410: $keyroot.='_'.$token->[2]->{'part'}; 2411: } 2412: } 2413: if (defined($token->[2]->{'id'})) { 2414: $keyroot.='_'.$token->[2]->{'id'}; 2415: } 2416: if ($metacache{$uri.':packages'}) { 2417: $metacache{$uri.':packages'}.=','.$package.$keyroot; 2418: } else { 2419: $metacache{$uri.':packages'}=$package.$keyroot; 2420: } 2421: foreach (keys %packagetab) { 2422: if ($_=~/^$package\&/) { 2423: my ($pack,$name,$subp)=split(/\&/,$_); 2424: my $value=$packagetab{$_}; 2425: my $part=$keyroot; 2426: $part=~s/^\_//; 2427: if ($subp eq 'display') { 2428: $value.=' [Part: '.$part.']'; 2429: } 2430: my $unikey='parameter'.$keyroot.'_'.$name; 2431: $metathesekeys{$unikey}=1; 2432: $metacache{$uri.':'.$unikey.'.part'}=$part; 2433: unless 2434: (defined($metacache{$uri.':'.$unikey.'.'.$subp})) { 2435: $metacache{$uri.':'.$unikey.'.'.$subp}=$value; 2436: } 2437: } 2438: } 2439: } else { 2440: # 2441: # This is not a package - some other kind of start tag 2442: # 2443: my $entry=$token->[1]; 2444: my $unikey; 2445: if ($entry eq 'import') { 2446: $unikey=''; 2447: } else { 2448: $unikey=$entry; 2449: } 2450: if ($prefix) { 2451: $unikey.=$prefix; 2452: } else { 2453: if (defined($token->[2]->{'part'})) { 2454: $unikey.='_'.$token->[2]->{'part'}; 2455: } 2456: } 2457: if (defined($token->[2]->{'id'})) { 2458: $unikey.='_'.$token->[2]->{'id'}; 2459: } 2460: 2461: if ($entry eq 'import') { 2462: # 2463: # Importing a library here 2464: # 2465: if (defined($depthcount)) { $depthcount++; } else 2466: { $depthcount=0; } 2467: if ($depthcount<20) { 2468: foreach (split(/\,/,&metadata($uri,'keys', 2469: $parser->get_text('/import'),$unikey, 2470: $depthcount))) { 2471: $metathesekeys{$_}=1; 2472: } 2473: } 2474: } else { 2475: 2476: if (defined($token->[2]->{'name'})) { 2477: $unikey.='_'.$token->[2]->{'name'}; 2478: } 2479: $metathesekeys{$unikey}=1; 2480: foreach (@{$token->[3]}) { 2481: $metacache{$uri.':'.$unikey.'.'.$_}=$token->[2]->{$_}; 2482: } 2483: unless ( 2484: $metacache{$uri.':'.$unikey}=&HTML::Entities::decode($parser->get_text('/'.$entry)) 2485: ) { $metacache{$uri.':'.$unikey}= 2486: $metacache{$uri.':'.$unikey.'.default'}; 2487: } 2488: # end of not-a-package not-a-library import 2489: } 2490: # end of not-a-package start tag 2491: } 2492: # the next is the end of "start tag" 2493: } 2494: } 2495: $metacache{$uri.':keys'}=join(',',keys %metathesekeys); 2496: $metacache{$uri.':cachedtimestamp'}=time; 2497: # this is the end of "was not already recently cached 2498: } 2499: return $metacache{$uri.':'.$what}; 2500: } 2501: 2502: # ------------------------------------------------- Update symbolic store links 2503: 2504: sub symblist { 2505: my ($mapname,%newhash)=@_; 2506: $mapname=declutter($mapname); 2507: my %hash; 2508: if (($ENV{'request.course.fn'}) && (%newhash)) { 2509: if (tie(%hash,'GDBM_File',$ENV{'request.course.fn'}.'_symb.db', 2510: &GDBM_WRCREAT,0640)) { 2511: foreach (keys %newhash) { 2512: $hash{declutter($_)}=$mapname.'___'.$newhash{$_}; 2513: } 2514: if (untie(%hash)) { 2515: return 'ok'; 2516: } 2517: } 2518: } 2519: return 'error'; 2520: } 2521: 2522: # --------------------------------------------------------------- Verify a symb 2523: 2524: sub symbverify { 2525: my ($symb,$thisfn)=@_; 2526: $thisfn=&declutter($thisfn); 2527: # direct jump to resource in page or to a sequence - will construct own symbs 2528: if ($thisfn=~/\.(page|sequence)$/) { return 1; } 2529: # check URL part 2530: my ($map,$resid,$url)=split(/\_\_\_/,$symb); 2531: unless (&symbclean($url) eq &symbclean($thisfn)) { return 0; } 2532: 2533: $symb=&symbclean($symb); 2534: 2535: my %bighash; 2536: my $okay=0; 2537: if (tie(%bighash,'GDBM_File',$ENV{'request.course.fn'}.'.db', 2538: &GDBM_READER,0640)) { 2539: my $ids=$bighash{'ids_/res/'.$thisfn}; 2540: unless ($ids) { 2541: $ids=$bighash{'ids_/'.$thisfn}; 2542: } 2543: if ($ids) { 2544: # ------------------------------------------------------------------- Has ID(s) 2545: foreach (split(/\,/,$ids)) { 2546: my ($mapid,$resid)=split(/\./,$_); 2547: if ( 2548: &symbclean(&declutter($bighash{'map_id_'.$mapid}).'___'.$resid.'___'.$thisfn) 2549: eq $symb) { 2550: $okay=1; 2551: } 2552: } 2553: } 2554: untie(%bighash); 2555: } 2556: return $okay; 2557: } 2558: 2559: # --------------------------------------------------------------- Clean-up symb 2560: 2561: sub symbclean { 2562: my $symb=shift; 2563: 2564: # remove version from map 2565: $symb=~s/\.(\d+)\.(\w+)\_\_\_/\.$2\_\_\_/; 2566: 2567: # remove version from URL 2568: $symb=~s/\.(\d+)\.(\w+)$/\.$2/; 2569: 2570: return $symb; 2571: } 2572: 2573: # ------------------------------------------------------ Return symb list entry 2574: 2575: sub symbread { 2576: my $thisfn=shift; 2577: unless ($thisfn) { 2578: if ($ENV{'request.symb'}) { return &symbclean($ENV{'request.symb'}); } 2579: $thisfn=$ENV{'request.filename'}; 2580: } 2581: $thisfn=declutter($thisfn); 2582: my %hash; 2583: my %bighash; 2584: my $syval=''; 2585: if (($ENV{'request.course.fn'}) && ($thisfn)) { 2586: if (tie(%hash,'GDBM_File',$ENV{'request.course.fn'}.'_symb.db', 2587: &GDBM_READER,0640)) { 2588: $syval=$hash{$thisfn}; 2589: untie(%hash); 2590: } 2591: # ---------------------------------------------------------- There was an entry 2592: if ($syval) { 2593: unless ($syval=~/\_\d+$/) { 2594: unless ($ENV{'form.request.prefix'}=~/\.(\d+)\_$/) { 2595: &appenv('request.ambiguous' => $thisfn); 2596: return ''; 2597: } 2598: $syval.=$1; 2599: } 2600: } else { 2601: # ------------------------------------------------------- Was not in symb table 2602: if (tie(%bighash,'GDBM_File',$ENV{'request.course.fn'}.'.db', 2603: &GDBM_READER,0640)) { 2604: # ---------------------------------------------- Get ID(s) for current resource 2605: my $ids=$bighash{'ids_/res/'.$thisfn}; 2606: unless ($ids) { 2607: $ids=$bighash{'ids_/'.$thisfn}; 2608: } 2609: if ($ids) { 2610: # ------------------------------------------------------------------- Has ID(s) 2611: my @possibilities=split(/\,/,$ids); 2612: if ($#possibilities==0) { 2613: # ----------------------------------------------- There is only one possibility 2614: my ($mapid,$resid)=split(/\./,$ids); 2615: $syval=declutter($bighash{'map_id_'.$mapid}).'___'.$resid; 2616: } else { 2617: # ------------------------------------------ There is more than one possibility 2618: my $realpossible=0; 2619: foreach (@possibilities) { 2620: my $file=$bighash{'src_'.$_}; 2621: if (&allowed('bre',$file)) { 2622: my ($mapid,$resid)=split(/\./,$_); 2623: if ($bighash{'map_type_'.$mapid} ne 'page') { 2624: $realpossible++; 2625: $syval=declutter($bighash{'map_id_'.$mapid}). 2626: '___'.$resid; 2627: } 2628: } 2629: } 2630: if ($realpossible!=1) { $syval=''; } 2631: } 2632: } 2633: untie(%bighash) 2634: } 2635: } 2636: if ($syval) { 2637: return &symbclean($syval.'___'.$thisfn); 2638: } 2639: } 2640: &appenv('request.ambiguous' => $thisfn); 2641: return ''; 2642: } 2643: 2644: # ---------------------------------------------------------- Return random seed 2645: 2646: sub numval { 2647: my $txt=shift; 2648: $txt=~tr/A-J/0-9/; 2649: $txt=~tr/a-j/0-9/; 2650: $txt=~tr/K-T/0-9/; 2651: $txt=~tr/k-t/0-9/; 2652: $txt=~tr/U-Z/0-5/; 2653: $txt=~tr/u-z/0-5/; 2654: $txt=~s/\D//g; 2655: return int($txt); 2656: } 2657: 2658: sub rndseed { 2659: my ($symb,$courseid,$domain,$username)=@_; 2660: if (!$symb) { 2661: unless ($symb=&symbread()) { return time; } 2662: } 2663: if (!$courseid) { $courseid=$ENV{'request.course.id'};} 2664: if (!$domain) {$domain=$ENV{'user.domain'};} 2665: if (!$username) {$username=$ENV{'user.name'};} 2666: { 2667: use integer; 2668: my $symbchck=unpack("%32C*",$symb) << 27; 2669: my $symbseed=numval($symb) << 22; 2670: my $namechck=unpack("%32C*",$username) << 17; 2671: my $nameseed=numval($username) << 12; 2672: my $domainseed=unpack("%32C*",$domain) << 7; 2673: my $courseseed=unpack("%32C*",$courseid); 2674: my $num=$symbseed+$nameseed+$domainseed+$courseseed+$namechck+$symbchck; 2675: #uncommenting these lines can break things! 2676: #&Apache::lonxml::debug("$symbseed:$nameseed;$domainseed|$courseseed;$namechck:$symbchck"); 2677: #&Apache::lonxml::debug("rndseed :$num:$symb"); 2678: return $num; 2679: } 2680: } 2681: 2682: sub ireceipt { 2683: my ($funame,$fudom,$fucourseid,$fusymb)=@_; 2684: my $cuname=unpack("%32C*",$funame); 2685: my $cudom=unpack("%32C*",$fudom); 2686: my $cucourseid=unpack("%32C*",$fucourseid); 2687: my $cusymb=unpack("%32C*",$fusymb); 2688: my $cunique=unpack("%32C*",$perlvar{'lonReceipt'}); 2689: return unpack("%32C*",$perlvar{'lonHostID'}).'-'. 2690: ($cunique%$cuname+ 2691: $cunique%$cudom+ 2692: $cusymb%$cuname+ 2693: $cusymb%$cudom+ 2694: $cucourseid%$cuname+ 2695: $cucourseid%$cudom); 2696: } 2697: 2698: sub receipt { 2699: return &ireceipt($ENV{'user.name'},$ENV{'user.domain'}, 2700: $ENV{'request.course.id'},&symbread()); 2701: } 2702: 2703: # ------------------------------------------------------------ Serves up a file 2704: # returns either the contents of the file or a -1 2705: sub getfile { 2706: my $file=shift; 2707: &repcopy($file); 2708: if (! -e $file ) { return -1; }; 2709: my $fh=Apache::File->new($file); 2710: my $a=''; 2711: while (<$fh>) { $a .=$_; } 2712: return $a 2713: } 2714: 2715: sub filelocation { 2716: my ($dir,$file) = @_; 2717: my $location; 2718: $file=~ s/^\s*(\S+)\s*$/$1/; ## strip off leading and trailing spaces 2719: if ($file=~m:^/~:) { # is a contruction space reference 2720: $location = $file; 2721: $location =~ s:/~(.*?)/(.*):/home/$1/public_html/$2:; 2722: } else { 2723: $file=~s/^$perlvar{'lonDocRoot'}//; 2724: $file=~s:^/*res::; 2725: if ( !( $file =~ m:^/:) ) { 2726: $location = $dir. '/'.$file; 2727: } else { 2728: $location = '/home/httpd/html/res'.$file; 2729: } 2730: } 2731: $location=~s://+:/:g; # remove duplicate / 2732: while ($location=~m:/\.\./:) {$location=~ s:/[^/]+/\.\./:/:g;} #remove dir/.. 2733: return $location; 2734: } 2735: 2736: sub hreflocation { 2737: my ($dir,$file)=@_; 2738: unless (($file=~/^http:\/\//i) || ($file=~/^\//)) { 2739: my $finalpath=filelocation($dir,$file); 2740: $finalpath=~s/^\/home\/httpd\/html//; 2741: return $finalpath; 2742: } else { 2743: return $file; 2744: } 2745: } 2746: 2747: # ------------------------------------------------------------- Declutters URLs 2748: 2749: sub declutter { 2750: my $thisfn=shift; 2751: $thisfn=~s/^$perlvar{'lonDocRoot'}//; 2752: $thisfn=~s/^\///; 2753: $thisfn=~s/^res\///; 2754: return $thisfn; 2755: } 2756: 2757: # -------------------------------------------------------- Escape Special Chars 2758: 2759: sub escape { 2760: my $str=shift; 2761: $str =~ s/(\W)/"%".unpack('H2',$1)/eg; 2762: return $str; 2763: } 2764: 2765: # ----------------------------------------------------- Un-Escape Special Chars 2766: 2767: sub unescape { 2768: my $str=shift; 2769: $str =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C",hex($1))/eg; 2770: return $str; 2771: } 2772: 2773: # ================================================================ Main Program 2774: 2775: sub goodbye { 2776: &logthis("Starting Shut down"); 2777: &flushcourselogs(); 2778: &logthis("Shutting down"); 2779: } 2780: 2781: BEGIN { 2782: # ------------------------------------------- Read access.conf and loncapa.conf 2783: # (eventually access.conf will become deprecated) 2784: unless ($readit) { 2785: 2786: { 2787: my $config=Apache::File->new("/etc/httpd/conf/access.conf"); 2788: 2789: while (my $configline=<$config>) { 2790: if ($configline =~ /^[^\#]*PerlSetVar/) { 2791: my ($dummy,$varname,$varvalue)=split(/\s+/,$configline); 2792: chomp($varvalue); 2793: $perlvar{$varname}=$varvalue; 2794: } 2795: } 2796: } 2797: { 2798: my $config=Apache::File->new("/etc/httpd/conf/loncapa.conf"); 2799: 2800: while (my $configline=<$config>) { 2801: if ($configline =~ /^[^\#]*PerlSetVar/) { 2802: my ($dummy,$varname,$varvalue)=split(/\s+/,$configline); 2803: chomp($varvalue); 2804: $perlvar{$varname}=$varvalue; 2805: } 2806: } 2807: } 2808: 2809: # ------------------------------------------------------------- Read hosts file 2810: { 2811: my $config=Apache::File->new("$perlvar{'lonTabDir'}/hosts.tab"); 2812: 2813: while (my $configline=<$config>) { 2814: chomp($configline); 2815: my ($id,$domain,$role,$name,$ip)=split(/:/,$configline); 2816: $hostname{$id}=$name; 2817: $hostdom{$id}=$domain; 2818: $hostip{$id}=$ip; 2819: if ($role eq 'library') { $libserv{$id}=$name; } 2820: } 2821: } 2822: 2823: # ------------------------------------------------------ Read spare server file 2824: { 2825: my $config=Apache::File->new("$perlvar{'lonTabDir'}/spare.tab"); 2826: 2827: while (my $configline=<$config>) { 2828: chomp($configline); 2829: if (($configline) && ($configline ne $perlvar{'lonHostID'})) { 2830: $spareid{$configline}=1; 2831: } 2832: } 2833: } 2834: # ------------------------------------------------------------ Read permissions 2835: { 2836: my $config=Apache::File->new("$perlvar{'lonTabDir'}/roles.tab"); 2837: 2838: while (my $configline=<$config>) { 2839: chomp($configline); 2840: if ($configline) { 2841: my ($role,$perm)=split(/ /,$configline); 2842: if ($perm ne '') { $pr{$role}=$perm; } 2843: } 2844: } 2845: } 2846: 2847: # -------------------------------------------- Read plain texts for permissions 2848: { 2849: my $config=Apache::File->new("$perlvar{'lonTabDir'}/rolesplain.tab"); 2850: 2851: while (my $configline=<$config>) { 2852: chomp($configline); 2853: if ($configline) { 2854: my ($short,$plain)=split(/:/,$configline); 2855: if ($plain ne '') { $prp{$short}=$plain; } 2856: } 2857: } 2858: } 2859: 2860: # ---------------------------------------------------------- Read package table 2861: { 2862: my $config=Apache::File->new("$perlvar{'lonTabDir'}/packages.tab"); 2863: 2864: while (my $configline=<$config>) { 2865: chomp($configline); 2866: my ($short,$plain)=split(/:/,$configline); 2867: my ($pack,$name)=split(/\&/,$short); 2868: if ($plain ne '') { 2869: $packagetab{$pack.'&'.$name.'&name'}=$name; 2870: $packagetab{$short}=$plain; 2871: } 2872: } 2873: } 2874: 2875: %metacache=(); 2876: 2877: $processmarker=$$.'_'.time.'_'.$perlvar{'lonHostID'}; 2878: $dumpcount=0; 2879: 2880: &logtouch(); 2881: &logthis('<font color=yellow>INFO: Read configuration</font>'); 2882: $readit=1; 2883: } 2884: } 2885: 2886: 1; 2887: __END__ 2888: 2889: =head1 NAME 2890: 2891: Apache::lonnet - TCP networking package 2892: 2893: =head1 SYNOPSIS 2894: 2895: Invoked by other LON-CAPA modules. 2896: 2897: &Apache::lonnet::SUBROUTINENAME(ARGUMENTS); 2898: 2899: =head1 INTRODUCTION 2900: 2901: This module provides subroutines which interact with the 2902: lonc/lond (TCP) network layer of LON-CAPA. 2903: 2904: This is part of the LearningOnline Network with CAPA project 2905: described at http://www.lon-capa.org. 2906: 2907: =head1 HANDLER SUBROUTINE 2908: 2909: There is no handler routine for this module. 2910: 2911: =head1 OTHER SUBROUTINES 2912: 2913: =over 4 2914: 2915: =item * 2916: 2917: logtouch() : make sure the logfile, lonnet.log, exists 2918: 2919: =item * 2920: 2921: logthis() : append message to lonnet.log 2922: 2923: =item * 2924: 2925: logperm() : append a permanent message to lonnet.perm.log 2926: 2927: =item * 2928: 2929: subreply() : non-critical communication, called by &reply 2930: 2931: =item * 2932: 2933: reply() : makes two attempts to pass message; logs refusals and rejections 2934: 2935: =item * 2936: 2937: reconlonc() : tries to reconnect lonc client processes. 2938: 2939: =item * 2940: 2941: critical() : passes a critical message to another server; if cannot get 2942: through then place message in connection buffer 2943: 2944: =item * 2945: 2946: appenv(%hash) : read in current user environment, append new environment 2947: values to make new user environment 2948: 2949: =item * 2950: 2951: delenv($varname) : read in current user environment, remove all values 2952: beginning with $varname, write new user environment (note: flock is used 2953: to prevent conflicting shared read/writes with file) 2954: 2955: =item * 2956: 2957: spareserver() : find server with least workload from spare.tab 2958: 2959: =item * 2960: 2961: queryauthenticate($uname,$udom) : try to determine user's current 2962: authentication scheme 2963: 2964: =item * 2965: 2966: authenticate($uname,$upass,$udom) : try to authenticate user from domain's lib 2967: servers (first use the current one) 2968: 2969: =item * 2970: 2971: homeserver($uname,$udom) : find the homebase for a user from domain's lib 2972: servers 2973: 2974: =item * 2975: 2976: idget($udom,@ids) : find the usernames behind a list of IDs (returns hash: 2977: id=>name,id=>name) 2978: 2979: =item * 2980: 2981: idrget($udom,@unames) : find the IDs behind a list of usernames (returns hash: 2982: name=>id,name=>id) 2983: 2984: =item * 2985: 2986: idput($udom,%ids) : store away a list of names and associated IDs 2987: 2988: =item * 2989: 2990: usection($domain,$user,$courseid) : output of section name/number or '' for 2991: "not in course" and '-1' for "no section" 2992: 2993: =item * 2994: 2995: userenvironment($domain,$user,$what) : puts out any environment parameter 2996: for a user 2997: 2998: =item * 2999: 3000: subscribe($fname) : subscribe to a resource, return URL if possible 3001: 3002: =item * 3003: 3004: repcopy($filename) : replicate file 3005: 3006: =item * 3007: 3008: ssi($url,%hash) : server side include, does a complete request cycle on url to 3009: localhost, posts hash 3010: 3011: =item * 3012: 3013: log($domain,$name,$home,$message) : write to permanent log for user; use 3014: critical subroutine 3015: 3016: =item * 3017: 3018: flushcourselogs() : flush (save) buffer logs and access logs 3019: 3020: =item * 3021: 3022: courselog($what) : save message for course in hash 3023: 3024: =item * 3025: 3026: courseacclog($what) : save message for course using &courselog(). Perform 3027: special processing for specific resource types (problems, exams, quizzes, etc). 3028: 3029: =item * 3030: 3031: countacc($url) : count the number of accesses to a given URL 3032: 3033: =item * 3034: 3035: sub checkout($symb,$tuname,$tudom,$tcrsid) : check out an item 3036: 3037: =item * 3038: 3039: sub checkin($token) : check in an item 3040: 3041: =item * 3042: 3043: sub expirespread($uname,$udom,$stype,$usymb) : set expire date for spreadsheet 3044: 3045: =item * 3046: 3047: devalidate($symb) : devalidate spreadsheets 3048: 3049: =item * 3050: 3051: hash2str(%hash) : convert a hash into a string complete with escaping and '=' 3052: and '&' separators, supports elements that are arrayrefs and hashrefs 3053: 3054: =item * 3055: 3056: hashref2str($hashref) : convert a hashref into a string complete with 3057: escaping and '=' and '&' separators, supports elements that are 3058: arrayrefs and hashrefs 3059: 3060: =item * 3061: 3062: arrayref2str($arrayref) : convert an arrayref into a string complete 3063: with escaping and '&' separators, supports elements that are arrayrefs 3064: and hashrefs 3065: 3066: =item * 3067: 3068: str2hash($string) : convert string to hash using unescaping and 3069: splitting on '=' and '&', supports elements that are arrayrefs and 3070: hashrefs 3071: 3072: =item * 3073: 3074: str2array($string) : convert string to hash using unescaping and 3075: splitting on '&', supports elements that are arrayrefs and hashrefs 3076: 3077: =item * 3078: 3079: tmpreset($symb,$namespace,$domain,$stuname) : temporary storage 3080: 3081: =item * 3082: 3083: tmprestore($symb,$namespace,$domain,$stuname) : temporary restore 3084: 3085: =item * 3086: 3087: store($storehash,$symb,$namespace,$domain,$stuname) : stores hash permanently 3088: for this url; hashref needs to be given and should be a \%hashname; the 3089: remaining args aren't required and if they aren't passed or are '' they will 3090: be derived from the ENV 3091: 3092: =item * 3093: 3094: cstore($storehash,$symb,$namespace,$domain,$stuname) : same as store but 3095: uses critical subroutine 3096: 3097: =item * 3098: 3099: restore($symb,$namespace,$domain,$stuname) : returns hash for this symb; 3100: all args are optional 3101: 3102: =item * 3103: 3104: coursedescription($courseid) : course description 3105: 3106: =item * 3107: 3108: rolesinit($domain,$username,$authhost) : get user privileges 3109: 3110: =item * 3111: 3112: get($namespace,$storearr,$udomain,$uname) : returns hash with keys from array 3113: reference filled in from namesp ($udomain and $uname are optional) 3114: 3115: =item * 3116: 3117: del($namespace,$storearr,$udomain,$uname) : deletes keys out of array from 3118: namesp ($udomain and $uname are optional) 3119: 3120: =item * 3121: 3122: dump($namespace,$udomain,$uname,$regexp) : 3123: dumps the complete (or key matching regexp) namespace into a hash 3124: ($udomain, $uname and $regexp are optional) 3125: 3126: =item * 3127: 3128: put($namespace,$storehash,$udomain,$uname) : stores hash in namesp 3129: ($udomain and $uname are optional) 3130: 3131: =item * 3132: 3133: cput($namespace,$storehash,$udomain,$uname) : critical put 3134: ($udomain and $uname are optional) 3135: 3136: =item * 3137: 3138: eget($namespace,$storearr,$udomain,$uname) : returns hash with keys from array 3139: reference filled in from namesp (encrypts the return communication) 3140: ($udomain and $uname are optional) 3141: 3142: =item * 3143: 3144: allowed($priv,$uri) : check for a user privilege; returns codes for allowed 3145: actions 3146: F: full access 3147: U,I,K: authentication modes (cxx only) 3148: '': forbidden 3149: 1: user needs to choose course 3150: 2: browse allowed 3151: 3152: =item * 3153: 3154: definerole($rolename,$sysrole,$domrole,$courole) : define role; define a custom 3155: role rolename set privileges in format of lonTabs/roles.tab for system, domain, 3156: and course level 3157: 3158: =item * 3159: 3160: metadata_query($query,$custom,$customshow) : make a metadata query against the 3161: network of library servers; returns file handle of where SQL and regex results 3162: will be stored for query 3163: 3164: =item * 3165: 3166: plaintext($short) : return value in %prp hash (rolesplain.tab); plain text 3167: explanation of a user role term 3168: 3169: =item * 3170: 3171: assignrole($udom,$uname,$url,$role,$end,$start) : assign role; give a role to a 3172: user for the level given by URL. Optional start and end dates (leave empty 3173: string or zero for "no date") 3174: 3175: =item * 3176: 3177: modifyuserauth($udom,$uname,$umode,$upass) : modify user authentication 3178: 3179: =item * 3180: 3181: modifyuser($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene) : 3182: modify user 3183: 3184: =item * 3185: 3186: modifystudent($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene,$usec, 3187: $end,$start) : modify student 3188: 3189: =item * 3190: 3191: writecoursepref($courseid,%prefs) : write preferences for a course 3192: 3193: =item * 3194: 3195: createcourse($udom,$description,$url) : make/modify course 3196: 3197: =item * 3198: 3199: assigncustomrole($udom,$uname,$url,$rdom,$rnam,$rolename,$end,$start) : assign 3200: custom role; give a custom role to a user for the level given by URL. Specify 3201: name and domain of role author, and role name 3202: 3203: =item * 3204: 3205: revokerole($udom,$uname,$url,$role) : revoke a role for url 3206: 3207: =item * 3208: 3209: revokecustomrole($udom,$uname,$url,$role) : revoke a custom role 3210: 3211: =item * 3212: 3213: dirlist($uri) : return directory list based on URI 3214: 3215: =item * 3216: 3217: directcondval($number) : get current value of a condition; reads from a state 3218: string 3219: 3220: =item * 3221: 3222: condval($condidx) : value of condition index based on state 3223: 3224: =item * 3225: 3226: EXT($varname,$symbparm) : value of a variable 3227: 3228: =item * 3229: 3230: metadata($uri,$what,$liburi,$prefix,$depthcount) : get metadata; returns the 3231: metadata entry for a file; entry='keys', returns a comma separated list of keys 3232: 3233: =item * 3234: 3235: symblist($mapname,%newhash) : update symbolic storage links 3236: 3237: =item * 3238: 3239: symbread($filename) : return symbolic list entry (filename argument optional); 3240: returns the data handle 3241: 3242: =item * 3243: 3244: numval($salt) : return random seed value (addend for rndseed) 3245: 3246: =item * 3247: 3248: rndseed($symb,$courseid,$domain,$username) : create a random sum; returns 3249: a random seed, all arguments are optional, if they aren't sent it uses the 3250: environment to derive them. Note: if symb isn't sent and it can't get one 3251: from &symbread it will use the current time as its return value 3252: 3253: =item * 3254: 3255: ireceipt($funame,$fudom,$fucourseid,$fusymb) : return unique, 3256: unfakeable, receipt 3257: 3258: =item * 3259: 3260: receipt() : API to ireceipt working off of ENV values; given out to users 3261: 3262: =item * 3263: 3264: getfile($file) : serves up a file, returns the contents of a file or -1; 3265: replicates and subscribes to the file 3266: 3267: =item * 3268: 3269: filelocation($dir,$file) : returns file system location of a file based on URI; 3270: meant to be "fairly clean" absolute reference 3271: 3272: =item * 3273: 3274: hreflocation($dir,$file) : returns file system location or a URL; same as 3275: filelocation except for hrefs 3276: 3277: =item * 3278: 3279: declutter() : declutters URLs (remove docroot, beginning slashes, 'res' etc) 3280: 3281: =item * 3282: 3283: escape() : unpack non-word characters into CGI-compatible hex codes 3284: 3285: =item * 3286: 3287: unescape() : pack CGI-compatible hex codes into actual non-word ASCII character 3288: 3289: =item * 3290: 3291: goodbye() : flush course logs and log shutting down; it is called in srm.conf 3292: as a PerlChildExitHandler 3293: 3294: =back 3295: 3296: =cut