--- loncom/lond 2004/02/24 16:52:16 1.178.2.5 +++ loncom/lond 2004/04/29 10:35:07 1.178.2.21 @@ -2,7 +2,7 @@ # The LearningOnline Network # lond "LON Daemon" Server (port "LOND" 5663) # -# $Id: lond,v 1.178.2.5 2004/02/24 16:52:16 albertel Exp $ +# $Id: lond,v 1.178.2.21 2004/04/29 10:35:07 foxr 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.5 $'; #' stupid emacs +my $VERSION='$Revision: 1.178.2.21 $'; #' stupid emacs my $remoteVERSION; my $currenthostid; my $currentdomainid; @@ -161,7 +161,108 @@ sub isManager { sub isClient { return (($ConnectionType eq "client") || ($ConnectionType eq "both")); } +# +# 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 TieDomainHash { + my $domain = shift; + my $namespace = shift; + my $how = shift; + + # Filter out any whitespace in the domain name: + + $domain =~ s/\W//g; + + # We have enough to go on to tie the hash: + + my $UserTopDir = $perlvar{'lonUsersDir'}; + my $DomainDir = $UserTopDir."/$domain"; + my $ResourceFile = $DomainDir."/$namespace.db"; + my %hash; + if(tie(%hash, 'GDBM_File', $ResourceFile, $how, 0640)) { + if (scalar @_) { # Need to log the operation. + my $logFh = IO::File->new(">>$DomainDir/$namespace.hist"); + if($logFh) { + my $TimeStamp = time; + my ($loghead, $logtail) = @_; + print $logFh "$loghead:$TimeStamp:$logtail\n"; + } + } + 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 TieUserHash { + my $domain = shift; + my $user = shift; + my $namespace = shift; + my $how = shift; + + $namespace=~s/\//\_/g; # / -> _ + $namespace=~s/\W//g; # whitespace eliminated. + my $proname = propath($domain, $user); + + # If this is a namespace for which a history is kept, + # make the history log entry: + + + unless ($namespace =~/^nohist\_/ && (scalar @_ > 0)) { + my $hfh = IO::File->new(">>$proname/$namespace.hist"); + if($hfh) { + my $now = time; + my $loghead = shift; + my $what = shift; + print $hfh "$loghead:$now:$what\n"; + } + } + # Tie the database. + + my %hash; + if(tie(%hash, 'GDBM_File', "$proname/$namespace.db", + $how, 0640)) { + return \%hash; + } + else { + return undef; + } + +} # # Get a Request: @@ -460,7 +561,16 @@ sub UserAuthorizationType { if($result eq "nouser") { Failure( $replyfd, "unknown_user\n", $userinput); } else { - Reply( $replyfd, "$result\n", $userinput); + # + # We only want to pass the second field from GetAuthType + # for ^krb.. otherwise we'll be handing out the encrypted + # password for internals e.g. + # + my ($type,$otherinfo) = split(/:/,$result); + if($type =~ /^krb/) { + $type = $result; + } + Reply( $replyfd, "$type\n", $userinput); } return 1; @@ -615,129 +725,30 @@ sub AuthenticateHandler { my $cmd = shift; my $tail = shift; my $client = shift; - + # Regenerate the full input line - + my $userinput = $cmd.":".$tail; - + # udom - User's domain. # uname - Username. # upass - User's password. - + my ($udom,$uname,$upass)=split(/:/,$tail); Debug(" Authenticate domain = $udom, user = $uname, password = $upass"); chomp($upass); $upass=unescape($upass); - my $proname=propath($udom,$uname); - my $passfilename="$proname/passwd"; - - # The user's 'personal' loncapa passworrd file describes how to authenticate: - - if (-e $passfilename) { - Debug("Located password file: $passfilename"); - my $pf = IO::File->new($passfilename); - my $realpasswd=<$pf>; - chomp($realpasswd); - my ($howpwd,$contentpwd)=split(/:/,$realpasswd); - my $pwdcorrect=0; - # - # Authenticate against password stored in the internal file. - # - Debug("Authenticating via $howpwd"); - if ($howpwd eq 'internal') { - &Debug("Internal auth"); - $pwdcorrect= (crypt($upass,$contentpwd) eq $contentpwd); - # - # Authenticate against the unix password file. - # - } elsif ($howpwd eq 'unix') { - &Debug("Unix auth"); - if((getpwnam($uname))[1] eq "") { #no such user! - $pwdcorrect = 0; - } else { - $contentpwd=(getpwnam($uname))[1]; - my $pwauth_path="/usr/local/sbin/pwauth"; - unless ($contentpwd eq 'x') { - $pwdcorrect= (crypt($upass,$contentpwd) eq $contentpwd); - } elsif (-e $pwauth_path) { - open PWAUTH, "|$pwauth_path" or - die "Cannot invoke authentication"; - print PWAUTH "$uname\n$upass\n"; - close PWAUTH; - $pwdcorrect=!$?; - } - } - # - # Authenticate against a Kerberos 4 server: - # - } elsif ($howpwd eq 'krb4') { - my $null=pack("C",0); - unless ($upass=~/$null/) { - my $krb4_error = &Authen::Krb4::get_pw_in_tkt($uname, - "", - $contentpwd, - 'krbtgt', - $contentpwd, - 1, - $upass); - if (!$krb4_error) { - $pwdcorrect = 1; - } else { - $pwdcorrect=0; - # log error if it is not a bad password - if ($krb4_error != 62) { - &logthis('krb4:'.$uname.','.$contentpwd.','. - &Authen::Krb4::get_err_txt($Authen::Krb4::error)); - } - } - } - # - # Authenticate against a Kerberos 5 server: - # - } elsif ($howpwd eq 'krb5') { - my $null=pack("C",0); - unless ($upass=~/$null/) { - my $krbclient=&Authen::Krb5::parse_name($uname.'@'.$contentpwd); - my $krbservice="krbtgt/".$contentpwd."\@".$contentpwd; - my $krbserver=&Authen::Krb5::parse_name($krbservice); - my $credentials=&Authen::Krb5::cc_default(); - $credentials->initialize($krbclient); - my $krbreturn = &Authen::Krb5::get_in_tkt_with_password($krbclient, - $krbserver, - $upass, - $credentials); - $pwdcorrect = ($krbreturn == 1); - } else { - $pwdcorrect=0; - } - # - # Finally, the user may have written in an authentication module. - # in that case, if requested, authenticate against it. - # - } elsif ($howpwd eq 'localauth') { - $pwdcorrect=&localauth::localauth($uname,$upass,$contentpwd); - } + my $pwdcorrect = ValidateUser($udom, $uname, $upass); + if($pwdcorrect) { + Reply( $client, "authorized\n", $userinput); # - # Successfully authorized. - # - if ($pwdcorrect) { - Reply( $client, "authorized\n", $userinput); - # - # Bad credentials: Failed to authorize - # - } else { - Failure( $client, "non_authorized\n", $userinput); - } - # - # User bad... note it may be bad security practice to - # differntiate to the caller a bad user from a bad - # passwd... since that supplies covert channel information - # (you have a good user but bad password e.g.) to guessers. + # Bad credentials: Failed to authorize # } else { - Failure( $client, "unknown_user\n", $userinput); + Failure( $client, "non_authorized\n", $userinput); } + return 1; } RegisterHandler("auth", \&AuthenticateHandler, 1, 1, 0); @@ -781,79 +792,57 @@ sub ChangePasswordHandler { $upass=&unescape($upass); $npass=&unescape($npass); &Debug("Trying to change password for $uname"); - my $proname=propath($udom,$uname); - my $passfilename="$proname/passwd"; - if (-e $passfilename) { - my $realpasswd; - { - my $pf = IO::File->new($passfilename); - $realpasswd=<$pf>; - } - chomp($realpasswd); + + # First require that the user can be authenticated with their + # old password: + + my $validated = ValidateUser($udom, $uname, $upass); + if($validated) { + my $realpasswd = GetAuthType($udom, $uname); # Defined since authd. + my ($howpwd,$contentpwd)=split(/:/,$realpasswd); if ($howpwd eq 'internal') { &Debug("internal auth"); - if (crypt($upass,$contentpwd) eq $contentpwd) { - my $salt=time; - $salt=substr($salt,6,2); - my $ncpass=crypt($npass,$salt); - { - my $pf = IO::File->new(">$passfilename"); - if ($pf) { - print $pf "internal:$ncpass\n"; - &logthis("Result of password change for " - ."$uname: pwchange_success"); - Reply($client, "ok\n", $userinput); - } else { - &logthis("Unable to open $uname passwd " - ."to change password"); - Failure( $client, "non_authorized\n",$userinput); - } - } + my $salt=time; + $salt=substr($salt,6,2); + my $ncpass=crypt($npass,$salt); + if(RewritePwFile($udom, $uname, "internal:$ncpass")) { + &logthis("Result of password change for " + ."$uname: pwchange_success"); + Reply($client, "ok\n", $userinput); } else { - Failure($client, "non_authorized\n", $userinput); + &logthis("Unable to open $uname passwd " + ."to change password"); + Failure( $client, "non_authorized\n",$userinput); } } elsif ($howpwd eq 'unix') { # Unix means we have to access /etc/password - # one way or another. - # First: Make sure the current password is - # correct &Debug("auth is unix"); - $contentpwd=(getpwnam($uname))[1]; - my $pwdcorrect = "0"; - my $pwauth_path="/usr/local/sbin/pwauth"; - unless ($contentpwd eq 'x') { - $pwdcorrect= (crypt($upass,$contentpwd) eq $contentpwd); - } elsif (-e $pwauth_path) { - open PWAUTH, "|$pwauth_path" or - die "Cannot invoke authentication"; - print PWAUTH "$uname\n$upass\n"; - close PWAUTH; - &Debug("exited pwauth with $? ($uname,$upass) "); - $pwdcorrect=($? == 0); - } - if ($pwdcorrect) { - my $execdir=$perlvar{'lonDaemons'}; - &Debug("Opening lcpasswd pipeline"); - my $pf = IO::File->new("|$execdir/lcpasswd > " - ."$perlvar{'lonDaemons'}" - ."/logs/lcpasswd.log"); - print $pf "$uname\n$npass\n$npass\n"; - close $pf; - my $err = $?; - my $result = ($err>0 ? 'pwchange_failure' : 'ok'); - &logthis("Result of password change for $uname: ". - &lcpasswdstrerror($?)); - Reply($client, "$result\n", $userinput); - } else { - Reply($client, "non_authorized\n", $userinput); - } + my $execdir=$perlvar{'lonDaemons'}; + &Debug("Opening lcpasswd pipeline"); + my $pf = IO::File->new("|$execdir/lcpasswd > " + ."$perlvar{'lonDaemons'}" + ."/logs/lcpasswd.log"); + print $pf "$uname\n$npass\n$npass\n"; + close $pf; + my $err = $?; + my $result = ($err>0 ? 'pwchange_failure' : 'ok'); + &logthis("Result of password change for $uname: ". + &lcpasswdstrerror($?)); + Reply($client, "$result\n", $userinput); } else { + # this just means that the current password mode is not + # one we know how to change (e.g the kerberos auth modes or + # locally written auth handler). + # Reply( $client, "auth_mode_error\n", $userinput); } - } else { - Reply( $client, "unknown_user\n", $userinput); + + } + else { + Reply( $client, "non_authorized\n", $userinput); } + return 1; } RegisterHandler("passwd", \&ChangePasswordHandler, 1, 1, 0); @@ -878,42 +867,49 @@ sub AddUserHandler { my $cmd = shift; my $tail = shift; my $client = shift; - - my $userinput = $cmd.":".$tail; - my $oldumask=umask(0077); my ($udom,$uname,$umode,$npass)=split(/:/,$tail); + my $userinput = $cmd.":".$tail; # Reconstruct the full request line. + &Debug("cmd =".$cmd." $udom =".$udom." uname=".$uname); - chomp($npass); - $npass=&unescape($npass); - my $proname=propath($udom,$uname); - my $passfilename="$proname/passwd"; - &Debug("Password file created will be:".$passfilename); - if (-e $passfilename) { - Failure( $client, "already_exists\n", $userinput); - } elsif ($udom ne $currentdomainid) { - Failure($client, "not_right_domain\n", $userinput); - } else { - my @fpparts=split(/\//,$proname); - my $fpnow=$fpparts[0].'/'.$fpparts[1].'/'.$fpparts[2]; - my $fperror=''; - for (my $i=3;$i<=$#fpparts;$i++) { - $fpnow.='/'.$fpparts[$i]; - unless (-e $fpnow) { - unless (mkdir($fpnow,0777)) { - $fperror="error: ".($!+0)." mkdir failed while attempting " - ."makeuser"; + + + if($udom eq $currentdomainid) { # Reject new users for other domains... + + my $oldumask=umask(0077); + chomp($npass); + $npass=&unescape($npass); + my $passfilename = PasswordPath($udom, $uname); + &Debug("Password file created will be:".$passfilename); + if (-e $passfilename) { + Failure( $client, "already_exists\n", $userinput); + } else { + my @fpparts=split(/\//,$passfilename); + my $fpnow=$fpparts[0].'/'.$fpparts[1].'/'.$fpparts[2]; + my $fperror=''; + for (my $i=3;$i<= ($#fpparts-1);$i++) { + $fpnow.='/'.$fpparts[$i]; + unless (-e $fpnow) { + &logthis("mkdir $fpnow"); + unless (mkdir($fpnow,0777)) { + $fperror="error: ".($!+0)." mkdir failed while attempting " + ."makeuser"; + } } } + unless ($fperror) { + my $result=&make_passwd_file($uname, $umode,$npass, $passfilename); + Reply($client, $result, $userinput); #BUGBUG - could be fail + } else { + Failure($client, "$fperror\n", $userinput); + } } - unless ($fperror) { - my $result=&make_passwd_file($uname, $umode,$npass, $passfilename); - Reply($client, $result, $userinput); #BUGBUG - could be fail - } else { - Failure($client, "$fperror\n", $userinput); - } + umask($oldumask); + } else { + Failure($client, "not_right_domain\n", + $userinput); # Even if we are multihomed. + } - umask($oldumask); return 1; } @@ -949,16 +945,21 @@ sub ChangeAuthenticationHandler { my $userinput = "$cmd:$tail"; # Reconstruct user input. my ($udom,$uname,$umode,$npass)=split(/:/,$tail); - chomp($npass); &Debug("cmd = ".$cmd." domain= ".$udom."uname =".$uname." umode= ".$umode); - $npass=&unescape($npass); - my $proname=&propath($udom,$uname); - my $passfilename="$proname/passwd"; if ($udom ne $currentdomainid) { Failure( $client, "not_right_domain\n", $client); } else { - my $result=&make_passwd_file($uname, $umode,$npass,$passfilename); - Reply($client, $result, $userinput); + + chomp($npass); + + $npass=&unescape($npass); + my $passfilename = PasswordPath($udom, $uname); + if ($passfilename) { # Not allowed to create a new user!! + my $result=&make_passwd_file($uname, $umode,$npass,$passfilename); + Reply($client, $result, $userinput); + } else { + Failure($client, "non_authorized", $userinput); # Fail the user now. + } } return 1; } @@ -989,8 +990,8 @@ sub IsHomeHandler { my ($udom,$uname)=split(/:/,$tail); chomp($uname); - my $proname=propath($udom,$uname); - if (-e $proname) { + my $passfile = PasswordFilename($udom, $uname); + if($passfile) { Reply( $client, "found\n", $userinput); } else { Failure($client, "not_found\n", $userinput); @@ -1027,7 +1028,9 @@ sub UpdateResourceHandler { my $userinput = "$cmd:$tail"; - my $fname=$tail; + my $fname=split(/:/,$tail); # This allows interactive testing + chomp($fname); # with telnet. + my $ownership=ishome($fname); if ($ownership eq 'not_owner') { if (-e $fname) { @@ -1137,9 +1140,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. @@ -1149,9 +1150,9 @@ RegisterHandler("fetchuserfile", \&Fetch # 0 - Requested to exit, caller should shut down. # 1 - Continue processing. sub AuthenticateUserFileAccess { - my $cmd = shift; - my $tail = shift; - my $client = shift; + my $cmd = shift; + my $tail = shift; + my $client = shift; my $userinput = "$cmd:$tail"; my ($fname,$session)=split(/:/,$tail); @@ -1189,17 +1190,22 @@ sub UnsubscribeHandler { my $client = shift; my $userinput= "$cmd:$tail"; - my $fname = $tail; + my ($fname) = split(/:/,$tail); # This allows for interactive testing + # e.g. manual telnet and unsub:res: + # Otherwise the \r gets in the way. + chomp($fname); + 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. +# Subscribe to a resource # # Parameters: # $cmd - The command that got us here. @@ -1273,7 +1279,7 @@ sub ActivityLogEntryHandler { print $hfh "$now:$clientname:$what\n"; Reply( $client, "ok\n", $userinput); } else { - Reply($client, "error: ".($!+0)." IO::File->new Failed " + Failure($client, "error: ".($!+0)." IO::File->new Failed " ."while attempting log\n", $userinput); } @@ -1300,29 +1306,19 @@ sub PutUserProfileEntry { my $tail = shift; my $client = shift; my $userinput = "$cmd:$tail"; - + my ($udom,$uname,$namespace,$what) =split(/:/,$tail); - $namespace=~s/\//\_/g; - $namespace=~s/\W//g; if ($namespace ne 'roles') { chomp($what); - my $proname=propath($udom,$uname); - my $now=time; - unless ($namespace=~/^nohist\_/) { - my $hfh; - if ($hfh=IO::File->new(">>$proname/$namespace.hist")) { - print $hfh "P:$now:$what\n"; - } - } - my @pairs=split(/\&/,$what); - my %hash; - if (tie(%hash,'GDBM_File',"$proname/$namespace.db", - &GDBM_WRCREAT(),0640)) { + my $hashref = TieUserHash($udom, $uname, $namespace, + &GDBM_WRCREAT(),"P",$what); + if($hashref) { + my @pairs=split(/\&/,$what); foreach my $pair (@pairs) { my ($key,$value)=split(/=/,$pair); - $hash{$key}=$value; + $hashref->{$key}=$value; } - if (untie(%hash)) { + if (untie(%$hashref)) { Reply( $client, "ok\n", $userinput); } else { Failure($client, "error: ".($!+0)." untie(GDBM) failed ". @@ -1334,9 +1330,9 @@ sub PutUserProfileEntry { "while attempting put\n", $userinput); } } else { - Failure( $client, "refused\n", $userinput); + Failure( $client, "refused\n", $userinput); } - + return 1; } RegisterHandler("put", \&PutUserProfileEntry, 0, 1, 0); @@ -1360,47 +1356,38 @@ sub IncrementUserValueHandler { my $cmd = shift; my $tail = shift; my $client = shift; - my $userinput = shift; + my $userinput = "$cmd:$tail"; my ($udom,$uname,$namespace,$what) =split(/:/,$tail); - $namespace=~s/\//\_/g; - $namespace=~s/\W//g; if ($namespace ne 'roles') { - chomp($what); - my $proname=propath($udom,$uname); - my $now=time; - unless ($namespace=~/^nohist\_/) { - my $hfh; - if ($hfh=IO::File->new(">>$proname/$namespace.hist")) { - print $hfh "P:$now:$what\n"; - } - } - my @pairs=split(/\&/,$what); - my %hash; - if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT(), - 0640)) { + chomp($what); + my $hashref = TieUserHash($udom, $uname, + $namespace, &GDBM_WRCREAT(), + "P",$what); + if ($hashref) { + my @pairs=split(/\&/,$what); foreach my $pair (@pairs) { my ($key,$value)=split(/=/,$pair); # We could check that we have a number... if (! defined($value) || $value eq '') { $value = 1; } - $hash{$key}+=$value; + $hashref->{$key}+=$value; } - if (untie(%hash)) { + if (untie(%$hashref)) { Reply( $client, "ok\n", $userinput); } else { Failure($client, "error: ".($!+0)." untie(GDBM) failed ". - "while attempting put\n", $userinput); + "while attempting inc\n", $userinput); } } else { Failure($client, "error: ".($!+0)." tie(GDBM) Failed ". - "while attempting put\n", $userinput); + "while attempting inc\n", $userinput); } } else { Failure($client, "refused\n", $userinput); } - + return 1; } RegisterHandler("inc", \&IncrementUserValueHandler, 0, 1, 0); @@ -1430,34 +1417,28 @@ 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 $proname=propath($udom,$uname); - my $now=time; + my $hashref = TieUserHash($udom, $uname, $namespace, + &GDBM_WRCREAT(), "P", + "$exedom:$exeuser:$what"); # # Log the attempt to set a role. The {}'s here ensure that the file # handle is open for the minimal amount of time. Since the flush # is done on close this improves the chances the log will be an un- # corrupted ordered thing. - { - my $hfh; - if ($hfh=IO::File->new(">>$proname/$namespace.hist")) { - print $hfh "P:$now:$exedom:$exeuser:$what\n"; - } - } - my @pairs=split(/\&/,$what); - my %hash; - if (tie(%hash,'GDBM_File',"$proname/$namespace.db", &GDBM_WRCREAT(),0640)) { + if ($hashref) { + my @pairs=split(/\&/,$what); foreach my $pair (@pairs) { my ($key,$value)=split(/=/,$pair); - &ManagePermissions($key, $udom, $uname, - &GetAuthType( $udom, $uname)); - $hash{$key}=$value; + &ManagePermissions($key, $udom, $uname, + &GetAuthType( $udom, $uname)); + $hashref->{$key}=$value; } - if (untie(%hash)) { + if (untie($hashref)) { Reply($client, "ok\n", $userinput); } else { Failure( $client, "error: ".($!+0)." untie(GDBM) Failed ". @@ -1498,34 +1479,24 @@ sub RolesDeleteHandler { "what = ".$what); my $namespace='roles'; chomp($what); - my $proname=propath($udom,$uname); - my $now=time; - # - # Log the attempt. This {}'ing is done to ensure that the - # logfile is flushed and closed as quickly as possible. Hopefully - # this preserves both time ordering and reduces the probability that - # messages will be interleaved. - # - { - my $hfh; - if ($hfh=IO::File->new(">>$proname/$namespace.hist")) { - print $hfh "D:$now:$exedom:$exeuser:$what\n"; - } - } - my @rolekeys=split(/\&/,$what); - my %hash; - if (tie(%hash,'GDBM_File',"$proname/$namespace.db", &GDBM_WRCREAT(),0640)) { + my $hashref = TieUserHash($udom, $uname, $namespace, + &GDBM_WRCREAT(), "D", + "$exedom:$exeuser:$what"); + + if ($hashref) { + my @rolekeys=split(/\&/,$what); + foreach my $key (@rolekeys) { - delete $hash{$key}; + delete $hashref->{$key}; } - if (untie(%hash)) { + if (untie(%$hashref)) { Reply($client, "ok\n", $userinput); } else { Failure( $client, "error: ".($!+0)." untie(GDBM) Failed ". "while attempting rolesdel\n", $userinput); } } else { - Failure( $client, "error: ".($!+0)." tie(GDBM) Failed ". + Failure( $client, "error: ".($!+0)." tie(GDBM) Failed ". "while attempting rolesdel\n", $userinput); } @@ -1559,19 +1530,18 @@ sub GetProfileEntry { my $userinput= "$cmd:$tail"; my ($udom,$uname,$namespace,$what) = split(/:/,$tail); - $namespace=~s/\//\_/g; - $namespace=~s/\W//g; chomp($what); - my @queries=split(/\&/,$what); - my $proname=propath($udom,$uname); - my $qresult=''; - my %hash; - if (tie(%hash,'GDBM_File',"$proname/$namespace.db", &GDBM_READER(),0640)) { + my $hashref = TieUserHash($udom, $uname, $namespace, + &GDBM_READER()); + if ($hashref) { + my @queries=split(/\&/,$what); + my $qresult=''; + for (my $i=0;$i<=$#queries;$i++) { - $qresult.="$hash{$queries[$i]}&"; # Presumably failure gives empty string. + $qresult.="$hashref->{$queries[$i]}&"; # Presumably failure gives empty string. } - if (untie(%hash)) { - $qresult=~s/\&$//; # Remove trailing & from last lookup. + $qresult=~s/\&$//; # Remove trailing & from last lookup. + if (untie(%$hashref)) { Reply($client, "$qresult\n", $userinput); } else { Failure($client, "error: ".($!+0)." untie(GDBM) Failed ". @@ -1615,27 +1585,26 @@ sub GetProfileEntryEncrypted { my $userinput = "$cmd:$tail"; my ($cmd,$udom,$uname,$namespace,$what) = split(/:/,$userinput); - $namespace=~s/\//\_/g; - $namespace=~s/\W//g; chomp($what); - my @queries=split(/\&/,$what); - my $proname=propath($udom,$uname); - my $qresult=''; - my %hash; - if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER(),0640)) { + my $hashref = TieUserHash($udom, $uname, $namespace, + &GDBM_READER()); + if ($hashref) { + my @queries=split(/\&/,$what); + my $qresult=''; for (my $i=0;$i<=$#queries;$i++) { - $qresult.="$hash{$queries[$i]}&"; + $qresult.="$hashref->{$queries[$i]}&"; } - if (untie(%hash)) { + if (untie(%$hashref)) { $qresult=~s/\&$//; if ($cipher) { my $cmdlength=length($qresult); $qresult.=" "; my $encqresult=''; for(my $encidx=0;$encidx<=$cmdlength;$encidx+=8) { - $encqresult.= unpack("H16", $cipher->encrypt(substr($qresult, - $encidx, - 8))); + $encqresult.= unpack("H16", + $cipher->encrypt(substr($qresult, + $encidx, + 8))); } Reply( $client, "enc:$cmdlength:$encqresult\n", $userinput); } else { @@ -1652,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. @@ -1672,31 +1641,24 @@ RegisterHandler("eget", \&GetProfileEncr # 0 - Exit server. # # -sub DeletProfileEntry { + +sub DeleteProfileEntry { my $cmd = shift; my $tail = shift; my $client = shift; my $userinput = "cmd:$tail"; my ($udom,$uname,$namespace,$what) = split(/:/,$tail); - $namespace=~s/\//\_/g; - $namespace=~s/\W//g; chomp($what); - my $proname=propath($udom,$uname); - my $now=time; - unless ($namespace=~/^nohist\_/) { - my $hfh; - if ($hfh=IO::File->new(">>$proname/$namespace.hist")) { - print $hfh "D:$now:$what\n"; - } - } - my @keys=split(/\&/,$what); - my %hash; - if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT(),0640)) { + my $hashref = TieUserHash($udom, $uname, $namespace, + &GDBM_WRCREAT(), + "D",$what); + if ($hashref) { + my @keys=split(/\&/,$what); foreach my $key (@keys) { - delete($hash{$key}); + delete($hashref->{$key}); } - if (untie(%hash)) { + if (untie(%$hashref)) { Reply($client, "ok\n", $userinput); } else { Failure($client, "error: ".($!+0)." untie(GDBM) Failed ". @@ -1731,16 +1693,14 @@ sub GetProfileKeys { my $userinput = "$cmd:$tail"; my ($udom,$uname,$namespace)=split(/:/,$tail); - $namespace=~s/\//\_/g; - $namespace=~s/\W//g; - my $proname=propath($udom,$uname); my $qresult=''; - my %hash; - if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER(),0640)) { - foreach my $key (keys %hash) { + my $hashref = TieUserHash($udom, $uname, $namespace, + &GDBM_READER()); + if ($hashref) { + foreach my $key (keys %$hashref) { $qresult.="$key&"; } - if (untie(%hash)) { + if (untie(%$hashref)) { $qresult=~s/\&$//; Reply($client, "$qresult\n", $userinput); } else { @@ -1781,19 +1741,18 @@ sub DumpProfileDatabase { my $userinput = "$cmd:$tail"; my ($udom,$uname,$namespace) = split(/:/,$tail); - $namespace=~s/\//\_/g; - $namespace=~s/\W//g; - my $qresult=''; - my $proname=propath($udom,$uname); - my %hash; - if (tie(%hash,'GDBM_File',"$proname/$namespace.db", &GDBM_READER(),0640)) { + my $hashref = TieUserHash($udom, $uname, $namespace, + &GDBM_READER()); + if ($hashref) { # Structure of %data: # $data{$symb}->{$parameter}=$value; # $data{$symb}->{'v.'.$parameter}=$version; # since $parameter will be unescaped, we do not - # have to worry about silly parameter names... + # have to worry about silly parameter names... + + my $qresult=''; my %data = (); # A hash of anonymous hashes.. - while (my ($key,$value) = each(%hash)) { + while (my ($key,$value) = each(%$hashref)) { my ($v,$symb,$param) = split(/:/,$key); next if ($v eq 'version' || $symb eq 'keys'); next if (exists($data{$symb}) && @@ -1802,7 +1761,7 @@ sub DumpProfileDatabase { $data{$symb}->{$param}=$value; $data{$symb}->{'v.'.$param}=$v; } - if (untie(%hash)) { + if (untie(%$hashref)) { while (my ($symb,$param_hash) = each(%data)) { while(my ($param,$value) = each (%$param_hash)){ next if ($param =~ /^v\./); # Ignore versions... @@ -1858,19 +1817,16 @@ sub DumpWithRegexp { my $userinput = "$cmd:$tail"; my ($udom,$uname,$namespace,$regexp)=split(/:/,$tail); - $namespace=~s/\//\_/g; - $namespace=~s/\W//g; if (defined($regexp)) { $regexp=&unescape($regexp); } else { $regexp='.'; } - my $qresult=''; - my $proname=propath($udom,$uname); - my %hash; - if (tie(%hash,'GDBM_File',"$proname/$namespace.db", - &GDBM_READER(),0640)) { - while (my ($key,$value) = each(%hash)) { + my $hashref =TieUserHash($udom, $uname, $namespace, + &GDBM_READER()); + if ($hashref) { + my $qresult=''; + while (my ($key,$value) = each(%$hashref)) { if ($regexp eq '.') { $qresult.=$key.'='.$value.'&'; } else { @@ -1880,7 +1836,7 @@ sub DumpWithRegexp { } } } - if (untie(%hash)) { + if (untie(%$hashref)) { chop($qresult); Reply($client, "$qresult\n", $userinput); } else { @@ -1896,7 +1852,8 @@ sub DumpWithRegexp { } RegisterHandler("dump", \&DumpWithRegexp, 0, 1, 0); -# Store an aitem in any database but the roles database. +# Store an aitem in any resource meta data(?) or database with +# versioning? # # Parameters: # $cmd - Request command keyword. @@ -1922,36 +1879,29 @@ sub StoreHandler { my $userinput = "$cmd:$tail"; my ($udom,$uname,$namespace,$rid,$what) =split(/:/,$tail); - $namespace=~s/\//\_/g; - $namespace=~s/\W//g; if ($namespace ne 'roles') { + chomp($what); - my $proname=propath($udom,$uname); - my $now=time; - unless ($namespace=~/^nohist\_/) { - my $hfh; - if ($hfh=IO::File->new(">>$proname/$namespace.hist")) { - print $hfh "P:$now:$rid:$what\n"; - } - } my @pairs=split(/\&/,$what); - my %hash; - if (tie(%hash,'GDBM_File',"$proname/$namespace.db", - &GDBM_WRCREAT(),0640)) { - my @previouskeys=split(/&/,$hash{"keys:$rid"}); + my $hashref = TieUserHash($udom, $uname, $namespace, + &GDBM_WRCREAT(), "P", + "$rid:$what"); + if ($hashref) { + my $now = time; + my @previouskeys=split(/&/,$hashref->{"keys:$rid"}); my $key; - $hash{"version:$rid"}++; - my $version=$hash{"version:$rid"}; + $hashref->{"version:$rid"}++; + my $version=$hashref->{"version:$rid"}; my $allkeys=''; foreach my $pair (@pairs) { my ($key,$value)=split(/=/,$pair); $allkeys.=$key.':'; - $hash{"$version:$rid:$key"}=$value; + $hashref->{"$version:$rid:$key"}=$value; } - $hash{"$version:$rid:timestamp"}=$now; + $hashref->{"$version:$rid:timestamp"}=$now; $allkeys.='timestamp'; - $hash{"$version:keys:$rid"}=$allkeys; - if (untie(%hash)) { + $hashref->{"$version:keys:$rid"}=$allkeys; + if (untie($hashref)) { Reply($client, "ok\n", $userinput); } else { Failure($client, "error: ".($!+0)." untie(GDBM) Failed ". @@ -2028,7 +1978,7 @@ sub RestoreHandler { } -RegisterHandler("restor", \&RestoreHandler, 0,1,0); +RegisterHandler("restore", \&RestoreHandler, 0,1,0); # # Add a chat message to to a discussion board. @@ -2212,20 +2162,18 @@ sub PutCourseIdHandler { my $userinput = "$cmd:$tail"; - my ($udom,$what)=split(/:/,$tail); + my ($udom, $what) = split(/:/, $tail); chomp($what); - $udom=~s/\W//g; - my $proname= - "$perlvar{'lonUsersDir'}/$udom/nohist_courseids"; my $now=time; my @pairs=split(/\&/,$what); - my %hash; - if (tie(%hash,'GDBM_File',"$proname.db",&GDBM_WRCREAT(),0640)) { + + my $hashref = TieDomainHash($udom, "nohist_courseids", &GDBM_WRCREAT()); + if ($hashref) { foreach my $pair (@pairs) { my ($key,$value)=split(/=/,$pair); - $hash{$key}=$value.':'.$now; + $hashref->{$key}=$value.':'.$now; } - if (untie(%hash)) { + if (untie(%$hashref)) { Reply($client, "ok\n", $userinput); } else { Failure( $client, "error: ".($!+0) @@ -2280,24 +2228,29 @@ sub DumpCourseIdHandler { } unless (defined($since)) { $since=0; } my $qresult=''; - my $proname = "$perlvar{'lonUsersDir'}/$udom/nohist_courseids"; - my %hash; - if (tie(%hash,'GDBM_File',"$proname.db",&GDBM_READER(),0640)) { - while (my ($key,$value) = each(%hash)) { + 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); + logthis("Matching with $unescapeVal"); if (eval('$unescapeVal=~/$description/i')) { + logthis("Adding on match"); $qresult.="$key=$descr&"; } } } - if (untie(%hash)) { + if (untie(%$hashref)) { chop($qresult); Reply($client, "$qresult\n", $userinput); } else { @@ -2338,23 +2291,15 @@ sub PutIdHandler { my ($udom,$what)=split(/:/,$tail); chomp($what); - $udom=~s/\W//g; - my $proname="$perlvar{'lonUsersDir'}/$udom/ids"; - my $now=time; - { - my $hfh; - if ($hfh=IO::File->new(">>$proname.hist")) { - print $hfh "P:$now:$what\n"; - } - } my @pairs=split(/\&/,$what); - my %hash; - if (tie(%hash,'GDBM_File',"$proname.db",&GDBM_WRCREAT(),0640)) { + my $hashref = TieDomainHash($udom, "ids", &GDBM_WRCREAT(), + "P", $what); + if ($hashref) { foreach my $pair (@pairs) { my ($key,$value)=split(/=/,$pair); - $hash{$key}=$value; + $hashref->{$key}=$value; } - if (untie(%hash)) { + if (untie(%$hashref)) { Reply($client, "ok\n", $userinput); } else { Failure($client, "error: ".($!+0)." untie(GDBM) Failed ". @@ -2392,21 +2337,19 @@ sub GetIdHandler { my $cmd = shift; my $tail = shift; my $client = shift; - + my $userinput = "$client:$tail"; - + my ($udom,$what)=split(/:/,$tail); chomp($what); - $udom=~s/\W//g; - my $proname="$perlvar{'lonUsersDir'}/$udom/ids"; my @queries=split(/\&/,$what); my $qresult=''; - my %hash; - if (tie(%hash,'GDBM_File',"$proname.db",&GDBM_READER(),0640)) { + my $hashref = TieDomainHash($udom, "ids", &GDBM_READER()); + if ($hashref) { for (my $i=0;$i<=$#queries;$i++) { - $qresult.="$hash{$queries[$i]}&"; + $qresult.="$hashref->{$queries[$i]}&"; } - if (untie(%hash)) { + if (untie(%$hashref)) { $qresult=~s/\&$//; Reply($client, "$qresult\n", $userinput); } else { @@ -2417,7 +2360,7 @@ sub GetIdHandler { Failure($client, "error: ".($!+0)." tie(GDBM) Failed ". "while attempting idget\n",$userinput); } - + return 1; } @@ -2485,7 +2428,7 @@ sub TmpGetHandler { my $id = shift; my $client = shift; my $userinput = "$cmd:$id"; - + chomp($id); $id=~s/\W/\_/g; my $store; @@ -2520,9 +2463,9 @@ sub TmpDelHandler { my $cmd = shift; my $id = shift; my $client = shift; - + my $userinput= "$cmd:$id"; - + chomp($id); $id=~s/\W/\_/g; my $execdir=$perlvar{'lonDaemons'}; @@ -2532,7 +2475,7 @@ sub TmpDelHandler { Failure( $client, "error: ".($!+0)."Unlink tmp Failed ". "while attempting tmpdel\n", $userinput); } - + return 1; } @@ -2560,10 +2503,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); @@ -2747,6 +2695,8 @@ sub ProcessRequest { # Split off the request keyword from the rest of the stuff. my ($command, $tail) = split(/:/, $userinput, 2); + chomp($command); + chomp($tail); Debug("Command received: $command, encoded = $wasenc"); @@ -2788,7 +2738,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); } @@ -3860,11 +3810,14 @@ sub subsqlreply { sub propath { my ($udom,$uname)=@_; + Debug("Propath:$udom:$uname"); $udom=~s/\W//g; $uname=~s/\W//g; + Debug("Propath2:$udom:$uname"); my $subdir=$uname.'__'; $subdir =~ s/(.)(.)(.).*/$1\/$2\/$3/; my $proname="$perlvar{'lonUsersDir'}/$udom/$subdir/$uname"; + Debug("Propath returning $proname"); return $proname; } @@ -3872,9 +3825,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 { @@ -4100,7 +4057,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" ; @@ -4108,6 +4065,79 @@ sub ManagePermissions { system("$execdir/lchtmldir $userhome $user $authtype"); } } + +# +# Return the full path of a user password file, whether it exists or not. +# Parameters: +# domain - Domain in which the password file lives. +# user - name of the user. +# Returns: +# Full passwd path: +# +sub PasswordPath { + my $domain = shift; + my $user = shift; + + my $path = &propath($domain, $user); + $path .= "/passwd"; + + return $path; +} + +# Password Filename +# Returns the path to a passwd file given domain and user... only if +# it exists. +# Parameters: +# domain - Domain in which to search. +# user - username. +# Returns: +# - If the password file exists returns its path. +# - If the password file does not exist, returns undefined. +# +sub PasswordFilename { + my $domain = shift; + my $user = shift; + + Debug ("PasswordFilename called: dom = $domain user = $user"); + + my $path = PasswordPath($domain, $user); + Debug("PasswordFilename got path: $path"); + if(-e $path) { + return $path; + } else { + return undef; + } +} + +# +# Rewrite the contents of the user's passwd file. +# Parameters: +# domain - domain of the user. +# name - User's name. +# contents - New contents of the file. +# Returns: +# 0 - Failed. +# 1 - Success. +# +sub RewritePwFile { + my $domain = shift; + my $user = shift; + my $contents = shift; + + my $file = PasswordFilename($domain, $user); + if (defined $file) { + my $pf = IO::File->new(">$file"); + if($pf) { + print $pf "$contents\n"; + return 1; + } else { + return 0; + } + } else { + return 0; + } + +} # # GetAuthType - Determines the authorization type of a user in a domain. @@ -4118,27 +4148,148 @@ sub GetAuthType { my $user = shift; Debug("GetAuthType( $domain, $user ) \n"); - my $proname = &propath($domain, $user); - my $passwdfile = "$proname/passwd"; - if( -e $passwdfile ) { + my $passwdfile = PasswordFilename($domain, $user); + if( defined $passwdfile ) { my $pf = IO::File->new($passwdfile); my $realpassword = <$pf>; chomp($realpassword); Debug("Password info = $realpassword\n"); - my ($authtype, $contentpwd) = split(/:/, $realpassword); - Debug("Authtype = $authtype, content = $contentpwd\n"); - my $availinfo = ''; - if($authtype eq 'krb4' or $authtype eq 'krb5') { - $availinfo = $contentpwd; - } - - return "$authtype:$availinfo"; + return $realpassword; } else { Debug("Returning nouser"); return "nouser"; } } +# +# Validate a user given their domain, name and password. This utility +# function is used by both AuthenticateHandler and ChangePasswordHandler +# to validate the login credentials of a user. +# Parameters: +# $domain - The domain being logged into (this is required due to +# the capability for multihomed systems. +# $user - The name of the user being validated. +# $password - The user's propoposed password. +# +# Returns: +# 1 - The domain,user,pasword triplet corresponds to a valid +# user. +# 0 - The domain,user,password triplet is not a valid user. +# +sub ValidateUser { + my $domain = shift; + my $user = shift; + my $password= shift; + + # Why negative ~pi you may well ask? Well this function is about + # authentication, and therefore very important to get right. + # I've initialized the flag that determines whether or not I've + # validated correctly to a value it's not supposed to get. + # At the end of this function. I'll ensure that it's not still that + # value so we don't just wind up returning some accidental value + # as a result of executing an unforseen code path that + # did not set $validated. + + my $validated = -3.14159; + + # How we authenticate is determined by the type of authentication + # the user has been assigned. If the authentication type is + # "nouser", the user does not exist so we will return 0. + + my $contents = GetAuthType($domain, $user); + my ($howpwd, $contentpwd) = split(/:/, $contents); + + my $null = pack("C",0); # Used by kerberos auth types. + + if ($howpwd ne 'nouser') { + + if($howpwd eq "internal") { # Encrypted is in local password file. + $validated = (crypt($password, $contentpwd) eq $contentpwd); + } + elsif ($howpwd eq "unix") { # User is a normal unix user. + $contentpwd = (getpwnam($user))[1]; + if($contentpwd) { + if($contentpwd eq 'x') { # Shadow password file... + my $pwauth_path = "/usr/local/sbin/pwauth"; + open PWAUTH, "|$pwauth_path" or + die "Cannot invoke authentication"; + print PWAUTH "$user\n$password\n"; + close PWAUTH; + $validated = ! $?; + + } else { # Passwords in /etc/passwd. + $validated = (crypt($password, + $contentpwd) eq $contentpwd); + } + } else { + $validated = 0; + } + } + elsif ($howpwd eq "krb4") { # user is in kerberos 4 auth. domain. + if(! ($password =~ /$null/) ) { + my $k4error = &Authen::Krb4::get_pw_in_tkt($user, + "", + $contentpwd,, + 'krbtgt', + $contentpwd, + 1, + $password); + if(!$k4error) { + $validated = 1; + } + else { + $validated = 0; + &logthis('krb4: '.$user.', '.$contentpwd.', '. + &Authen::Krb4::get_err_txt($Authen::Krb4::error)); + } + } + else { + $validated = 0; # Password has a match with null. + } + } + elsif ($howpwd eq "krb5") { # User is in kerberos 5 auth. domain. + if(!($password =~ /$null/)) { # Null password not allowed. + my $krbclient = &Authen::Krb5::parse_name($user.'@' + .$contentpwd); + my $krbservice = "krbtgt/".$contentpwd."\@".$contentpwd; + my $krbserver = &Authen::Krb5::parse_name($krbservice); + my $credentials= &Authen::Krb5::cc_default(); + $credentials->initialize($krbclient); + my $krbreturn = &Authen::KRb5::get_in_tkt_with_password($krbclient, + $krbserver, + $password, + $credentials); + $validated = ($krbreturn == 1); + } + else { + $validated = 0; + } + } + elsif ($howpwd eq "localauth") { + # Authenticate via installation specific authentcation method: + $validated = &localauth::localauth($user, + $password, + $contentpwd); + } + else { # Unrecognized auth is also bad. + $validated = 0; + } + } else { + $validated = 0; + } + # + # $validated has the correct stat of the authentication: + # + + unless ($validated != -3.14159) { + die "ValidateUser - failed to set the value of validated"; + } + return $validated; +} + +# +# Add a line to the subscription list? +# sub addline { my ($fname,$hostid,$ip,$newline)=@_; my $contents; @@ -4146,19 +4297,31 @@ 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; } - +# +# Get chat messages. +# sub getchat { my ($cdom,$cname,$udom,$uname)=@_; my %hash; @@ -4183,7 +4346,9 @@ sub getchat { } return (@participants,@entries); } - +# +# Add a chat message +# sub chatadd { my ($cdom,$cname,$newchat)=@_; my %hash; @@ -4223,17 +4388,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; } @@ -4285,12 +4469,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)*)$/) { @@ -4306,6 +4493,7 @@ sub subscribe { } } if (-e $fname) { + Debug("subscribe - exists"); if (-d $fname) { $result="directory\n"; } else { @@ -4354,23 +4542,35 @@ sub make_passwd_file { print $pf "localauth:$npass\n"; } } elsif ($umode eq 'unix') { - { - my $execpath="$perlvar{'lonDaemons'}/"."lcuseradd"; - { - &Debug("Executing external: ".$execpath); - &Debug("user = ".$uname.", Password =". $npass); - my $se = IO::File->new("|$execpath > $perlvar{'lonDaemons'}/logs/lcuseradd.log"); - print $se "$uname\n"; - print $se "$npass\n"; - print $se "$npass\n"; - } - my $useraddok = $?; - if($useraddok > 0) { - &logthis("Failed lcuseradd: ".&lcuseraddstrerror($useraddok)); - } - my $pf = IO::File->new(">$passfilename"); - print $pf "unix:\n"; + # + # Don't allow the creation of privileged accounts!!! that would + # be real bad!!! + # + my $uid = getpwnam($uname); + if((defined $uid) && ($uid == 0)) { + &logthis(">>>Attempted add of privileged account blocked<<<"); + return "no_priv_account_error\n"; } + + # + my $execpath="$perlvar{'lonDaemons'}/"."lcuseradd"; + + &Debug("Executing external: ".$execpath); + &Debug("user = ".$uname.", Password =". $npass); + my $se = IO::File->new("|$execpath > $perlvar{'lonDaemons'}/logs/lcuseradd.log"); + print $se "$uname\n"; + print $se "$npass\n"; + print $se "$npass\n"; + + my $useraddok = $?; + if($useraddok > 0) { + my $lcstring = lcuseraddstrerror($useraddok); + &logthis("Failed lcuseradd: $lcstring"); + return "error: lcuseradd failed: $lcstring\n"; + } + my $pf = IO::File->new(">$passfilename"); + print $pf "unix:\n"; + } elsif ($umode eq 'none') { { my $pf = IO::File->new(">$passfilename"); @@ -4384,8 +4584,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};