# The LearningOnline Network # Base routines # # $Id: LONCAPA.pm,v 1.36 2019/08/25 02:43:33 raeburn Exp $ # # Copyright Michigan State University Board of Trustees # # This file is part of the LearningOnline Network with CAPA (LON-CAPA). # # LON-CAPA is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. # # LON-CAPA is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with LON-CAPA; if not, write to the Free Software # Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA # # /home/httpd/html/adm/gpl.txt # # http://www.lon-capa.org/ # ### 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 &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 'MathJax'; } # 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. sub passwd_min { return 7; } #---------------------------------------------------------------------- # # some of these subs need a bit of documentation sub add_get_param { my ($url,$form_data) = @_; my $needs_question_mark = ($url !~ /\?/); while (my ($name,$value) = each(%$form_data)) { if ($needs_question_mark) { $url.='?'; $needs_question_mark = 0; } else { $url.='&'; } $url.=$name.'='.&escape($form_data->{$name}); } return $url; } # -------------------------------------------------------- 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; } $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__ =pod =head1 NAME Apache::LONCAPA LONCAPA - Basic routines =head1 SYNOPSIS Generally useful routines =head1 EXPORTED SUBROUTINES =over =item escape() unpack non-word characters into CGI-compatible hex codes =item unescape() pack CGI-compatible hex codes into actual non-word ASCII character =item 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 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