loncom/lonnet/perl/lonnet.pm - view

File: [LON-CAPA] / loncom / lonnet / perl / lonnet.pm
Revision 1.133: download - view: text, annotated - select for diffs
Thu Jul 26 21:40:27 2001 UTC (22 years, 11 months ago) by albertel
Branches: MAIN
CVS tags: HEAD

- modified eget and del in lonnet to take optiona domain and user args
- modified lonmsg usr_crit_received to use new semantics
- retrofitted devalidate to use the new more powerful del

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