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