--- loncom/lond 2006/03/04 00:59:59 1.323 +++ loncom/lond 2006/06/24 00:36:23 1.334 @@ -2,7 +2,7 @@ # The LearningOnline Network # lond "LON Daemon" Server (port "LOND" 5663) # -# $Id: lond,v 1.323 2006/03/04 00:59:59 albertel Exp $ +# $Id: lond,v 1.334 2006/06/24 00:36:23 albertel Exp $ # # Copyright Michigan State University Board of Trustees # @@ -31,12 +31,12 @@ use strict; use lib '/home/httpd/lib/perl/'; +use LONCAPA; use LONCAPA::Configuration; use IO::Socket; use IO::File; #use Apache::File; -use Symbol; use POSIX; use Crypt::IDEA; use LWP::UserAgent(); @@ -53,15 +53,13 @@ use LONCAPA::ConfigFileEdit; use LONCAPA::lonlocal; use LONCAPA::lonssl; use Fcntl qw(:flock); -use Symbol; my $DEBUG = 0; # Non zero to enable debug log entries. my $status=''; my $lastlog=''; -my $lond_max_wait_time = 13; -my $VERSION='$Revision: 1.323 $'; #' stupid emacs +my $VERSION='$Revision: 1.334 $'; #' stupid emacs my $remoteVERSION; my $currenthostid="default"; my $currentdomainid; @@ -941,169 +939,6 @@ sub EditFile { return "ok\n"; } -#--------------------------------------------------------------- -# -# 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. -# -sub tie_domain_hash { - my ($domain,$namespace,$how,$loghead,$logtail) = @_; - - # Filter out any whitespace in the domain name: - - $domain =~ s/\W//g; - - # 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(@_); -} -# -# 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. -# -sub tie_user_hash { - my ($domain,$user,$namespace,$how,$loghead,$what) = @_; - - $namespace=~s/\//\_/g; # / -> _ - $namespace=~s/\W//g; # whitespace eliminated. - 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(@_); -} - -# 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 $args = scalar @_; - Debug(" Opening history: $file_prefix $args"); - 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; - - sub _locking_hash_tie { - my ($file_prefix,$namespace,$how,$loghead,$what) = @_; - - my ($lock); - - if ($how eq &GDBM_READER()) { - $lock=LOCK_SH; - $how=$how|&GDBM_NOLOCK(); - #if the db doesn't exist we can't read from it - if (! -e "$file_prefix.db") { - $! = 2; - return undef; - } - } elsif ($how eq &GDBM_WRCREAT()) { - $lock=LOCK_EX; - $how=$how|&GDBM_NOLOCK(); - if (! -e "$file_prefix.db") { - # doesn't exist but we need it to in order to successfully - # lock it so bring it into existance - open(TOUCH,">>$file_prefix.db"); - close(TOUCH); - } - } else { - &logthis("Unknown method $how for $file_prefix"); - die(); - } - - $sym=&Symbol::gensym(); - open($sym,"$file_prefix.db"); - my $failed=0; - eval { - local $SIG{__DIE__}='DEFAULT'; - local $SIG{ALRM}=sub { - $failed=1; - die("failed lock"); - }; - alarm($lond_max_wait_time); - flock($sym,$lock); - alarm(0); - }; - if ($failed) { - $! = 100; # throwing error # 100 - return undef; - } - return &_do_hash_tie($file_prefix,$namespace,$how,$loghead,$what); - } - - sub _locking_hash_untie { - my ($hashref) = @_; - my $result = untie(%$hashref); - flock($sym,LOCK_UN); - close($sym); - undef($sym); - return $result; - } -} - # read_profile # # Returns a set of specific entries from a user's profile file. @@ -2012,6 +1847,7 @@ sub update_resource_handler { my $reply=&reply("unsub:$fname","$clientname"); &devalidate_meta_cache($fname); unlink("$fname"); + unlink("$fname.meta"); } else { my $transname="$fname.in.transfer"; my $remoteurl=&reply("sub:$fname","$clientname"); @@ -2291,8 +2127,11 @@ sub token_auth_user_file_handler { my $reply="non_auth\n"; if (open(ENVIN,$perlvar{'lonIDsDir'}.'/'. $session.'.id')) { + flock(ENVIN,LOCK_SH); while (my $line=) { - if ($line=~ m|userfile\.\Q$fname\E\=|) { $reply="ok\n"; } + my ($envname)=split(/=/,$line,2); + $envname=&unescape($envname); + if ($envname=~ m|^userfile\.\Q$fname\E|) { $reply="ok\n"; } } close(ENVIN); &Reply($client, $reply, "$cmd:$tail"); @@ -3240,15 +3079,17 @@ sub restore_handler { ®ister_handler("restore", \&restore_handler, 0,1,0); # -# Add a chat message to to a discussion board. +# Add a chat message to a synchronous discussion board. # # Parameters: # $cmd - Request keyword. # $tail - Tail of the command. A colon separated list # containing: # cdom - Domain on which the chat board lives -# cnum - Identifier of the discussion group. -# post - Body of the posting. +# cnum - Course containing the chat board. +# newpost - Body of the posting. +# group - Optional group, if chat board is only +# accessible in a group within the course # $client - Socket open on the client. # Returns: # 1 - Indicating caller should keep on processing. @@ -3263,8 +3104,8 @@ sub send_chat_handler { my $userinput = "$cmd:$tail"; - my ($cdom,$cnum,$newpost)=split(/\:/,$tail); - &chat_add($cdom,$cnum,$newpost); + my ($cdom,$cnum,$newpost,$group)=split(/\:/,$tail); + &chat_add($cdom,$cnum,$newpost,$group); &Reply($client, "ok\n", $userinput); return 1; @@ -3272,7 +3113,7 @@ sub send_chat_handler { ®ister_handler("chatsend", \&send_chat_handler, 0, 1, 0); # -# Retrieve the set of chat messagss from a discussion board. +# Retrieve the set of chat messages from a discussion board. # # Parameters: # $cmd - Command keyword that initiated the request. @@ -3282,6 +3123,8 @@ sub send_chat_handler { # chat id - Discussion thread(?) # domain/user - Authentication domain and username # of the requesting person. +# group - Optional course group containing +# the board. # $client - Socket open on the client program. # Returns: # 1 - continue processing @@ -3294,9 +3137,9 @@ sub retrieve_chat_handler { my $userinput = "$cmd:$tail"; - my ($cdom,$cnum,$udom,$uname)=split(/\:/,$tail); + my ($cdom,$cnum,$udom,$uname,$group)=split(/\:/,$tail); my $reply=''; - foreach (&get_chat($cdom,$cnum,$udom,$uname)) { + foreach (&get_chat($cdom,$cnum,$udom,$uname,$group)) { $reply.=&escape($_).':'; } $reply=~s/\:$//; @@ -3446,10 +3289,10 @@ sub put_course_id_handler { my @new_items = split(/:/,$courseinfo); my $numnew = scalar(@new_items); if ($numcurrent > 0) { - if ($numnew == 1) { # flushcourselogs() from 1.1 or earlier - $courseinfo .= ':'.join(':',@current_items); - } elsif ($numnew == 2) { # flushcourselogs() from 1.2.X - $courseinfo .= ':'.$current_items[$numcurrent-1]; + if ($numnew <= $numcurrent) { # flushcourselogs() from pre 2.2 + for (my $j=$numcurrent-$numnew; $j>=0; $j--) { + $courseinfo .= ':'.$current_items[$numcurrent-$j-1]; + } } } $hashref->{$key}=$courseinfo.':'.$now; @@ -3509,7 +3352,8 @@ sub dump_course_id_handler { my $userinput = "$cmd:$tail"; - my ($udom,$since,$description,$instcodefilter,$ownerfilter,$coursefilter) =split(/:/,$tail); + my ($udom,$since,$description,$instcodefilter,$ownerfilter,$coursefilter, + $typefilter) =split(/:/,$tail); if (defined($description)) { $description=&unescape($description); } else { @@ -3530,16 +3374,21 @@ sub dump_course_id_handler { } else { $coursefilter='.'; } + if (defined($typefilter)) { + $typefilter=&unescape($typefilter); + } else { + $typefilter='.'; + } unless (defined($since)) { $since=0; } my $qresult=''; my $hashref = &tie_domain_hash($udom, "nohist_courseids", &GDBM_WRCREAT()); if ($hashref) { while (my ($key,$value) = each(%$hashref)) { - my ($descr,$lasttime,$inst_code,$owner); + my ($descr,$lasttime,$inst_code,$owner,$type); my @courseitems = split(/:/,$value); $lasttime = pop(@courseitems); - ($descr,$inst_code,$owner)=@courseitems; + ($descr,$inst_code,$owner,$type)=@courseitems; if ($lasttime<$since) { next; } my $match = 1; unless ($description eq '.') { @@ -3566,6 +3415,18 @@ sub dump_course_id_handler { $match = 0; } } + unless ($typefilter eq '.' || !defined($typefilter)) { + my $unescapeType = &unescape($type); + if (!defined($type)) { + if ($typefilter ne 'Course') { + $match = 0; + } + } else { + unless (eval('$unescapeType=~/^\Q$typefilter\E$/')) { + $match = 0; + } + } + } if ($match == 1) { $qresult.=$key.'='.$descr.':'.$inst_code.':'.$owner.'&'; } @@ -5173,22 +5034,6 @@ sub status { $0='lond: '.$what.' '.$local; } -# -------------------------------------------------------- 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; -} - # ----------------------------------------------------------- Send USR1 to lonc sub reconlonc { @@ -5270,18 +5115,6 @@ sub sub_sql_reply { return $answer; } -# -------------------------------------------- Return path to profile directory - -sub propath { - my ($udom,$uname)=@_; - $udom=~s/\W//g; - $uname=~s/\W//g; - my $subdir=$uname.'__'; - $subdir =~ s/(.)(.)(.).*/$1\/$2\/$3/; - my $proname="$perlvar{'lonUsersDir'}/$udom/$subdir/$uname"; - return $proname; -} - # --------------------------------------- Is this the home server of an author? sub ishome { @@ -5875,10 +5708,16 @@ sub addline { } sub get_chat { - my ($cdom,$cname,$udom,$uname)=@_; + my ($cdom,$cname,$udom,$uname,$group)=@_; my @entries=(); - my $hashref = &tie_user_hash($cdom, $cname, 'nohist_chatroom', + my $namespace = 'nohist_chatroom'; + my $namespace_inroom = 'nohist_inchatroom'; + if (defined($group)) { + $namespace .= '_'.$group; + $namespace_inroom .= '_'.$group; + } + my $hashref = &tie_user_hash($cdom, $cname, $namespace, &GDBM_READER()); if ($hashref) { @entries=map { $_.':'.$hashref->{$_} } sort(keys(%$hashref)); @@ -5886,7 +5725,7 @@ sub get_chat { } my @participants=(); my $cutoff=time-60; - $hashref = &tie_user_hash($cdom, $cname, 'nohist_inchatroom', + $hashref = &tie_user_hash($cdom, $cname, $namespace_inroom, &GDBM_WRCREAT()); if ($hashref) { $hashref->{$uname.':'.$udom}=time; @@ -5901,10 +5740,16 @@ sub get_chat { } sub chat_add { - my ($cdom,$cname,$newchat)=@_; + my ($cdom,$cname,$newchat,$group)=@_; my @entries=(); my $time=time; - my $hashref = &tie_user_hash($cdom, $cname, 'nohist_chatroom', + my $namespace = 'nohist_chatroom'; + my $logfile = 'chatroom.log'; + if (defined($group)) { + $namespace .= '_'.$group; + $logfile = 'chatroom_'.$group.'.log'; + } + my $hashref = &tie_user_hash($cdom, $cname, $namespace, &GDBM_WRCREAT()); if ($hashref) { @entries=map { $_.':'.$hashref->{$_} } sort(keys(%$hashref)); @@ -5927,7 +5772,7 @@ sub chat_add { } { my $proname=&propath($cdom,$cname); - if (open(CHATLOG,">>$proname/chatroom.log")) { + if (open(CHATLOG,">>$proname/$logfile")) { print CHATLOG ("$time:".&unescape($newchat)."\n"); } close(CHATLOG); @@ -6632,7 +6477,6 @@ to the client, and the connection is clo IO::Socket IO::File Apache::File -Symbol POSIX Crypt::IDEA LWP::UserAgent() 500 Internal Server Error

Internal Server Error

The server encountered an internal error or misconfiguration and was unable to complete your request.

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.

More information about this error may be available in the server error log.