--- loncom/lond 2006/02/09 20:23:28 1.318.2.1
+++ loncom/lond 2006/05/13 01:31:15 1.326
@@ -2,7 +2,7 @@
# The LearningOnline Network
# lond "LON Daemon" Server (port "LOND" 5663)
#
-# $Id: lond,v 1.318.2.1 2006/02/09 20:23:28 albertel Exp $
+# $Id: lond,v 1.326 2006/05/13 01:31:15 www Exp $
#
# Copyright Michigan State University Board of Trustees
#
@@ -31,6 +31,7 @@
use strict;
use lib '/home/httpd/lib/perl/';
+use LONCAPA;
use LONCAPA::Configuration;
use IO::Socket;
@@ -61,7 +62,7 @@ my $status='';
my $lastlog='';
my $lond_max_wait_time = 13;
-my $VERSION='$Revision: 1.318.2.1 $'; #' stupid emacs
+my $VERSION='$Revision: 1.326 $'; #' stupid emacs
my $remoteVERSION;
my $currenthostid="default";
my $currentdomainid;
@@ -1050,6 +1051,41 @@ sub _do_hash_untie {
sub _locking_hash_tie {
my ($file_prefix,$namespace,$how,$loghead,$what) = @_;
+# is this locked by an external program?
+
+ if (-e "$file_prefix.db.lock") {
+ my $failed=0;
+ eval {
+ local $SIG{__DIE__}='DEFAULT';
+ local $SIG{ALRM}=sub {
+ $failed=1;
+ die("failed lock");
+ };
+ alarm(2*$lond_max_wait_time);
+ while (-e "$file_prefix.db.lock") {}
+ alarm(0);
+ };
+ if ($failed) {
+ $! = 100; # throwing error # 100
+ return undef;
+ }
+ }
+
+# is this archived?
+
+ if (-e "$file_prefix.db.gz") {
+# lock immediately
+ open(TOUCH,">>$file_prefix.db.lock");
+ close(TOUCH);
+ system("gunzip $file_prefix.db.gz");
+ if (-e "$file_prefix.hist.gz") {
+ system("gunzip $file_prefix.hist.gz");
+ }
+# all set, unlock
+ unlink("$file_prefix.db.lock");
+ }
+
+
my ($lock);
if ($how eq &GDBM_READER()) {
@@ -3068,11 +3104,10 @@ sub store_handler {
my $version=$hashref->{"version:$rid"};
my $allkeys='';
foreach my $pair (@pairs) {
- my ($key)=split(/=/,$pair);
+ my ($key,$value)=split(/=/,$pair);
$allkeys.=$key.':';
+ $hashref->{"$version:$rid:$key"}=$value;
}
- $hashref->{"$version:$rid"}=$what;
-
$hashref->{"$version:$rid:timestamp"}=$now;
$allkeys.='timestamp';
$hashref->{"$version:keys:$rid"}=$allkeys;
@@ -3094,6 +3129,85 @@ sub store_handler {
}
®ister_handler("store", \&store_handler, 0, 1, 0);
+# Modify a set of key=value pairs associated with a versioned name.
+#
+# Parameters:
+# $cmd - Request command keyword.
+# $tail - Tail of the request. This is a colon
+# separated list containing:
+# domain/user - User and authentication domain.
+# namespace - Name of the database being modified
+# rid - Resource keyword to modify.
+# v - Version item to modify
+# what - new value associated with rid.
+#
+# $client - Socket open on the client.
+#
+#
+# Returns:
+# 1 (keep on processing).
+# Side-Effects:
+# Writes to the client
+sub putstore_handler {
+ my ($cmd, $tail, $client) = @_;
+
+ my $userinput = "$cmd:$tail";
+
+ my ($udom,$uname,$namespace,$rid,$v,$what) =split(/:/,$tail);
+ if ($namespace ne 'roles') {
+
+ chomp($what);
+ my $hashref = &tie_user_hash($udom, $uname, $namespace,
+ &GDBM_WRCREAT(), "M",
+ "$rid:$v:$what");
+ if ($hashref) {
+ my $now = time;
+ my %data = &hash_extract($what);
+ my @allkeys;
+ while (my($key,$value) = each(%data)) {
+ push(@allkeys,$key);
+ $hashref->{"$v:$rid:$key"} = $value;
+ }
+ my $allkeys = join(':',@allkeys);
+ $hashref->{"$v:keys:$rid"}=$allkeys;
+
+ if (&untie_user_hash($hashref)) {
+ &Reply($client, "ok\n", $userinput);
+ } else {
+ &Failure($client, "error: ".($!+0)." untie(GDBM) Failed ".
+ "while attempting store\n", $userinput);
+ }
+ } else {
+ &Failure( $client, "error: ".($!+0)." tie(GDBM) Failed ".
+ "while attempting store\n", $userinput);
+ }
+ } else {
+ &Failure($client, "refused\n", $userinput);
+ }
+
+ return 1;
+}
+®ister_handler("putstore", \&putstore_handler, 0, 1, 0);
+
+sub hash_extract {
+ my ($str)=@_;
+ my %hash;
+ foreach my $pair (split(/\&/,$str)) {
+ my ($key,$value)=split(/=/,$pair);
+ $hash{$key}=$value;
+ }
+ return (%hash);
+}
+sub hash_to_str {
+ my ($hash_ref)=@_;
+ my $str;
+ foreach my $key (keys(%$hash_ref)) {
+ $str.=$key.'='.$hash_ref->{$key}.'&';
+ }
+ $str=~s/\&$//;
+ return $str;
+}
+
#
# Dump out all versions of a resource that has key=value pairs associated
# with it for each version. These resources are built up via the store
@@ -3139,17 +3253,9 @@ sub restore_handler {
my @keys=split(/:/,$vkeys);
my $key;
$qresult.="$scope:keys=$vkeys&";
- if (exists($hashref->{"$scope:$rid"})) {
- my $what=$hashref->{"$scope:$rid"};
- foreach my $pair (split(/\&/,$hashref->{"$scope:$rid"})) {
- my ($key,$value)=split(/=/,$pair);
- $qresult.="$scope:".$pair."&";
- }
- } else {
- foreach $key (@keys) {
- $qresult.="$scope:$key=".$hashref->{"$scope:$rid:$key"}."&";
- }
- }
+ foreach $key (@keys) {
+ $qresult.="$scope:$key=".$hashref->{"$scope:$rid:$key"}."&";
+ }
}
if (&untie_user_hash($hashref)) {
$qresult=~s/\&$//;
@@ -3170,15 +3276,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.
@@ -3193,8 +3301,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;
@@ -3202,7 +3310,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.
@@ -3212,6 +3320,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
@@ -3224,9 +3334,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/\:$//;
@@ -4357,10 +4467,19 @@ sub photo_permission_handler {
my $userinput = "$cmd:$tail";
my $cdom = $tail;
my ($perm_reqd,$conditions);
- my $outcome = &localenroll::photo_permission($cdom,\$perm_reqd,
- \$conditions);
- &Reply($client, &escape($outcome.':'.$perm_reqd.':'. $conditions)."\n",
- $userinput);
+ my $outcome;
+ eval {
+ local($SIG{__DIE__})='DEFAULT';
+ $outcome = &localenroll::photo_permission($cdom,\$perm_reqd,
+ \$conditions);
+ };
+ if (!$@) {
+ &Reply($client, &escape($outcome.':'.$perm_reqd.':'. $conditions)."\n",
+ $userinput);
+ } else {
+ &Failure($client,"unknown_cmd\n",$userinput);
+ }
+ return 1;
}
®ister_handler("autophotopermission",\&photo_permission_handler,0,1,0);
@@ -4385,6 +4504,7 @@ sub photo_check_handler {
my $result = &localstudentphoto::fetch($udom,$uname,$pid,\$response);
$result .= ':'.$response;
&Reply($client, &escape($result)."\n",$userinput);
+ return 1;
}
®ister_handler("autophotocheck",\&photo_check_handler,0,1,0);
@@ -4398,8 +4518,17 @@ sub photo_choice_handler {
my ($cmd, $tail, $client) = @_;
my $userinput = "$cmd:$tail";
my $cdom = &unescape($tail);
- my ($update,$comment) = &localenroll::manager_photo_update($cdom);
- &Reply($client,&escape($update).':'.&escape($comment)."\n",$userinput);
+ my ($update,$comment);
+ eval {
+ local($SIG{__DIE__})='DEFAULT';
+ ($update,$comment) = &localenroll::manager_photo_update($cdom);
+ };
+ if (!$@) {
+ &Reply($client,&escape($update).':'.&escape($comment)."\n",$userinput);
+ } else {
+ &Failure($client,"unknown_cmd\n",$userinput);
+ }
+ return 1;
}
®ister_handler("autophotochoice",\&photo_choice_handler,0,1,0);
@@ -4432,7 +4561,10 @@ sub student_photo_handler {
&mkpath($path);
my $file;
if ($type eq 'thumbnail') {
- $file=&localstudentphoto::fetch_thumbnail($domain,$uname);
+ eval {
+ local($SIG{__DIE__})='DEFAULT';
+ $file=&localstudentphoto::fetch_thumbnail($domain,$uname);
+ };
} else {
$file=&localstudentphoto::fetch($domain,$uname);
}
@@ -4502,6 +4634,22 @@ sub process_request {
# fix all the userinput -> user_input.
my $wasenc = 0; # True if request was encrypted.
# ------------------------------------------------------------ See if encrypted
+ # for command
+ # sethost:<server>
+ # <command>:<args>
+ # we just send it to the processor
+ # for
+ # sethost:<server>:<command>:<args>
+ # we do the implict set host and then do the command
+ if ($userinput =~ /^sethost:/) {
+ (my $cmd,my $newid,$userinput) = split(':',$userinput,3);
+ if (defined($userinput)) {
+ &sethost("$cmd:$newid");
+ } else {
+ $userinput = "$cmd:$newid";
+ }
+ }
+
if ($userinput =~ /^enc/) {
$userinput = decipher($userinput);
$wasenc=1;
@@ -5065,22 +5213,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 {
@@ -5155,7 +5287,7 @@ sub sub_sql_reply {
Type => SOCK_STREAM,
Timeout => 10)
or return "con_lost";
- print $sclient "$cmd\n";
+ print $sclient "$cmd:$currentdomainid\n";
my $answer=<$sclient>;
chomp($answer);
if (!$answer) { $answer="con_lost"; }
@@ -5490,8 +5622,11 @@ sub is_author {
# Author role should show up as a key /domain/_au
- my $key = "/$domain/_au";
- my $value = $hashref->{$key};
+ my $key = "/$domain/_au";
+ my $value;
+ if (defined($hashref)) {
+ $value = $hashref->{$key};
+ }
if(defined($value)) {
&Debug("$user @ $domain is an author");
@@ -5764,10 +5899,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));
@@ -5775,7 +5916,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;
@@ -5790,10 +5931,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));
@@ -5816,7 +5963,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);
@@ -6091,6 +6238,11 @@ sub convert_photo {
sub sethost {
my ($remotereq) = @_;
my (undef,$hostid)=split(/:/,$remotereq);
+ # ignore sethost if we are already correct
+ if ($hostid eq $currenthostid) {
+ return 'ok';
+ }
+
if (!defined($hostid)) { $hostid=$perlvar{'lonHostID'}; }
if ($hostip{$perlvar{'lonHostID'}} eq $hostip{$hostid}) {
$currenthostid =$hostid;