--- loncom/LONCAPA.pm 2006/05/08 22:05:54 1.1 +++ loncom/LONCAPA.pm 2019/08/25 22:29:29 1.35.2.2 @@ -1,7 +1,7 @@ # The LearningOnline Network # Base routines # -# $Id: LONCAPA.pm,v 1.1 2006/05/08 22:05:54 albertel Exp $ +# $Id: LONCAPA.pm,v 1.35.2.2 2019/08/25 22:29:29 raeburn Exp $ # # Copyright Michigan State University Board of Trustees # @@ -27,18 +27,145 @@ # ### + + package LONCAPA; use strict; +use lib '/home/httpd/lib/perl/'; +use LONCAPA::Configuration; +use Fcntl qw(:flock); +use GDBM_File; +use POSIX; +#use Apache::lonnet; + +my $loncapa_max_wait_time = 13; + + +#-------------------------------------------------------------------------- +# +# The constant definnitions below probably should really be in +# a configuration file somewhere (loncapa.conf?) and loaded so that they can be +# modified without requring source code changes: +# +# COURSE_CACHE_TIME - Number of minutes after which an unaccessed +# course.db or course_param.db file is considered +# to be a stale cache of this info. +# +# LONCAPA_TEMPDIR - Place loncapa puts temporary files +# + +my $COURSE_CACHE_TIME = 60; # minutes course cache file is considered valid. +my $LONCAPA_TEMPDIR = '/tmp/'; # relative to configuration{'lonTabDir'}. + +use vars qw($match_domain $match_not_domain + $match_username $match_not_username + $match_courseid $match_not_courseid + $match_community + $match_name + $match_lonid + $match_handle $match_not_handle); + require Exporter; our @ISA = qw (Exporter); -our @EXPORT = qw(&add_get_param &escape &unescape); +our @EXPORT = qw(&add_get_param &escape &unescape + &tie_domain_hash &untie_domain_hash &tie_user_hash + &untie_user_hash &propath &tie_course); +our @EXPORT_OK = qw($match_domain $match_not_domain + $match_username $match_not_username + $match_courseid $match_not_courseid + $match_community + $match_name + $match_lonid + $match_handle $match_not_handle &tie_course); +our %EXPORT_TAGS = ( 'match' =>[qw($match_domain $match_not_domain + $match_username $match_not_username + $match_courseid $match_not_courseid + $match_community + $match_name + $match_lonid + $match_handle $match_not_handle)],); +my %perlvar; + + +# +# If necessary fetch and tie a user's image of the course hash +# to the specified hash +# Parameters: +# domain - User's domain +# user - Name of user. +# course - Course number. +# cdom - Domain that is home to the course +# hash - reference to the has to tie. +# +# Side effects: +# a gdbm file and it's associated lock file will be created in the +# tmp directory tree. +# +# Returns: +# 0 - failure. +# 1 - success. +# +# Note: +# It's possible the required user's db file is already present in the tempdir. +# in that case a decision must be made about whether or not to just tie to it +# or to fetch it again. Remember this sub could be called in the context of a user +# other than the one whose data are being fetched. We don't know if that user already +# has a live session on this server. What we'll do is only re-fetch if the hash atime. +# is older than COURSE_CACHE_TIME...that is if it's been accessed relatively recently +# where COURSE_CACHE_TIME defines the caching time. +# +# The database files this function creates are of the form: +# $user@$domain_$course@$cdom.{db,lock} +# This differs from the prior filenames. Therefore if a module does its own +# caching (That's a coding no-no) and does not use this centralized sub, +# multiple cache files for the same course/user will be created. +# +sub tie_course { + my ($domain, $user, $course, $cdom, $hash) = @_; + + # + # See if we need to re-fetch the course data + # + + +} + +# Return a string that is the path in which loncapa puts temp files: + +sub tempdir { + my $result = $perlvar{'lonDaemons'}.$LONCAPA_TEMPDIR; # to allow debugging. + return $result; +} + +# Return the default engine to use to render content of tags unless +# a domain, course, or user specific value exists. + +sub texengine { + return 'tth'; +} + +# Return the Linux distro where this LON-CAPA instance is running + +sub distro { + my $distro; + if (open(PIPE,"/home/httpd/perl/distprobe |")) { + $distro = ; + close(PIPE); + } + return $distro; +} + +# Return the default password length. Can be overridden in a domain +# by specifying a larger value (integer) in the domain configuration. -# Inputs are a url, adn a hash ref of -# form name => value pairs -# takes care of properly adding the form name elements and values to the -# the url doing proper escaping of the values and joining with ? or & as -# needed +sub passwd_min { + return 7; +} + +#---------------------------------------------------------------------- +# +# some of these subs need a bit of documentation sub add_get_param { my ($url,$form_data) = @_; @@ -72,6 +199,323 @@ sub unescape { return $str; } +$LONCAPA::assess_re = qr{\.(problem|exam|quiz|assess|survey|form|library|task)$}; +$LONCAPA::assess_page_re = qr{\.(problem|exam|quiz|assess|survey|form|library|task|page)$}; +$LONCAPA::assess_page_seq_re = qr{\.(problem|exam|quiz|assess|survey|form|library|task|sequence|page)$}; +$LONCAPA::parse_re = qr{\.(problem|exam|quiz|assess|survey|form|library|page|xml|html|htm|xhtml|xhtm)$}; +$LONCAPA::parse_page_re = qr{\.(problem|exam|quiz|assess|survey|form|library|page|xml|html|htm|xhtml|xhtm|page)$}; +$LONCAPA::parse_page_sty_re = qr{\.(problem|exam|quiz|assess|survey|form|library|page|xml|html|htm|xhtml|xhtm|page|sty)$}; + + +$match_domain = $LONCAPA::domain_re = qr{[[:alnum:]\-.]+}; +$match_not_domain = $LONCAPA::not_domain_re = qr{[^[:alnum:]\-.]+}; +sub clean_domain { + my ($domain) = @_; + $domain =~ s/$match_not_domain//g; + return $domain; +} + +$match_username = $LONCAPA::username_re = qr{\w[\w\-.@]+}; +$match_not_username = $LONCAPA::not_username_re = qr{[^\w\-.@]+}; +sub clean_username { + my ($username) = @_; + $username =~ s/^\W+//; + $username =~ s/$match_not_username//g; + return $username; +} + + +$match_courseid = $LONCAPA::courseid_re = qr{\d[\w\-.]+}; +$match_community =$LONCAPA::community_re = qr{0[\w\-.]+}; +$match_not_courseid = $LONCAPA::not_courseid_re = qr{[^\w\-.]+}; +sub clean_courseid { + my ($courseid) = @_; + $courseid =~ s/^\D+//; + $courseid =~ s/$match_not_courseid//g; + return $courseid; +} + +$match_name = $LONCAPA::name_re = qr{$match_username|$match_courseid}; +sub clean_name { + my ($name) = @_; + $name =~ s/$match_not_username//g; + return $name; +} + +$match_lonid = $LONCAPA::lonid_re = qr{[\w\-.]+}; + +sub split_courseid { + my ($courseid) = @_; + my ($domain,$coursenum) = + ($courseid=~m{^/($match_domain)/($match_courseid)}); + return ($domain,$coursenum); +} + +$match_handle = $LONCAPA::handle_re = qr{[\w\-.@]+}; +$match_not_handle = $LONCAPA::not_handle_re = qr{[^\w\-.@]+}; +sub clean_handle { + my ($handle) = @_; + $handle =~ s/$match_not_handle//g; + return $handle; +} + +# +# -- Ensure another process for same filesystem action is not running. +# lond uses for: apachereload; loncron uses for: lciptables +# + +sub try_to_lock { + my ($lockfile)=@_; + my $currentpid; + my $lastpid; + # Do not manipulate lock file as root + if ($>==0) { + return 0; + } + # Try to generate lock file. + # Wait 3 seconds. If same process id is in + # lock file, then assume lock file is stale, and + # go ahead. If process id's fluctuate, try + # for a maximum of 10 times. + for (0..10) { + if (-e $lockfile) { + open(LOCK,"<$lockfile"); + $currentpid=; + close LOCK; + if ($currentpid==$lastpid) { + last; + } + sleep 3; + $lastpid=$currentpid; + } else { + last; + } + if ($_==10) { + return 0; + } + } + open(LOCK,">$lockfile"); + print LOCK $$; + close LOCK; + return 1; +} + +# -------------------------------------------- Return path to profile directory + +sub propath { + my ($udom,$uname)=@_; + $udom = &clean_domain($udom); + $uname= &clean_name($uname); + my $subdir=$uname.'__'; + $subdir =~ s/(.)(.)(.).*/$1\/$2\/$3/; + my $proname="$perlvar{'lonUsersDir'}/$udom/$subdir/$uname"; + return $proname; +} + +sub tie_domain_hash { + my ($domain,$namespace,$how,$loghead,$logtail) = @_; + + # Filter out any whitespace in the domain name: + + $domain = &clean_domain($domain); + + # We have enough to go on to tie the hash: + + my $user_top_dir = $perlvar{'lonUsersDir'}; + my $domain_dir = $user_top_dir."/$domain"; + my $resource_file = $domain_dir."/$namespace"; + return &_locking_hash_tie($resource_file,$namespace,$how,$loghead,$logtail); +} + +sub untie_domain_hash { + return &_locking_hash_untie(@_); +} + + +sub tie_user_hash { + my ($domain,$user,$namespace,$how,$loghead,$what) = @_; + + $namespace=~s{/}{_}g; # / -> _ + $namespace = &clean_username($namespace); + my $proname = &propath($domain, $user); + my $file_prefix="$proname/$namespace"; + return &_locking_hash_tie($file_prefix,$namespace,$how,$loghead,$what); +} + +sub untie_user_hash { + return &_locking_hash_untie(@_); +} + + +sub locking_hash_tie { + my ($filename,$how)=@_; + my ($file_prefix,$namespace)=&db_filename_parts($filename); + if ($namespace eq '') { return undef; } + return &_locking_hash_tie($file_prefix,$namespace,$how); +} + +sub locking_hash_untie { + return &_locking_hash_untie(@_); +} + +sub db_filename_parts { + my ($filename)=@_; + my ($file_path,$namespace)=($filename=~/^(.*)\/([^\/]+)\.db$/); + if ($namespace eq '') { return undef; } + return ($file_path.'/'.$namespace,$namespace); +} + +# internal routines that handle the actual tieing and untieing process + +sub _do_hash_tie { + my ($file_prefix,$namespace,$how,$loghead,$what) = @_; + my %hash; + if(tie(%hash, 'GDBM_File', "$file_prefix.db", $how, 0640)) { + # If this is a namespace for which a history is kept, + # make the history log entry: + if (($namespace !~/^nohist\_/) && (defined($loghead))) { + my $hfh = IO::File->new(">>$file_prefix.hist"); + if($hfh) { + my $now = time(); + print $hfh ("$loghead:$now:$what\n"); + } + $hfh->close; + } + return \%hash; + } else { + return undef; + } +} + +sub _do_hash_untie { + my ($hashref) = @_; + my $result = untie(%$hashref); + return $result; +} + +{ + my $sym; + my @pushed_syms; + + sub clean_sym { + undef($sym); + } + sub push_locking_hash_tie { + if (!defined($sym)) { + die("Invalid used of push_locking_hash_tie, should only be called after a lock has occurred and before and unlock."); + } + push(@pushed_syms,$sym); + undef($sym); + } + + sub pop_locking_hash_tie { + if (defined($sym)) { + die("Invalid nested used of pop_locking_hash_tie, should only be called after a unlock has occurred."); + } + $sym = pop(@pushed_syms); + } + + sub _locking_hash_tie { + my ($file_prefix,$namespace,$how,$loghead,$what) = @_; + if (defined($sym)) { + die('Nested locking attempted without proper use of push_locking_hash_tie, this is unsupported'); + } + + my $lock_type=LOCK_SH; +# Are we reading or writing? + if ($how eq &GDBM_READER()) { +# We are reading + if (!open($sym,"$file_prefix.db.lock")) { +# We don't have a lock file. This could mean +# - that there is no such db-file +# - that it does not have a lock file yet + if ((! -e "$file_prefix.db") && (! -e "$file_prefix.db.gz")) { +# No such file. Forget it. + $! = 2; + &clean_sym(); + return undef; + } +# Apparently just no lock file yet. Make one + open($sym,">>$file_prefix.db.lock"); + } +# Do a shared lock + if (!&flock_sym(LOCK_SH)) { + &clean_sym(); + return undef; + } +# If this is compressed, we will actually need an exclusive lock + if (-e "$file_prefix.db.gz") { + if (!&flock_sym(LOCK_EX)) { + &clean_sym(); + return undef; + } + } + } elsif ($how eq &GDBM_WRCREAT()) { +# We are writing + open($sym,">>$file_prefix.db.lock"); +# Writing needs exclusive lock + if (!&flock_sym(LOCK_EX)) { + &clean_sym(); + return undef; + } + } else { + die("Unknown method $how for $file_prefix"); + } +# The file is ours! +# If it is archived, un-archive it now + if (-e "$file_prefix.db.gz") { + system("gunzip $file_prefix.db.gz"); + if (-e "$file_prefix.hist.gz") { + system("gunzip $file_prefix.hist.gz"); + } + } +# Change access mode to non-blocking + $how=$how|&GDBM_NOLOCK(); +# Go ahead and tie the hash + my $result = + &_do_hash_tie($file_prefix,$namespace,$how,$loghead,$what); + if (!$result) { + &clean_sym(); + } + return $result; + } + + sub flock_sym { + my ($lock_type)=@_; + my $failed=0; + eval { + local $SIG{__DIE__}='DEFAULT'; + local $SIG{ALRM}=sub { + $failed=1; + die("failed lock"); + }; + alarm($loncapa_max_wait_time); + flock($sym,$lock_type); + alarm(0); + }; + if ($failed) { + $! = 100; # throwing error # 100 + return undef; + } else { + return 1; + } + } + + sub _locking_hash_untie { + my ($hashref) = @_; + my $result = untie(%$hashref); + flock($sym,LOCK_UN); + close($sym); + &clean_sym(); + return $result; + } +} + + +BEGIN { + %perlvar=%{&LONCAPA::Configuration::read_conf('loncapa.conf')}; +} + 1; __END__ @@ -80,6 +524,8 @@ __END__ =head1 NAME +Apache::LONCAPA + LONCAPA - Basic routines =head1 SYNOPSIS @@ -88,25 +534,129 @@ Generally useful routines =head1 EXPORTED SUBROUTINES -=over 4 +=over -=item * +=item escape() -escape() : unpack non-word characters into CGI-compatible hex codes +unpack non-word characters into CGI-compatible hex codes -=item * +=item unescape() -unescape() : pack CGI-compatible hex codes into actual non-word ASCII character + pack CGI-compatible hex codes into actual non-word ASCII character -=item * +=item add_get_param() -add_get_param() : +Append escaped form elements (name=value etc.) to a url. + Inputs: url (with or without exit GET from parameters), hash ref of form name => value pairs - Return: url with properly added the form name elements and values to the - the url doing proper escaping of the values and joining with ? or & + Return: url with form name elements and values appended to the + the url, doing proper escaping of the values and joining with ? or & as needed +=item clean_handle() + +=item propath() + +=item untie_domain_hash() + +=item tie_domain_hash() + +Manipulation of hash based databases (factoring out common code +for later use as we refactor. + + Ties a domain level resource file to a hash. + If requested a history entry is created in the associated hist file. + + Parameters: + domain - Name of the domain in which the resource file lives. + namespace - Name of the hash within that domain. + how - How to tie the hash (e.g. GDBM_WRCREAT()). + loghead - Optional parameter, if present a log entry is created + in the associated history file and this is the first part + of that entry. + logtail - Goes along with loghead, The actual logentry is of the + form $loghead::logtail. +Returns: + Reference to a hash bound to the db file or alternatively undef + if the tie failed. + +=item tie_user_hash() + + Ties a user's resource file to a hash. + If necessary, an appropriate history + log file entry is made as well. + This sub factors out common code from the subs that manipulate + the various gdbm files that keep keyword value pairs. +Parameters: + domain - Name of the domain the user is in. + user - Name of the 'current user'. + namespace - Namespace representing the file to tie. + how - What the tie is done to (e.g. GDBM_WRCREAT(). + loghead - Optional first part of log entry if there may be a + history file. + what - Optional tail of log entry if there may be a history + file. +Returns: + hash to which the database is tied. It's up to the caller to untie. + undef if the has could not be tied. + +=item tie_course + +Caches the course database into the temp directory in the context of a specific +user and ties it to a hash. +Parameters: + domain - Domain the user is in. + user - Username of the user. + course - Course specification + cdom - The course domain. + hash - Reference to the hash to tie. + +Returns: + 1 - Success + 0 - Failure. + +=item tie_course_params + +Caches the course parameter database into the temp directory in the context +of a specific user and ties it to a hash. +Parameters: + domain - Domain the user is in. + user - Username of the user. + course - course specification. + cdom - The course domain. + hash - reference to the hash to tie. + +Returns: + 1 - Success. + 0 - Failure./ + + +=item locking_hash_tie() + +routines if you just have a filename return tied hashref or undef + +=item locking_hash_untie() + +=item db_filename_parts() + +=back + +=item tempdir() + +Returns the file system path to the place loncapa temporary files should be placed/found. + + +=head1 INTERNAL SUBROUTINES + +=over + +=item _do_hash_tie() + +=item _do_hash_untie() + =back +=cut +