--- loncom/lonnet/perl/lonnet.pm 1999/11/22 17:23:13 1.5 +++ loncom/lonnet/perl/lonnet.pm 2000/10/06 21:00:05 1.37 @@ -1,15 +1,77 @@ # The LearningOnline Network # TCP networking package +# +# Functions for use by content handlers: +# +# plaintext(short) : plain text explanation of short term +# fileembstyle(ext) : embed style in page for file extension +# filedescription(ext) : descriptor text for file extension +# allowed(short,url) : returns codes for allowed actions +# F: full access +# U,I,K: authentication modes (cxx only) +# '': forbidden +# 1: user needs to choose course +# 2: browse allowed +# definerole(rolename,sys,dom,cou) : define a custom role rolename +# set priviledges in format of lonTabs/roles.tab for +# system, domain and course level, +# assignrole(udom,uname,url,role,end,start) : give a role to a user for the +# level given by url. Optional start and end dates +# (leave empty string or zero for "no date") +# assigncustomrole (udom,uname,url,rdom,rnam,rolename,end,start) : give a +# custom role to a user for the level given by url. +# Specify name and domain of role author, and role name +# revokerole (udom,uname,url,role) : Revoke a role for url +# revokecustomrole (udom,uname,url,rdom,rnam,rolename) : Revoke a custom role +# appenv(hash) : adds hash to session environment +# store(hash) : stores hash permanently for this url +# restore : returns hash for this url +# eget(namesp,array) : returns hash with keys from array filled in from namesp +# get(namesp,array) : returns hash with keys from array filled in from namesp +# del(namesp,array) : deletes keys out of arry from namesp +# put(namesp,hash) : stores hash in namesp +# dump(namesp) : dumps the complete namespace into a hash +# ssi(url,hash) : does a complete request cycle on url to localhost, posts +# hash +# coursedescription(id) : returns and caches course description for id +# repcopy(filename) : replicate file +# dirlist(url) : gets a directory listing +# condval(index) : value of condition index based on state +# varval(name) : value of a variable +# refreshstate() : refresh the state information string +# symblist(map,hash) : Updates symbolic storage links +# rndseed() : returns a random seed +# getfile(filename) : returns the contents of filename, or a -1 if it can't +# be found, replicates and subscribes to the file +# filelocation(dir,file) : returns a farily clean absolute reference to file +# from the directory dir +# # 6/1/99,6/2,6/10,6/11,6/12,6/14,6/26,6/28,6/29,6/30, # 7/1,7/2,7/9,7/10,7/12,7/14,7/15,7/19, -# 11/8,11/16,11/18,11/22 Gerd Kortemeyer +# 11/8,11/16,11/18,11/22,11/23,12/22, +# 01/06,01/13,02/24,02/28,02/29, +# 03/01,03/02,03/06,03/07,03/13, +# 04/05,05/29,05/31,06/01, +# 06/05,06/26 Gerd Kortemeyer +# 06/26 Ben Tyszka +# 06/30,07/15,07/17,07/18,07/20,07/21,07/22,07/25 Gerd Kortemeyer +# 08/14 Ben Tyszka +# 08/22,08/28,08/31,09/01,09/02,09/04,09/05,09/25,09/28,09/30 Gerd Kortemeyer +# 10/04 Gerd Kortemeyer +# 10/04 Guy Albertelli +# 10/06 Gerd Kortemeyer package Apache::lonnet; use strict; use Apache::File; -use vars qw(%perlvar %hostname %homecache %spareid %hostdom %libserv $readit); +use LWP::UserAgent(); +use HTTP::Headers; +use vars +qw(%perlvar %hostname %homecache %spareid %hostdom %libserv %pr %prp %fe %fd $readit); use IO::Socket; +use GDBM_File; +use Apache::Constants qw(:common :http); # --------------------------------------------------------------------- Logging @@ -43,8 +105,8 @@ sub subreply { or return "con_lost"; print $client "$cmd\n"; my $answer=<$client>; - chomp($answer); if (!$answer) { $answer="con_lost"; } + chomp($answer); return $answer; } @@ -52,6 +114,11 @@ sub reply { my ($cmd,$server)=@_; my $answer=subreply($cmd,$server); if ($answer eq 'con_lost') { $answer=subreply($cmd,$server); } + if (($answer=~/^error:/) || ($answer=~/^refused/) || + ($answer=~/^rejected/)) { + &logthis("WARNING:". + " $cmd to $server returned $answer"); + } return $answer; } @@ -72,16 +139,20 @@ sub reconlonc { &logthis("$peerfile still not there, give it another try"); sleep 5; if (-e "$peerfile") { return; } - &logthis("$peerfile still not there, giving up"); + &logthis( + "WARNING: $peerfile still not there, giving up"); } else { - &logthis("lonc at pid $loncpid not responding, giving up"); + &logthis( + "WARNING:". + " lonc at pid $loncpid not responding, giving up"); } } else { - &logthis('lonc not running, giving up'); + &logthis('WARNING: lonc not running, giving up'); } } # ------------------------------------------------------ Critical communication + sub critical { my ($cmd,$server)=@_; my $answer=reply($cmd,$server); @@ -101,7 +172,7 @@ sub critical { { my $dfh; if ($dfh=Apache::File->new(">$dfilename")) { - print $dfh "$server:$cmd\n"; + print $dfh "$cmd\n"; } } sleep 2; @@ -113,12 +184,14 @@ sub critical { } } chomp($wcmd); - if ($wcmd eq "$server:$cmd") { - &logthis("Connection buffer $dfilename: $cmd"); + if ($wcmd eq $cmd) { + &logthis("WARNING: ". + "Connection buffer $dfilename: $cmd"); &logperm("D:$server:$cmd"); return 'con_delayed'; } else { - &logthis("CRITICAL CONNECTION FAILED: $server $cmd"); + &logthis("CRITICAL:" + ." Critical connection failed: $server $cmd"); &logperm("F:$server:$cmd"); return 'con_failed'; } @@ -130,16 +203,48 @@ sub critical { # ---------------------------------------------------------- Append Environment sub appenv { - my ($name,$value)=@_; - my $fh; - unless ($fh=Apache::File->new(">>$ENV{'user.environment'}")) { + my %newenv=@_; + map { + if (($newenv{$_}=~/^user\.role/) || ($newenv{$_}=~/^user\.priv/)) { + &logthis("WARNING: ". + "Attempt to modify environment ".$_." to ".$newenv{$_}); + delete($newenv{$_}); + } else { + $ENV{$_}=$newenv{$_}; + } + } keys %newenv; + my @oldenv; + { + my $fh; + unless ($fh=Apache::File->new("$ENV{'user.environment'}")) { + return 'error'; + } + @oldenv=<$fh>; + } + for (my $i=0; $i<=$#oldenv; $i++) { + chomp($oldenv[$i]); + if ($oldenv[$i] ne '') { + my ($name,$value)=split(/=/,$oldenv[$i]); + unless (defined($newenv{$name})) { + $newenv{$name}=$value; + } + } + } + { + my $fh; + unless ($fh=Apache::File->new(">$ENV{'user.environment'}")) { return 'error'; + } + my $newname; + foreach $newname (keys %newenv) { + print $fh "$newname=$newenv{$newname}\n"; + } } - print $fh "$name=$value\n"; return 'ok'; } # ------------------------------ Find server with least workload from spare.tab + sub spareserver { my $tryserver; my $spareserver=''; @@ -155,31 +260,47 @@ sub spareserver { } # --------- Try to authenticate user from domain's lib servers (first this one) + sub authenticate { my ($uname,$upass,$udom)=@_; - + $upass=escape($upass); if (($perlvar{'lonRole'} eq 'library') && ($udom eq $perlvar{'lonDefDomain'})) { my $answer=reply("encrypt:auth:$udom:$uname:$upass",$perlvar{'lonHostID'}); if ($answer =~ /authorized/) { - if ($answer eq 'authorized') { return $perlvar{'lonHostID'}; } - if ($answer eq 'non_authorized') { return 'no_host'; } + if ($answer eq 'authorized') { + &logthis("User $uname at $udom authorized by local server"); + return $perlvar{'lonHostID'}; + } + if ($answer eq 'non_authorized') { + &logthis("User $uname at $udom rejected by local server"); + return 'no_host'; + } } } my $tryserver; foreach $tryserver (keys %libserv) { if ($hostdom{$tryserver} eq $udom) { - my $answer=reply("enc:auth:$udom:$uname:$upass",$tryserver); + my $answer=reply("encrypt:auth:$udom:$uname:$upass",$tryserver); if ($answer =~ /authorized/) { - if ($answer eq 'authorized') { return $tryserver; } + if ($answer eq 'authorized') { + &logthis("User $uname at $udom authorized by $tryserver"); + return $tryserver; + } + if ($answer eq 'non_authorized') { + &logthis("User $uname at $udom rejected by $tryserver"); + return 'no_host'; + } } } - } + } + &logthis("User $uname at $udom could not be authenticated"); return 'no_host'; } # ---------------------- Find the homebase for a user from domain's lib servers + sub homeserver { my ($uname,$udom)=@_; @@ -200,14 +321,13 @@ sub homeserver { } # ----------------------------- Subscribe to a resource, return URL if possible + sub subscribe { my $fname=shift; - &logthis($fname); my $author=$fname; $author=~s/\/home\/httpd\/html\/res\/([^\/]*)\/([^\/]*).*/$1\/$2/; my ($udom,$uname)=split(/\//,$author); my $home=homeserver($uname,$udom); - &logthis("$home $udom $uname"); if (($home eq 'no_host') || ($home eq $perlvar{'lonHostID'})) { return 'not_found'; } @@ -215,6 +335,812 @@ sub subscribe { return $answer; } +# -------------------------------------------------------------- Replicate file + +sub repcopy { + my $filename=shift; + $filename=~s/\/+/\//g; + my $transname="$filename.in.transfer"; + if ((-e $filename) || (-e $transname)) { return OK; } + my $remoteurl=subscribe($filename); + if ($remoteurl eq 'con_lost') { + &logthis("Subscribe returned con_lost: $filename"); + return HTTP_SERVICE_UNAVAILABLE; + } elsif ($remoteurl eq 'not_found') { + &logthis("Subscribe returned not_found: $filename"); + return HTTP_NOT_FOUND; + } elsif ($remoteurl eq 'rejected') { + &logthis("Subscribe returned rejected: $filename"); + return FORBIDDEN; + } elsif ($remoteurl eq 'directory') { + return OK; + } else { + my @parts=split(/\//,$filename); + my $path="/$parts[1]/$parts[2]/$parts[3]/$parts[4]"; + if ($path ne "$perlvar{'lonDocRoot'}/res") { + &logthis("Malconfiguration for replication: $filename"); + return HTTP_BAD_REQUEST; + } + my $count; + for ($count=5;$count<$#parts;$count++) { + $path.="/$parts[$count]"; + if ((-e $path)!=1) { + mkdir($path,0777); + } + } + my $ua=new LWP::UserAgent; + my $request=new HTTP::Request('GET',"$remoteurl"); + my $response=$ua->request($request,$transname); + if ($response->is_error()) { + unlink($transname); + my $message=$response->status_line; + &logthis("WARNING:" + ." LWP get: $message: $filename"); + return HTTP_SERVICE_UNAVAILABLE; + } else { + if ($remoteurl!~/\.meta$/) { + my $mrequest=new HTTP::Request('GET',$remoteurl.'.meta'); + my $mresponse=$ua->request($mrequest,$filename.'.meta'); + if ($mresponse->is_error()) { + unlink($filename.'.meta'); + &logthis( + "INFO: No metadata: $filename"); + } + } + rename($transname,$filename); + return OK; + } + } +} + +# --------------------------------------------------------- Server Side Include + +sub ssi { + + my ($fn,%form)=@_; + + my $ua=new LWP::UserAgent; + + my $request; + + if (%form) { + $request=new HTTP::Request('POST',"http://".$ENV{'HTTP_HOST'}.$fn); + $request->content(join '&', map { "$_=$form{$_}" } keys %form); + } else { + $request=new HTTP::Request('GET',"http://".$ENV{'HTTP_HOST'}.$fn); + } + + $request->header(Cookie => $ENV{'HTTP_COOKIE'}); + my $response=$ua->request($request); + + return $response->content; +} + +# ------------------------------------------------------------------------- Log + +sub log { + my ($dom,$nam,$hom,$what)=@_; + return reply("log:$dom:$nam:$what",$hom); +} + +# ----------------------------------------------------------------------- Store + +sub store { + my %storehash=@_; + my $symb; + unless ($symb=escape(&symbread($ENV{'request.filename'}))) { return ''; } + my $namespace; + unless ($namespace=$ENV{'request.course.id'}) { return ''; } + my $namevalue=''; + map { + $namevalue.=escape($_).'='.escape($storehash{$_}).'&'; + } keys %storehash; + $namevalue=~s/\&$//; + return reply( + "store:$ENV{'user.domain'}:$ENV{'user.name'}:$namespace:$symb:$namevalue", + "$ENV{'user.home'}"); +} + +# --------------------------------------------------------------------- Restore + +sub restore { + my $symb; + unless ($symb=escape(&symbread($ENV{'request.filename'}))) { return ''; } + my $namespace; + unless ($namespace=$ENV{'request.course.id'}) { return ''; } + my $answer=reply( + "restore:$ENV{'user.domain'}:$ENV{'user.name'}:$namespace:$symb", + "$ENV{'user.home'}"); + my %returnhash=(); + map { + my ($name,$value)=split(/\=/,$_); + $returnhash{&unescape($name)}=&unescape($value); + } split(/\&/,$answer); + map { + $returnhash{$_}=$returnhash{$returnhash{'version'}.':'.$_}; + } split(/\:/,$returnhash{$returnhash{'version'}.':keys'}); + return %returnhash; +} + +# ---------------------------------------------------------- Course Description + +sub coursedescription { + my $courseid=shift; + $courseid=~s/^\///; + my ($cdomain,$cnum)=split(/\//,$courseid); + my $chome=homeserver($cnum,$cdomain); + if ($chome ne 'no_host') { + my $rep=reply("dump:$cdomain:$cnum:environment",$chome); + if ($rep ne 'con_lost') { + my %cachehash=(); + my %returnhash=('home' => $chome, + 'domain' => $cdomain, + 'num' => $cnum); + map { + my ($name,$value)=split(/\=/,$_); + $name=&unescape($name); + $value=&unescape($value); + $returnhash{$name}=$value; + if ($name eq 'description') { + $cachehash{$courseid}=$value; + } + } split(/\&/,$rep); + $returnhash{'url'}='/res/'.declutter($returnhash{'url'}); + $returnhash{'fn'}=$perlvar{'lonDaemons'}.'/tmp/'. + $ENV{'user.name.'}.'_'.$cdomain.'_'.$cnum; + put ('coursedescriptions',%cachehash); + return %returnhash; + } + } + return (); +} + +# -------------------------------------------------------- Get user priviledges + +sub rolesinit { + my ($domain,$username,$authhost)=@_; + my $rolesdump=reply("dump:$domain:$username:roles",$authhost); + if (($rolesdump eq 'con_lost') || ($rolesdump eq '')) { return ''; } + my %allroles=(); + my %thesepriv=(); + my $now=time; + my $userroles="user.login.time=$now\n"; + my $thesestr; + + if ($rolesdump ne '') { + map { + if ($_!~/^rolesdef\&/) { + my ($area,$role)=split(/=/,$_); + $area=~s/\_\w\w$//; + my ($trole,$tend,$tstart)=split(/_/,$role); + $userroles.='user.role.'.$trole.'.'.$area.'='. + $tstart.'.'.$tend."\n"; + if ($tend!=0) { + if ($tend<$now) { + $trole=''; + } + } + if ($tstart!=0) { + if ($tstart>$now) { + $trole=''; + } + } + if (($area ne '') && ($trole ne '')) { + my ($tdummy,$tdomain,$trest)=split(/\//,$area); + if ($trole =~ /^cr\//) { + my ($rdummy,$rdomain,$rauthor,$rrole)=split(/\//,$trole); + my $homsvr=homeserver($rauthor,$rdomain); + if ($hostname{$homsvr} ne '') { + my $roledef= + reply("get:$rdomain:$rauthor:roles:rolesdef_$rrole", + $homsvr); + if (($roledef ne 'con_lost') && ($roledef ne '')) { + my ($syspriv,$dompriv,$coursepriv)= + split(/\_/,unescape($roledef)); + $allroles{'/'}.=':'.$syspriv; + if ($tdomain ne '') { + $allroles{'/'.$tdomain.'/'}.=':'.$dompriv; + if ($trest ne '') { + $allroles{$area}.=':'.$coursepriv; + } + } + } + } + } else { + $allroles{'/'}.=':'.$pr{$trole.':s'}; + if ($tdomain ne '') { + $allroles{'/'.$tdomain.'/'}.=':'.$pr{$trole.':d'}; + if ($trest ne '') { + $allroles{$area}.=':'.$pr{$trole.':c'}; + } + } + } + } + } + } split(/&/,$rolesdump); + map { + %thesepriv=(); + map { + if ($_ ne '') { + my ($priviledge,$restrictions)=split(/&/,$_); + if ($restrictions eq '') { + $thesepriv{$priviledge}='F'; + } else { + if ($thesepriv{$priviledge} ne 'F') { + $thesepriv{$priviledge}.=$restrictions; + } + } + } + } split(/:/,$allroles{$_}); + $thesestr=''; + map { $thesestr.=':'.$_.'&'.$thesepriv{$_}; } keys %thesepriv; + $userroles.='user.priv.'.$_.'='.$thesestr."\n"; + } keys %allroles; + } + return $userroles; +} + +# --------------------------------------------------------------- get interface + +sub get { + my ($namespace,@storearr)=@_; + my $items=''; + map { + $items.=escape($_).'&'; + } @storearr; + $items=~s/\&$//; + my $rep=reply("get:$ENV{'user.domain'}:$ENV{'user.name'}:$namespace:$items", + $ENV{'user.home'}); + my @pairs=split(/\&/,$rep); + my %returnhash=(); + map { + my ($key,$value)=split(/=/,$_); + $returnhash{unescape($key)}=unescape($value); + } @pairs; + return %returnhash; +} + +# --------------------------------------------------------------- del interface + +sub del { + my ($namespace,@storearr)=@_; + my $items=''; + map { + $items.=escape($_).'&'; + } @storearr; + $items=~s/\&$//; + return reply("del:$ENV{'user.domain'}:$ENV{'user.name'}:$namespace:$items", + $ENV{'user.home'}); +} + +# -------------------------------------------------------------- dump interface + +sub dump { + my $namespace=shift; + my $rep=reply("dump:$ENV{'user.domain'}:$ENV{'user.name'}:$namespace", + $ENV{'user.home'}); + my @pairs=split(/\&/,$rep); + my %returnhash=(); + map { + my ($key,$value)=split(/=/,$_); + $returnhash{unescape($key)}=unescape($value); + } @pairs; + return %returnhash; +} + +# --------------------------------------------------------------- put interface + +sub put { + my ($namespace,%storehash)=@_; + my $items=''; + map { + $items.=escape($_).'='.escape($storehash{$_}).'&'; + } keys %storehash; + $items=~s/\&$//; + return reply("put:$ENV{'user.domain'}:$ENV{'user.name'}:$namespace:$items", + $ENV{'user.home'}); +} + +# -------------------------------------------------------------- eget interface + +sub eget { + my ($namespace,@storearr)=@_; + my $items=''; + map { + $items.=escape($_).'&'; + } @storearr; + $items=~s/\&$//; + my $rep=reply("eget:$ENV{'user.domain'}:$ENV{'user.name'}:$namespace:$items", + $ENV{'user.home'}); + my @pairs=split(/\&/,$rep); + my %returnhash=(); + map { + my ($key,$value)=split(/=/,$_); + $returnhash{unescape($key)}=unescape($value); + } @pairs; + return %returnhash; +} + +# ------------------------------------------------- Check for a user priviledge + +sub allowed { + my ($priv,$uri)=@_; + $uri=~s/^\/res//; + $uri=~s/^\///; + +# Free bre access to adm resources + + if (($uri=~/^adm\//) && ($priv eq 'bre')) { + return 'F'; + } + +# Gather priviledges over system and domain + + my $thisallowed=''; + if ($ENV{'user.priv./'}=~/$priv\&([^\:]*)/) { + $thisallowed.=$1; + } + if ($ENV{'user.priv./'.(split(/\//,$uri))[0].'/'}=~/$priv\&([^\:]*)/) { + $thisallowed.=$1; + } + +# Full access at system or domain level? Exit. + + if ($thisallowed=~/F/) { + return 'F'; + } + +# The user does not have full access at system or domain level +# Course level access control + +# uri itself refering to a course? + + if ($uri=~/\.course$/) { + if ($ENV{'user.priv./'.$uri}=~/$priv\&([^\:]*)/) { + $thisallowed.=$1; + } +# Full access on course level? Exit. + if ($thisallowed=~/F/) { + return 'F'; + } + +# uri is refering to an individual resource; user needs to be in a course + + } else { + + unless(defined($ENV{'request.course.id'})) { + return '1'; + } + +# Get access priviledges for course + + if ($ENV{'user.priv./'.$ENV{'request.course.id'}}=~/$priv\&([^\:]*)/) { + $thisallowed.=$1; + } + +# See if resource or referer is part of this course + + my @uriparts=split(/\//,$uri); + my $urifile=$uriparts[$#uriparts]; + $urifile=~/\.(\w+)$/; + my $uritype=$1; + $#uriparts--; + my $uripath=join('/',@uriparts); + my $uricond=-1; + if ($ENV{'acc.res.'.$ENV{'request.course.id'}.'.'.$uripath}=~ + /\&$urifile\:(\d+)\&/) { + $uricond=$1; + } elsif (($fe{$uritype} eq 'emb') || ($fe{$uritype} eq 'img')) { + my $refuri=$ENV{'HTTP_REFERER'}; + $refuri=~s/^\/res//; + $refuri=~s/^\///; + @uriparts=split(/\//,$refuri); + $urifile=$uriparts[$#uriparts]; + $#uriparts--; + $uripath=join('/',@uriparts); + if ($ENV{'acc.res.'.$ENV{'request.course.id'}.'.'.$uripath}=~ + /\&$urifile\:(\d+)\&/) { + $uricond=$1; + } + } + + if ($uricond>=0) { + +# The resource is part of the course +# If user had full access on course level, go ahead + + if ($thisallowed=~/F/) { + return 'F'; + } + +# Restricted by state? + + if ($thisallowed=~/X/) { + if (&condval($uricond)>1) { + return '2'; + } else { + return ''; + } + } + } + } + return $thisallowed; +} + +# ---------------------------------------------------------- Refresh State Info + +sub refreshstate { +} + +# ----------------------------------------------------------------- Define Role + +sub definerole { + if (allowed('mcr','/')) { + my ($rolename,$sysrole,$domrole,$courole)=@_; + map { + my ($crole,$cqual)=split(/\&/,$_); + if ($pr{'cr:s'}!~/$crole/) { return "refused:s:$crole"; } + if ($pr{'cr:s'}=~/$crole\&/) { + if ($pr{'cr:s'}!~/$crole\&\w*$cqual/) { + return "refused:s:$crole&$cqual"; + } + } + } split('/',$sysrole); + map { + my ($crole,$cqual)=split(/\&/,$_); + if ($pr{'cr:d'}!~/$crole/) { return "refused:d:$crole"; } + if ($pr{'cr:d'}=~/$crole\&/) { + if ($pr{'cr:d'}!~/$crole\&\w*$cqual/) { + return "refused:d:$crole&$cqual"; + } + } + } split('/',$domrole); + map { + my ($crole,$cqual)=split(/\&/,$_); + if ($pr{'cr:c'}!~/$crole/) { return "refused:c:$crole"; } + if ($pr{'cr:c'}=~/$crole\&/) { + if ($pr{'cr:c'}!~/$crole\&\w*$cqual/) { + return "refused:c:$crole&$cqual"; + } + } + } split('/',$courole); + my $command="encrypt:rolesput:$ENV{'user.domain'}:$ENV{'user.name'}:". + "$ENV{'user.domain'}:$ENV{'user.name'}:". + "rolesdef_$rolename=". + escape($sysrole.'_'.$domrole.'_'.$courole); + return reply($command,$ENV{'user.home'}); + } else { + return 'refused'; + } +} + +# ------------------------------------------------------------------ Plain Text + +sub plaintext { + my $short=shift; + return $prp{$short}; +} + +# ------------------------------------------------------------------ Plain Text + +sub fileembstyle { + my $ending=shift; + return $fe{$ending}; +} + +# ------------------------------------------------------------ Description Text + +sub filedecription { + my $ending=shift; + return $fd{$ending}; +} + +# ----------------------------------------------------------------- Assign Role + +sub assignrole { + my ($udom,$uname,$url,$role,$end,$start)=@_; + my $mrole; + $url=declutter($url); + if ($role =~ /^cr\//) { + unless ($url=~/\.course$/) { return 'invalid'; } + unless (allowed('ccr',$url)) { return 'refused'; } + $mrole='cr'; + } else { + unless (($url=~/\.course$/) || ($url=~/\/$/)) { return 'invalid'; } + unless (allowed('c'+$role)) { return 'refused'; } + $mrole=$role; + } + my $command="encrypt:rolesput:$ENV{'user.domain'}:$ENV{'user.name'}:". + "$udom:$uname:$url".'_'."$mrole=$role"; + if ($end) { $command.='_$end'; } + if ($start) { + if ($end) { + $command.='_$start'; + } else { + $command.='_0_$start'; + } + } + return &reply($command,&homeserver($uname,$udom)); +} + +# ---------------------------------------------------------- Assign Custom Role + +sub assigncustomrole { + my ($udom,$uname,$url,$rdom,$rnam,$rolename,$end,$start)=@_; + return &assignrole($udom,$uname,$url,'cr/'.$rdom.'/'.$rnam.'/'.$rolename, + $end,$start); +} + +# ----------------------------------------------------------------- Revoke Role + +sub revokerole { + my ($udom,$uname,$url,$role)=@_; + my $now=time; + return &assignrole($udom,$uname,$url,$role,$now); +} + +# ---------------------------------------------------------- Revoke Custom Role + +sub revokecustomrole { + my ($udom,$uname,$url,$rdom,$rnam,$rolename)=@_; + my $now=time; + return &assigncustomrole($udom,$uname,$url,$rdom,$rnam,$rolename,$now); +} + +# ------------------------------------------------------------ Directory lister + +sub dirlist { + my $uri=shift; + $uri=~s/^\///; + $uri=~s/\/$//; + my ($res,$udom,$uname,@rest)=split(/\//,$uri); + if ($udom) { + if ($uname) { + my $listing=reply('ls:'.$perlvar{'lonDocRoot'}.'/'.$uri, + homeserver($uname,$udom)); + return split(/:/,$listing); + } else { + my $tryserver; + my %allusers=(); + foreach $tryserver (keys %libserv) { + if ($hostdom{$tryserver} eq $udom) { + my $listing=reply('ls:'.$perlvar{'lonDocRoot'}.'/res/'.$udom, + $tryserver); + if (($listing ne 'no_such_dir') && ($listing ne 'empty') + && ($listing ne 'con_lost')) { + map { + my ($entry,@stat)=split(/&/,$_); + $allusers{$entry}=1; + } split(/:/,$listing); + } + } + } + my $alluserstr=''; + map { + $alluserstr.=$_.'&user:'; + } sort keys %allusers; + $alluserstr=~s/:$//; + return split(/:/,$alluserstr); + } + } else { + my $tryserver; + my %alldom=(); + foreach $tryserver (keys %libserv) { + $alldom{$hostdom{$tryserver}}=1; + } + my $alldomstr=''; + map { + $alldomstr.=$perlvar{'lonDocRoot'}.'/res/'.$_.'&domain:'; + } sort keys %alldom; + $alldomstr=~s/:$//; + return split(/:/,$alldomstr); + } +} + +# -------------------------------------------------------- Value of a Condition + +sub condval { + my $condidx=shift; + my $result=0; + if ($ENV{'request.course.id'}) { + if (defined($ENV{'acc.cond.'.$ENV{'request.course.id'}.'.'.$condidx})) { + my $operand='|'; + my @stack; + map { + if ($_ eq '(') { + push @stack,($operand,$result) + } elsif ($_ eq ')') { + my $before=pop @stack; + if (pop @stack eq '&') { + $result=$result>$before?$before:$result; + } else { + $result=$result>$before?$result:$before; + } + } elsif (($_ eq '&') || ($_ eq '|')) { + $operand=$_; + } else { + my $new= + substr($ENV{'user.state.'.$ENV{'request.course.id'}},$_,1); + if ($operand eq '&') { + $result=$result>$new?$new:$result; + } else { + $result=$result>$new?$result:$new; + } + } + } ($ENV{'acc.cond.'.$ENV{'request.course.id'}.'.'.$condidx}=~ + /(\d+|\(|\)|\&|\|)/g); + } + } + return $result; +} + +# --------------------------------------------------------- Value of a Variable + +sub varval { + my ($realm,$space,@components)=split(/\./,shift); + my $value=''; + if ($realm eq 'user') { + if ($space=~/^resource/) { + $space=~s/^resource\[//; + $space=~s/\]$//; + + } else { + } + } elsif ($realm eq 'course') { + } elsif ($realm eq 'session') { + } elsif ($realm eq 'system') { + } + return $value; +} + +# ------------------------------------------------- Update symbolic store links + +sub symblist { + my ($mapname,%newhash)=@_; + $mapname=declutter($mapname); + my %hash; + if (($ENV{'request.course.fn'}) && (%newhash)) { + if (tie(%hash,'GDBM_File',$ENV{'request.course.fn'}.'_symb.db', + &GDBM_WRCREAT,0640)) { + map { + $hash{declutter($_)}=$mapname.'___'.$newhash{$_}; + } keys %newhash; + if (untie(%hash)) { + return 'ok'; + } + } + } + return 'error'; +} + +# ------------------------------------------------------ Return symb list entry + +sub symbread { + my $thisfn=declutter(shift); + my %hash; + my %bighash; + my $syval=''; + if (($ENV{'request.course.fn'}) && ($ENV{'request.filename'})) { + if (tie(%hash,'GDBM_File',$ENV{'request.course.fn'}.'_symb.db', + &GDBM_READER,0640)) { + $syval=$hash{$thisfn}; + untie(%hash); + } +# ---------------------------------------------------------- There was an entry + if ($syval) { + unless ($syval=~/\_\d+$/) { + unless ($ENV{'form.request.prefix'}=~/\.(\d+)\_$/) { + return ''; + } + $syval.=$1; + } + } else { +# ------------------------------------------------------- Was not in symb table + if (tie(%bighash,'GDBM_File',$ENV{'request.course.fn'}.'.db', + &GDBM_READER,0640)) { +# ---------------------------------------------- Get ID(s) for current resource + my $ids=$bighash{'ids_/res/'.$thisfn}; + if ($ids) { +# ------------------------------------------------------------------- Has ID(s) + my @possibilities=split(/\,/,$ids); + if ($#possibilities==1) { + my ($mapid,$resid)=split(/\./,$ids); + $syval=declutter($bighash{'map_id_'.$mapid}).'___'.$resid; + } else { + $syval=''; + } + } + untie(%bighash) + } + } + return $syval.'___'.$thisfn; + } + return ''; +} + +# ---------------------------------------------------------- Return random seed + +sub numval { + my $txt=shift; + $txt=~tr/A-J/0-9/; + $txt=~tr/a-j/0-9/; + $txt=~tr/K-T/0-9/; + $txt=~tr/k-t/0-9/; + $txt=~tr/U-Z/0-5/; + $txt=~tr/u-z/0-5/; + $txt=~s/\D//g; + return int($txt); +} + +sub rndseed { + my $symb; + unless ($symb=&symbread($ENV{'request.filename'})) { return ''; } + my $symbchck=unpack("%32C*",$symb); + my $symbseed=numval($symb)%$symbchck; + my $namechck=unpack("%32C*",$ENV{'user.name'}); + my $nameseed=numval($ENV{'user.name'})%$namechck; + return int( $symbseed + .$nameseed + .unpack("%32C*",$ENV{'user.domain'}) + .unpack("%32C*",$ENV{'request.course.id'}) + .$namechck + .$symbchck); +} + +# ------------------------------------------------------------ Serves up a file +# returns either the contents of the file or a -1 +sub getfile { + my $file=shift; + &repcopy($file); + if (! -e $file ) { return -1; }; + my $fh=Apache::File->new($file); + my $a=''; + while (<$fh>) { $a .=$_; } + return $a +} + +sub filelocation { + my ($dir,$file) = @_; + my $location; + $file=~ s/^\s*(\S+)\s*$/$1/; ## strip off leading and trailing spaces + $file=~s/^$perlvar{'lonDocRoot'}//; + $file=~s:^/*res::; + if ( !( $file =~ m:^/:) ) { + $location = $dir. '/'.$file; + } else { + $location = '/home/httpd/html/res'.$file; + } + $location=~s://+:/:g; # remove duplicate / + while ($location=~m:/../:) {$location=~ s:/[^/]+/\.\./:/:g;} #remove dir/.. + + return $location; +} + +# ------------------------------------------------------------- Declutters URLs + +sub declutter { + my $thisfn=shift; + $thisfn=~s/^$perlvar{'lonDocRoot'}//; + $thisfn=~s/^\///; + $thisfn=~s/^res\///; + return $thisfn; +} + +# -------------------------------------------------------- Escape Special Chars + +sub escape { + my $str=shift; + $str =~ s/(\W)/"%".unpack('H2',$1)/eg; + return $str; +} + +# ----------------------------------------------------- Un-Escape Special Chars + +sub unescape { + my $str=shift; + $str =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C",hex($1))/eg; + return $str; +} # ================================================================ Main Program @@ -227,6 +1153,7 @@ if ($readit ne 'done') { while (my $configline=<$config>) { if ($configline =~ /PerlSetVar/) { my ($dummy,$varname,$varvalue)=split(/\s+/,$configline); + chomp($varvalue); $perlvar{$varname}=$varvalue; } } @@ -255,11 +1182,45 @@ if ($readit ne 'done') { } } } -$readit='done'; -&logthis('Read configuration'); +# ------------------------------------------------------------ Read permissions +{ + my $config=Apache::File->new("$perlvar{'lonTabDir'}/roles.tab"); + + while (my $configline=<$config>) { + chomp($configline); + my ($role,$perm)=split(/ /,$configline); + if ($perm ne '') { $pr{$role}=$perm; } + } } + +# -------------------------------------------- Read plain texts for permissions +{ + my $config=Apache::File->new("$perlvar{'lonTabDir'}/rolesplain.tab"); + + while (my $configline=<$config>) { + chomp($configline); + my ($short,$plain)=split(/:/,$configline); + if ($plain ne '') { $prp{$short}=$plain; } + } } -1; +# ------------------------------------------------------------- Read file types +{ + my $config=Apache::File->new("$perlvar{'lonTabDir'}/filetypes.tab"); + + while (my $configline=<$config>) { + chomp($configline); + my ($ending,$emb,@descr)=split(/\s+/,$configline); + if ($descr[0] ne '') { + $fe{$ending}=$emb; + $fd{$ending}=join(' ',@descr); + } + } +} +$readit='done'; +&logthis('INFO: Read configuration'); +} +} +1;