# The LearningOnline Network
# Base routines
#
# $Id: LONCAPA.pm,v 1.33 2011/11/07 20:05:52 www 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;
}


#----------------------------------------------------------------------
#
#  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

<!DOCTYPE HTML PUBLIC "-//IETF//DTD HTML 2.0//EN">
<html><head>
<title>500 Internal Server Error</title>
</head><body>
<h1>Internal Server Error</h1>
<p>The server encountered an internal error or
misconfiguration and was unable to complete
your request.</p>
<p>Please contact the server administrator at 
 root@localhost to inform them of the time this error occurred,
 and the actions you performed just before this error.</p>
<p>More information about this error may be available
in the server error log.</p>
</body></html>