--- loncom/lond 2006/03/04 04:27:38 1.318.2.6 +++ loncom/lond 2006/05/18 02:17:27 1.327 @@ -2,7 +2,7 @@ # The LearningOnline Network # lond "LON Daemon" Server (port "LOND" 5663) # -# $Id: lond,v 1.318.2.6 2006/03/04 04:27:38 albertel Exp $ +# $Id: lond,v 1.327 2006/05/18 02:17:27 www 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,7 +53,6 @@ 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. @@ -61,7 +60,7 @@ my $status=''; my $lastlog=''; my $lond_max_wait_time = 13; -my $VERSION='$Revision: 1.318.2.6 $'; #' stupid emacs +my $VERSION='$Revision: 1.327 $'; #' stupid emacs my $remoteVERSION; my $currenthostid="default"; my $currentdomainid; @@ -1049,49 +1048,61 @@ sub _do_hash_untie { 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); + my $lock_type=LOCK_SH; +# Are we reading or writing? + if ($how eq &GDBM_READER()) { +# We are reading + unless (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 + unless ((-e "$file_prefix.db") || (-e "$file_prefix.db.gz")) { +# No such file. Forget it. + $! = 2; + return undef; + } +# Apparently just no lock file yet. Make one + open($sym,">>$file_prefix.db.lock"); + } + } elsif ($how eq &GDBM_WRCREAT()) { +# We are writing + open($sym,">>$file_prefix.db.lock"); +# Writing needs exclusive lock + $lock_type=LOCK_EX; + } else { + &logthis("Unknown method $how for $file_prefix"); + die(); + } +# If this is compressed, we will also need an exclusive lock + if (-e "$file_prefix.db.gz") { $lock_type=LOCK_EX; } +# Okay, try to obtain the lock we want + 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_type); + alarm(0); + }; + if ($failed) { + $! = 100; # throwing error # 100 + return undef; + } +# 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 + return &_do_hash_tie($file_prefix,$namespace,$how,$loghead,$what); } sub _locking_hash_untie { @@ -2915,21 +2926,11 @@ sub dump_profile_database { while (my ($key,$value) = each(%$hashref)) { my ($v,$symb,$param) = split(/:/,$key); next if ($v eq 'version' || $symb eq 'keys'); - # making old style store entries '$ver:$symb:$key = $value' - # look like new '$ver:compressed:$symb = "$key=$value"' - if ($symb eq 'compressed') { - $symb = $param; - } else { - $value = $param.'='.$value; - } - foreach my $pair (split(/\&/,$value)) { - my ($param,$value)=split(/=/,$pair); - next if (exists($data{$symb}) && - exists($data{$symb}->{$param}) && - $data{$symb}->{'v.'.$param} > $v); - $data{$symb}->{$param}=$value; - $data{$symb}->{'v.'.$param}=$v; - } + next if (exists($data{$symb}) && + exists($data{$symb}->{$param}) && + $data{$symb}->{'v.'.$param} > $v); + $data{$symb}->{$param}=$value; + $data{$symb}->{'v.'.$param}=$v; } if (&untie_user_hash($hashref)) { while (my ($symb,$param_hash) = each(%data)) { @@ -3078,10 +3079,11 @@ 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:compressed:$rid"}=$what."\×tamp=$now"; + $hashref->{"$version:$rid:timestamp"}=$now; $allkeys.='timestamp'; $hashref->{"$version:keys:$rid"}=$allkeys; if (&untie_user_hash($hashref)) { @@ -3102,6 +3104,25 @@ 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) = @_; @@ -3112,24 +3133,15 @@ sub putstore_handler { chomp($what); my $hashref = &tie_user_hash($udom, $uname, $namespace, - &GDBM_WRCREAT(), "C", - "$rid:$what"); + &GDBM_WRCREAT(), "M", + "$rid:$v:$what"); if ($hashref) { my $now = time; my %data = &hash_extract($what); my @allkeys; - if (exists($hashref->{"$v:compressed:$rid"})) { - my %current = &hash_extract($hashref->{"$v:compressed:$rid"}); - while (my($key,$value) = each(%data)) { - push(@allkeys,$key); - $current{$key} = $value; - } - $hashref->{"$v:compressed:$rid"}= &hash_to_str(\%current); - } else { - while (my($key,$value) = each(%data)) { - push(@allkeys,$key); - $hashref->{"$v:$rid:$key"} = $value; - } + while (my($key,$value) = each(%data)) { + push(@allkeys,$key); + $hashref->{"$v:$rid:$key"} = $value; } my $allkeys = join(':',@allkeys); $hashref->{"$v:keys:$rid"}=$allkeys; @@ -3216,16 +3228,9 @@ sub restore_handler { my @keys=split(/:/,$vkeys); my $key; $qresult.="$scope:keys=$vkeys&"; - if (exists($hashref->{"$scope:compressed:$rid"})) { - foreach my $pair (split(/\&/,$hashref->{"$scope:compressed:$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/\&$//; @@ -3246,15 +3251,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. @@ -3269,8 +3276,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; @@ -3278,7 +3285,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. @@ -3288,6 +3295,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 @@ -3300,9 +3309,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/\:$//; @@ -4433,10 +4442,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); @@ -4461,6 +4479,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); @@ -4474,8 +4493,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); @@ -4508,7 +4536,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); } @@ -4578,6 +4609,22 @@ sub process_request { # fix all the userinput -> user_input. my $wasenc = 0; # True if request was encrypted. # ------------------------------------------------------------ See if encrypted + # for command + # sethost: + # : + # we just send it to the processor + # for + # sethost::: + # 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; @@ -5141,22 +5188,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 { @@ -5231,7 +5262,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"; } @@ -5566,8 +5597,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"); @@ -5840,10 +5874,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)); @@ -5851,7 +5891,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; @@ -5866,10 +5906,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)); @@ -5892,7 +5938,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); @@ -6167,6 +6213,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; @@ -6592,7 +6643,6 @@ to the client, and the connection is clo IO::Socket IO::File Apache::File -Symbol POSIX Crypt::IDEA LWP::UserAgent()