--- loncom/lond 2004/04/13 09:41:57 1.178.2.15 +++ loncom/lond 2004/05/07 17:57:18 1.178.2.23 @@ -2,7 +2,7 @@ # The LearningOnline Network # lond "LON Daemon" Server (port "LOND" 5663) # -# $Id: lond,v 1.178.2.15 2004/04/13 09:41:57 foxr Exp $ +# $Id: lond,v 1.178.2.23 2004/05/07 17:57:18 www Exp $ # # Copyright Michigan State University Board of Trustees # @@ -53,7 +53,7 @@ my $DEBUG = 1; # Non zero to ena my $status=''; my $lastlog=''; -my $VERSION='$Revision: 1.178.2.15 $'; #' stupid emacs +my $VERSION='$Revision: 1.178.2.23 $'; #' stupid emacs my $remoteVERSION; my $currenthostid; my $currentdomainid; @@ -242,7 +242,9 @@ sub TieUserHash { # make the history log entry: - unless ($namespace =~/^nohist\_/ && (scalar @_ > 0)) { + if (($namespace =~/^nohist\_/) && (scalar @_ > 0)) { + my $args = scalar @_; + Debug(" Opening history: $namespace $args"); my $hfh = IO::File->new(">>$proname/$namespace.hist"); if($hfh) { my $now = time; @@ -788,7 +790,7 @@ sub ChangePasswordHandler { # npass - New password. my ($udom,$uname,$upass,$npass)=split(/:/,$tail); - chomp($npass); + $upass=&unescape($upass); $npass=&unescape($npass); &Debug("Trying to change password for $uname"); @@ -1028,7 +1030,9 @@ sub UpdateResourceHandler { my $userinput = "$cmd:$tail"; - my $fname=$tail; + my $fname= $tail; # This allows interactive testing + + my $ownership=ishome($fname); if ($ownership eq 'not_owner') { if (-e $fname) { @@ -1138,10 +1142,7 @@ sub FetchUserFileHandler { } RegisterHandler("fetchuserfile", \&FetchUserFileHandler, 0, 1, 0); # -# Authenticate access to a user file. Question? The token for athentication -# is allowed to be sent as cleartext is this really what we want? This token -# represents the user's session id. Once it is forged does this allow too much -# access?? +# Authenticate access to a user file. # # Parameters: # $cmd - The command that got us here. @@ -1191,15 +1192,18 @@ sub UnsubscribeHandler { my $client = shift; my $userinput= "$cmd:$tail"; - my $fname = $tail; + my ($fname) = $tail; + + Debug("Unsubscribing $fname"); if (-e $fname) { - Reply($client, &unsub($client,$fname,$clientip), $userinput); + Debug("Exists"); + Reply($client, &unsub($fname,$clientip), $userinput); } else { Failure($client, "not_found\n", $userinput); } return 1; } -RegisterHandler("unusb", \&UnsubscribeHandler, 0, 1, 0); +RegisterHandler("unsub", \&UnsubscribeHandler, 0, 1, 0); # Subscribe to a resource # @@ -1413,9 +1417,9 @@ sub RolesPutHandler { my $client = shift; my $userinput = "$cmd:$tail"; - my ($exedom,$exeuser,$udom,$uname,$what) =split(/:/,$tail); - &Debug("cmd = ".$cmd." exedom= ".$exedom."user = ".$exeuser." udom=".$udom. - "what = ".$what); + my ( $exedom, $exeuser, $udom, $uname, $what) = split(/:/,$tail); + + my $namespace='roles'; chomp($what); my $hashref = TieUserHash($udom, $uname, $namespace, @@ -1617,7 +1621,7 @@ sub GetProfileEntryEncrypted { return 1; } -RegisterHandler("eget", \&GetProfileEncrypted, 0, 1, 0); +RegisterHandler("eget", \&GetProfileEntryEncrypted, 0, 1, 0); # # Deletes a key in a user profile database. @@ -1848,7 +1852,7 @@ sub DumpWithRegexp { } RegisterHandler("dump", \&DumpWithRegexp, 0, 1, 0); -# Store an aitem in any database but the roles database. +# Store a set of key=value pairs associated with a versioned name. # # Parameters: # $cmd - Request command keyword. @@ -1914,7 +1918,9 @@ sub StoreHandler { } RegisterHandler("store", \&StoreHandler, 0, 1, 0); # -# Restore a prior version of a resource. +# 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 +# command. # # Parameters: # $cmd - Command keyword. @@ -1928,6 +1934,13 @@ RegisterHandler("store", \&StoreHandler, # 1 indicating the caller should not yet exit. # Side-effects: # Writes a reply to the client. +# The reply is a string of the following shape: +# version=current&version:keys=k1:k2...&1:k1=v1&1:k2=v2... +# Where the 1 above represents version 1. +# this continues for all pairs of keys in all versions. +# +# +# # sub RestoreHandler { my $cmd = shift; @@ -2223,19 +2236,24 @@ sub DumpCourseIdHandler { } unless (defined($since)) { $since=0; } my $qresult=''; - + logthis(" Looking for $description since $since"); my $hashref = TieDomainHash($udom, "nohist_courseids", &GDBM_WRCREAT()); if ($hashref) { while (my ($key,$value) = each(%$hashref)) { my ($descr,$lasttime)=split(/\:/,$value); + logthis("Got: key = $key descr = $descr time: $lasttime"); if ($lasttime<$since) { + logthis("Skipping .. too early"); next; } if ($description eq '.') { + logthis("Adding wildcard match"); $qresult.=$key.'='.$descr.'&'; } else { my $unescapeVal = &unescape($descr); - if (eval('$unescapeVal=~/$description/i')) { + logthis("Matching with $unescapeVal"); + if (eval('$unescapeVal=~/\Q$description\E/i')) { + logthis("Adding on match"); $qresult.="$key=$descr&"; } } @@ -2419,7 +2437,7 @@ sub TmpGetHandler { my $client = shift; my $userinput = "$cmd:$id"; - chomp($id); + $id=~s/\W/\_/g; my $store; my $execdir=$perlvar{'lonDaemons'}; @@ -2493,10 +2511,15 @@ sub LsHandler { my $userinput = "$cmd:$ulsdir"; + chomp($ulsdir); + my $ulsout=''; my $ulsfn; + logthis("ls for '$ulsdir'"); if (-e $ulsdir) { + logthis("ls - directory exists"); if(-d $ulsdir) { + logthis("ls $ulsdir is a file"); if (opendir(LSDIR,$ulsdir)) { while ($ulsfn=readdir(LSDIR)) { my @ulsstats=stat($ulsdir.'/'.$ulsfn); @@ -2680,6 +2703,9 @@ sub ProcessRequest { # Split off the request keyword from the rest of the stuff. my ($command, $tail) = split(/:/, $userinput, 2); + chomp($command); + chomp($tail); + $tail =~ s/(\r)//; # This helps people debugging with e.g. telnet. Debug("Command received: $command, encoded = $wasenc"); @@ -2721,7 +2747,7 @@ sub ProcessRequest { $KeepGoing = &$Handler($command, $tail, $client); } else { Debug("Refusing to dispatch because ok is false"); - Failure($client, "refused", $userinput); + Failure($client, "refused\n", $userinput); } @@ -3808,9 +3834,13 @@ sub propath { sub ishome { my $author=shift; + Debug("ishome: $author"); $author=~s/\/home\/httpd\/html\/res\/([^\/]*)\/([^\/]*).*/$1\/$2/; + Debug(" after big regsub: $author"); my ($udom,$uname)=split(/\//,$author); + Debug(" domain: $udom user: $uname"); my $proname=propath($udom,$uname); + Debug(" path = $proname"); if (-e $proname) { return 'owner'; } else { @@ -4036,7 +4066,7 @@ sub ManagePermissions { my $authtype= shift; # See if the request is of the form /$domain/_au - &logthis("ruequest is $request"); + &logthis("request is $request"); if($request =~ /^(\/$domain\/_au)$/) { # It's an author rolesput... my $execdir = $perlvar{'lonDaemons'}; my $userhome= "/home/$user" ; @@ -4276,15 +4306,25 @@ sub addline { my $expr='^'.$hostid.':'.$ip.':'; $expr =~ s/\./\\\./g; my $sh; + Debug("Looking for $expr"); if ($sh=IO::File->new("$fname.subscription")) { while (my $subline=<$sh>) { - if ($subline !~ /$expr/) {$contents.= $subline;} else {$found=1;} + Debug("addline: line: $subline"); + if ($subline !~ /$expr/) { + $contents.= $subline; + } else { + Debug("Found $subline"); + $found=1; + } } $sh->close(); } $sh=IO::File->new(">$fname.subscription"); if ($contents) { print $sh $contents; } - if ($newline) { print $sh $newline; } + if ($newline) { + Debug("Appending $newline"); + print $sh $newline; + } $sh->close(); return $found; } @@ -4357,17 +4397,36 @@ sub chatadd { sub unsub { my ($fname,$clientip)=@_; my $result; + my $unsubs = 0; # Number of successful unsubscribes: + + + # An old way subscriptions were handled was to have a + # subscription marker file: + + Debug("Attempting unlink of $fname.$clientname"); if (unlink("$fname.$clientname")) { - $result="ok\n"; - } else { - $result="not_subscribed\n"; - } + $unsubs++; # Successful unsub via marker file. + } + + # The more modern way to do it is to have a subscription list + # file: + if (-e "$fname.subscription") { my $found=&addline($fname,$clientname,$clientip,''); - if ($found) { $result="ok\n"; } + if ($found) { + $unsubs++; + } + } + + # If either or both of these mechanisms succeeded in unsubscribing a + # resource we can return ok: + + if($unsubs) { + $result = "ok\n"; } else { - if ($result != "ok\n") { $result="not_subscribed\n"; } + $result = "not_subscribed\n"; } + return $result; } @@ -4419,12 +4478,15 @@ sub thisversion { sub subscribe { my ($userinput,$clientip)=@_; + chomp($userinput); my $result; my ($cmd,$fname)=split(/:/,$userinput); my $ownership=&ishome($fname); + Debug("subscribe: Owner = $ownership file: '$fname'"); if ($ownership eq 'owner') { # explitly asking for the current version? unless (-e $fname) { + Debug("subscribe - does not exist"); my $currentversion=¤tversion($fname); if (&thisversion($fname)==$currentversion) { if ($fname=~/^(.+)\.\d+\.(\w+(?:\.meta)*)$/) { @@ -4440,6 +4502,7 @@ sub subscribe { } } if (-e $fname) { + Debug("subscribe - exists"); if (-d $fname) { $result="directory\n"; } else { @@ -4510,7 +4573,9 @@ sub make_passwd_file { my $useraddok = $?; if($useraddok > 0) { - &logthis("Failed lcuseradd: ".&lcuseraddstrerror($useraddok)); + my $lcstring = lcuseraddstrerror($useraddok); + &logthis("Failed lcuseradd: $lcstring"); + return "error: lcuseradd failed: $lcstring\n"; } my $pf = IO::File->new(">$passfilename"); print $pf "unix:\n"; @@ -4528,8 +4593,10 @@ sub make_passwd_file { sub sethost { my ($remotereq) = @_; + Debug("sethost got $remotereq"); my (undef,$hostid)=split(/:/,$remotereq); if (!defined($hostid)) { $hostid=$perlvar{'lonHostID'}; } + Debug("sethost attempting to set host $hostid"); if ($hostip{$perlvar{'lonHostID'}} eq $hostip{$hostid}) { $currenthostid=$hostid; $currentdomainid=$hostdom{$hostid};