loncom/lonnet/perl/lonnet.pm - view

File: [LON-CAPA] / loncom / lonnet / perl / lonnet.pm
Revision 1.403: download - view: text, annotated - select for diffs
Wed Aug 20 01:13:56 2003 UTC (20 years, 11 months ago) by www
Branches: MAIN
CVS tags: HEAD

The "4" in split(/:,4) did connect all following domain.tab entries into the
authentication argument. If indeed the argument is supposed to include ":",
those should be escaped instead. Fixed, and now also reading in new info
fields.

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