File:
[LON-CAPA] /
loncom /
LONCAPA.pm
Revision
1.36:
download - view:
text,
annotated -
select for diffs
Sun Aug 25 02:43:33 2019 UTC (5 years, 4 months ago) by
raeburn
Branches:
MAIN
CVS tags:
version_2_12_X,
HEAD
- Domain Configuration for passwords for internally-authenticated users.
- Default minimum password length of 7 set in a single location.
- Value for min length set in domain's configuration may not be less than
the default.
- javascript function: warnIntPass() warns aboit invalid values for
min and max length, expiration time, and number saved for domain
config for passwords.
# 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 <m></m> 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 = <PIPE>;
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=<LOCK>;
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:<timestamp>: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
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>
![[BACK]](/icons/back.gif){kind=icon}
Return to LONCAPA.pm CVS log ![[TXT]](/icons/text.gif){kind=icon}
![[DIR]](/icons/dir.gif){kind=icon}
Up to [LON-CAPA] / loncom