Annotation of loncom/lonnet/perl/lonnet.pm, revision 1.54
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.52 www 788: if (($ENV{'HTTP_REFERER'}) && ($checkreferer)) {
1.53 www 789: my $refuri=&declutter($ENV{'HTTP_REFERER'});
790: my @uriparts=split(/\//,$refuri);
1.52 www 791: my $filename=$uriparts[$#uriparts];
1.53 www 792: my $pathname=$refuri;
1.52 www 793: $pathname=~s/\/$filename$//;
1.53 www 794: my @filenameparts=split(/\./,$filename);
795: if (&fileembstyle($filenameparts[$#filenameparts]) ne 'ssi') {
796: if ($ENV{'acc.res.'.$ENV{'request.course.id'}.'.'.$pathname}=~
1.54 ! www 797: /\&$filename\:([\d\|]+)\&/) {
1.53 www 798: my $refstatecond=$1;
1.52 www 799: if ($ENV{'user.priv.'.$ENV{'request.role'}.'./'.$courseprivid}
800: =~/$priv\&([^\:]*)/) {
801: $thisallowed.=$1;
1.53 www 802: $uri=$refuri;
803: $statecond=$refstatecond;
1.52 www 804: }
1.53 www 805: }
1.52 www 806: }
1.29 www 807: }
1.52 www 808: }
1.29 www 809:
1.52 www 810: #
811: # Gathered now: all priviledges that could apply, and condition number
812: #
813: #
814: # Full or no access?
815: #
1.29 www 816:
1.52 www 817: if ($thisallowed=~/F/) {
818: return 'F';
819: }
1.29 www 820:
1.52 www 821: unless ($thisallowed) {
822: return '';
823: }
1.29 www 824:
1.52 www 825: # Restrictions exist, deal with them
826: #
827: # C:according to course preferences
828: # R:according to resource settings
829: # L:unless locked
830: # X:according to user session state
831: #
832:
833: # Possibly locked functionality, check all courses
1.54 ! www 834: # Locks might take effect only after 10 minutes cache expiration for other
! 835: # courses, and 2 minutes for current course
1.52 www 836:
837: my $envkey;
838: if ($thisallowed=~/L/) {
839: foreach $envkey (keys %ENV) {
1.54 ! www 840: if ($envkey=~/^user\.role\.(st|ta)\.([^\.]*)/) {
! 841: my $courseid=$2;
! 842: my $roleid=$1.'.'.$2;
! 843: my $expiretime=600;
! 844: if ($ENV{'request.role'} eq $roleid) {
! 845: $expiretime=120;
! 846: }
! 847: my ($cdom,$cnum,$csec)=split(/\//,$courseid);
! 848: my $prefix='course.'.$cdom.'_'.$cnum.'.';
! 849: if ((time-$ENV{$prefix.'last_cache'})>$expiretime) {
! 850: &coursedescription($courseid);
! 851: }
! 852: if (($ENV{$prefix.'res.'.$uri.'.lock.sections'}=~/\,$csec\,/)
! 853: || ($ENV{$prefix.'res.'.$uri.'.lock.sections'} eq 'all')) {
! 854: if ($ENV{$prefix.'res.'.$uri.'.lock.expire'}>time) {
1.52 www 855: &log('Locked by res: '.$priv.' for '.$uri.' due to '.
856: $cdom.'/'.$cnum.'/'.$csec.' expire '.
1.54 ! www 857: $ENV{$prefix.'priv.'.$priv.'.lock.expire'});
1.52 www 858: return '';
859: }
860: }
1.54 ! www 861: if (($ENV{$prefix.'priv.'.$priv.'.lock.sections'}=~/\,$csec\,/)
! 862: || ($ENV{$prefix.'priv.'.$priv.'.lock.sections'} eq 'all')) {
! 863: if ($ENV{'priv.'.$priv.'.lock.expire'}>time) {
1.52 www 864: &log('Locked by priv: '.$priv.' for '.$uri.' due to '.
865: $cdom.'/'.$cnum.'/'.$csec.' expire '.
1.54 ! www 866: $ENV{$prefix.'priv.'.$priv.'.lock.expire'});
1.52 www 867: return '';
868: }
869: }
870: }
1.29 www 871: }
1.52 www 872: }
873:
874: #
875: # Rest of the restrictions depend on selected course
876: #
877:
878: unless ($ENV{'request.course.id'}) {
879: return '1';
880: }
1.29 www 881:
1.52 www 882: #
883: # Now user is definitely in a course
884: #
1.53 www 885:
886:
887: # Course preferences
888:
889: if ($thisallowed=~/C/) {
1.54 ! www 890: my $rolecode=(split(/\./,$ENV{'request.role'}))[0];
! 891: if ($ENV{'course.'.$ENV{'request.course.id'}.'.'.$priv.'.roles.denied'}
! 892: =~/\,$rolecode\,/) {
! 893: &log('Denied by role: '.$priv.' for '.$uri.' as '.$rolecode.' in '.
! 894: $ENV{'request.course.id'});
! 895: return '';
! 896: }
1.53 www 897: }
898:
899: # Resource preferences
900:
901: if ($thisallowed=~/R/) {
1.54 ! www 902: my $rolecode=(split(/\./,$ENV{'request.role'}))[0];
! 903: my $filename=$perlvar{'lonDocRoot'}.'/res/'.$uri.'.meta';
! 904: if (-e $filename) {
! 905: my @content;
! 906: {
! 907: my $fh=Apache::File->new($filename);
! 908: @content=<$fh>;
! 909: }
! 910: if (join('',@content)=~
! 911: /\<roledeny[^\>]*\>[^\<]*$rolecode[^\<]*\<\/roledeny\>/) {
! 912: &log('Denied by role: '.$priv.' for '.$uri.' as '.$rolecode);
! 913: return '';
! 914:
! 915: }
! 916: }
1.53 www 917: }
1.30 www 918:
1.52 www 919: # Restricted by state?
1.30 www 920:
1.52 www 921: if ($thisallowed=~/X/) {
922: if (&condval($statecond)) {
923: return '2';
924: } else {
925: return '';
926: }
927: }
1.30 www 928:
1.52 www 929: return 'F';
1.12 www 930: }
931:
1.29 www 932: # ---------------------------------------------------------- Refresh State Info
933:
934: sub refreshstate {
935: }
936:
1.12 www 937: # ----------------------------------------------------------------- Define Role
938:
939: sub definerole {
940: if (allowed('mcr','/')) {
941: my ($rolename,$sysrole,$domrole,$courole)=@_;
1.21 www 942: map {
943: my ($crole,$cqual)=split(/\&/,$_);
944: if ($pr{'cr:s'}!~/$crole/) { return "refused:s:$crole"; }
945: if ($pr{'cr:s'}=~/$crole\&/) {
946: if ($pr{'cr:s'}!~/$crole\&\w*$cqual/) {
947: return "refused:s:$crole&$cqual";
948: }
949: }
950: } split('/',$sysrole);
951: map {
952: my ($crole,$cqual)=split(/\&/,$_);
953: if ($pr{'cr:d'}!~/$crole/) { return "refused:d:$crole"; }
954: if ($pr{'cr:d'}=~/$crole\&/) {
955: if ($pr{'cr:d'}!~/$crole\&\w*$cqual/) {
956: return "refused:d:$crole&$cqual";
957: }
958: }
959: } split('/',$domrole);
960: map {
961: my ($crole,$cqual)=split(/\&/,$_);
962: if ($pr{'cr:c'}!~/$crole/) { return "refused:c:$crole"; }
963: if ($pr{'cr:c'}=~/$crole\&/) {
964: if ($pr{'cr:c'}!~/$crole\&\w*$cqual/) {
965: return "refused:c:$crole&$cqual";
966: }
967: }
968: } split('/',$courole);
1.12 www 969: my $command="encrypt:rolesput:$ENV{'user.domain'}:$ENV{'user.name'}:".
970: "$ENV{'user.domain'}:$ENV{'user.name'}:".
1.21 www 971: "rolesdef_$rolename=".
972: escape($sysrole.'_'.$domrole.'_'.$courole);
1.12 www 973: return reply($command,$ENV{'user.home'});
974: } else {
975: return 'refused';
976: }
977: }
978:
979: # ------------------------------------------------------------------ Plain Text
980:
981: sub plaintext {
1.22 www 982: my $short=shift;
983: return $prp{$short};
1.12 www 984: }
985:
1.25 www 986: # ------------------------------------------------------------------ Plain Text
987:
988: sub fileembstyle {
989: my $ending=shift;
990: return $fe{$ending};
991: }
992:
993: # ------------------------------------------------------------ Description Text
994:
995: sub filedecription {
996: my $ending=shift;
997: return $fd{$ending};
998: }
999:
1.12 www 1000: # ----------------------------------------------------------------- Assign Role
1001:
1002: sub assignrole {
1.21 www 1003: my ($udom,$uname,$url,$role,$end,$start)=@_;
1004: my $mrole;
1.31 www 1005: $url=declutter($url);
1.21 www 1006: if ($role =~ /^cr\//) {
1007: unless ($url=~/\.course$/) { return 'invalid'; }
1008: unless (allowed('ccr',$url)) { return 'refused'; }
1009: $mrole='cr';
1010: } else {
1011: unless (($url=~/\.course$/) || ($url=~/\/$/)) { return 'invalid'; }
1012: unless (allowed('c'+$role)) { return 'refused'; }
1013: $mrole=$role;
1014: }
1015: my $command="encrypt:rolesput:$ENV{'user.domain'}:$ENV{'user.name'}:".
1016: "$udom:$uname:$url".'_'."$mrole=$role";
1017: if ($end) { $command.='_$end'; }
1018: if ($start) {
1019: if ($end) {
1020: $command.='_$start';
1021: } else {
1022: $command.='_0_$start';
1023: }
1024: }
1025: return &reply($command,&homeserver($uname,$udom));
1026: }
1027:
1028: # ---------------------------------------------------------- Assign Custom Role
1029:
1030: sub assigncustomrole {
1031: my ($udom,$uname,$url,$rdom,$rnam,$rolename,$end,$start)=@_;
1032: return &assignrole($udom,$uname,$url,'cr/'.$rdom.'/'.$rnam.'/'.$rolename,
1033: $end,$start);
1034: }
1035:
1036: # ----------------------------------------------------------------- Revoke Role
1037:
1038: sub revokerole {
1039: my ($udom,$uname,$url,$role)=@_;
1040: my $now=time;
1041: return &assignrole($udom,$uname,$url,$role,$now);
1042: }
1043:
1044: # ---------------------------------------------------------- Revoke Custom Role
1045:
1046: sub revokecustomrole {
1047: my ($udom,$uname,$url,$rdom,$rnam,$rolename)=@_;
1048: my $now=time;
1049: return &assigncustomrole($udom,$uname,$url,$rdom,$rnam,$rolename,$now);
1.17 www 1050: }
1051:
1052: # ------------------------------------------------------------ Directory lister
1053:
1054: sub dirlist {
1055: my $uri=shift;
1.18 www 1056: $uri=~s/^\///;
1057: $uri=~s/\/$//;
1.19 www 1058: my ($res,$udom,$uname,@rest)=split(/\//,$uri);
1059: if ($udom) {
1060: if ($uname) {
1061: my $listing=reply('ls:'.$perlvar{'lonDocRoot'}.'/'.$uri,
1062: homeserver($uname,$udom));
1063: return split(/:/,$listing);
1064: } else {
1065: my $tryserver;
1066: my %allusers=();
1067: foreach $tryserver (keys %libserv) {
1068: if ($hostdom{$tryserver} eq $udom) {
1069: my $listing=reply('ls:'.$perlvar{'lonDocRoot'}.'/res/'.$udom,
1070: $tryserver);
1071: if (($listing ne 'no_such_dir') && ($listing ne 'empty')
1072: && ($listing ne 'con_lost')) {
1073: map {
1074: my ($entry,@stat)=split(/&/,$_);
1075: $allusers{$entry}=1;
1076: } split(/:/,$listing);
1077: }
1078: }
1079: }
1080: my $alluserstr='';
1081: map {
1082: $alluserstr.=$_.'&user:';
1083: } sort keys %allusers;
1084: $alluserstr=~s/:$//;
1085: return split(/:/,$alluserstr);
1086: }
1087: } else {
1088: my $tryserver;
1089: my %alldom=();
1090: foreach $tryserver (keys %libserv) {
1091: $alldom{$hostdom{$tryserver}}=1;
1092: }
1093: my $alldomstr='';
1094: map {
1095: $alldomstr.=$perlvar{'lonDocRoot'}.'/res/'.$_.'&domain:';
1096: } sort keys %alldom;
1097: $alldomstr=~s/:$//;
1098: return split(/:/,$alldomstr);
1099: }
1.26 www 1100: }
1101:
1102: # -------------------------------------------------------- Value of a Condition
1103:
1.40 www 1104: sub directcondval {
1105: my $number=shift;
1106: if ($ENV{'user.state.'.$ENV{'request.course.id'}}) {
1107: return substr($ENV{'user.state.'.$ENV{'request.course.id'}},$number,1);
1108: } else {
1109: return 2;
1110: }
1111: }
1112:
1.26 www 1113: sub condval {
1114: my $condidx=shift;
1115: my $result=0;
1.54 ! www 1116: my $allpathcond='';
! 1117: map {
! 1118: if (defined($ENV{'acc.cond.'.$ENV{'request.course.id'}.'.'.$_})) {
! 1119: $allpathcond.=
! 1120: '('.$ENV{'acc.cond.'.$ENV{'request.course.id'}.'.'.$_}.')|';
! 1121: }
! 1122: } split(/\|/,$condidx);
! 1123: $allpathcond=~s/\|$//;
1.33 www 1124: if ($ENV{'request.course.id'}) {
1.54 ! www 1125: if ($allpathcond) {
1.26 www 1126: my $operand='|';
1127: my @stack;
1128: map {
1129: if ($_ eq '(') {
1130: push @stack,($operand,$result)
1131: } elsif ($_ eq ')') {
1132: my $before=pop @stack;
1133: if (pop @stack eq '&') {
1134: $result=$result>$before?$before:$result;
1135: } else {
1136: $result=$result>$before?$result:$before;
1137: }
1138: } elsif (($_ eq '&') || ($_ eq '|')) {
1139: $operand=$_;
1140: } else {
1.40 www 1141: my $new=directcondval($_);
1.26 www 1142: if ($operand eq '&') {
1143: $result=$result>$new?$new:$result;
1144: } else {
1145: $result=$result>$new?$result:$new;
1146: }
1147: }
1.54 ! www 1148: } ($allpathcond=~/(\d+|\(|\)|\&|\|)/g);
1.26 www 1149: }
1150: }
1151: return $result;
1.28 www 1152: }
1153:
1154: # --------------------------------------------------------- Value of a Variable
1155:
1156: sub varval {
1.48 www 1157: my $varname=shift;
1158: my ($realm,$space,$qualifier,@therest)=split(/\./,$varname);
1159: my $rest;
1160: if ($therest[0]) {
1161: $rest=join('.',@therest);
1162: } else {
1163: $rest='';
1164: }
1.28 www 1165: if ($realm eq 'user') {
1.48 www 1166: # --------------------------------------------------------------- user.resource
1167: if ($space eq 'resource') {
1168: # ----------------------------------------------------------------- user.access
1169: } elsif ($space eq 'access') {
1170: return &allowed($qualifier,$rest);
1171: # ------------------------------------------ user.preferences, user.environment
1172: } elsif (($space eq 'preferences') || ($space eq 'environment')) {
1173: return $ENV{join('.',('environment',$qualifier,$rest))};
1174: # ----------------------------------------------------------------- user.course
1175: } elsif ($space eq 'course') {
1176: return $ENV{join('.',('request.course',$qualifier))};
1177: # ------------------------------------------------------------------- user.role
1178: } elsif ($space eq 'role') {
1179: my ($role,$where)=split(/\./,$ENV{'request.role'});
1180: if ($qualifier eq 'value') {
1181: return $role;
1182: } elsif ($qualifier eq 'extent') {
1183: return $where;
1184: }
1185: # ----------------------------------------------------------------- user.domain
1186: } elsif ($space eq 'domain') {
1187: return $ENV{'user.domain'};
1188: # ------------------------------------------------------------------- user.name
1189: } elsif ($space eq 'name') {
1190: return $ENV{'user.name'};
1191: # ---------------------------------------------------- Any other user namespace
1.29 www 1192: } else {
1.48 www 1193: my $item=($rest)?$qualifier.'.'.$rest:$qualifier;
1194: my %reply=&get($space,$item);
1195: return $reply{$item};
1196: }
1197: } elsif ($realm eq 'request') {
1198: # ------------------------------------------------------------- request.browser
1199: if ($space eq 'browser') {
1200: return $ENV{'browser.'.$qualifier};
1201: } elsif ($space eq 'filename') {
1202: return $ENV{'request.filename'};
1.29 www 1203: }
1.28 www 1204: } elsif ($realm eq 'course') {
1.48 www 1205: # ---------------------------------------------------------- course.description
1206: if ($space eq 'description') {
1.49 www 1207: my %reply=&coursedescription($ENV{'request.course.id'});
1208: return $reply{'description'};
1.48 www 1209: # ------------------------------------------------------------------- course.id
1210: } elsif ($space eq 'id') {
1211: return $ENV{'request.course.id'};
1212: # -------------------------------------------------- Any other course namespace
1213: } else {
1214: my ($cdom,$cnam)=split(/\_/,$ENV{'request.course.id'});
1215: my $chome=&homeserver($cnam,$cdom);
1216: my $item=join('.',($qualifier,$rest));
1217: return &unescape
1218: (&reply('get:'.$cdom.':'.$cnam.':'.&escape($space).':'.
1219: &escape($item),$chome));
1220: }
1221: } elsif ($realm eq 'userdata') {
1222: my $uhome=&homeserver($qualifier,$space);
1223: # ----------------------------------------------- userdata.domain.name.resource
1224: # ---------------------------------------------------- Any other user namespace
1225: } elsif ($realm eq 'environment') {
1226: # ----------------------------------------------------------------- environment
1227: return $ENV{join('.',($space,$qualifier,$rest))};
1.28 www 1228: } elsif ($realm eq 'system') {
1.48 www 1229: # ----------------------------------------------------------------- system.time
1230: if ($space eq 'time') {
1231: return time;
1232: }
1.28 www 1233: }
1.48 www 1234: return '';
1.31 www 1235: }
1236:
1237: # ------------------------------------------------- Update symbolic store links
1238:
1239: sub symblist {
1240: my ($mapname,%newhash)=@_;
1241: $mapname=declutter($mapname);
1242: my %hash;
1243: if (($ENV{'request.course.fn'}) && (%newhash)) {
1244: if (tie(%hash,'GDBM_File',$ENV{'request.course.fn'}.'_symb.db',
1245: &GDBM_WRCREAT,0640)) {
1246: map {
1247: $hash{declutter($_)}=$mapname.'___'.$newhash{$_};
1248: } keys %newhash;
1249: if (untie(%hash)) {
1250: return 'ok';
1251: }
1252: }
1253: }
1254: return 'error';
1255: }
1256:
1257: # ------------------------------------------------------ Return symb list entry
1258:
1259: sub symbread {
1.44 www 1260: my $thisfn=shift;
1261: unless ($thisfn) {
1262: $thisfn=$ENV{'request.filename'};
1263: }
1264: $thisfn=declutter($thisfn);
1.31 www 1265: my %hash;
1.37 www 1266: my %bighash;
1267: my $syval='';
1.45 www 1268: if (($ENV{'request.course.fn'}) && ($thisfn)) {
1.31 www 1269: if (tie(%hash,'GDBM_File',$ENV{'request.course.fn'}.'_symb.db',
1270: &GDBM_READER,0640)) {
1271: $syval=$hash{$thisfn};
1.37 www 1272: untie(%hash);
1273: }
1274: # ---------------------------------------------------------- There was an entry
1275: if ($syval) {
1276: unless ($syval=~/\_\d+$/) {
1277: unless ($ENV{'form.request.prefix'}=~/\.(\d+)\_$/) {
1.44 www 1278: &appenv('request.ambiguous' => $thisfn);
1.37 www 1279: return '';
1280: }
1281: $syval.=$1;
1282: }
1283: } else {
1284: # ------------------------------------------------------- Was not in symb table
1285: if (tie(%bighash,'GDBM_File',$ENV{'request.course.fn'}.'.db',
1286: &GDBM_READER,0640)) {
1287: # ---------------------------------------------- Get ID(s) for current resource
1288: my $ids=$bighash{'ids_/res/'.$thisfn};
1289: if ($ids) {
1290: # ------------------------------------------------------------------- Has ID(s)
1291: my @possibilities=split(/\,/,$ids);
1.39 www 1292: if ($#possibilities==0) {
1293: # ----------------------------------------------- There is only one possibility
1.37 www 1294: my ($mapid,$resid)=split(/\./,$ids);
1295: $syval=declutter($bighash{'map_id_'.$mapid}).'___'.$resid;
1296: } else {
1.39 www 1297: # ------------------------------------------ There is more than one possibility
1298: my $realpossible=0;
1299: map {
1300: my $file=$bighash{'src_'.$_};
1301: if (&allowed('bre',$file)) {
1302: my ($mapid,$resid)=split(/\./,$_);
1303: if ($bighash{'map_type_'.$mapid} ne 'page') {
1304: $realpossible++;
1305: $syval=declutter($bighash{'map_id_'.$mapid}).
1306: '___'.$resid;
1307: }
1308: }
1309: } @possibilities;
1310: if ($realpossible!=1) { $syval=''; }
1.37 www 1311: }
1312: }
1313: untie(%bighash)
1314: }
1.31 www 1315: }
1.38 www 1316: if ($syval) { return $syval.'___'.$thisfn; }
1.31 www 1317: }
1.44 www 1318: &appenv('request.ambiguous' => $thisfn);
1.31 www 1319: return '';
1320: }
1321:
1322: # ---------------------------------------------------------- Return random seed
1323:
1.32 www 1324: sub numval {
1325: my $txt=shift;
1326: $txt=~tr/A-J/0-9/;
1327: $txt=~tr/a-j/0-9/;
1328: $txt=~tr/K-T/0-9/;
1329: $txt=~tr/k-t/0-9/;
1330: $txt=~tr/U-Z/0-5/;
1331: $txt=~tr/u-z/0-5/;
1332: $txt=~s/\D//g;
1333: return int($txt);
1334: }
1335:
1.31 www 1336: sub rndseed {
1337: my $symb;
1.44 www 1338: unless ($symb=&symbread()) { return time; }
1.32 www 1339: my $symbchck=unpack("%32C*",$symb);
1340: my $symbseed=numval($symb)%$symbchck;
1341: my $namechck=unpack("%32C*",$ENV{'user.name'});
1342: my $nameseed=numval($ENV{'user.name'})%$namechck;
1343: return int( $symbseed
1344: .$nameseed
1345: .unpack("%32C*",$ENV{'user.domain'})
1.33 www 1346: .unpack("%32C*",$ENV{'request.course.id'})
1.32 www 1347: .$namechck
1348: .$symbchck);
1.36 albertel 1349: }
1350:
1351: # ------------------------------------------------------------ Serves up a file
1352: # returns either the contents of the file or a -1
1353: sub getfile {
1354: my $file=shift;
1.37 www 1355: &repcopy($file);
1.36 albertel 1356: if (! -e $file ) { return -1; };
1357: my $fh=Apache::File->new($file);
1358: my $a='';
1359: while (<$fh>) { $a .=$_; }
1360: return $a
1361: }
1362:
1363: sub filelocation {
1364: my ($dir,$file) = @_;
1365: my $location;
1366: $file=~ s/^\s*(\S+)\s*$/$1/; ## strip off leading and trailing spaces
1367: $file=~s/^$perlvar{'lonDocRoot'}//;
1368: $file=~s:^/*res::;
1369: if ( !( $file =~ m:^/:) ) {
1370: $location = $dir. '/'.$file;
1371: } else {
1372: $location = '/home/httpd/html/res'.$file;
1373: }
1374: $location=~s://+:/:g; # remove duplicate /
1.46 www 1375: while ($location=~m:/\.\./:) {$location=~ s:/[^/]+/\.\./:/:g;} #remove dir/..
1376: return $location;
1377: }
1.36 albertel 1378:
1.46 www 1379: sub hreflocation {
1380: my ($dir,$file)=@_;
1381: unless (($_=~/^http:\/\//i) || ($_=~/^\//)) {
1382: my $finalpath=filelocation($dir,$file);
1383: $finalpath=~s/^\/home\/httpd\/html//;
1384: return $finalpath;
1385: } else {
1386: return $file;
1387: }
1.31 www 1388: }
1389:
1390: # ------------------------------------------------------------- Declutters URLs
1391:
1392: sub declutter {
1393: my $thisfn=shift;
1394: $thisfn=~s/^$perlvar{'lonDocRoot'}//;
1395: $thisfn=~s/^\///;
1396: $thisfn=~s/^res\///;
1397: return $thisfn;
1.12 www 1398: }
1399:
1400: # -------------------------------------------------------- Escape Special Chars
1401:
1402: sub escape {
1403: my $str=shift;
1404: $str =~ s/(\W)/"%".unpack('H2',$1)/eg;
1405: return $str;
1406: }
1407:
1408: # ----------------------------------------------------- Un-Escape Special Chars
1409:
1410: sub unescape {
1411: my $str=shift;
1412: $str =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C",hex($1))/eg;
1413: return $str;
1414: }
1.11 www 1415:
1.1 albertel 1416: # ================================================================ Main Program
1417:
1418: sub BEGIN {
1419: if ($readit ne 'done') {
1420: # ------------------------------------------------------------ Read access.conf
1421: {
1422: my $config=Apache::File->new("/etc/httpd/conf/access.conf");
1423:
1424: while (my $configline=<$config>) {
1425: if ($configline =~ /PerlSetVar/) {
1426: my ($dummy,$varname,$varvalue)=split(/\s+/,$configline);
1.8 www 1427: chomp($varvalue);
1.1 albertel 1428: $perlvar{$varname}=$varvalue;
1429: }
1430: }
1431: }
1432:
1433: # ------------------------------------------------------------- Read hosts file
1434: {
1435: my $config=Apache::File->new("$perlvar{'lonTabDir'}/hosts.tab");
1436:
1437: while (my $configline=<$config>) {
1438: my ($id,$domain,$role,$name,$ip)=split(/:/,$configline);
1439: $hostname{$id}=$name;
1440: $hostdom{$id}=$domain;
1441: if ($role eq 'library') { $libserv{$id}=$name; }
1442: }
1443: }
1444:
1445: # ------------------------------------------------------ Read spare server file
1446: {
1447: my $config=Apache::File->new("$perlvar{'lonTabDir'}/spare.tab");
1448:
1449: while (my $configline=<$config>) {
1450: chomp($configline);
1451: if (($configline) && ($configline ne $perlvar{'lonHostID'})) {
1452: $spareid{$configline}=1;
1453: }
1454: }
1455: }
1.11 www 1456: # ------------------------------------------------------------ Read permissions
1457: {
1458: my $config=Apache::File->new("$perlvar{'lonTabDir'}/roles.tab");
1459:
1460: while (my $configline=<$config>) {
1461: chomp($configline);
1462: my ($role,$perm)=split(/ /,$configline);
1463: if ($perm ne '') { $pr{$role}=$perm; }
1464: }
1465: }
1466:
1467: # -------------------------------------------- Read plain texts for permissions
1468: {
1469: my $config=Apache::File->new("$perlvar{'lonTabDir'}/rolesplain.tab");
1470:
1471: while (my $configline=<$config>) {
1472: chomp($configline);
1473: my ($short,$plain)=split(/:/,$configline);
1474: if ($plain ne '') { $prp{$short}=$plain; }
1.25 www 1475: }
1476: }
1477:
1478: # ------------------------------------------------------------- Read file types
1479: {
1480: my $config=Apache::File->new("$perlvar{'lonTabDir'}/filetypes.tab");
1481:
1482: while (my $configline=<$config>) {
1483: chomp($configline);
1484: my ($ending,$emb,@descr)=split(/\s+/,$configline);
1485: if ($descr[0] ne '') {
1486: $fe{$ending}=$emb;
1487: $fd{$ending}=join(' ',@descr);
1488: }
1.11 www 1489: }
1490: }
1491:
1.22 www 1492:
1.1 albertel 1493: $readit='done';
1.12 www 1494: &logthis('<font color=yellow>INFO: Read configuration</font>');
1.1 albertel 1495: }
1496: }
1497: 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