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