--- loncom/lond 2006/02/07 16:20:39 1.318 +++ loncom/lond 2006/05/18 19:57:59 1.330 @@ -2,7 +2,7 @@ # The LearningOnline Network # lond "LON Daemon" Server (port "LOND" 5663) # -# $Id: lond,v 1.318 2006/02/07 16:20:39 albertel Exp $ +# $Id: lond,v 1.330 2006/05/18 19:57:59 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,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 $'; #' stupid emacs +my $VERSION='$Revision: 1.330 $'; #' stupid emacs my $remoteVERSION; my $currenthostid="default"; my $currentdomainid; @@ -1049,49 +1048,70 @@ sub _do_hash_untie { sub _locking_hash_tie { my ($file_prefix,$namespace,$how,$loghead,$what) = @_; + 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; + 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)) { return undef; } +# If this is compressed, we will actually need an exclusive lock + if (-e "$file_prefix.db.gz") { + if (!&flock_sym(LOCK_EX)) { 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)) { return undef; } + } else { + &logthis("Unknown method $how for $file_prefix"); + die(); + } +# 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); + } - 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"); + sub flock_sym { + my ($lock_type)=@_; my $failed=0; eval { local $SIG{__DIE__}='DEFAULT'; - local $SIG{ALRM}=sub { + local $SIG{ALRM}=sub { $failed=1; die("failed lock"); }; alarm($lond_max_wait_time); - flock($sym,$lock); + flock($sym,$lock_type); alarm(0); }; if ($failed) { $! = 100; # throwing error # 100 return undef; + } else { + return 1; } - return &_do_hash_tie($file_prefix,$namespace,$how,$loghead,$what); } sub _locking_hash_untie { @@ -2292,7 +2312,9 @@ sub token_auth_user_file_handler { if (open(ENVIN,$perlvar{'lonIDsDir'}.'/'. $session.'.id')) { 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"); @@ -3093,6 +3115,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 @@ -3161,15 +3262,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. @@ -3184,8 +3287,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; @@ -3193,7 +3296,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. @@ -3203,6 +3306,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 @@ -3215,9 +3320,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/\:$//; @@ -4348,10 +4453,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); @@ -4376,6 +4490,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); @@ -4389,8 +4504,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); @@ -4423,7 +4547,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); } @@ -4493,6 +4620,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; @@ -5056,22 +5199,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 { @@ -5146,7 +5273,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"; } @@ -5481,8 +5608,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"); @@ -5755,10 +5885,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)); @@ -5766,7 +5902,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; @@ -5781,10 +5917,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)); @@ -5807,7 +5949,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); @@ -6082,6 +6224,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; @@ -6507,7 +6654,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.