loncom/lonnet/perl/lonnet.pm - view

File: [LON-CAPA] / loncom / lonnet / perl / lonnet.pm
Revision 1.242: download - view: text, annotated - select for diffs
Mon Jun 24 14:16:58 2002 UTC (22 years ago) by www
Branches: MAIN
CVS tags: HEAD

Toward bug 305: &symbread now recognizes "mapalias" names and returns symb.

Also, if &symbread is handed a symb, it verifies the symb and returns it
"cleaned" if okay.

In effect, &symbread can now be handed symbs, URLs, and aliases, and should
return a cleaned verified symb in any of those cases.

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