path: root/FS/FS/UID.pm

package FS::UID;

use strict;
use vars qw(
  @ISA @EXPORT_OK $cgi $dbh $freeside_uid $user 
  $conf_dir $secrets $datasrc $db_user $db_pass %callback @callback
  $driver_name $AutoCommit
);
use subs qw(
  getsecrets cgisetotaker
);
use Exporter;
use Carp qw(carp croak cluck);
use DBI;
use FS::Conf;

@ISA = qw(Exporter);
@EXPORT_OK = qw(checkeuid checkruid cgisuidsetup adminsuidsetup forksuidsetup
                getotaker dbh datasrc getsecrets driver_name );

$freeside_uid = scalar(getpwnam('freeside'));

$conf_dir = "/usr/local/etc/freeside/";

$AutoCommit = 1; #ours, not DBI

=head1 NAME

FS::UID - Subroutines for database login and assorted other stuff

=head1 SYNOPSIS

  use FS::UID qw(adminsuidsetup cgisuidsetup dbh datasrc getotaker
  checkeuid checkruid);

  adminsuidsetup $user;

  $cgi = new CGI;
  $dbh = cgisuidsetup($cgi);

  $dbh = dbh;

  $datasrc = datasrc;

  $driver_name = driver_name;

=head1 DESCRIPTION

Provides a hodgepodge of subroutines. 

=head1 SUBROUTINES

=over 4

=item adminsuidsetup USER

Sets the user to USER (see config.html from the base documentation).
Cleans the environment.
Make sure the script is running as freeside, or setuid freeside.
Opens a connection to the database.
Swaps real and effective UIDs.
Runs any defined callbacks (see below).
Returns the DBI database handle (usually you don't need this).

=cut

sub adminsuidsetup {
  $dbh->disconnect if $dbh;
  &forksuidsetup(@_);
}

sub forksuidsetup {
  $user = shift;
  croak "fatal: adminsuidsetup called without arguements" unless $user;

  $user =~ /^([\w\-\.]+)$/ or croak "fatal: illegal user $user";
  $user = $1;

  $ENV{'PATH'} ='/usr/local/bin:/usr/bin:/usr/ucb:/bin';
  $ENV{'SHELL'} = '/bin/sh';
  $ENV{'IFS'} = " \t\n";
  $ENV{'CDPATH'} = '';
  $ENV{'ENV'} = '';
  $ENV{'BASH_ENV'} = '';

  croak "Not running uid freeside!" unless checkeuid();
  getsecrets;
  $dbh = DBI->connect($datasrc,$db_user,$db_pass, {
                          'AutoCommit' => 0,
                          'ChopBlanks' => 1,
  } ) or die "DBI->connect error: $DBI::errstr\n";

  foreach ( keys %callback ) {
    &{$callback{$_}};
    # breaks multi-database installs # delete $callback{$_}; #run once
  }

  &{$_} foreach @callback;

  $dbh;
}

=item install_callback

A package can install a callback to be run in adminsuidsetup by passing
a coderef to the FS::UID->install_callback class method.  If adminsuidsetup has
run already, the callback will also be run immediately.

    $coderef = sub { warn "Hi, I'm returning your call!" };
    FS::UID->install_callback($coderef);

    install_callback FS::UID sub { 
      warn "Hi, I'm returning your call!"
    };

=cut

sub install_callback {
  my $class = shift;
  my $callback = shift;
  push @callback, $callback;
  &{$callback} if $dbh;
}

=item cgisuidsetup CGI_object

Takes a single argument, which is a CGI (see L<CGI>) or Apache (see L<Apache>)
object (CGI::Base is depriciated).  Runs cgisetotaker and then adminsuidsetup.

=cut

sub cgisuidsetup {
  $cgi=shift;
  if ( $cgi->isa('CGI::Base') ) {
    carp "Use of CGI::Base is depriciated";
  } elsif ( $cgi->isa('Apache') ) {

  } elsif ( ! $cgi->isa('CGI') ) {
    croak "fatal: unrecognized object $cgi";
  }
  cgisetotaker; 
  adminsuidsetup($user);
}

=item cgi

Returns the CGI (see L<CGI>) object.

=cut

sub cgi {
  carp "warning: \$FS::UID::cgi isa Apache" if $cgi->isa('Apache');
  $cgi;
}

=item dbh

Returns the DBI database handle.

=cut

sub dbh {
  $dbh;
}

=item datasrc

Returns the DBI data source.

=cut

sub datasrc {
  $datasrc;
}

=item driver_name

Returns just the driver name portion of the DBI data source.

=cut

sub driver_name {
  return $driver_name if defined $driver_name;
  $driver_name = ( split(':', $datasrc) )[1];
}

sub suidsetup {
  croak "suidsetup depriciated";
}

=item getotaker

Returns the current Freeside user.

=cut

sub getotaker {
  $user;
}

=item cgisetotaker

Sets and returns the CGI REMOTE_USER.  $cgi should be defined as a CGI.pm
object (see L<CGI>) or an Apache object (see L<Apache>).  Support for CGI::Base
and derived classes is depriciated.

=cut

sub cgisetotaker {
  if ( $cgi && $cgi->isa('CGI::Base') && defined $cgi->var('REMOTE_USER')) {
    carp "Use of CGI::Base is depriciated";
    $user = lc ( $cgi->var('REMOTE_USER') );
  } elsif ( $cgi && $cgi->isa('CGI') && defined $cgi->remote_user ) {
    $user = lc ( $cgi->remote_user );
  } elsif ( $cgi && $cgi->isa('Apache') ) {
    $user = lc ( $cgi->connection->user );
  } else {
    die "fatal: Can't get REMOTE_USER! for cgi $cgi - you need to setup ".
        "Apache user authentication as documented in httemplate/docs/install.html";
  }
  $user;
}

=item checkeuid

Returns true if effective UID is that of the freeside user.

=cut

sub checkeuid {
  ( $> == $freeside_uid );
}

=item checkruid

Returns true if the real UID is that of the freeside user.

=cut

sub checkruid {
  ( $< == $freeside_uid );
}

=item getsecrets [ USER ]

Sets the user to USER, if supplied.
Sets and returns the DBI datasource, username and password for this user from
the `/usr/local/etc/freeside/mapsecrets' file.

=cut

sub getsecrets {
  my($setuser) = shift;
  $user = $setuser if $setuser;
  die "No user!" unless $user;
  my($conf) = new FS::Conf $conf_dir;
  my($line) = grep /^\s*$user\s/, $conf->config('mapsecrets');
  die "User $user not found in mapsecrets!" unless $line;
  $line =~ /^\s*$user\s+(.*)$/;
  $secrets = $1;
  die "Illegal mapsecrets line for user?!" unless $secrets;
  ($datasrc, $db_user, $db_pass) = $conf->config($secrets)
    or die "Can't get secrets: $!";
  $FS::Conf::default_dir = $conf_dir. "/conf.$datasrc";
  undef $driver_name;
  ($datasrc, $db_user, $db_pass);
}

=back

=head1 CALLBACKS

Warning: this interface is (still) likely to change in future releases.

New (experimental) callback interface:

A package can install a callback to be run in adminsuidsetup by passing
a coderef to the FS::UID->install_callback class method.  If adminsuidsetup has
run already, the callback will also be run immediately.

    $coderef = sub { warn "Hi, I'm returning your call!" };
    FS::UID->install_callback($coderef);

    install_callback FS::UID sub { 
      warn "Hi, I'm returning your call!"
    };

Old (deprecated) callback interface:

A package can install a callback to be run in adminsuidsetup by putting a
coderef into the hash %FS::UID::callback :

    $coderef = sub { warn "Hi, I'm returning your call!" };
    $FS::UID::callback{'Package::Name'} = $coderef;

=head1 BUGS

Too many package-global variables.

Not OO.

No capabilities yet.  When mod_perl and Authen::DBI are implemented, 
cgisuidsetup will go away as well.

Goes through contortions to support non-OO syntax with multiple datasrc's.

Callbacks are (still) inelegant.

=head1 SEE ALSO

L<FS::Record>, L<CGI>, L<DBI>, config.html from the base documentation.

=cut

1;