![]() ![]() | ![]() |
Removed get bug from EXT to get course data
1: # The LearningOnline Network 2: # TCP networking package 3: # 4: # Functions for use by content handlers: 5: # 6: # plaintext(short) : plain text explanation of short term 7: # fileembstyle(ext) : embed style in page for file extension 8: # filedescription(ext) : descriptor text for file extension 9: # allowed(short,url) : returns codes for allowed actions 10: # F: full access 11: # U,I,K: authentication modes (cxx only) 12: # '': forbidden 13: # 1: user needs to choose course 14: # 2: browse allowed 15: # definerole(rolename,sys,dom,cou) : define a custom role rolename 16: # set priviledges in format of lonTabs/roles.tab for 17: # system, domain and course level, 18: # assignrole(udom,uname,url,role,end,start) : give a role to a user for the 19: # level given by url. Optional start and end dates 20: # (leave empty string or zero for "no date") 21: # assigncustomrole (udom,uname,url,rdom,rnam,rolename,end,start) : give a 22: # custom role to a user for the level given by url. 23: # Specify name and domain of role author, and role name 24: # revokerole (udom,uname,url,role) : Revoke a role for url 25: # revokecustomrole (udom,uname,url,rdom,rnam,rolename) : Revoke a custom role 26: # appenv(hash) : adds hash to session environment 27: # delenv(varname) : deletes all environment entries starting with varname 28: # store(hash) : stores hash permanently for this url 29: # cstore(hash) : critical store 30: # restore : returns hash for this url 31: # eget(namesp,array) : returns hash with keys from array filled in from namesp 32: # get(namesp,array) : returns hash with keys from array filled in from namesp 33: # del(namesp,array) : deletes keys out of array from namesp 34: # put(namesp,hash) : stores hash in namesp 35: # cput(namesp,hash) : critical put 36: # dump(namesp) : dumps the complete namespace into a hash 37: # ssi(url,hash) : does a complete request cycle on url to localhost, posts 38: # hash 39: # coursedescription(id) : returns and caches course description for id 40: # repcopy(filename) : replicate file 41: # dirlist(url) : gets a directory listing 42: # directcondval(index) : reading condition value of single condition from 43: # state string 44: # condval(index) : value of condition index based on state 45: # EXT(name) : value of a variable 46: # symblist(map,hash) : Updates symbolic storage links 47: # symbread([filename]) : returns the data handle (filename optional) 48: # rndseed() : returns a random seed 49: # receipt() : returns a receipt to be given out to users 50: # getfile(filename) : returns the contents of filename, or a -1 if it can't 51: # be found, replicates and subscribes to the file 52: # filelocation(dir,file) : returns a farily clean absolute reference to file 53: # from the directory dir 54: # hreflocation(dir,file) : same as filelocation, but for hrefs 55: # log(domain,user,home,msg) : write to permanent log for user 56: # usection(domain,user,courseid) : output of section name/number or '' for 57: # "not in course" and '-1' for "no section" 58: # userenvironment(domain,user,what) : puts out any environment parameter 59: # for a user 60: # idput(domain,hash) : writes IDs for users from hash (name=>id,name=>id) 61: # idget(domain,array): returns hash with usernames (id=>name,id=>name) for 62: # an array of IDs 63: # idrget(domain,array): returns hash with IDs for usernames (name=>id,...) for 64: # an array of names 65: # metadata(file,entry): returns the metadata entry for a file. entry='keys' 66: # returns a comma separated list of keys 67: # 68: # 6/1/99,6/2,6/10,6/11,6/12,6/14,6/26,6/28,6/29,6/30, 69: # 7/1,7/2,7/9,7/10,7/12,7/14,7/15,7/19, 70: # 11/8,11/16,11/18,11/22,11/23,12/22, 71: # 01/06,01/13,02/24,02/28,02/29, 72: # 03/01,03/02,03/06,03/07,03/13, 73: # 04/05,05/29,05/31,06/01, 74: # 06/05,06/26 Gerd Kortemeyer 75: # 06/26 Ben Tyszka 76: # 06/30,07/15,07/17,07/18,07/20,07/21,07/22,07/25 Gerd Kortemeyer 77: # 08/14 Ben Tyszka 78: # 08/22,08/28,08/31,09/01,09/02,09/04,09/05,09/25,09/28,09/30 Gerd Kortemeyer 79: # 10/04 Gerd Kortemeyer 80: # 10/04 Guy Albertelli 81: # 10/06,10/09,10/10,10/11,10/14,10/20,10/23,10/25,10/26,10/27,10/28,10/29, 82: # 10/30,10/31, 83: # 11/2,11/14,11/15,11/16,11/20,11/21,11/22,11/25,11/27, 84: # 12/02,12/12 Gerd Kortemeyer 85: 86: package Apache::lonnet; 87: 88: use strict; 89: use Apache::File; 90: use LWP::UserAgent(); 91: use HTTP::Headers; 92: use vars 93: qw(%perlvar %hostname %homecache %spareid %hostdom %libserv %pr %prp %fe %fd $readit %metacache); 94: use IO::Socket; 95: use GDBM_File; 96: use Apache::Constants qw(:common :http); 97: use HTML::TokeParser; 98: 99: # --------------------------------------------------------------------- Logging 100: 101: sub logthis { 102: my $message=shift; 103: my $execdir=$perlvar{'lonDaemons'}; 104: my $now=time; 105: my $local=localtime($now); 106: my $fh=Apache::File->new(">>$execdir/logs/lonnet.log"); 107: print $fh "$local ($$): $message\n"; 108: return 1; 109: } 110: 111: sub logperm { 112: my $message=shift; 113: my $execdir=$perlvar{'lonDaemons'}; 114: my $now=time; 115: my $local=localtime($now); 116: my $fh=Apache::File->new(">>$execdir/logs/lonnet.perm.log"); 117: print $fh "$now:$message:$local\n"; 118: return 1; 119: } 120: 121: # -------------------------------------------------- Non-critical communication 122: sub subreply { 123: my ($cmd,$server)=@_; 124: my $peerfile="$perlvar{'lonSockDir'}/$server"; 125: my $client=IO::Socket::UNIX->new(Peer =>"$peerfile", 126: Type => SOCK_STREAM, 127: Timeout => 10) 128: or return "con_lost"; 129: print $client "$cmd\n"; 130: my $answer=<$client>; 131: if (!$answer) { $answer="con_lost"; } 132: chomp($answer); 133: return $answer; 134: } 135: 136: sub reply { 137: my ($cmd,$server)=@_; 138: my $answer=subreply($cmd,$server); 139: if ($answer eq 'con_lost') { $answer=subreply($cmd,$server); } 140: if (($answer=~/^refused/) || ($answer=~/^rejected/)) { 141: &logthis("<font color=blue>WARNING:". 142: " $cmd to $server returned $answer</font>"); 143: } 144: return $answer; 145: } 146: 147: # ----------------------------------------------------------- Send USR1 to lonc 148: 149: sub reconlonc { 150: my $peerfile=shift; 151: &logthis("Trying to reconnect for $peerfile"); 152: my $loncfile="$perlvar{'lonDaemons'}/logs/lonc.pid"; 153: if (my $fh=Apache::File->new("$loncfile")) { 154: my $loncpid=<$fh>; 155: chomp($loncpid); 156: if (kill 0 => $loncpid) { 157: &logthis("lonc at pid $loncpid responding, sending USR1"); 158: kill USR1 => $loncpid; 159: sleep 1; 160: if (-e "$peerfile") { return; } 161: &logthis("$peerfile still not there, give it another try"); 162: sleep 5; 163: if (-e "$peerfile") { return; } 164: &logthis( 165: "<font color=blue>WARNING: $peerfile still not there, giving up</font>"); 166: } else { 167: &logthis( 168: "<font color=blue>WARNING:". 169: " lonc at pid $loncpid not responding, giving up</font>"); 170: } 171: } else { 172: &logthis('<font color=blue>WARNING: lonc not running, giving up</font>'); 173: } 174: } 175: 176: # ------------------------------------------------------ Critical communication 177: 178: sub critical { 179: my ($cmd,$server)=@_; 180: my $answer=reply($cmd,$server); 181: if ($answer eq 'con_lost') { 182: my $pingreply=reply('ping',$server); 183: &reconlonc("$perlvar{'lonSockDir'}/$server"); 184: my $pongreply=reply('pong',$server); 185: &logthis("Ping/Pong for $server: $pingreply/$pongreply"); 186: $answer=reply($cmd,$server); 187: if ($answer eq 'con_lost') { 188: my $now=time; 189: my $middlename=$cmd; 190: $middlename=substr($middlename,0,16); 191: $middlename=~s/\W//g; 192: my $dfilename= 193: "$perlvar{'lonSockDir'}/delayed/$now.$middlename.$server"; 194: { 195: my $dfh; 196: if ($dfh=Apache::File->new(">$dfilename")) { 197: print $dfh "$cmd\n"; 198: } 199: } 200: sleep 2; 201: my $wcmd=''; 202: { 203: my $dfh; 204: if ($dfh=Apache::File->new("$dfilename")) { 205: $wcmd=<$dfh>; 206: } 207: } 208: chomp($wcmd); 209: if ($wcmd eq $cmd) { 210: &logthis("<font color=blue>WARNING: ". 211: "Connection buffer $dfilename: $cmd</font>"); 212: &logperm("D:$server:$cmd"); 213: return 'con_delayed'; 214: } else { 215: &logthis("<font color=red>CRITICAL:" 216: ." Critical connection failed: $server $cmd</font>"); 217: &logperm("F:$server:$cmd"); 218: return 'con_failed'; 219: } 220: } 221: } 222: return $answer; 223: } 224: 225: # ---------------------------------------------------------- Append Environment 226: 227: sub appenv { 228: my %newenv=@_; 229: map { 230: if (($newenv{$_}=~/^user\.role/) || ($newenv{$_}=~/^user\.priv/)) { 231: &logthis("<font color=blue>WARNING: ". 232: "Attempt to modify environment ".$_." to ".$newenv{$_}); 233: delete($newenv{$_}); 234: } else { 235: $ENV{$_}=$newenv{$_}; 236: } 237: } keys %newenv; 238: my @oldenv; 239: { 240: my $fh; 241: unless ($fh=Apache::File->new("$ENV{'user.environment'}")) { 242: return 'error'; 243: } 244: @oldenv=<$fh>; 245: } 246: for (my $i=0; $i<=$#oldenv; $i++) { 247: chomp($oldenv[$i]); 248: if ($oldenv[$i] ne '') { 249: my ($name,$value)=split(/=/,$oldenv[$i]); 250: unless (defined($newenv{$name})) { 251: $newenv{$name}=$value; 252: } 253: } 254: } 255: { 256: my $fh; 257: unless ($fh=Apache::File->new(">$ENV{'user.environment'}")) { 258: return 'error'; 259: } 260: my $newname; 261: foreach $newname (keys %newenv) { 262: print $fh "$newname=$newenv{$newname}\n"; 263: } 264: } 265: return 'ok'; 266: } 267: # ----------------------------------------------------- Delete from Environment 268: 269: sub delenv { 270: my $delthis=shift; 271: my %newenv=(); 272: if (($delthis=~/user\.role/) || ($delthis=~/user\.priv/)) { 273: &logthis("<font color=blue>WARNING: ". 274: "Attempt to delete from environment ".$delthis); 275: return 'error'; 276: } 277: my @oldenv; 278: { 279: my $fh; 280: unless ($fh=Apache::File->new("$ENV{'user.environment'}")) { 281: return 'error'; 282: } 283: @oldenv=<$fh>; 284: } 285: { 286: my $fh; 287: unless ($fh=Apache::File->new(">$ENV{'user.environment'}")) { 288: return 'error'; 289: } 290: map { 291: unless ($_=~/^$delthis/) { print $fh $_; } 292: } @oldenv; 293: } 294: return 'ok'; 295: } 296: 297: # ------------------------------ Find server with least workload from spare.tab 298: 299: sub spareserver { 300: my $tryserver; 301: my $spareserver=''; 302: my $lowestserver=100; 303: foreach $tryserver (keys %spareid) { 304: my $answer=reply('load',$tryserver); 305: if (($answer =~ /\d/) && ($answer<$lowestserver)) { 306: $spareserver="http://$hostname{$tryserver}"; 307: $lowestserver=$answer; 308: } 309: } 310: return $spareserver; 311: } 312: 313: # --------- Try to authenticate user from domain's lib servers (first this one) 314: 315: sub authenticate { 316: my ($uname,$upass,$udom)=@_; 317: $upass=escape($upass); 318: if (($perlvar{'lonRole'} eq 'library') && 319: ($udom eq $perlvar{'lonDefDomain'})) { 320: my $answer=reply("encrypt:auth:$udom:$uname:$upass",$perlvar{'lonHostID'}); 321: if ($answer =~ /authorized/) { 322: if ($answer eq 'authorized') { 323: &logthis("User $uname at $udom authorized by local server"); 324: return $perlvar{'lonHostID'}; 325: } 326: if ($answer eq 'non_authorized') { 327: &logthis("User $uname at $udom rejected by local server"); 328: return 'no_host'; 329: } 330: } 331: } 332: 333: my $tryserver; 334: foreach $tryserver (keys %libserv) { 335: if ($hostdom{$tryserver} eq $udom) { 336: my $answer=reply("encrypt:auth:$udom:$uname:$upass",$tryserver); 337: if ($answer =~ /authorized/) { 338: if ($answer eq 'authorized') { 339: &logthis("User $uname at $udom authorized by $tryserver"); 340: return $tryserver; 341: } 342: if ($answer eq 'non_authorized') { 343: &logthis("User $uname at $udom rejected by $tryserver"); 344: return 'no_host'; 345: } 346: } 347: } 348: } 349: &logthis("User $uname at $udom could not be authenticated"); 350: return 'no_host'; 351: } 352: 353: # ---------------------- Find the homebase for a user from domain's lib servers 354: 355: sub homeserver { 356: my ($uname,$udom)=@_; 357: 358: my $index="$uname:$udom"; 359: if ($homecache{$index}) { return "$homecache{$index}"; } 360: 361: my $tryserver; 362: foreach $tryserver (keys %libserv) { 363: if ($hostdom{$tryserver} eq $udom) { 364: my $answer=reply("home:$udom:$uname",$tryserver); 365: if ($answer eq 'found') { 366: $homecache{$index}=$tryserver; 367: return $tryserver; 368: } 369: } 370: } 371: return 'no_host'; 372: } 373: 374: # ------------------------------------- Find the usernames behind a list of IDs 375: 376: sub idget { 377: my ($udom,@ids)=@_; 378: my %returnhash=(); 379: 380: my $tryserver; 381: foreach $tryserver (keys %libserv) { 382: if ($hostdom{$tryserver} eq $udom) { 383: my $idlist=join('&',@ids); 384: $idlist=~tr/A-Z/a-z/; 385: my $reply=&reply("idget:$udom:".$idlist,$tryserver); 386: my @answer=(); 387: if (($reply ne 'con_lost') && ($reply!~/^error\:/)) { 388: @answer=split(/\&/,$reply); 389: } ; 390: my $i; 391: for ($i=0;$i<=$#ids;$i++) { 392: if ($answer[$i]) { 393: $returnhash{$ids[$i]}=$answer[$i]; 394: } 395: } 396: } 397: } 398: return %returnhash; 399: } 400: 401: # ------------------------------------- Find the IDs behind a list of usernames 402: 403: sub idrget { 404: my ($udom,@unames)=@_; 405: my %returnhash=(); 406: map { 407: $returnhash{$_}=(&userenvironment($udom,$_,'id'))[1]; 408: } @unames; 409: return %returnhash; 410: } 411: 412: # ------------------------------- Store away a list of names and associated IDs 413: 414: sub idput { 415: my ($udom,%ids)=@_; 416: my %servers=(); 417: map { 418: my $uhom=&homeserver($_,$udom); 419: if ($uhom ne 'no_host') { 420: my $id=&escape($ids{$_}); 421: $id=~tr/A-Z/a-z/; 422: my $unam=&escape($_); 423: if ($servers{$uhom}) { 424: $servers{$uhom}.='&'.$id.'='.$unam; 425: } else { 426: $servers{$uhom}=$id.'='.$unam; 427: } 428: &critical('put:'.$udom.':'.$unam.':environment:id='.$id,$uhom); 429: } 430: } keys %ids; 431: map { 432: &critical('idput:'.$udom.':'.$servers{$_},$_); 433: } keys %servers; 434: } 435: 436: # ------------------------------------- Find the section of student in a course 437: 438: sub usection { 439: my ($udom,$unam,$courseid)=@_; 440: $courseid=~s/\_/\//g; 441: $courseid=~s/^(\w)/\/$1/; 442: map { 443: my ($key,$value)=split(/\=/,$_); 444: $key=&unescape($key); 445: if ($key=~/^$courseid(?:\/)*(\w+)*\_st$/) { 446: my $section=$1; 447: if ($key eq $courseid.'_st') { $section=''; } 448: my ($dummy,$end,$start)=split(/\_/,&unescape($value)); 449: my $now=time; 450: my $notactive=0; 451: if ($start) { 452: if ($now<$start) { $notactive=1; } 453: } 454: if ($end) { 455: if ($now>$end) { $notactive=1; } 456: } 457: unless ($notactive) { return $section; } 458: } 459: } split(/\&/,&reply('dump:'.$udom.':'.$unam.':roles', 460: &homeserver($unam,$udom))); 461: return '-1'; 462: } 463: 464: # ------------------------------------- Read an entry from a user's environment 465: 466: sub userenvironment { 467: my ($udom,$unam,@what)=@_; 468: my %returnhash=(); 469: my @answer=split(/\&/, 470: &reply('get:'.$udom.':'.$unam.':environment:'.join('&',@what), 471: &homeserver($unam,$udom))); 472: my $i; 473: for ($i=0;$i<=$#what;$i++) { 474: $returnhash{$what[$i]}=&unescape($answer[$i]); 475: } 476: return %returnhash; 477: } 478: 479: # ----------------------------- Subscribe to a resource, return URL if possible 480: 481: sub subscribe { 482: my $fname=shift; 483: my $author=$fname; 484: $author=~s/\/home\/httpd\/html\/res\/([^\/]*)\/([^\/]*).*/$1\/$2/; 485: my ($udom,$uname)=split(/\//,$author); 486: my $home=homeserver($uname,$udom); 487: if (($home eq 'no_host') || ($home eq $perlvar{'lonHostID'})) { 488: return 'not_found'; 489: } 490: my $answer=reply("sub:$fname",$home); 491: if (($answer eq 'con_lost') || ($answer eq 'rejected')) { 492: $answer.=' by '.$home; 493: } 494: return $answer; 495: } 496: 497: # -------------------------------------------------------------- Replicate file 498: 499: sub repcopy { 500: my $filename=shift; 501: $filename=~s/\/+/\//g; 502: my $transname="$filename.in.transfer"; 503: if ((-e $filename) || (-e $transname)) { return OK; } 504: my $remoteurl=subscribe($filename); 505: if ($remoteurl =~ /^con_lost by/) { 506: &logthis("Subscribe returned $remoteurl: $filename"); 507: return HTTP_SERVICE_UNAVAILABLE; 508: } elsif ($remoteurl eq 'not_found') { 509: &logthis("Subscribe returned not_found: $filename"); 510: return HTTP_NOT_FOUND; 511: } elsif ($remoteurl =~ /^rejected by/) { 512: &logthis("Subscribe returned $remoteurl: $filename"); 513: return FORBIDDEN; 514: } elsif ($remoteurl eq 'directory') { 515: return OK; 516: } else { 517: my @parts=split(/\//,$filename); 518: my $path="/$parts[1]/$parts[2]/$parts[3]/$parts[4]"; 519: if ($path ne "$perlvar{'lonDocRoot'}/res") { 520: &logthis("Malconfiguration for replication: $filename"); 521: return HTTP_BAD_REQUEST; 522: } 523: my $count; 524: for ($count=5;$count<$#parts;$count++) { 525: $path.="/$parts[$count]"; 526: if ((-e $path)!=1) { 527: mkdir($path,0777); 528: } 529: } 530: my $ua=new LWP::UserAgent; 531: my $request=new HTTP::Request('GET',"$remoteurl"); 532: my $response=$ua->request($request,$transname); 533: if ($response->is_error()) { 534: unlink($transname); 535: my $message=$response->status_line; 536: &logthis("<font color=blue>WARNING:" 537: ." LWP get: $message: $filename</font>"); 538: return HTTP_SERVICE_UNAVAILABLE; 539: } else { 540: if ($remoteurl!~/\.meta$/) { 541: my $mrequest=new HTTP::Request('GET',$remoteurl.'.meta'); 542: my $mresponse=$ua->request($mrequest,$filename.'.meta'); 543: if ($mresponse->is_error()) { 544: unlink($filename.'.meta'); 545: &logthis( 546: "<font color=yellow>INFO: No metadata: $filename</font>"); 547: } 548: } 549: rename($transname,$filename); 550: return OK; 551: } 552: } 553: } 554: 555: # --------------------------------------------------------- Server Side Include 556: 557: sub ssi { 558: 559: my ($fn,%form)=@_; 560: 561: my $ua=new LWP::UserAgent; 562: 563: my $request; 564: 565: if (%form) { 566: $request=new HTTP::Request('POST',"http://".$ENV{'HTTP_HOST'}.$fn); 567: $request->content(join '&', map { "$_=$form{$_}" } keys %form); 568: } else { 569: $request=new HTTP::Request('GET',"http://".$ENV{'HTTP_HOST'}.$fn); 570: } 571: 572: $request->header(Cookie => $ENV{'HTTP_COOKIE'}); 573: my $response=$ua->request($request); 574: 575: return $response->content; 576: } 577: 578: # ------------------------------------------------------------------------- Log 579: 580: sub log { 581: my ($dom,$nam,$hom,$what)=@_; 582: return critical("log:$dom:$nam:$what",$hom); 583: } 584: 585: # ----------------------------------------------------------------------- Store 586: 587: sub store { 588: my %storehash=@_; 589: my $symb; 590: unless ($symb=escape(&symbread())) { return ''; } 591: my $namespace; 592: unless ($namespace=$ENV{'request.course.id'}) { return ''; } 593: my $namevalue=''; 594: map { 595: $namevalue.=escape($_).'='.escape($storehash{$_}).'&'; 596: } keys %storehash; 597: $namevalue=~s/\&$//; 598: return reply( 599: "store:$ENV{'user.domain'}:$ENV{'user.name'}:$namespace:$symb:$namevalue", 600: "$ENV{'user.home'}"); 601: } 602: 603: # -------------------------------------------------------------- Critical Store 604: 605: sub cstore { 606: my %storehash=@_; 607: my $symb; 608: unless ($symb=escape(&symbread())) { return ''; } 609: my $namespace; 610: unless ($namespace=$ENV{'request.course.id'}) { return ''; } 611: my $namevalue=''; 612: map { 613: $namevalue.=escape($_).'='.escape($storehash{$_}).'&'; 614: } keys %storehash; 615: $namevalue=~s/\&$//; 616: return critical( 617: "store:$ENV{'user.domain'}:$ENV{'user.name'}:$namespace:$symb:$namevalue", 618: "$ENV{'user.home'}"); 619: } 620: 621: # --------------------------------------------------------------------- Restore 622: 623: sub restore { 624: my $symb; 625: unless ($symb=escape(&symbread())) { return ''; } 626: my $namespace; 627: unless ($namespace=$ENV{'request.course.id'}) { return ''; } 628: my $answer=reply( 629: "restore:$ENV{'user.domain'}:$ENV{'user.name'}:$namespace:$symb", 630: "$ENV{'user.home'}"); 631: my %returnhash=(); 632: map { 633: my ($name,$value)=split(/\=/,$_); 634: $returnhash{&unescape($name)}=&unescape($value); 635: } split(/\&/,$answer); 636: my $version; 637: for ($version=1;$version<=$returnhash{'version'};$version++) { 638: map { 639: $returnhash{$_}=$returnhash{$version.':'.$_}; 640: } split(/\:/,$returnhash{$version.':keys'}); 641: } 642: return %returnhash; 643: } 644: 645: # ---------------------------------------------------------- Course Description 646: 647: sub coursedescription { 648: my $courseid=shift; 649: $courseid=~s/^\///; 650: $courseid=~s/\_/\//g; 651: my ($cdomain,$cnum)=split(/\//,$courseid); 652: my $chome=homeserver($cnum,$cdomain); 653: if ($chome ne 'no_host') { 654: my $rep=reply("dump:$cdomain:$cnum:environment",$chome); 655: if ($rep ne 'con_lost') { 656: my $normalid=$courseid; 657: $normalid=~s/\//\_/g; 658: my %envhash=(); 659: my %returnhash=('home' => $chome, 660: 'domain' => $cdomain, 661: 'num' => $cnum); 662: map { 663: my ($name,$value)=split(/\=/,$_); 664: $name=&unescape($name); 665: $value=&unescape($value); 666: $returnhash{$name}=$value; 667: $envhash{'course.'.$normalid.'.'.$name}=$value; 668: } split(/\&/,$rep); 669: $returnhash{'url'}='/res/'.declutter($returnhash{'url'}); 670: $returnhash{'fn'}=$perlvar{'lonDaemons'}.'/tmp/'. 671: $ENV{'user.name'}.'_'.$cdomain.'_'.$cnum; 672: $envhash{'course.'.$normalid.'.last_cache'}=time; 673: $envhash{'course.'.$normalid.'.home'}=$chome; 674: $envhash{'course.'.$normalid.'.domain'}=$cdomain; 675: $envhash{'course.'.$normalid.'.num'}=$cnum; 676: &appenv(%envhash); 677: return %returnhash; 678: } 679: } 680: return (); 681: } 682: 683: # -------------------------------------------------------- Get user priviledges 684: 685: sub rolesinit { 686: my ($domain,$username,$authhost)=@_; 687: my $rolesdump=reply("dump:$domain:$username:roles",$authhost); 688: if (($rolesdump eq 'con_lost') || ($rolesdump eq '')) { return ''; } 689: my %allroles=(); 690: my %thesepriv=(); 691: my $now=time; 692: my $userroles="user.login.time=$now\n"; 693: my $thesestr; 694: 695: if ($rolesdump ne '') { 696: map { 697: if ($_!~/^rolesdef\&/) { 698: my ($area,$role)=split(/=/,$_); 699: $area=~s/\_\w\w$//; 700: my ($trole,$tend,$tstart)=split(/_/,$role); 701: $userroles.='user.role.'.$trole.'.'.$area.'='. 702: $tstart.'.'.$tend."\n"; 703: if ($tend!=0) { 704: if ($tend<$now) { 705: $trole=''; 706: } 707: } 708: if ($tstart!=0) { 709: if ($tstart>$now) { 710: $trole=''; 711: } 712: } 713: if (($area ne '') && ($trole ne '')) { 714: my $spec=$trole.'.'.$area; 715: my ($tdummy,$tdomain,$trest)=split(/\//,$area); 716: if ($trole =~ /^cr\//) { 717: my ($rdummy,$rdomain,$rauthor,$rrole)=split(/\//,$trole); 718: my $homsvr=homeserver($rauthor,$rdomain); 719: if ($hostname{$homsvr} ne '') { 720: my $roledef= 721: reply("get:$rdomain:$rauthor:roles:rolesdef_$rrole", 722: $homsvr); 723: if (($roledef ne 'con_lost') && ($roledef ne '')) { 724: my ($syspriv,$dompriv,$coursepriv)= 725: split(/\_/,unescape($roledef)); 726: $allroles{'cm./'}.=':'.$syspriv; 727: $allroles{$spec.'./'}.=':'.$syspriv; 728: if ($tdomain ne '') { 729: $allroles{'cm./'.$tdomain.'/'}.=':'.$dompriv; 730: $allroles{$spec.'./'.$tdomain.'/'}.=':'.$dompriv; 731: if ($trest ne '') { 732: $allroles{'cm.'.$area}.=':'.$coursepriv; 733: $allroles{$spec.'.'.$area}.=':'.$coursepriv; 734: } 735: } 736: } 737: } 738: } else { 739: $allroles{'cm./'}.=':'.$pr{$trole.':s'}; 740: $allroles{$spec.'./'}.=':'.$pr{$trole.':s'}; 741: if ($tdomain ne '') { 742: $allroles{'cm./'.$tdomain.'/'}.=':'.$pr{$trole.':d'}; 743: $allroles{$spec.'./'.$tdomain.'/'}.=':'.$pr{$trole.':d'}; 744: if ($trest ne '') { 745: $allroles{'cm.'.$area}.=':'.$pr{$trole.':c'}; 746: $allroles{$spec.'.'.$area}.=':'.$pr{$trole.':c'}; 747: } 748: } 749: } 750: } 751: } 752: } split(/&/,$rolesdump); 753: map { 754: %thesepriv=(); 755: map { 756: if ($_ ne '') { 757: my ($priviledge,$restrictions)=split(/&/,$_); 758: if ($restrictions eq '') { 759: $thesepriv{$priviledge}='F'; 760: } else { 761: if ($thesepriv{$priviledge} ne 'F') { 762: $thesepriv{$priviledge}.=$restrictions; 763: } 764: } 765: } 766: } split(/:/,$allroles{$_}); 767: $thesestr=''; 768: map { $thesestr.=':'.$_.'&'.$thesepriv{$_}; } keys %thesepriv; 769: $userroles.='user.priv.'.$_.'='.$thesestr."\n"; 770: } keys %allroles; 771: } 772: return $userroles; 773: } 774: 775: # --------------------------------------------------------------- get interface 776: 777: sub get { 778: my ($namespace,@storearr)=@_; 779: my $items=''; 780: map { 781: $items.=escape($_).'&'; 782: } @storearr; 783: $items=~s/\&$//; 784: my $rep=reply("get:$ENV{'user.domain'}:$ENV{'user.name'}:$namespace:$items", 785: $ENV{'user.home'}); 786: my @pairs=split(/\&/,$rep); 787: my %returnhash=(); 788: my $i=0; 789: map { 790: $returnhash{$_}=unescape($pairs[$i]); 791: $i++; 792: } @storearr; 793: return %returnhash; 794: } 795: 796: # --------------------------------------------------------------- del interface 797: 798: sub del { 799: my ($namespace,@storearr)=@_; 800: my $items=''; 801: map { 802: $items.=escape($_).'&'; 803: } @storearr; 804: $items=~s/\&$//; 805: return reply("del:$ENV{'user.domain'}:$ENV{'user.name'}:$namespace:$items", 806: $ENV{'user.home'}); 807: } 808: 809: # -------------------------------------------------------------- dump interface 810: 811: sub dump { 812: my $namespace=shift; 813: my $rep=reply("dump:$ENV{'user.domain'}:$ENV{'user.name'}:$namespace", 814: $ENV{'user.home'}); 815: my @pairs=split(/\&/,$rep); 816: my %returnhash=(); 817: map { 818: my ($key,$value)=split(/=/,$_); 819: $returnhash{unescape($key)}=unescape($value); 820: } @pairs; 821: return %returnhash; 822: } 823: 824: # --------------------------------------------------------------- put interface 825: 826: sub put { 827: my ($namespace,%storehash)=@_; 828: my $items=''; 829: map { 830: $items.=escape($_).'='.escape($storehash{$_}).'&'; 831: } keys %storehash; 832: $items=~s/\&$//; 833: return reply("put:$ENV{'user.domain'}:$ENV{'user.name'}:$namespace:$items", 834: $ENV{'user.home'}); 835: } 836: 837: # ------------------------------------------------------ critical put interface 838: 839: sub cput { 840: my ($namespace,%storehash)=@_; 841: my $items=''; 842: map { 843: $items.=escape($_).'='.escape($storehash{$_}).'&'; 844: } keys %storehash; 845: $items=~s/\&$//; 846: return critical 847: ("put:$ENV{'user.domain'}:$ENV{'user.name'}:$namespace:$items", 848: $ENV{'user.home'}); 849: } 850: 851: # -------------------------------------------------------------- eget interface 852: 853: sub eget { 854: my ($namespace,@storearr)=@_; 855: my $items=''; 856: map { 857: $items.=escape($_).'&'; 858: } @storearr; 859: $items=~s/\&$//; 860: my $rep=reply("eget:$ENV{'user.domain'}:$ENV{'user.name'}:$namespace:$items", 861: $ENV{'user.home'}); 862: my @pairs=split(/\&/,$rep); 863: my %returnhash=(); 864: my $i=0; 865: map { 866: $returnhash{$_}=unescape($pairs[$i]); 867: $i++; 868: } @storearr; 869: return %returnhash; 870: } 871: 872: # ------------------------------------------------- Check for a user priviledge 873: 874: sub allowed { 875: my ($priv,$uri)=@_; 876: $uri=&declutter($uri); 877: 878: # Free bre access to adm and meta resources 879: 880: if ((($uri=~/^adm\//) || ($uri=~/\.meta$/)) && ($priv eq 'bre')) { 881: return 'F'; 882: } 883: 884: my $thisallowed=''; 885: my $statecond=0; 886: my $courseprivid=''; 887: 888: # Course 889: 890: if ($ENV{'user.priv.'.$ENV{'request.role'}.'./'}=~/$priv\&([^\:]*)/) { 891: $thisallowed.=$1; 892: } 893: 894: # Domain 895: 896: if ($ENV{'user.priv.'.$ENV{'request.role'}.'./'.(split(/\//,$uri))[0].'/'} 897: =~/$priv\&([^\:]*)/) { 898: $thisallowed.=$1; 899: } 900: 901: # Course: uri itself is a course 902: my $courseuri=$uri; 903: $courseuri=~s/\_(\d)/\/$1/; 904: if ($ENV{'user.priv.'.$ENV{'request.role'}.'./'.$courseuri} 905: =~/$priv\&([^\:]*)/) { 906: $thisallowed.=$1; 907: } 908: 909: # Full access at system, domain or course-wide level? Exit. 910: 911: if ($thisallowed=~/F/) { 912: return 'F'; 913: } 914: 915: # If this is generating or modifying users, exit with special codes 916: 917: if (':csu:cdc:ccc:cin:cta:cep:ccr:cst:cad:cli:cau:cdg:'=~/\:$priv\:/) { 918: return $thisallowed; 919: } 920: # 921: # Gathered so far: system, domain and course wide priviledges 922: # 923: # Course: See if uri or referer is an individual resource that is part of 924: # the course 925: 926: if ($ENV{'request.course.id'}) { 927: $courseprivid=$ENV{'request.course.id'}; 928: if ($ENV{'request.course.sec'}) { 929: $courseprivid.='/'.$ENV{'request.course.sec'}; 930: } 931: $courseprivid=~s/\_/\//; 932: my $checkreferer=1; 933: my @uriparts=split(/\//,$uri); 934: my $filename=$uriparts[$#uriparts]; 935: my $pathname=$uri; 936: $pathname=~s/\/$filename$//; 937: if ($ENV{'acc.res.'.$ENV{'request.course.id'}.'.'.$pathname}=~ 938: /\&$filename\:([\d\|]+)\&/) { 939: $statecond=$1; 940: if ($ENV{'user.priv.'.$ENV{'request.role'}.'./'.$courseprivid} 941: =~/$priv\&([^\:]*)/) { 942: $thisallowed.=$1; 943: $checkreferer=0; 944: } 945: } 946: 947: if (($ENV{'HTTP_REFERER'}) && ($checkreferer)) { 948: my $refuri=$ENV{'HTTP_REFERER'}; 949: $refuri=~s/^http\:\/\/$ENV{'request.host'}//i; 950: $refuri=&declutter($refuri); 951: my @uriparts=split(/\//,$refuri); 952: my $filename=$uriparts[$#uriparts]; 953: my $pathname=$refuri; 954: $pathname=~s/\/$filename$//; 955: my @filenameparts=split(/\./,$uri); 956: if (&fileembstyle($filenameparts[$#filenameparts]) ne 'ssi') { 957: if ($ENV{'acc.res.'.$ENV{'request.course.id'}.'.'.$pathname}=~ 958: /\&$filename\:([\d\|]+)\&/) { 959: my $refstatecond=$1; 960: if ($ENV{'user.priv.'.$ENV{'request.role'}.'./'.$courseprivid} 961: =~/$priv\&([^\:]*)/) { 962: $thisallowed.=$1; 963: $uri=$refuri; 964: $statecond=$refstatecond; 965: } 966: } 967: } 968: } 969: } 970: 971: # 972: # Gathered now: all priviledges that could apply, and condition number 973: # 974: # 975: # Full or no access? 976: # 977: 978: if ($thisallowed=~/F/) { 979: return 'F'; 980: } 981: 982: unless ($thisallowed) { 983: return ''; 984: } 985: 986: # Restrictions exist, deal with them 987: # 988: # C:according to course preferences 989: # R:according to resource settings 990: # L:unless locked 991: # X:according to user session state 992: # 993: 994: # Possibly locked functionality, check all courses 995: # Locks might take effect only after 10 minutes cache expiration for other 996: # courses, and 2 minutes for current course 997: 998: my $envkey; 999: if ($thisallowed=~/L/) { 1000: foreach $envkey (keys %ENV) { 1001: if ($envkey=~/^user\.role\.(st|ta)\.([^\.]*)/) { 1002: my $courseid=$2; 1003: my $roleid=$1.'.'.$2; 1004: my $expiretime=600; 1005: if ($ENV{'request.role'} eq $roleid) { 1006: $expiretime=120; 1007: } 1008: my ($cdom,$cnum,$csec)=split(/\//,$courseid); 1009: my $prefix='course.'.$cdom.'_'.$cnum.'.'; 1010: if ((time-$ENV{$prefix.'last_cache'})>$expiretime) { 1011: &coursedescription($courseid); 1012: } 1013: if (($ENV{$prefix.'res.'.$uri.'.lock.sections'}=~/\,$csec\,/) 1014: || ($ENV{$prefix.'res.'.$uri.'.lock.sections'} eq 'all')) { 1015: if ($ENV{$prefix.'res.'.$uri.'.lock.expire'}>time) { 1016: &log($ENV{'user.domain'},$ENV{'user.name'}, 1017: $ENV{'user.host'}, 1018: 'Locked by res: '.$priv.' for '.$uri.' due to '. 1019: $cdom.'/'.$cnum.'/'.$csec.' expire '. 1020: $ENV{$prefix.'priv.'.$priv.'.lock.expire'}); 1021: return ''; 1022: } 1023: } 1024: if (($ENV{$prefix.'priv.'.$priv.'.lock.sections'}=~/\,$csec\,/) 1025: || ($ENV{$prefix.'priv.'.$priv.'.lock.sections'} eq 'all')) { 1026: if ($ENV{'priv.'.$priv.'.lock.expire'}>time) { 1027: &log($ENV{'user.domain'},$ENV{'user.name'}, 1028: $ENV{'user.host'}, 1029: 'Locked by priv: '.$priv.' for '.$uri.' due to '. 1030: $cdom.'/'.$cnum.'/'.$csec.' expire '. 1031: $ENV{$prefix.'priv.'.$priv.'.lock.expire'}); 1032: return ''; 1033: } 1034: } 1035: } 1036: } 1037: } 1038: 1039: # 1040: # Rest of the restrictions depend on selected course 1041: # 1042: 1043: unless ($ENV{'request.course.id'}) { 1044: return '1'; 1045: } 1046: 1047: # 1048: # Now user is definitely in a course 1049: # 1050: 1051: 1052: # Course preferences 1053: 1054: if ($thisallowed=~/C/) { 1055: my $rolecode=(split(/\./,$ENV{'request.role'}))[0]; 1056: if ($ENV{'course.'.$ENV{'request.course.id'}.'.'.$priv.'.roles.denied'} 1057: =~/\,$rolecode\,/) { 1058: &log($ENV{'user.domain'},$ENV{'user.name'},$ENV{'user.host'}, 1059: 'Denied by role: '.$priv.' for '.$uri.' as '.$rolecode.' in '. 1060: $ENV{'request.course.id'}); 1061: return ''; 1062: } 1063: } 1064: 1065: # Resource preferences 1066: 1067: if ($thisallowed=~/R/) { 1068: my $rolecode=(split(/\./,$ENV{'request.role'}))[0]; 1069: my $filename=$perlvar{'lonDocRoot'}.'/res/'.$uri.'.meta'; 1070: if (-e $filename) { 1071: my @content; 1072: { 1073: my $fh=Apache::File->new($filename); 1074: @content=<$fh>; 1075: } 1076: if (join('',@content)=~ 1077: /\<roledeny[^\>]*\>[^\<]*$rolecode[^\<]*\<\/roledeny\>/) { 1078: &log($ENV{'user.domain'},$ENV{'user.name'},$ENV{'user.host'}, 1079: 'Denied by role: '.$priv.' for '.$uri.' as '.$rolecode); 1080: return ''; 1081: 1082: } 1083: } 1084: } 1085: 1086: # Restricted by state? 1087: 1088: if ($thisallowed=~/X/) { 1089: if (&condval($statecond)) { 1090: return '2'; 1091: } else { 1092: return ''; 1093: } 1094: } 1095: 1096: return 'F'; 1097: } 1098: 1099: # ----------------------------------------------------------------- Define Role 1100: 1101: sub definerole { 1102: if (allowed('mcr','/')) { 1103: my ($rolename,$sysrole,$domrole,$courole)=@_; 1104: map { 1105: my ($crole,$cqual)=split(/\&/,$_); 1106: if ($pr{'cr:s'}!~/$crole/) { return "refused:s:$crole"; } 1107: if ($pr{'cr:s'}=~/$crole\&/) { 1108: if ($pr{'cr:s'}!~/$crole\&\w*$cqual/) { 1109: return "refused:s:$crole&$cqual"; 1110: } 1111: } 1112: } split('/',$sysrole); 1113: map { 1114: my ($crole,$cqual)=split(/\&/,$_); 1115: if ($pr{'cr:d'}!~/$crole/) { return "refused:d:$crole"; } 1116: if ($pr{'cr:d'}=~/$crole\&/) { 1117: if ($pr{'cr:d'}!~/$crole\&\w*$cqual/) { 1118: return "refused:d:$crole&$cqual"; 1119: } 1120: } 1121: } split('/',$domrole); 1122: map { 1123: my ($crole,$cqual)=split(/\&/,$_); 1124: if ($pr{'cr:c'}!~/$crole/) { return "refused:c:$crole"; } 1125: if ($pr{'cr:c'}=~/$crole\&/) { 1126: if ($pr{'cr:c'}!~/$crole\&\w*$cqual/) { 1127: return "refused:c:$crole&$cqual"; 1128: } 1129: } 1130: } split('/',$courole); 1131: my $command="encrypt:rolesput:$ENV{'user.domain'}:$ENV{'user.name'}:". 1132: "$ENV{'user.domain'}:$ENV{'user.name'}:". 1133: "rolesdef_$rolename=". 1134: escape($sysrole.'_'.$domrole.'_'.$courole); 1135: return reply($command,$ENV{'user.home'}); 1136: } else { 1137: return 'refused'; 1138: } 1139: } 1140: 1141: # ------------------------------------------------------------------ Plain Text 1142: 1143: sub plaintext { 1144: my $short=shift; 1145: return $prp{$short}; 1146: } 1147: 1148: # ------------------------------------------------------------------ Plain Text 1149: 1150: sub fileembstyle { 1151: my $ending=shift; 1152: return $fe{$ending}; 1153: } 1154: 1155: # ------------------------------------------------------------ Description Text 1156: 1157: sub filedescription { 1158: my $ending=shift; 1159: return $fd{$ending}; 1160: } 1161: 1162: # ----------------------------------------------------------------- Assign Role 1163: 1164: sub assignrole { 1165: my ($udom,$uname,$url,$role,$end,$start)=@_; 1166: my $mrole; 1167: $url=declutter($url); 1168: if ($role =~ /^cr\//) { 1169: unless ($url=~/\.course$/) { return 'invalid'; } 1170: unless (allowed('ccr',$url)) { return 'refused'; } 1171: $mrole='cr'; 1172: } else { 1173: unless (($url=~/\.course$/) || ($url=~/\/$/)) { return 'invalid'; } 1174: unless (allowed('c'+$role)) { return 'refused'; } 1175: $mrole=$role; 1176: } 1177: my $command="encrypt:rolesput:$ENV{'user.domain'}:$ENV{'user.name'}:". 1178: "$udom:$uname:$url".'_'."$mrole=$role"; 1179: if ($end) { $command.='_$end'; } 1180: if ($start) { 1181: if ($end) { 1182: $command.='_$start'; 1183: } else { 1184: $command.='_0_$start'; 1185: } 1186: } 1187: return &reply($command,&homeserver($uname,$udom)); 1188: } 1189: 1190: # ---------------------------------------------------------- Assign Custom Role 1191: 1192: sub assigncustomrole { 1193: my ($udom,$uname,$url,$rdom,$rnam,$rolename,$end,$start)=@_; 1194: return &assignrole($udom,$uname,$url,'cr/'.$rdom.'/'.$rnam.'/'.$rolename, 1195: $end,$start); 1196: } 1197: 1198: # ----------------------------------------------------------------- Revoke Role 1199: 1200: sub revokerole { 1201: my ($udom,$uname,$url,$role)=@_; 1202: my $now=time; 1203: return &assignrole($udom,$uname,$url,$role,$now); 1204: } 1205: 1206: # ---------------------------------------------------------- Revoke Custom Role 1207: 1208: sub revokecustomrole { 1209: my ($udom,$uname,$url,$rdom,$rnam,$rolename)=@_; 1210: my $now=time; 1211: return &assigncustomrole($udom,$uname,$url,$rdom,$rnam,$rolename,$now); 1212: } 1213: 1214: # ------------------------------------------------------------ Directory lister 1215: 1216: sub dirlist { 1217: my $uri=shift; 1218: $uri=~s/^\///; 1219: $uri=~s/\/$//; 1220: my ($res,$udom,$uname,@rest)=split(/\//,$uri); 1221: if ($udom) { 1222: if ($uname) { 1223: my $listing=reply('ls:'.$perlvar{'lonDocRoot'}.'/'.$uri, 1224: homeserver($uname,$udom)); 1225: return split(/:/,$listing); 1226: } else { 1227: my $tryserver; 1228: my %allusers=(); 1229: foreach $tryserver (keys %libserv) { 1230: if ($hostdom{$tryserver} eq $udom) { 1231: my $listing=reply('ls:'.$perlvar{'lonDocRoot'}.'/res/'.$udom, 1232: $tryserver); 1233: if (($listing ne 'no_such_dir') && ($listing ne 'empty') 1234: && ($listing ne 'con_lost')) { 1235: map { 1236: my ($entry,@stat)=split(/&/,$_); 1237: $allusers{$entry}=1; 1238: } split(/:/,$listing); 1239: } 1240: } 1241: } 1242: my $alluserstr=''; 1243: map { 1244: $alluserstr.=$_.'&user:'; 1245: } sort keys %allusers; 1246: $alluserstr=~s/:$//; 1247: return split(/:/,$alluserstr); 1248: } 1249: } else { 1250: my $tryserver; 1251: my %alldom=(); 1252: foreach $tryserver (keys %libserv) { 1253: $alldom{$hostdom{$tryserver}}=1; 1254: } 1255: my $alldomstr=''; 1256: map { 1257: $alldomstr.=$perlvar{'lonDocRoot'}.'/res/'.$_.'&domain:'; 1258: } sort keys %alldom; 1259: $alldomstr=~s/:$//; 1260: return split(/:/,$alldomstr); 1261: } 1262: } 1263: 1264: # -------------------------------------------------------- Value of a Condition 1265: 1266: sub directcondval { 1267: my $number=shift; 1268: if ($ENV{'user.state.'.$ENV{'request.course.id'}}) { 1269: return substr($ENV{'user.state.'.$ENV{'request.course.id'}},$number,1); 1270: } else { 1271: return 2; 1272: } 1273: } 1274: 1275: sub condval { 1276: my $condidx=shift; 1277: my $result=0; 1278: my $allpathcond=''; 1279: map { 1280: if (defined($ENV{'acc.cond.'.$ENV{'request.course.id'}.'.'.$_})) { 1281: $allpathcond.= 1282: '('.$ENV{'acc.cond.'.$ENV{'request.course.id'}.'.'.$_}.')|'; 1283: } 1284: } split(/\|/,$condidx); 1285: $allpathcond=~s/\|$//; 1286: if ($ENV{'request.course.id'}) { 1287: if ($allpathcond) { 1288: my $operand='|'; 1289: my @stack; 1290: map { 1291: if ($_ eq '(') { 1292: push @stack,($operand,$result) 1293: } elsif ($_ eq ')') { 1294: my $before=pop @stack; 1295: if (pop @stack eq '&') { 1296: $result=$result>$before?$before:$result; 1297: } else { 1298: $result=$result>$before?$result:$before; 1299: } 1300: } elsif (($_ eq '&') || ($_ eq '|')) { 1301: $operand=$_; 1302: } else { 1303: my $new=directcondval($_); 1304: if ($operand eq '&') { 1305: $result=$result>$new?$new:$result; 1306: } else { 1307: $result=$result>$new?$result:$new; 1308: } 1309: } 1310: } ($allpathcond=~/(\d+|\(|\)|\&|\|)/g); 1311: } 1312: } 1313: return $result; 1314: } 1315: 1316: # --------------------------------------------------------- Value of a Variable 1317: 1318: sub EXT { 1319: my $varname=shift; 1320: unless ($varname) { return ''; } 1321: my ($realm,$space,$qualifier,@therest)=split(/\./,$varname); 1322: my $rest; 1323: if ($therest[0]) { 1324: $rest=join('.',@therest); 1325: } else { 1326: $rest=''; 1327: } 1328: my $qualifierrest=$qualifier; 1329: if ($rest) { $qualifierrest.='.'.$rest; } 1330: my $spacequalifierrest=$space; 1331: if ($qualifierrest) { $spacequalifierrest.='.'.$qualifierrest; } 1332: if ($realm eq 'user') { 1333: # --------------------------------------------------------------- user.resource 1334: if ($space eq 'resource') { 1335: my %restored=&restore; 1336: return $restored{$qualifierrest}; 1337: # ----------------------------------------------------------------- user.access 1338: } elsif ($space eq 'access') { 1339: return &allowed($qualifier,$rest); 1340: # ------------------------------------------ user.preferences, user.environment 1341: } elsif (($space eq 'preferences') || ($space eq 'environment')) { 1342: return $ENV{join('.',('environment',$qualifierrest))}; 1343: # ----------------------------------------------------------------- user.course 1344: } elsif ($space eq 'course') { 1345: return $ENV{join('.',('request.course',$qualifier))}; 1346: # ------------------------------------------------------------------- user.role 1347: } elsif ($space eq 'role') { 1348: my ($role,$where)=split(/\./,$ENV{'request.role'}); 1349: if ($qualifier eq 'value') { 1350: return $role; 1351: } elsif ($qualifier eq 'extent') { 1352: return $where; 1353: } 1354: # ----------------------------------------------------------------- user.domain 1355: } elsif ($space eq 'domain') { 1356: return $ENV{'user.domain'}; 1357: # ------------------------------------------------------------------- user.name 1358: } elsif ($space eq 'name') { 1359: return $ENV{'user.name'}; 1360: # ---------------------------------------------------- Any other user namespace 1361: } else { 1362: my $item=($rest)?$qualifier.'.'.$rest:$qualifier; 1363: my %reply=&get($space,$item); 1364: return $reply{$item}; 1365: } 1366: } elsif ($realm eq 'request') { 1367: # ------------------------------------------------------------- request.browser 1368: if ($space eq 'browser') { 1369: return $ENV{'browser.'.$qualifier}; 1370: # ------------------------------------------------------------ request.filename 1371: } else { 1372: return $ENV{'request.'.$spacequalifierrest}; 1373: } 1374: } elsif ($realm eq 'course') { 1375: # ---------------------------------------------------------- course.description 1376: my $section=''; 1377: if ($ENV{'request.course.sec'}) { 1378: $section='_'.$ENV{'request.course.sec'}; 1379: } 1380: return $ENV{'course.'.$ENV{'request.course.id'}.$section.'.'. 1381: $spacequalifierrest}; 1382: } elsif ($realm eq 'resource') { 1383: if ($ENV{'request.course.id'}) { 1384: # ----------------------------------------------------- Cascading lookup scheme 1385: my $symbp=&symbread(); 1386: my $mapp=(split(/\_\_\_/,$symbp))[0]; 1387: 1388: my $symbparm=$symbp.'.'.$spacequalifierrest; 1389: my $mapparm=$mapp.'___(all).'.$spacequalifierrest; 1390: 1391: my $seclevel= 1392: $ENV{'request.course.id'}.'.['. 1393: $ENV{'request.course.sec'}.'].'.$spacequalifierrest; 1394: my $seclevelr= 1395: $ENV{'request.course.id'}.'.['. 1396: $ENV{'request.course.sec'}.'].'.$symbparm; 1397: my $seclevelm= 1398: $ENV{'request.course.id'}.'.['. 1399: $ENV{'request.course.sec'}.'].'.$mapparm; 1400: 1401: my $courselevel= 1402: $ENV{'request.course.id'}.'.'.$spacequalifierrest; 1403: my $courselevelr= 1404: $ENV{'request.course.id'}.'.'.$symbparm; 1405: my $courselevelm= 1406: $ENV{'request.course.id'}.'.'.$mapparm; 1407: 1408: 1409: # ----------------------------------------------------------- first, check user 1410: my %resourcedata=get('resourcedata', 1411: ($courselevelr,$courselevelm,$courselevel)); 1412: if ($resourcedata{$courselevelr}!~/^error\:/) { 1413: 1414: if ($resourcedata{$courselevelr}) { 1415: return $resourcedata{$courselevelr}; } 1416: if ($resourcedata{$courselevelm}) { 1417: return $resourcedata{$courselevelm}; } 1418: if ($resourcedata{$courselevel}) { return $resourcedata{$courselevel}; } 1419: 1420: } 1421: # -------------------------------------------------------- second, check course 1422: my $section=''; 1423: if ($ENV{'request.course.sec'}) { 1424: $section='_'.$ENV{'request.course.sec'}; 1425: } 1426: my $reply=&reply('get:'. 1427: $ENV{'course.'.$ENV{'request.course.id'}.$section.'.domain'}.':'. 1428: $ENV{'course.'.$ENV{'request.course.id'}.$section.'.num'}. 1429: ':resourcedata:'. 1430: &escape($seclevelr).'&'.&escape($seclevelm).'&'.&escape($seclevel).'&'. 1431: &escape($courselevelr).'&'.&escape($courselevelm).'&'.&escape($courselevel), 1432: $ENV{'course.'.$ENV{'request.course.id'}.$section.'.home'}); 1433: if ($reply!~/^error\:/) { 1434: map { 1435: if ($_) { return &unescape($_); } 1436: } split(/\&/,$reply); 1437: } 1438: 1439: # ------------------------------------------------------ third, check map parms 1440: my %parmhash=(); 1441: my $thisparm=''; 1442: if (tie(%parmhash,'GDBM_File', 1443: $ENV{'request.course.fn'}.'_parms.db',&GDBM_READER,0640)) { 1444: $thisparm=$parmhash{$symbparm}; 1445: untie(%parmhash); 1446: } 1447: if ($thisparm) { return $thisparm; } 1448: } 1449: 1450: # --------------------------------------------- last, look in resource metadata 1451: 1452: $spacequalifierrest=~s/\./\_/; 1453: my $metadata=&metadata($ENV{'request.filename'},$spacequalifierrest); 1454: if ($metadata) { return $metadata; } 1455: $metadata=&metadata($ENV{'request.filename'}, 1456: 'parameter_'.$spacequalifierrest); 1457: if ($metadata) { return $metadata; } 1458: 1459: # ---------------------------------------------------- Any other user namespace 1460: } elsif ($realm eq 'environment') { 1461: # ----------------------------------------------------------------- environment 1462: return $ENV{$spacequalifierrest}; 1463: } elsif ($realm eq 'system') { 1464: # ----------------------------------------------------------------- system.time 1465: if ($space eq 'time') { 1466: return time; 1467: } 1468: } 1469: return ''; 1470: } 1471: 1472: # ---------------------------------------------------------------- Get metadata 1473: 1474: sub metadata { 1475: my ($uri,$what)=@_; 1476: 1477: $uri=&declutter($uri); 1478: my $filename=$uri; 1479: $uri=~s/\.meta$//; 1480: unless ($metacache{$uri.':keys'}) { 1481: unless ($filename=~/\.meta$/) { $filename.='.meta'; } 1482: my $metastring=&getfile($perlvar{'lonDocRoot'}.'/res/'.$filename); 1483: my $parser=HTML::TokeParser->new(\$metastring); 1484: my $token; 1485: while ($token=$parser->get_token) { 1486: if ($token->[0] eq 'S') { 1487: my $entry=$token->[1]; 1488: my $unikey=$entry; 1489: if (defined($token->[2]->{'part'})) { 1490: $unikey.='_'.$token->[2]->{'part'}; 1491: } 1492: if (defined($token->[2]->{'name'})) { 1493: $unikey.='_'.$token->[2]->{'name'}; 1494: } 1495: if ($metacache{$uri.':keys'}) { 1496: $metacache{$uri.':keys'}.=','.$unikey; 1497: } else { 1498: $metacache{$uri.':keys'}=$unikey; 1499: } 1500: map { 1501: $metacache{$uri.':'.$unikey.'.'.$_}=$token->[2]->{$_}; 1502: } @{$token->[3]}; 1503: unless ( 1504: $metacache{$uri.':'.$unikey}=$parser->get_text('/'.$entry) 1505: ) { $metacache{$uri.':'.$unikey}= 1506: $metacache{$uri.':'.$unikey.'.default'}; 1507: } 1508: } 1509: } 1510: } 1511: return $metacache{$uri.':'.$what}; 1512: } 1513: 1514: # ------------------------------------------------- Update symbolic store links 1515: 1516: sub symblist { 1517: my ($mapname,%newhash)=@_; 1518: $mapname=declutter($mapname); 1519: my %hash; 1520: if (($ENV{'request.course.fn'}) && (%newhash)) { 1521: if (tie(%hash,'GDBM_File',$ENV{'request.course.fn'}.'_symb.db', 1522: &GDBM_WRCREAT,0640)) { 1523: map { 1524: $hash{declutter($_)}=$mapname.'___'.$newhash{$_}; 1525: } keys %newhash; 1526: if (untie(%hash)) { 1527: return 'ok'; 1528: } 1529: } 1530: } 1531: return 'error'; 1532: } 1533: 1534: # ------------------------------------------------------ Return symb list entry 1535: 1536: sub symbread { 1537: my $thisfn=shift; 1538: unless ($thisfn) { 1539: $thisfn=$ENV{'request.filename'}; 1540: } 1541: $thisfn=declutter($thisfn); 1542: my %hash; 1543: my %bighash; 1544: my $syval=''; 1545: if (($ENV{'request.course.fn'}) && ($thisfn)) { 1546: if (tie(%hash,'GDBM_File',$ENV{'request.course.fn'}.'_symb.db', 1547: &GDBM_READER,0640)) { 1548: $syval=$hash{$thisfn}; 1549: untie(%hash); 1550: } 1551: # ---------------------------------------------------------- There was an entry 1552: if ($syval) { 1553: unless ($syval=~/\_\d+$/) { 1554: unless ($ENV{'form.request.prefix'}=~/\.(\d+)\_$/) { 1555: &appenv('request.ambiguous' => $thisfn); 1556: return ''; 1557: } 1558: $syval.=$1; 1559: } 1560: } else { 1561: # ------------------------------------------------------- Was not in symb table 1562: if (tie(%bighash,'GDBM_File',$ENV{'request.course.fn'}.'.db', 1563: &GDBM_READER,0640)) { 1564: # ---------------------------------------------- Get ID(s) for current resource 1565: my $ids=$bighash{'ids_/res/'.$thisfn}; 1566: unless ($ids) { 1567: $ids=$bighash{'ids_/'.$thisfn}; 1568: } 1569: if ($ids) { 1570: # ------------------------------------------------------------------- Has ID(s) 1571: my @possibilities=split(/\,/,$ids); 1572: if ($#possibilities==0) { 1573: # ----------------------------------------------- There is only one possibility 1574: my ($mapid,$resid)=split(/\./,$ids); 1575: $syval=declutter($bighash{'map_id_'.$mapid}).'___'.$resid; 1576: } else { 1577: # ------------------------------------------ There is more than one possibility 1578: my $realpossible=0; 1579: map { 1580: my $file=$bighash{'src_'.$_}; 1581: if (&allowed('bre',$file)) { 1582: my ($mapid,$resid)=split(/\./,$_); 1583: if ($bighash{'map_type_'.$mapid} ne 'page') { 1584: $realpossible++; 1585: $syval=declutter($bighash{'map_id_'.$mapid}). 1586: '___'.$resid; 1587: } 1588: } 1589: } @possibilities; 1590: if ($realpossible!=1) { $syval=''; } 1591: } 1592: } 1593: untie(%bighash) 1594: } 1595: } 1596: if ($syval) { 1597: return $syval.'___'.$thisfn; 1598: } 1599: } 1600: &appenv('request.ambiguous' => $thisfn); 1601: return ''; 1602: } 1603: 1604: # ---------------------------------------------------------- Return random seed 1605: 1606: sub numval { 1607: my $txt=shift; 1608: $txt=~tr/A-J/0-9/; 1609: $txt=~tr/a-j/0-9/; 1610: $txt=~tr/K-T/0-9/; 1611: $txt=~tr/k-t/0-9/; 1612: $txt=~tr/U-Z/0-5/; 1613: $txt=~tr/u-z/0-5/; 1614: $txt=~s/\D//g; 1615: return int($txt); 1616: } 1617: 1618: sub rndseed { 1619: my $symb; 1620: unless ($symb=&symbread()) { return time; } 1621: my $symbchck=unpack("%32C*",$symb); 1622: my $symbseed=numval($symb)%$symbchck; 1623: my $namechck=unpack("%32C*",$ENV{'user.name'}); 1624: my $nameseed=numval($ENV{'user.name'})%$namechck; 1625: return int( $symbseed 1626: .$nameseed 1627: .unpack("%32C*",$ENV{'user.domain'}) 1628: .unpack("%32C*",$ENV{'request.course.id'}) 1629: .$namechck 1630: .$symbchck); 1631: } 1632: 1633: sub ireceipt { 1634: my ($funame,$fudom,$fucourseid,$fusymb)=@_; 1635: my $cuname=unpack("%32C*",$funame); 1636: my $cudom=unpack("%32C*",$fudom); 1637: my $cucourseid=unpack("%32C*",$fucourseid); 1638: my $cusymb=unpack("%32C*",$fusymb); 1639: my $cunique=unpack("%32C*",$perlvar{'lonReceipt'}); 1640: return unpack("%32C*",$perlvar{'lonHostID'}).'-'. 1641: ($cunique%$cuname+ 1642: $cunique%$cudom+ 1643: $cusymb%$cuname+ 1644: $cusymb%$cudom+ 1645: $cucourseid%$cuname+ 1646: $cucourseid%$cudom); 1647: } 1648: 1649: sub receipt { 1650: return &ireceipt($ENV{'user.name'},$ENV{'user.domain'}, 1651: $ENV{'request.course.id'},&symbread()); 1652: } 1653: 1654: # ------------------------------------------------------------ Serves up a file 1655: # returns either the contents of the file or a -1 1656: sub getfile { 1657: my $file=shift; 1658: &repcopy($file); 1659: if (! -e $file ) { return -1; }; 1660: my $fh=Apache::File->new($file); 1661: my $a=''; 1662: while (<$fh>) { $a .=$_; } 1663: return $a 1664: } 1665: 1666: sub filelocation { 1667: my ($dir,$file) = @_; 1668: my $location; 1669: $file=~ s/^\s*(\S+)\s*$/$1/; ## strip off leading and trailing spaces 1670: if ($file=~m:^/~:) { # is a contruction space reference 1671: $location = $file; 1672: $location =~ s:/~(.*?)/(.*):/home/$1/public_html/$2:; 1673: } else { 1674: $file=~s/^$perlvar{'lonDocRoot'}//; 1675: $file=~s:^/*res::; 1676: if ( !( $file =~ m:^/:) ) { 1677: $location = $dir. '/'.$file; 1678: } else { 1679: $location = '/home/httpd/html/res'.$file; 1680: } 1681: } 1682: $location=~s://+:/:g; # remove duplicate / 1683: while ($location=~m:/\.\./:) {$location=~ s:/[^/]+/\.\./:/:g;} #remove dir/.. 1684: return $location; 1685: } 1686: 1687: sub hreflocation { 1688: my ($dir,$file)=@_; 1689: unless (($_=~/^http:\/\//i) || ($_=~/^\//)) { 1690: my $finalpath=filelocation($dir,$file); 1691: $finalpath=~s/^\/home\/httpd\/html//; 1692: return $finalpath; 1693: } else { 1694: return $file; 1695: } 1696: } 1697: 1698: # ------------------------------------------------------------- Declutters URLs 1699: 1700: sub declutter { 1701: my $thisfn=shift; 1702: $thisfn=~s/^$perlvar{'lonDocRoot'}//; 1703: $thisfn=~s/^\///; 1704: $thisfn=~s/^res\///; 1705: return $thisfn; 1706: } 1707: 1708: # -------------------------------------------------------- Escape Special Chars 1709: 1710: sub escape { 1711: my $str=shift; 1712: $str =~ s/(\W)/"%".unpack('H2',$1)/eg; 1713: return $str; 1714: } 1715: 1716: # ----------------------------------------------------- Un-Escape Special Chars 1717: 1718: sub unescape { 1719: my $str=shift; 1720: $str =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C",hex($1))/eg; 1721: return $str; 1722: } 1723: 1724: # ================================================================ Main Program 1725: 1726: sub BEGIN { 1727: if ($readit ne 'done') { 1728: # ------------------------------------------------------------ Read access.conf 1729: { 1730: my $config=Apache::File->new("/etc/httpd/conf/access.conf"); 1731: 1732: while (my $configline=<$config>) { 1733: if ($configline =~ /PerlSetVar/) { 1734: my ($dummy,$varname,$varvalue)=split(/\s+/,$configline); 1735: chomp($varvalue); 1736: $perlvar{$varname}=$varvalue; 1737: } 1738: } 1739: } 1740: 1741: # ------------------------------------------------------------- Read hosts file 1742: { 1743: my $config=Apache::File->new("$perlvar{'lonTabDir'}/hosts.tab"); 1744: 1745: while (my $configline=<$config>) { 1746: my ($id,$domain,$role,$name,$ip)=split(/:/,$configline); 1747: $hostname{$id}=$name; 1748: $hostdom{$id}=$domain; 1749: if ($role eq 'library') { $libserv{$id}=$name; } 1750: } 1751: } 1752: 1753: # ------------------------------------------------------ Read spare server file 1754: { 1755: my $config=Apache::File->new("$perlvar{'lonTabDir'}/spare.tab"); 1756: 1757: while (my $configline=<$config>) { 1758: chomp($configline); 1759: if (($configline) && ($configline ne $perlvar{'lonHostID'})) { 1760: $spareid{$configline}=1; 1761: } 1762: } 1763: } 1764: # ------------------------------------------------------------ Read permissions 1765: { 1766: my $config=Apache::File->new("$perlvar{'lonTabDir'}/roles.tab"); 1767: 1768: while (my $configline=<$config>) { 1769: chomp($configline); 1770: my ($role,$perm)=split(/ /,$configline); 1771: if ($perm ne '') { $pr{$role}=$perm; } 1772: } 1773: } 1774: 1775: # -------------------------------------------- Read plain texts for permissions 1776: { 1777: my $config=Apache::File->new("$perlvar{'lonTabDir'}/rolesplain.tab"); 1778: 1779: while (my $configline=<$config>) { 1780: chomp($configline); 1781: my ($short,$plain)=split(/:/,$configline); 1782: if ($plain ne '') { $prp{$short}=$plain; } 1783: } 1784: } 1785: 1786: # ------------------------------------------------------------- Read file types 1787: { 1788: my $config=Apache::File->new("$perlvar{'lonTabDir'}/filetypes.tab"); 1789: 1790: while (my $configline=<$config>) { 1791: chomp($configline); 1792: my ($ending,$emb,@descr)=split(/\s+/,$configline); 1793: if ($descr[0] ne '') { 1794: $fe{$ending}=$emb; 1795: $fd{$ending}=join(' ',@descr); 1796: } 1797: } 1798: } 1799: 1800: %metacache=(); 1801: 1802: $readit='done'; 1803: &logthis('<font color=yellow>INFO: Read configuration</font>'); 1804: } 1805: } 1806: 1;