--- loncom/lond 2005/06/27 22:32:37 1.289 +++ loncom/lond 2007/01/08 16:23:48 1.353 @@ -2,7 +2,7 @@ # The LearningOnline Network # lond "LON Daemon" Server (port "LOND" 5663) # -# $Id: lond,v 1.289 2005/06/27 22:32:37 albertel Exp $ +# $Id: lond,v 1.353 2007/01/08 16:23:48 albertel Exp $ # # Copyright Michigan State University Board of Trustees # @@ -31,15 +31,16 @@ 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(); +use Digest::MD5 qw(md5_hex); use GDBM_File; use Authen::Krb4; use Authen::Krb5; @@ -48,6 +49,7 @@ use localauth; use localenroll; use localstudentphoto; use File::Copy; +use File::Find; use LONCAPA::ConfigFileEdit; use LONCAPA::lonlocal; use LONCAPA::lonssl; @@ -58,7 +60,7 @@ my $DEBUG = 0; # Non zero to ena my $status=''; my $lastlog=''; -my $VERSION='$Revision: 1.289 $'; #' stupid emacs +my $VERSION='$Revision: 1.353 $'; #' stupid emacs my $remoteVERSION; my $currenthostid="default"; my $currentdomainid; @@ -86,6 +88,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. @@ -833,16 +836,14 @@ sub AdjustOurHost { # Use the config line to get my hostname. # Use gethostbyname to translate that into an IP address. # - my ($id,$domain,$role,$name,$ip,$maxcon,$idleto,$mincon) = split(/:/,$ConfigLine); - my $BinaryIp = gethostbyname($name); - my $ip = inet_ntoa($ip); + my ($id,$domain,$role,$name,$maxcon,$idleto,$mincon) = split(/:/,$ConfigLine); # # Reassemble the config line from the elements in the list. # Note that if the loncnew items were not present before, they will # be now even if they would be empty # my $newConfigLine = $id; - foreach my $item ($domain, $role, $name, $ip, $maxcon, $idleto, $mincon) { + foreach my $item ($domain, $role, $name, $maxcon, $idleto, $mincon) { $newConfigLine .= ":".$item; } # Replace the line: @@ -888,11 +889,11 @@ sub EditFile { # Split the command into it's pieces: edit:filetype:script - my ($request, $filetype, $script) = split(/:/, $request,3); # : in script + my ($cmd, $filetype, $script) = split(/:/, $request,3); # : in script # Check the pre-coditions for success: - if($request != "edit") { # Something is amiss afoot alack. + if($cmd != "edit") { # Something is amiss afoot alack. return "error:edit request detected, but request != 'edit'\n"; } if( ($filetype ne "hosts") && @@ -937,105 +938,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.db"; - my %hash; - if(tie(%hash, 'GDBM_File', $resource_file, $how, 0640)) { - if (defined($loghead)) { # Need to log the operation. - my $logFh = IO::File->new(">>$domain_dir/$namespace.hist"); - if($logFh) { - my $timestamp = time; - print $logFh "$loghead:$timestamp:$logtail\n"; - } - $logFh->close; - } - return \%hash; # Return the tied hash. - } else { - return undef; # Tie failed. - } -} - -# -# 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); - - # Tie the database. - - my %hash; - if(tie(%hash, 'GDBM_File', "$proname/$namespace.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: $namespace $args"); - my $hfh = IO::File->new(">>$proname/$namespace.hist"); - if($hfh) { - my $now = time; - print $hfh "$loghead:$now:$what\n"; - } - $hfh->close; - } - return \%hash; - } else { - return undef; - } - -} - # read_profile # # Returns a set of specific entries from a user's profile file. @@ -1066,7 +968,7 @@ sub read_profile { $qresult.="$hashref->{$queries[$i]}&"; # Presumably failure gives empty string. } $qresult=~s/\&$//; # Remove trailing & from last lookup. - if (untie %$hashref) { + if (&untie_user_hash($hashref)) { return $qresult; } else { return "error: ".($!+0)." untie (GDBM) Failed"; @@ -1349,7 +1251,7 @@ sub push_file_handler { # sub du_handler { my ($cmd, $ududir, $client) = @_; - my ($ududir) = split(/:/,$ududir); # Make 'telnet' testing easier. + ($ududir) = split(/:/,$ududir); # Make 'telnet' testing easier. my $userinput = "$cmd:$ududir"; if ($ududir=~/\.\./ || $ududir!~m|^/home/httpd/|) { @@ -1363,18 +1265,18 @@ sub du_handler { # etc. # if (-d $ududir) { - # And as Shakespeare would say to make - # assurance double sure, - # use execute_command to ensure that the command is not executed in - # a shell that can screw us up. - - my $duout = execute_command("du -ks $ududir"); - $duout=~s/[^\d]//g; #preserve only the numbers - &Reply($client,"$duout\n","$cmd:$ududir"); + my $total_size=0; + my $code=sub { + if ($_=~/\.\d+\./) { return;} + if ($_=~/\.meta$/) { return;} + $total_size+=(stat($_))[7]; + }; + chdir($ududir); + find($code,$ududir); + $total_size=int($total_size/1024); + &Reply($client,"$total_size\n","$cmd:$ududir"); } else { - &Failure($client, "bad_directory:$ududir\n","$cmd:$ududir"); - } return 1; } @@ -1413,14 +1315,15 @@ sub ls_handler { if(-d $ulsdir) { if (opendir(LSDIR,$ulsdir)) { while ($ulsfn=readdir(LSDIR)) { - undef $obs, $rights; + undef($obs); + undef($rights); my @ulsstats=stat($ulsdir.'/'.$ulsfn); #We do some obsolete checking here if(-e $ulsdir.'/'.$ulsfn.".meta") { open(FILE, $ulsdir.'/'.$ulsfn.".meta"); my @obsolete=; foreach my $obsolete (@obsolete) { - if($obsolete =~ m|()(on)|) { $obs = 1; } + if($obsolete =~ m/()(on|1)/) { $obs = 1; } if($obsolete =~ m|()(default)|) { $rights = 1; } } } @@ -1480,14 +1383,15 @@ sub ls2_handler { if(-d $ulsdir) { if (opendir(LSDIR,$ulsdir)) { while ($ulsfn=readdir(LSDIR)) { - undef $obs, $rights; + undef($obs); + undef($rights); my @ulsstats=stat($ulsdir.'/'.$ulsfn); #We do some obsolete checking here if(-e $ulsdir.'/'.$ulsfn.".meta") { open(FILE, $ulsdir.'/'.$ulsfn.".meta"); my @obsolete=; foreach my $obsolete (@obsolete) { - if($obsolete =~ m|()(on)|) { $obs = 1; } + if($obsolete =~ m/()(on|1)/) { $obs = 1; } if($obsolete =~ m|()(default)|) { $rights = 1; } @@ -1671,17 +1575,24 @@ sub change_password_handler { # uname - Username. # upass - Current password. # npass - New password. + # context - Context in which this was called + # (preferences or reset_by_email). - my ($udom,$uname,$upass,$npass)=split(/:/,$tail); + my ($udom,$uname,$upass,$npass,$context)=split(/:/,$tail); $upass=&unescape($upass); $npass=&unescape($npass); &Debug("Trying to change password for $uname"); # First require that the user can be authenticated with their - # old password: - - my $validated = &validate_user($udom, $uname, $upass); + # old password unless context was 'reset_by_email': + + my $validated; + if ($context eq 'reset_by_email') { + $validated = 1; + } else { + $validated = &validate_user($udom, $uname, $upass); + } if($validated) { my $realpasswd = &get_auth_type($udom, $uname); # Defined since authd. @@ -1700,7 +1611,7 @@ sub change_password_handler { ."to change password"); &Failure( $client, "non_authorized\n",$userinput); } - } elsif ($howpwd eq 'unix') { + } elsif ($howpwd eq 'unix' && $context ne 'reset_by_email') { my $result = &change_unix_password($uname, $npass); &logthis("Result of password change for $uname: ". $result); @@ -1940,7 +1851,9 @@ sub update_resource_handler { my $since=$now-$atime; if ($since>$perlvar{'lonExpire'}) { 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"); @@ -1970,6 +1883,7 @@ sub update_resource_handler { alarm(0); } rename($transname,$fname); + &devalidate_meta_cache($fname); } } &Reply( $client, "ok\n", $userinput); @@ -1983,6 +1897,26 @@ sub update_resource_handler { } ®ister_handler("update", \&update_resource_handler, 0 ,1, 0); +sub devalidate_meta_cache { + my ($url) = @_; + use Cache::Memcached; + my $memcache = new Cache::Memcached({'servers'=>['127.0.0.1:11211']}); + $url = &declutter($url); + $url =~ s-\.meta$--; + my $id = &escape('meta:'.$url); + $memcache->delete($id); +} + +sub declutter { + my $thisfn=shift; + $thisfn=~s/^\Q$perlvar{'lonDocRoot'}\E//; + $thisfn=~s/^\///; + $thisfn=~s|^adm/wrapper/||; + $thisfn=~s|^adm/coursedocs/showdoc/||; + $thisfn=~s/^res\///; + $thisfn=~s/\?.+$//; + return $thisfn; +} # # Fetch a user file from a remote server to the user's home directory # userfiles subdir. @@ -2197,11 +2131,21 @@ sub token_auth_user_file_handler { chomp($session); my $reply="non_auth\n"; - if (open(ENVIN,$perlvar{'lonIDsDir'}.'/'. - $session.'.id')) { - while (my $line=) { - if ($line=~ m|userfile\.\Q$fname\E\=|) { $reply="ok\n"; } + my $file = $perlvar{'lonIDsDir'}.'/'.$session.'.id'; + if (open(ENVIN,"$file")) { + flock(ENVIN,LOCK_SH); + tie(my %disk_env,'GDBM_File',"$file",&GDBM_READER(),0640); + if (exists($disk_env{"userfile.$fname"})) { + $reply="ok\n"; + } else { + foreach my $envname (keys(%disk_env)) { + if ($envname=~ m|^userfile\.\Q$fname\E|) { + $reply="ok\n"; + last; + } + } } + untie(%disk_env); close(ENVIN); &Reply($client, $reply, "$cmd:$tail"); } else { @@ -2351,7 +2295,7 @@ sub put_user_profile_entry { my ($key,$value)=split(/=/,$pair); $hashref->{$key}=$value; } - if (untie(%$hashref)) { + if (&untie_user_hash($hashref)) { &Reply( $client, "ok\n", $userinput); } else { &Failure($client, "error: ".($!+0)." untie(GDBM) failed ". @@ -2359,7 +2303,7 @@ sub put_user_profile_entry { $userinput); } } else { - &Failure( $client, "error: ".($!)." tie(GDBM) Failed ". + &Failure( $client, "error: ".($!+0)." tie(GDBM) Failed ". "while attempting put\n", $userinput); } } else { @@ -2395,7 +2339,7 @@ sub newput_user_profile_entry { my $hashref = &tie_user_hash($udom, $uname, $namespace, &GDBM_WRCREAT(),"N",$what); if(!$hashref) { - &Failure( $client, "error: ".($!)." tie(GDBM) Failed ". + &Failure( $client, "error: ".($!+0)." tie(GDBM) Failed ". "while attempting put\n", $userinput); return 1; } @@ -2414,7 +2358,7 @@ sub newput_user_profile_entry { $hashref->{$key}=$value; } - if (untie(%$hashref)) { + if (&untie_user_hash($hashref)) { &Reply( $client, "ok\n", $userinput); } else { &Failure($client, "error: ".($!+0)." untie(GDBM) failed ". @@ -2467,7 +2411,7 @@ sub increment_user_value_handler { } } } - if (untie(%$hashref)) { + if (&untie_user_hash($hashref)) { &Reply( $client, "ok\n", $userinput); } else { &Failure($client, "error: ".($!+0)." untie(GDBM) failed ". @@ -2534,7 +2478,7 @@ sub roles_put_handler { $auth_type); $hashref->{$key}=$value; } - if (untie($hashref)) { + if (&untie_user_hash($hashref)) { &Reply($client, "ok\n", $userinput); } else { &Failure( $client, "error: ".($!+0)." untie(GDBM) Failed ". @@ -2585,7 +2529,7 @@ sub roles_delete_handler { foreach my $key (@rolekeys) { delete $hashref->{$key}; } - if (untie(%$hashref)) { + if (&untie_user_hash($hashref)) { &Reply($client, "ok\n", $userinput); } else { &Failure( $client, "error: ".($!+0)." untie(GDBM) Failed ". @@ -2664,7 +2608,7 @@ sub get_profile_entry_encrypted { my $userinput = "$cmd:$tail"; - my ($cmd,$udom,$uname,$namespace,$what) = split(/:/,$userinput); + my ($udom,$uname,$namespace,$what) = split(/:/,$tail); chomp($what); my $qresult = read_profile($udom, $uname, $namespace, $what); my ($first) = split(/:/, $qresult); @@ -2726,7 +2670,7 @@ sub delete_profile_entry { foreach my $key (@keys) { delete($hashref->{$key}); } - if (untie(%$hashref)) { + if (&untie_user_hash($hashref)) { &Reply($client, "ok\n", $userinput); } else { &Failure($client, "error: ".($!+0)." untie(GDBM) Failed ". @@ -2768,7 +2712,7 @@ sub get_profile_keys { foreach my $key (keys %$hashref) { $qresult.="$key&"; } - if (untie(%$hashref)) { + if (&untie_user_hash($hashref)) { $qresult=~s/\&$//; &Reply($client, "$qresult\n", $userinput); } else { @@ -2829,7 +2773,7 @@ sub dump_profile_database { $data{$symb}->{$param}=$value; $data{$symb}->{'v.'.$param}=$v; } - if (untie(%$hashref)) { + if (&untie_user_hash($hashref)) { while (my ($symb,$param_hash) = each(%data)) { while(my ($param,$value) = each (%$param_hash)){ next if ($param =~ /^v\./); # Ignore versions... @@ -2884,27 +2828,44 @@ 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&"; } } } - if (untie(%$hashref)) { + if (&untie_user_hash($hashref)) { chop($qresult); &Reply($client, "$qresult\n", $userinput); } else { @@ -2966,7 +2927,7 @@ sub store_handler { $hashref->{"$version:$rid:timestamp"}=$now; $allkeys.='timestamp'; $hashref->{"$version:keys:$rid"}=$allkeys; - if (untie($hashref)) { + if (&untie_user_hash($hashref)) { &Reply($client, "ok\n", $userinput); } else { &Failure($client, "error: ".($!+0)." untie(GDBM) Failed ". @@ -2984,6 +2945,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 @@ -3013,29 +3053,27 @@ sub restore_handler { my ($cmd, $tail, $client) = @_; my $userinput = "$cmd:$tail"; # Only used for logging purposes. - - my ($cmd,$udom,$uname,$namespace,$rid) = split(/:/,$userinput); + my ($udom,$uname,$namespace,$rid) = split(/:/,$tail); $namespace=~s/\//\_/g; - $namespace=~s/\W//g; + $namespace = &LONCAPA::clean_username($namespace); + chomp($rid); - my $proname=&propath($udom,$uname); my $qresult=''; - my %hash; - if (tie(%hash,'GDBM_File',"$proname/$namespace.db", - &GDBM_READER(),0640)) { - my $version=$hash{"version:$rid"}; + my $hashref = &tie_user_hash($udom, $uname, $namespace, &GDBM_READER()); + if ($hashref) { + my $version=$hashref->{"version:$rid"}; $qresult.="version=$version&"; my $scope; for ($scope=1;$scope<=$version;$scope++) { - my $vkeys=$hash{"$scope:keys:$rid"}; + my $vkeys=$hashref->{"$scope:keys:$rid"}; my @keys=split(/:/,$vkeys); my $key; $qresult.="$scope:keys=$vkeys&"; foreach $key (@keys) { - $qresult.="$scope:$key=".$hash{"$scope:$rid:$key"}."&"; + $qresult.="$scope:$key=".$hashref->{"$scope:$rid:$key"}."&"; } } - if (untie(%hash)) { + if (&untie_user_hash($hashref)) { $qresult=~s/\&$//; &Reply( $client, "$qresult\n", $userinput); } else { @@ -3054,15 +3092,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. @@ -3077,8 +3117,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; @@ -3086,7 +3126,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. @@ -3096,6 +3136,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 @@ -3108,9 +3150,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/\:$//; @@ -3187,7 +3229,7 @@ sub reply_query_handler { my $userinput = "$cmd:$tail"; - my ($cmd,$id,$reply)=split(/:/,$userinput); + my ($id,$reply)=split(/:/,$tail); my $store; my $execdir=$perlvar{'lonDaemons'}; if ($store=IO::File->new(">$execdir/tmp/$id")) { @@ -3260,15 +3302,15 @@ 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; } - if (untie(%$hashref)) { + if (&untie_domain_hash($hashref)) { &Reply( $client, "ok\n", $userinput); } else { &Failure($client, "error: ".($!+0) @@ -3307,12 +3349,11 @@ sub put_course_id_handler { # institutional code - optional supplied code to filter # the dump. Only courses with an institutional code # that match the supplied code will be returned. -# owner - optional supplied username of owner to filter -# the dump. Only courses for which the course -# owner matches the supplied username will be -# returned. Implicit assumption that owner -# is a user in the domain in which the -# course database is defined. +# owner - optional supplied username and domain of owner to +# filter the dump. Only courses for which the course +# owner matches the supplied username and/or domain +# will be returned. Pre-2.2.0 legacy entries from +# nohist_courseiddump will only contain usernames. # $client - The socket open on the client. # Returns: # 1 - Continue processing. @@ -3323,7 +3364,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,$regexp_ok) =split(/:/,$tail); if (defined($description)) { $description=&unescape($description); } else { @@ -3334,26 +3376,45 @@ sub dump_course_id_handler { } else { $instcodefilter='.'; } + my ($ownerunamefilter,$ownerdomfilter); if (defined($ownerfilter)) { $ownerfilter=&unescape($ownerfilter); + if ($ownerfilter ne '.' && defined($ownerfilter)) { + if ($ownerfilter =~ /^([^:]*):([^:]*)$/) { + $ownerunamefilter = $1; + $ownerdomfilter = $2; + } else { + $ownerunamefilter = $ownerfilter; + $ownerdomfilter = ''; + } + } } else { $ownerfilter='.'; } + if (defined($coursefilter)) { $coursefilter=&unescape($coursefilter); } else { $coursefilter='.'; } + if (defined($typefilter)) { + $typefilter=&unescape($typefilter); + } else { + $typefilter='.'; + } + if (defined($regexp_ok)) { + $regexp_ok=&unescape($regexp_ok); + } 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 '.') { @@ -3364,14 +3425,49 @@ sub dump_course_id_handler { } unless ($instcodefilter eq '.' || !defined($instcodefilter)) { my $unescapeInstcode = &unescape($inst_code); - unless (eval('$unescapeInstcode=~/\Q$instcodefilter\E/i')) { - $match = 0; + if ($regexp_ok) { + unless (eval('$unescapeInstcode=~/$instcodefilter/')) { + $match = 0; + } + } else { + unless (eval('$unescapeInstcode=~/\Q$instcodefilter\E/i')) { + $match = 0; + } } } unless ($ownerfilter eq '.' || !defined($ownerfilter)) { my $unescapeOwner = &unescape($owner); - unless (eval('$unescapeOwner=~/\Q$ownerfilter\E/i')) { - $match = 0; + if (($ownerunamefilter ne '') && ($ownerdomfilter ne '')) { + if ($unescapeOwner =~ /:/) { + if (eval('$unescapeOwner !~ + /\Q$ownerunamefilter\E:\Q$ownerdomfilter\E$/i')) { + $match = 0; + } + } else { + if (eval('$unescapeOwner!~/\Q$ownerunamefilter\E/i')) { + $match = 0; + } + } + } elsif ($ownerunamefilter ne '') { + if ($unescapeOwner =~ /:/) { + if (eval('$unescapeOwner!~/\Q$ownerunamefilter\E:[^:]+$/i')) { + $match = 0; + } + } else { + if (eval('$unescapeOwner!~/\Q$ownerunamefilter\E/i')) { + $match = 0; + } + } + } elsif ($ownerdomfilter ne '') { + if ($unescapeOwner =~ /:/) { + if (eval('$unescapeOwner!~/^[^:]+:\Q$ownerdomfilter\E/')) { + $match = 0; + } + } else { + if ($ownerdomfilter ne $udom) { + $match = 0; + } + } } } unless ($coursefilter eq '.' || !defined($coursefilter)) { @@ -3380,11 +3476,23 @@ sub dump_course_id_handler { $match = 0; } } + unless ($typefilter eq '.' || !defined($typefilter)) { + my $unescapeType = &unescape($type); + if ($type eq '') { + if ($typefilter ne 'Course') { + $match = 0; + } + } else { + unless (eval('$unescapeType=~/^\Q$typefilter\E$/')) { + $match = 0; + } + } + } if ($match == 1) { $qresult.=$key.'='.$descr.':'.$inst_code.':'.$owner.'&'; } } - if (untie(%$hashref)) { + if (&untie_domain_hash($hashref)) { chop($qresult); &Reply($client, "$qresult\n", $userinput); } else { @@ -3402,6 +3510,99 @@ sub dump_course_id_handler { ®ister_handler("courseiddump", \&dump_course_id_handler, 0, 1, 0); # +# Puts an unencrypted entry in a namespace db file at the domain level +# +# Parameters: +# $cmd - The command that got us here. +# $tail - Tail of the command (remaining parameters). +# $client - File descriptor connected to client. +# Returns +# 0 - Requested to exit, caller should shut down. +# 1 - Continue processing. +# Side effects: +# reply is written to $client. +# +sub put_domain_handler { + my ($cmd,$tail,$client) = @_; + + my $userinput = "$cmd:$tail"; + + my ($udom,$namespace,$what) =split(/:/,$tail,3); + chomp($what); + my @pairs=split(/\&/,$what); + my $hashref = &tie_domain_hash($udom, "$namespace", &GDBM_WRCREAT(), + "P", $what); + if ($hashref) { + foreach my $pair (@pairs) { + my ($key,$value)=split(/=/,$pair); + $hashref->{$key}=$value; + } + if (&untie_domain_hash($hashref)) { + &Reply($client, "ok\n", $userinput); + } else { + &Failure($client, "error: ".($!+0)." untie(GDBM) Failed ". + "while attempting putdom\n", $userinput); + } + } else { + &Failure( $client, "error: ".($!+0)." tie(GDBM) Failed ". + "while attempting putdom\n", $userinput); + } + + return 1; +} +®ister_handler("putdom", \&put_domain_handler, 0, 1, 0); + +# Unencrypted get from the namespace database file at the domain level. +# This function retrieves a keyed item from a specific named database in the +# domain directory. +# +# Parameters: +# $cmd - Command request keyword (get). +# $tail - Tail of the command. This is a colon separated list +# consisting of the domain and the 'namespace' +# which selects the gdbm file to do the lookup in, +# & separated list of keys to lookup. Note that +# the values are returned as an & separated list too. +# $client - File descriptor open on the client. +# Returns: +# 1 - Continue processing. +# 0 - Exit. +# Side effects: +# reply is written to $client. +# + +sub get_domain_handler { + my ($cmd, $tail, $client) = @_; + + my $userinput = "$client:$tail"; + + my ($udom,$namespace,$what)=split(/:/,$tail,3); + chomp($what); + my @queries=split(/\&/,$what); + my $qresult=''; + my $hashref = &tie_domain_hash($udom, "$namespace", &GDBM_READER()); + if ($hashref) { + for (my $i=0;$i<=$#queries;$i++) { + $qresult.="$hashref->{$queries[$i]}&"; + } + if (&untie_domain_hash($hashref)) { + $qresult=~s/\&$//; + &Reply($client, "$qresult\n", $userinput); + } else { + &Failure( $client, "error: ".($!+0)." untie(GDBM) Failed ". + "while attempting getdom\n",$userinput); + } + } else { + &Failure($client, "error: ".($!+0)." tie(GDBM) Failed ". + "while attempting getdom\n",$userinput); + } + + return 1; +} +®ister_handler("getdom", \&get_id_handler, 0, 1, 0); + + +# # Puts an id to a domains id database. # # Parameters: @@ -3433,7 +3634,7 @@ sub put_id_handler { my ($key,$value)=split(/=/,$pair); $hashref->{$key}=$value; } - if (untie(%$hashref)) { + if (&untie_domain_hash($hashref)) { &Reply($client, "ok\n", $userinput); } else { &Failure($client, "error: ".($!+0)." untie(GDBM) Failed ". @@ -3482,7 +3683,7 @@ sub get_id_handler { for (my $i=0;$i<=$#queries;$i++) { $qresult.="$hashref->{$queries[$i]}&"; } - if (untie(%$hashref)) { + if (&untie_domain_hash($hashref)) { $qresult=~s/\&$//; &Reply($client, "$qresult\n", $userinput); } else { @@ -3499,6 +3700,258 @@ sub get_id_handler { ®ister_handler("idget", \&get_id_handler, 0, 1, 0); # +# Puts broadcast e-mail sent by Domain Coordinator in nohist_dcmail database +# +# Parameters +# $cmd - Command keyword that caused us to be dispatched. +# $tail - Tail of the command. Consists of a colon separated: +# domain - the domain whose dcmail we are recording +# email Consists of key=value pair +# where key is unique msgid +# and value is message (in XML) +# $client - Socket open on the client. +# +# Returns: +# 1 - indicating processing should continue. +# Side effects +# reply is written to $client. +# +sub put_dcmail_handler { + my ($cmd,$tail,$client) = @_; + my $userinput = "$cmd:$tail"; + + my ($udom,$what)=split(/:/,$tail); + chomp($what); + my $hashref = &tie_domain_hash($udom, "nohist_dcmail", &GDBM_WRCREAT()); + if ($hashref) { + my ($key,$value)=split(/=/,$what); + $hashref->{$key}=$value; + } + if (&untie_domain_hash($hashref)) { + &Reply($client, "ok\n", $userinput); + } else { + &Failure($client, "error: ".($!+0)." untie(GDBM) Failed ". + "while attempting dcmailput\n", $userinput); + } + return 1; +} +®ister_handler("dcmailput", \&put_dcmail_handler, 0, 1, 0); + +# +# Retrieves broadcast e-mail from nohist_dcmail database +# Returns to client an & separated list of key=value pairs, +# where key is msgid and value is message information. +# +# Parameters +# $cmd - Command keyword that caused us to be dispatched. +# $tail - Tail of the command. Consists of a colon separated: +# domain - the domain whose dcmail table we dump +# startfilter - beginning of time window +# endfilter - end of time window +# sendersfilter - & separated list of username:domain +# for senders to search for. +# $client - Socket open on the client. +# +# Returns: +# 1 - indicating processing should continue. +# Side effects +# reply (& separated list of msgid=messageinfo pairs) is +# written to $client. +# +sub dump_dcmail_handler { + my ($cmd, $tail, $client) = @_; + + my $userinput = "$cmd:$tail"; + my ($udom,$startfilter,$endfilter,$sendersfilter) = split(/:/,$tail); + chomp($sendersfilter); + my @senders = (); + if (defined($startfilter)) { + $startfilter=&unescape($startfilter); + } else { + $startfilter='.'; + } + if (defined($endfilter)) { + $endfilter=&unescape($endfilter); + } else { + $endfilter='.'; + } + if (defined($sendersfilter)) { + $sendersfilter=&unescape($sendersfilter); + @senders = map { &unescape($_) } split(/\&/,$sendersfilter); + } + + my $qresult=''; + my $hashref = &tie_domain_hash($udom, "nohist_dcmail", &GDBM_WRCREAT()); + if ($hashref) { + while (my ($key,$value) = each(%$hashref)) { + my $match = 1; + my ($timestamp,$subj,$uname,$udom) = + split(/:/,&unescape(&unescape($key)),5); # yes, twice really + $subj = &unescape($subj); + unless ($startfilter eq '.' || !defined($startfilter)) { + if ($timestamp < $startfilter) { + $match = 0; + } + } + unless ($endfilter eq '.' || !defined($endfilter)) { + if ($timestamp > $endfilter) { + $match = 0; + } + } + unless (@senders < 1) { + unless (grep/^$uname:$udom$/,@senders) { + $match = 0; + } + } + if ($match == 1) { + $qresult.=$key.'='.$value.'&'; + } + } + if (&untie_domain_hash($hashref)) { + chop($qresult); + &Reply($client, "$qresult\n", $userinput); + } else { + &Failure($client, "error: ".($!+0)." untie(GDBM) Failed ". + "while attempting dcmaildump\n", $userinput); + } + } else { + &Failure($client, "error: ".($!+0)." tie(GDBM) Failed ". + "while attempting dcmaildump\n", $userinput); + } + return 1; +} + +®ister_handler("dcmaildump", \&dump_dcmail_handler, 0, 1, 0); + +# +# Puts domain roles in nohist_domainroles database +# +# Parameters +# $cmd - Command keyword that caused us to be dispatched. +# $tail - Tail of the command. Consists of a colon separated: +# domain - the domain whose roles we are recording +# role - Consists of key=value pair +# where key is unique role +# and value is start/end date information +# $client - Socket open on the client. +# +# Returns: +# 1 - indicating processing should continue. +# Side effects +# reply is written to $client. +# + +sub put_domainroles_handler { + my ($cmd,$tail,$client) = @_; + + my $userinput = "$cmd:$tail"; + my ($udom,$what)=split(/:/,$tail); + chomp($what); + my @pairs=split(/\&/,$what); + my $hashref = &tie_domain_hash($udom, "nohist_domainroles", &GDBM_WRCREAT()); + if ($hashref) { + foreach my $pair (@pairs) { + my ($key,$value)=split(/=/,$pair); + $hashref->{$key}=$value; + } + if (&untie_domain_hash($hashref)) { + &Reply($client, "ok\n", $userinput); + } else { + &Failure($client, "error: ".($!+0)." untie(GDBM) Failed ". + "while attempting domroleput\n", $userinput); + } + } else { + &Failure( $client, "error: ".($!+0)." tie(GDBM) Failed ". + "while attempting domroleput\n", $userinput); + } + + return 1; +} + +®ister_handler("domroleput", \&put_domainroles_handler, 0, 1, 0); + +# +# Retrieves domain roles from nohist_domainroles database +# Returns to client an & separated list of key=value pairs, +# where key is role and value is start and end date information. +# +# Parameters +# $cmd - Command keyword that caused us to be dispatched. +# $tail - Tail of the command. Consists of a colon separated: +# domain - the domain whose domain roles table we dump +# $client - Socket open on the client. +# +# Returns: +# 1 - indicating processing should continue. +# Side effects +# reply (& separated list of role=start/end info pairs) is +# written to $client. +# +sub dump_domainroles_handler { + my ($cmd, $tail, $client) = @_; + + my $userinput = "$cmd:$tail"; + my ($udom,$startfilter,$endfilter,$rolesfilter) = split(/:/,$tail); + chomp($rolesfilter); + my @roles = (); + if (defined($startfilter)) { + $startfilter=&unescape($startfilter); + } else { + $startfilter='.'; + } + if (defined($endfilter)) { + $endfilter=&unescape($endfilter); + } else { + $endfilter='.'; + } + if (defined($rolesfilter)) { + $rolesfilter=&unescape($rolesfilter); + @roles = split(/\&/,$rolesfilter); + } + + my $hashref = &tie_domain_hash($udom, "nohist_domainroles", &GDBM_WRCREAT()); + if ($hashref) { + my $qresult = ''; + while (my ($key,$value) = each(%$hashref)) { + my $match = 1; + my ($start,$end) = split(/:/,&unescape($value)); + my ($trole,$uname,$udom,$runame,$rudom,$rsec) = split(/:/,&unescape($key)); + unless ($startfilter eq '.' || !defined($startfilter)) { + if ($start >= $startfilter) { + $match = 0; + } + } + unless ($endfilter eq '.' || !defined($endfilter)) { + if ($end <= $endfilter) { + $match = 0; + } + } + unless (@roles < 1) { + unless (grep/^$trole$/,@roles) { + $match = 0; + } + } + if ($match == 1) { + $qresult.=$key.'='.$value.'&'; + } + } + if (&untie_domain_hash($hashref)) { + chop($qresult); + &Reply($client, "$qresult\n", $userinput); + } else { + &Failure($client, "error: ".($!+0)." untie(GDBM) Failed ". + "while attempting domrolesdump\n", $userinput); + } + } else { + &Failure($client, "error: ".($!+0)." tie(GDBM) Failed ". + "while attempting domrolesdump\n", $userinput); + } + return 1; +} + +®ister_handler("domrolesdump", \&dump_domainroles_handler, 0, 1, 0); + + # Process the tmpput command I'm not sure what this does.. Seems to # create a file in the lonDaemons/tmp directory of the form $id.tmp # where Id is the client's ip concatenated with a sequence number. @@ -3520,15 +3973,23 @@ sub tmp_put_handler { my $userinput = "$cmd:$what"; # Reconstruct for logging. - - my $store; + my ($record,$context) = split(/:/,$what); + if ($context ne '') { + chomp($context); + $context = &unescape($context); + } + my ($id,$store); $tmpsnum++; - my $id=$$.'_'.$clientip.'_'.$tmpsnum; + if ($context eq 'resetpw') { + $id = &md5_hex(&md5_hex(time.{}.rand().$$)); + } else { + $id = $$.'_'.$clientip.'_'.$tmpsnum; + } $id=~s/\W/\_/g; - $what=~s/\n//g; + $record=~s/\n//g; my $execdir=$perlvar{'lonDaemons'}; if ($store=IO::File->new(">$execdir/tmp/$id.tmp")) { - print $store $what; + print $store $record; close $store; &Reply($client, "$id\n", $userinput); } else { @@ -3745,7 +4206,8 @@ sub enrollment_enabled_handler { my $userinput = $cmd.":".$tail; # For logging purposes. - my $cdom = split(/:/, $tail); # Domain we're asking about. + my ($cdom) = split(/:/, $tail, 2); # Domain we're asking about. + my $outcome = &localenroll::run($cdom); &Reply($client, "$outcome\n", $userinput); @@ -3801,6 +4263,7 @@ sub validate_course_owner_handler { my $userinput = "$cmd:$tail"; my ($inst_course_id, $owner, $cdom) = split(/:/, $tail); + $owner = &unescape($owner); my $outcome = &localenroll::new_course($inst_course_id,$owner,$cdom); &Reply($client, "$outcome\n", $userinput); @@ -3841,16 +4304,47 @@ sub validate_course_section_handler { ®ister_handler("autovalidatecourse", \&validate_course_section_handler, 0, 1, 0); # -# Create a password for a new auto-enrollment user. -# I think/guess, this password allows access to the institutions -# AIS class list server/services. Stuart can correct this comment -# when he finds out how wrong I am. +# Validate course owner's access to enrollment data for specific class section. +# +# +# Formal Parameters: +# $cmd - The command request that got us dispatched. +# $tail - The tail of the command. In this case this is a colon separated +# set of words that will be split into: +# $inst_class - Institutional code for the specific class section +# $courseowner - The escaped username:domain of the course owner +# $cdom - The domain of the course from the institution's +# point of view. +# $client - The socket open on the client. +# Returns: +# 1 - continue processing. +# + +sub validate_class_access_handler { + my ($cmd, $tail, $client) = @_; + my $userinput = "$cmd:$tail"; + my ($inst_class,$courseowner,$cdom) = split(/:/, $tail); + $courseowner = &unescape($courseowner); + my $outcome; + eval { + local($SIG{__DIE__})='DEFAULT'; + $outcome=&localenroll::check_section($inst_class,$courseowner,$cdom); + }; + &Reply($client,"$outcome\n", $userinput); + + return 1; +} +®ister_handler("autovalidateclass_sec", \&validate_class_access_handler, 0, 1, 0); + +# +# Create a password for a new LON-CAPA user added by auto-enrollment. +# Only used for case where authentication method for new user is localauth # # Formal Parameters: # $cmd - The command request that got us dispatched. # $tail - The tail of the command. In this case this is a colon separated # set of words that will be split into: -# $authparam - An authentication parameter (username??). +# $authparam - An authentication parameter (localauth parameter). # $cdom - The domain of the course from the institution's # point of view. # $client - The socket open on the client. @@ -3977,6 +4471,115 @@ sub get_institutional_code_format_handle ®ister_handler("autoinstcodeformat", \&get_institutional_code_format_handler,0,1,0); +sub get_institutional_defaults_handler { + my ($cmd, $tail, $client) = @_; + my $userinput = "$cmd:$tail"; + + my $dom = $tail; + my %defaults_hash; + my @code_order; + my $outcome; + eval { + local($SIG{__DIE__})='DEFAULT'; + $outcome = &localenroll::instcode_defaults($dom,\%defaults_hash, + \@code_order); + }; + if (!$@) { + if ($outcome eq 'ok') { + my $result=''; + while (my ($key,$value) = each(%defaults_hash)) { + $result.=&escape($key).'='.&escape($value).'&'; + } + $result .= 'code_order='.&escape(join('&',@code_order)); + &Reply($client,$result."\n",$userinput); + } else { + &Reply($client,"error\n", $userinput); + } + } else { + &Failure($client,"unknown_cmd\n",$userinput); + } +} +®ister_handler("autoinstcodedefaults", + \&get_institutional_defaults_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. @@ -3989,24 +4592,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; } @@ -4067,6 +4682,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; @@ -4402,18 +5033,26 @@ sub ReadHostTable { open (CONFIG,"$perlvar{'lonTabDir'}/hosts.tab") || die "Can't read host file"; my $myloncapaname = $perlvar{'lonHostID'}; Debug("My loncapa name is : $myloncapaname"); + my %name_to_ip; while (my $configline=) { if ($configline !~ /^\s*\#/ && $configline !~ /^\s*$/ ) { my ($id,$domain,$role,$name)=split(/:/,$configline); $name=~s/\s//g; - my $ip = gethostbyname($name); - if (length($ip) ne 4) { - &logthis("Skipping host $id name $name no IP $ip found\n"); - next; + my $ip; + if (!exists($name_to_ip{$name})) { + $ip = gethostbyname($name); + if (!$ip || length($ip) ne 4) { + &logthis("Skipping host $id name $name no IP found\n"); + next; + } + $ip=inet_ntoa($ip); + $name_to_ip{$name} = $ip; + } else { + $ip = $name_to_ip{$name}; } - $ip=inet_ntoa($ip); $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. @@ -4622,22 +5261,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 { @@ -4664,12 +5287,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"; } @@ -4685,7 +5308,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); } @@ -4712,25 +5335,13 @@ 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"; } 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 { @@ -4855,7 +5466,8 @@ sub make_new_child { # my $tmpsnum=0; # Now global #---------------------------------------------------- kerberos 5 initialization &Authen::Krb5::init_context(); - if ($dist ne 'fedora4') { + unless (($dist eq 'fedora5') || ($dist eq 'fedora4') + || ($dist eq 'suse9.3')) { &Authen::Krb5::init_ets(); } @@ -4896,7 +5508,7 @@ sub make_new_child { my $remotereq=<$client>; chomp($remotereq); Debug("Got init: $remotereq"); - my $inikeyword = split(/:/, $remotereq); + if ($remotereq =~ /^init/) { &sethost("sethost:$perlvar{'lonHostID'}"); # @@ -4991,7 +5603,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); @@ -5047,8 +5659,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"); @@ -5278,7 +5893,8 @@ sub validate_user { # Authenticate via installation specific authentcation method: $validated = &localauth::localauth($user, $password, - $contentpwd); + $contentpwd, + $domain); } else { # Unrecognized auth is also bad. $validated = 0; } @@ -5321,39 +5937,51 @@ sub addline { } sub get_chat { - my ($cdom,$cname,$udom,$uname)=@_; - my %hash; - my $proname=&propath($cdom,$cname); + my ($cdom,$cname,$udom,$uname,$group)=@_; + my @entries=(); - if (tie(%hash,'GDBM_File',"$proname/nohist_chatroom.db", - &GDBM_READER(),0640)) { - @entries=map { $_.':'.$hash{$_} } sort keys %hash; - untie %hash; + my $namespace = 'nohist_chatroom'; + my $namespace_inroom = 'nohist_inchatroom'; + if ($group ne '') { + $namespace .= '_'.$group; + $namespace_inroom .= '_'.$group; + } + my $hashref = &tie_user_hash($cdom, $cname, $namespace, + &GDBM_READER()); + if ($hashref) { + @entries=map { $_.':'.$hashref->{$_} } sort(keys(%$hashref)); + &untie_user_hash($hashref); } my @participants=(); my $cutoff=time-60; - if (tie(%hash,'GDBM_File',"$proname/nohist_inchatroom.db", - &GDBM_WRCREAT(),0640)) { - $hash{$uname.':'.$udom}=time; - foreach (sort keys %hash) { - if ($hash{$_}>$cutoff) { - $participants[$#participants+1]='active_participant:'.$_; + $hashref = &tie_user_hash($cdom, $cname, $namespace_inroom, + &GDBM_WRCREAT()); + if ($hashref) { + $hashref->{$uname.':'.$udom}=time; + foreach my $user (sort(keys(%$hashref))) { + if ($hashref->{$user}>$cutoff) { + push(@participants, 'active_participant:'.$user); } } - untie %hash; + &untie_user_hash($hashref); } return (@participants,@entries); } sub chat_add { - my ($cdom,$cname,$newchat)=@_; - my %hash; - my $proname=&propath($cdom,$cname); + my ($cdom,$cname,$newchat,$group)=@_; my @entries=(); my $time=time; - if (tie(%hash,'GDBM_File',"$proname/nohist_chatroom.db", - &GDBM_WRCREAT(),0640)) { - @entries=map { $_.':'.$hash{$_} } sort keys %hash; + my $namespace = 'nohist_chatroom'; + my $logfile = 'chatroom.log'; + if ($group ne '') { + $namespace .= '_'.$group; + $logfile = 'chatroom_'.$group.'.log'; + } + my $hashref = &tie_user_hash($cdom, $cname, $namespace, + &GDBM_WRCREAT()); + if ($hashref) { + @entries=map { $_.':'.$hashref->{$_} } sort(keys(%$hashref)); my ($lastid)=($entries[$#entries]=~/^(\w+)\:/); my ($thentime,$idnum)=split(/\_/,$lastid); my $newid=$time.'_000000'; @@ -5363,21 +5991,22 @@ sub chat_add { $idnum=substr('000000'.$idnum,-6,6); $newid=$time.'_'.$idnum; } - $hash{$newid}=$newchat; + $hashref->{$newid}=$newchat; my $expired=$time-3600; - foreach (keys %hash) { - my ($thistime)=($_=~/(\d+)\_/); + foreach my $comment (keys(%$hashref)) { + my ($thistime) = ($comment=~/(\d+)\_/); if ($thistime<$expired) { - delete $hash{$_}; + delete $hashref->{$comment}; } } - untie %hash; - } - { - my $hfh; - if ($hfh=IO::File->new(">>$proname/chatroom.log")) { - print $hfh "$time:".&unescape($newchat)."\n"; + { + my $proname=&propath($cdom,$cname); + if (open(CHATLOG,">>$proname/$logfile")) { + print CHATLOG ("$time:".&unescape($newchat)."\n"); + } + close(CHATLOG); } + &untie_user_hash($hashref); } } @@ -5466,7 +6095,7 @@ sub thisversion { sub subscribe { my ($userinput,$clientip)=@_; my $result; - my ($cmd,$fname)=split(/:/,$userinput); + my ($cmd,$fname)=split(/:/,$userinput,2); my $ownership=&ishome($fname); if ($ownership eq 'owner') { # explitly asking for the current version? @@ -5647,6 +6276,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; @@ -6072,7 +6706,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.