# $Id: UserAdmin.pm,v 1.1.1.1 2004/06/28 19:24:27 veselosky Exp $
package CGI::Builder::Auth::UserAdmin;
use CGI::Builder::Auth::AdminBase ();
use Carp ();
use strict;
use vars qw($VERSION @ISA);
@ISA = qw(CGI::Builder::Auth::AdminBase);
$VERSION = 1.51;
sub delete {
my($self, $user) = @_;
my $rc = 1;
delete($self->{'_HASH'}{$user});
$self->{'_HASH'}{$user} and $rc = 0;
$rc;
}
sub suspend {
my($self, $user) = @_;
$self->{'_HASH'}->{$user} = "!".$self->{'_HASH'}->{$user}
if $self->{'_HASH'}->{$user} !~ m/^!/;
return 0 unless $self->{'_HASH'}->{$user} =~ m/^!/;
return 1;
}
sub unsuspend {
my($self, $user) = @_;
$self->{'_HASH'}->{$user} =~ s/^!//;
return 0 unless $self->{'_HASH'}->{$user} !~ m/^!/;
return 1;
}
sub list {
keys %{$_[0]->{'_HASH'}};
}
sub exists {
my($self, $name) = @_;
return 0 unless defined $self->{'_HASH'}{$name};
return $self->{'_HASH'}{$name};
}
sub db {
my($self, $file) = @_;
my $old = $self->{'DB'};
return $old unless $file;
if($self->{'_HASH'}) {
$self->DESTROY;
}
$self->{'DB'} = $file;
#return unless $self->{NAME};
$self->lock || Carp::croak();
$self->_tie('_HASH', $self->{DB});
$old;
}
sub group {
my($self) = shift;
$self->load('CGI::Builder::Auth::GroupAdmin');
my %attr = %{$self};
foreach(qw(DB _HASH)) {
delete $attr{$_}; #just incase, everything else should be OK
}
return new CGI::Builder::Auth::GroupAdmin (%attr, @_);
}
sub update {
my($self, $username, $passwd, @fields) = @_;
return (0, "User '$username' does not exist") unless $self->exists($username);
my ($old_encr, $bool);
if (!defined $passwd) {
$bool = 1;
$passwd = $self->password($username);
$old_encr = $self->{ENCRYPT};
$self->{ENCRYPT} = 'none';
}
$self->delete($username);
$self->add($username, $passwd, @fields);
$self->{ENCRYPT} = $old_encr if $bool;
1;
}
sub convert {
my($self) = shift;
my $class = $self->baseclass(2); #hmm
my $new = $class->new(@_);
foreach($self->list) {
$new->add($_, $self->password($_), 1);
}
$new;
}
sub password {
my $self = shift;
my $val = $self->exists(@_);
my($x,$y,$z) = split(':',$val);
return defined($z) ? join(':',$x,$y,$z) : join(':',$x,$y)
if $self->{ENCRYPT} eq 'MD5';
return $x;
}
# from Apache's dbmmanage:
# if $newstyle is 1, then use new style salt (starts with '_' and contains
# four bytes of iteration count and four bytes of salt). Otherwise, just use
# the traditional two-byte salt.
# see the man page on your system to decide if you have a newer crypt() lib.
# I believe that 4.4BSD derived systems do (at least BSD/OS 2.0 does).
# The new style crypt() allows up to 20 characters of the password to be
# significant rather than only 8.
#my %NewStyle = map $_,1, qw(bsd/os-2.0);
sub encrypt {
my($self) = shift;
my $newstyle = defined $_[1]; # || defined $NewStyle{ join("-",@Config{qw(osname osvers)}) };
my($passwd) = "";
my($scheme) = $self->{ENCRYPT} || "crypt";
# not quite sure where we're at risk here...
# $_[0] =~ /^[^<>;|]+$/ or Carp::croak("Bad password name"); $_[0] = $&;
if($scheme eq "crypt") {
$passwd = crypt($_[0], salt($newstyle));
}
elsif ($scheme eq "MD5") {
#I know, this isn't really "encryption",
#since you can't decrypt it, oh well...
unless (defined $self->{'_MD5'}) {
require Digest::MD5;
$self->{'_MD5'} = new Digest::MD5;
}
my($username,$realm,$pass) = split(":", $_[0]);
$self->{'_MD5'}->add(join(":", $username, $realm, $pass));
$passwd = join(":", $realm, $self->{'_MD5'}->hexdigest());
$self->{'_MD5'}->reset;
} elsif ($scheme eq "SHA") {
require Digest::SHA1;
$passwd = '{SHA}' . Digest::SHA1::sha1_base64(shift) .'=';
} elsif ($scheme eq 'none') {
return $_[0];
} else {
Carp::croak("unknown encryption method '$_'");
}
return $passwd;
}
sub salt {
my($newstyle) = @_;
return defined($newstyle) && $newstyle ?
join('', "_", randchar(1), "a..", randchar(4)) : randchar(2);
}
my(@saltset) = (qw(. /), 0..9, "A".."Z", "a".."z");
sub randchar {
local($^W) = 0; #we get a bogus warning here
my($count) = @_;
my $str = "";
$str .= $saltset[rand(@saltset)] while $count--;
$str;
}
sub DESTROY {
}
#These should work fine with the _generic classes
my %Support = (apache => [qw(DBM Text SQL)],
ncsa => [qw(DBM Text)],
);
CGI::Builder::Auth::UserAdmin->support(%Support);
1;
__END__
=head1 NAME
CGI::Builder::Auth::UserAdmin - Management of HTTP server user databases
=head1 SYNOPSIS
use CGI::Builder::Auth::UserAdmin ();
=head1 DESCRIPTION
Pay no attention to that man behind the curtain! Move along, nothing to see
here!
This module was originally part of the HTTPD-User-Manage collection, which is
available on CPAN. If you want to use it, go download that package. This module
is used as part of the internal implementation of CGI::Builder::Auth. The
original documentation is preserved here in this release for historical
purposes. The software has been hacked and this documentation is not guaranteed
to be correct. The module may disappear from the CGI::Builder::Auth
distribution in a future release. Do not use it directly or rely on it.
This software is meant to provide a generic interface that
hides the inconsistencies across HTTP server implementations
of user and group databases.
=head1 METHODS
=over 4
=item new ()
Here's where we find out what's different about your server.
Some examples:
@DBM = (DBType => 'DBM',
DB => '.htpasswd',
Server => 'apache');
$user = new CGI::Builder::Auth::UserAdmin @DBM;
This creates an object who's database is a DBM file named '.htpasswd', in a format that
the Apache server understands.
@Text = (DBType => 'Text',
DB => '.htpasswd',
Server => 'ncsa');
$user = new CGI::Builder::Auth::UserAdmin @Text;
This creates an object whose database is a plain text file named '.htpasswd', in a format that
the NCSA server understands.
@SQL = (DBType => "SQL",
Host => "", #server hostname
Port => "", #server port
DB => "www", #database name
User => "", #database login name
Auth => "", #database login password
Encrypt => "crypt", #encryption method
Driver => "mSQL", #driver for DBI
Server => "apache", #HTTP server type, not required
UserTable => "www-users", #table with field names below
NameField => "user", #field for the name
PasswordField => "password", #field for the password
);
$user = new CGI::Builder::Auth::UserAdmin @SQL;
This creates an object who's mSQL database is named 'www', with a schema that
the Apache server (extention) understands.
Full list of constructor attributes:
Note: Attribute names are case-insensitive
B<DBType> - The type of database, one of 'DBM', 'Text', or 'SQL' (Default is 'DBM')
B<DB> - The database name (Default is '.htpasswd' for DBM & Text databases)
B<Server> - HTTP server name (Default is the generic class, that works with NCSA, Apache and possibly others)
Note: run 'perl t/support.t matrix' to see what support is currently availible
B<Encrypt> - One of 'crypt', 'MD5', or 'none' (no encryption. Defaults to 'crypt'
B<Locking> - Boolean, Lock Text and DBM files (Default is true)
B<Path> - Relative DB files are resolved to this value (Default is '.')
B<Debug> - Boolean, Turn on debug mode
B<Flags> - The read, write and create flags.
There are four modes:
B<rwc> - the default, open for reading, writing and creating.
B<rw> - open for reading and writing.
B<r> - open for reading only.
B<w> - open for writing only.
Specific to DBM files:
B<DBMF> - The DBM file implementation to use (Default is 'NDBM')
B<Mode> - The file creation mode, defaults to '0644'
Specific to DBI:
We talk to an SQL server via Tim Bunce's DBI interface. For more info see:
http://www.hermetica.com/technologia/DBI/
B<Host> - Server hostname
B<Port> - Server port
B<User> - Database login name
B<Auth> - Database login password
B<Driver> - Driver for DBI (Default is 'mSQL')
B<UserTable> - Table with field names below
B<NameField> - Field for the name (Default is 'user')
B<PasswordField> - Field for the password (Default is 'password')
From here on out, things should look the same for everyone.
=item add($username,$password,[@fields])
=item add($username,$password,\%fields)
Add a user.
Fails if $username exists in the database
if($user->add('dougm', 'secret')) {
print "You have the power!\n";
}
You may need to pass additional fields, such as the user's real name.
This depends on your server of course.
$user->add('JoeUser', 'try2guess', '', 'Joseph A. User');
You can also pass a set of field name/value pairs in
the form of a hash ref. Example
$user->add('JoeUser','try2guess','',
{'Name'=>'Joseph A. User','Credit_limit'=>2000});
=item delete($username)
Delete a user
if($user->delete('dougm')) {
print "He's gone\n";
}
=item suspend($username)
Suspend a user
if($user->suspend('dougm')) {
print "Account suspended\n";
}
=item unsuspend($username)
Unsuspend a suspended user
if($user->unsuspend('dougm')) {
print "Account restored to normal\n";
}
=item exists($username)
True if $username is found in the database
if($user->exists('dougm')) {
die "oh no!";
}
=item password()
Returns the encrypted password for a user
$passwd = $user->password("dougm");
Useful for copying users to another database.
=item fetch($username,@fields)
Fetch a list of field values from the indicated user. Field names may
be provided as a list or as an array reference. The return value is a
reference to a hash containing the field/value pairs.
=item list()
Returns a list of usernames in the current database
@users = $user->list
=item update($username,$password)
=item update($username,$password,\%fields) B<SQL only>
Update $username with a new $password
if($user->update('dougm', 'idunno')) {
print "Updated\n";
}
With SQL servers, you can update other fields in the table by passing
a hash reference:
$user->update('dougm','idunno',{'credit_limit'=>1000});
An undefined value in the password field will leave the field unchanged.
=item group()
Short cut for creating an CGI::Builder::Auth::GroupAdmin object.
All applicable attributes are inherited, but can be
overridden.
$group = $user->group(NAME => 'www-group');
(See CGI::Builder::Auth::GroupAdmin)
=item convert(@Attributes)
Convert a database.
$dbmuser = $user->convert(@Apache);
=item lock([$timeout])
=item unlock()
These methods give you control of the locking mechanism.
$user = new CGI::Builder::Auth::UserAdmin (Locking => 0); #turn off auto-locking
$user->lock; #lock the object's database
$user->add($username,$passwd); #write while file is locked
$user->unlock; release the lock
=item db($dbname);
Select a different database.
$olddb = $user->db($newdb);
print "Now we're reading and writing '$newdb', done with '$olddb'n\";
=item flags([$flags])
Get or set read, write, create flags.
=item commit
Commit changes to disk (for Text files).
=back
=head1 Message Digest User Databases
Currently, you can store user info in a format for servers who support
Message Digest Authentication. Here's an example:
$user = new CGI::Builder::Auth::UserAdmin (DB => '.htdigest', Encrypt => 'MD5');
($username,$realm,$password) = ('JoeUser', 'SomePlace', '14me');
#The checksum contains more info that just a password
$user->add($username, "$username:$realm:$password");
$user->update($username, "$username:$realm:newone");
$info = $user->password($username);
($realm, $checksum) = split(":", $info);
$user->delete($username);
See <URL:http://hoohoo.ncsa.uiuc.edu/docs/howto/md5_auth.html> for NCSA's
implementation.
So, it's a little more work, but don't worry, a nicer interface is on the way.
=head1 SEE ALSO
CGI::Builder::Auth::GroupAdmin(3), CGI::Builder::Auth::Authen(3)
=head1 AUTHOR
Doug MacEachern <dougm@osf.org>
Copyright (c) 1996, Doug MacEachern
This library is free software;
you can redistribute it and/or modify it under the same terms as Perl itself.
=cut