--- loncom/lond 2006/02/02 10:32:31 1.305.2.2 +++ loncom/lond 2006/03/29 19:56:10 1.324 @@ -2,7 +2,7 @@ # The LearningOnline Network # lond "LON Daemon" Server (port "LOND" 5663) # -# $Id: lond,v 1.305.2.2 2006/02/02 10:32:31 albertel Exp $ +# $Id: lond,v 1.324 2006/03/29 19:56:10 raeburn Exp $ # # Copyright Michigan State University Board of Trustees # @@ -61,7 +61,7 @@ my $status=''; my $lastlog=''; my $lond_max_wait_time = 13; -my $VERSION='$Revision: 1.305.2.2 $'; #' stupid emacs +my $VERSION='$Revision: 1.324 $'; #' stupid emacs my $remoteVERSION; my $currenthostid="default"; my $currentdomainid; @@ -89,6 +89,7 @@ my $ConnectionType; my %hostid; # ID's for hosts in cluster by ip. my %hostdom; # LonCAPA domain for hosts in cluster. +my %hostname; # DNSname -> ID's mapping. my %hostip; # IPs for hosts in cluster. my %hostdns; # ID's of hosts looked up by DNS name. @@ -2975,22 +2976,39 @@ sub dump_with_regexp { my $userinput = "$cmd:$tail"; - my ($udom,$uname,$namespace,$regexp)=split(/:/,$tail); + my ($udom,$uname,$namespace,$regexp,$range)=split(/:/,$tail); if (defined($regexp)) { $regexp=&unescape($regexp); } else { $regexp='.'; } + my ($start,$end); + if (defined($range)) { + if ($range =~/^(\d+)\-(\d+)$/) { + ($start,$end) = ($1,$2); + } elsif ($range =~/^(\d+)$/) { + ($start,$end) = (0,$1); + } else { + undef($range); + } + } my $hashref = &tie_user_hash($udom, $uname, $namespace, &GDBM_READER()); if ($hashref) { my $qresult=''; + my $count=0; while (my ($key,$value) = each(%$hashref)) { if ($regexp eq '.') { + $count++; + if (defined($range) && $count >= $end) { last; } + if (defined($range) && $count < $start) { next; } $qresult.=$key.'='.$value.'&'; } else { my $unescapeKey = &unescape($key); if (eval('$unescapeKey=~/$regexp/')) { + $count++; + if (defined($range) && $count >= $end) { last; } + if (defined($range) && $count < $start) { next; } $qresult.="$key=$value&"; } } @@ -3075,6 +3093,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 @@ -3143,15 +3240,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. @@ -3166,8 +3265,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; @@ -3175,7 +3274,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. @@ -3185,6 +3284,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 @@ -3197,9 +3298,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/\:$//; @@ -4318,6 +4419,83 @@ sub get_institutional_code_format_handle ®ister_handler("autoinstcodeformat", \&get_institutional_code_format_handler,0,1,0); +# Get domain specific conditions for import of student photographs to a course +# +# Retrieves information from photo_permission subroutine in localenroll. +# Returns outcome (ok) if no processing errors, and whether course owner is +# required to accept conditions of use (yes/no). +# +# +sub photo_permission_handler { + my ($cmd, $tail, $client) = @_; + my $userinput = "$cmd:$tail"; + my $cdom = $tail; + my ($perm_reqd,$conditions); + 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); + +# +# Checks if student photo is available for a user in the domain, in the user's +# directory (in /userfiles/internal/studentphoto.jpg). +# Uses localstudentphoto:fetch() to ensure there is an up to date copy of +# the student's photo. + +sub photo_check_handler { + my ($cmd, $tail, $client) = @_; + my $userinput = "$cmd:$tail"; + my ($udom,$uname,$pid) = split(/:/,$tail); + $udom = &unescape($udom); + $uname = &unescape($uname); + $pid = &unescape($pid); + my $path=&propath($udom,$uname).'/userfiles/internal/'; + if (!-e $path) { + &mkpath($path); + } + my $response; + 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); + +# +# Retrieve information from localenroll about whether to provide a button +# for users who have enbled import of student photos to initiate an +# update of photo files for registered students. Also include +# comment to display alongside button. + +sub photo_choice_handler { + my ($cmd, $tail, $client) = @_; + my $userinput = "$cmd:$tail"; + my $cdom = &unescape($tail); + 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); + # # Gets a student's photo to exist (in the correct image type) in the user's # directory. @@ -4330,24 +4508,36 @@ sub get_institutional_code_format_handle # $client - The socket open on the client. # Returns: # 1 - continue processing. + sub student_photo_handler { my ($cmd, $tail, $client) = @_; - my ($domain,$uname,$type) = split(/:/, $tail); + my ($domain,$uname,$ext,$type) = split(/:/, $tail); - my $path=&propath($domain,$uname). - '/userfiles/internal/studentphoto.'.$type; - if (-e $path) { + my $path=&propath($domain,$uname). '/userfiles/internal/'; + my $filename = 'studentphoto.'.$ext; + if ($type eq 'thumbnail') { + $filename = 'studentphoto_tn.'.$ext; + } + if (-e $path.$filename) { &Reply($client,"ok\n","$cmd:$tail"); return 1; } &mkpath($path); - my $file=&localstudentphoto::fetch($domain,$uname); + my $file; + if ($type eq 'thumbnail') { + eval { + local($SIG{__DIE__})='DEFAULT'; + $file=&localstudentphoto::fetch_thumbnail($domain,$uname); + }; + } else { + $file=&localstudentphoto::fetch($domain,$uname); + } if (!$file) { &Failure($client,"unavailable\n","$cmd:$tail"); return 1; } - if (!-e $path) { &convert_photo($file,$path); } - if (-e $path) { + if (!-e $path.$filename) { &convert_photo($file,$path.$filename); } + if (-e $path.$filename) { &Reply($client,"ok\n","$cmd:$tail"); return 1; } @@ -4408,6 +4598,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; @@ -4762,6 +4968,7 @@ sub ReadHostTable { } $hostid{$ip}=$id; # LonCAPA name of host by IP. $hostdom{$id}=$domain; # LonCAPA domain name of host. + $hostname{$id}=$name; # LonCAPA name -> DNS name $hostip{$id}=$ip; # IP address of host. $hostdns{$name} = $id; # LonCAPA name of host by DNS. @@ -5012,12 +5219,12 @@ sub reconlonc { sub subreply { my ($cmd,$server)=@_; - my $peerfile="$perlvar{'lonSockDir'}/$server"; + my $peerfile="$perlvar{'lonSockDir'}/".$hostname{$server}; my $sclient=IO::Socket::UNIX->new(Peer =>"$peerfile", Type => SOCK_STREAM, Timeout => 10) or return "con_lost"; - print $sclient "$cmd\n"; + print $sclient "sethost:$server:$cmd\n"; my $answer=<$sclient>; chomp($answer); if (!$answer) { $answer="con_lost"; } @@ -5033,7 +5240,7 @@ sub reply { $answer=subreply("ping",$server); if ($answer ne $server) { &logthis("sub reply: answer != server answer is $answer, server is $server"); - &reconlonc("$perlvar{'lonSockDir'}/$server"); + &reconlonc("$perlvar{'lonSockDir'}/".$hostname{$server}); } $answer=subreply($cmd,$server); } @@ -5060,7 +5267,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"; } @@ -5339,7 +5546,7 @@ sub make_new_child { # no need to try to do recon's to myself next; } - &reconlonc("$perlvar{'lonSockDir'}/$id"); + &reconlonc("$perlvar{'lonSockDir'}/".$hostname{$id}); } &logthis("Established connection: $clientname"); &status('Will listen to '.$clientname); @@ -5395,8 +5602,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"); @@ -5669,10 +5879,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)); @@ -5680,7 +5896,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; @@ -5695,10 +5911,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)); @@ -5721,7 +5943,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); @@ -5996,6 +6218,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;