FS/FS/UID.pm

   1 package FS::UID;
   2
   3 use strict;
   4 use vars qw(
   5   @ISA @EXPORT_OK $DEBUG $me $cgi $dbh $freeside_uid $user
   6   $conf_dir $secrets $datasrc $db_user $db_pass %callback @callback
   7   $driver_name $AutoCommit $callback_hack $use_confcompat
   8 );
   9 use subs qw(
  10   getsecrets cgisetotaker
  11 );
  12 use Exporter;
  13 use Carp qw(carp croak cluck confess);
  14 use DBI;
  15 use IO::File;
  16 use FS::CurrentUser;
  17
  18 @ISA = qw(Exporter);
  19 @EXPORT_OK = qw(checkeuid checkruid cgisuidsetup adminsuidsetup forksuidsetup
  20                 getotaker dbh datasrc getsecrets driver_name myconnect
  21                 use_confcompat);
  22
  23 $DEBUG = 0;
  24 $me = '[FS::UID]';
  25
  26 $freeside_uid = scalar(getpwnam('freeside'));
  27
  28 $conf_dir = "%%%FREESIDE_CONF%%%";
  29
  30 $AutoCommit = 1; #ours, not DBI
  31 $use_confcompat = 1;
  32 $callback_hack = 0;
  33
  34 =head1 NAME
  35
  36 FS::UID - Subroutines for database login and assorted other stuff
  37
  38 =head1 SYNOPSIS
  39
  40   use FS::UID qw(adminsuidsetup cgisuidsetup dbh datasrc getotaker
  41   checkeuid checkruid);
  42
  43   adminsuidsetup $user;
  44
  45   $cgi = new CGI;
  46   $dbh = cgisuidsetup($cgi);
  47
  48   $dbh = dbh;
  49
  50   $datasrc = datasrc;
  51
  52   $driver_name = driver_name;
  53
  54 =head1 DESCRIPTION
  55
  56 Provides a hodgepodge of subroutines.
  57
  58 =head1 SUBROUTINES
  59
  60 =over 4
  61
  62 =item adminsuidsetup USER
  63
  64 Sets the user to USER (see config.html from the base documentation).
  65 Cleans the environment.
  66 Make sure the script is running as freeside, or setuid freeside.
  67 Opens a connection to the database.
  68 Swaps real and effective UIDs.
  69 Runs any defined callbacks (see below).
  70 Returns the DBI database handle (usually you don't need this).
  71
  72 =cut
  73
  74 sub adminsuidsetup {
  75   $dbh->disconnect if $dbh;
  76   &forksuidsetup(@_);
  77 }
  78
  79 sub forksuidsetup {
  80   $user = shift;
  81   my $olduser = $user;
  82   warn "$me forksuidsetup starting for $user\n" if $DEBUG;
  83
  84   if ( $FS::CurrentUser::upgrade_hack ) {
  85     $user = 'fs_bootstrap';
  86   } else {
  87     croak "fatal: adminsuidsetup called without arguements" unless $user;
  88
  89     $user =~ /^([\w\-\.]+)$/ or croak "fatal: illegal user $user";
  90     $user = $1;
  91   }
  92
  93   $ENV{'PATH'} ='/usr/local/bin:/usr/bin:/usr/ucb:/bin';
  94   $ENV{'SHELL'} = '/bin/sh';
  95   $ENV{'IFS'} = " \t\n";
  96   $ENV{'CDPATH'} = '';
  97   $ENV{'ENV'} = '';
  98   $ENV{'BASH_ENV'} = '';
  99
 100   croak "Not running uid freeside!" unless checkeuid();
 101
 102   warn "$me forksuidsetup connecting to database\n" if $DEBUG;
 103   if ( $FS::CurrentUser::upgrade_hack && $olduser ) {
 104     $dbh = &myconnect($olduser);
 105   } else {
 106     $dbh = &myconnect();
 107   }
 108   warn "$me forksuidsetup connected to database with handle $dbh\n" if $DEBUG;
 109
 110   warn "$me forksuidsetup loading schema\n" if $DEBUG;
 111   use FS::Schema qw(reload_dbdef);
 112   reload_dbdef("$conf_dir/dbdef.$datasrc")
 113     unless $FS::Schema::setup_hack;
 114
 115   warn "$me forksuidsetup deciding upon config system to use\n" if $DEBUG;
 116
 117   my $confcount = 0;
 118
 119   my $sth = $dbh->prepare("SELECT COUNT(*) FROM conf") or warn $dbh->errstr;
 120   $sth and $sth->execute or warn $sth->errstr;
 121   $sth and $confcount = $sth->fetchrow_arrayref->[0];
 122
 123   if ($confcount) {
 124     $use_confcompat = 0;
 125   }else{
 126     warn "NO CONFIGURATION RECORDS FOUND";
 127   }
 128
 129   unless ( $callback_hack ) {
 130     warn "$me calling callbacks\n" if $DEBUG;
 131     foreach ( keys %callback ) {
 132       &{$callback{$_}};
 133       # breaks multi-database installs # delete $callback{$_}; #run once
 134     }
 135
 136     &{$_} foreach @callback;
 137   } else {
 138     warn "$me skipping callbacks (callback_hack set)\n" if $DEBUG;
 139   }
 140
 141   warn "$me forksuidsetup loading user\n" if $DEBUG;
 142   FS::CurrentUser->load_user($user);
 143
 144   $dbh;
 145 }
 146
 147 sub myconnect {
 148   DBI->connect( getsecrets(@_), { 'AutoCommit'         => 0,
 149                                   'ChopBlanks'         => 1,
 150                                   'ShowErrorStatement' => 1,
 151                                 }
 152               )
 153     or die "DBI->connect error: $DBI::errstr\n";
 154 }
 155
 156 =item install_callback
 157
 158 A package can install a callback to be run in adminsuidsetup by passing
 159 a coderef to the FS::UID->install_callback class method.  If adminsuidsetup has
 160 run already, the callback will also be run immediately.
 161
 162     $coderef = sub { warn "Hi, I'm returning your call!" };
 163     FS::UID->install_callback($coderef);
 164
 165     install_callback FS::UID sub {
 166       warn "Hi, I'm returning your call!"
 167     };
 168
 169 =cut
 170
 171 sub install_callback {
 172   my $class = shift;
 173   my $callback = shift;
 174   push @callback, $callback;
 175   &{$callback} if $dbh;
 176 }
 177
 178 =item cgisuidsetup CGI_object
 179
 180 Takes a single argument, which is a CGI (see L<CGI>) or Apache (see L<Apache>)
 181 object (CGI::Base is depriciated).  Runs cgisetotaker and then adminsuidsetup.
 182
 183 =cut
 184
 185 sub cgisuidsetup {
 186   $cgi=shift;
 187   if ( $cgi->isa('CGI::Base') ) {
 188     carp "Use of CGI::Base is depriciated";
 189   } elsif ( $cgi->isa('Apache') ) {
 190
 191   } elsif ( ! $cgi->isa('CGI') ) {
 192     croak "fatal: unrecognized object $cgi";
 193   }
 194   cgisetotaker;
 195   adminsuidsetup($user);
 196 }
 197
 198 =item cgi
 199
 200 Returns the CGI (see L<CGI>) object.
 201
 202 =cut
 203
 204 sub cgi {
 205   carp "warning: \$FS::UID::cgi isa Apache" if $cgi->isa('Apache');
 206   $cgi;
 207 }
 208
 209 =item dbh
 210
 211 Returns the DBI database handle.
 212
 213 =cut
 214
 215 sub dbh {
 216   $dbh;
 217 }
 218
 219 =item datasrc
 220
 221 Returns the DBI data source.
 222
 223 =cut
 224
 225 sub datasrc {
 226   $datasrc;
 227 }
 228
 229 =item driver_name
 230
 231 Returns just the driver name portion of the DBI data source.
 232
 233 =cut
 234
 235 sub driver_name {
 236   return $driver_name if defined $driver_name;
 237   $driver_name = ( split(':', $datasrc) )[1];
 238 }
 239
 240 sub suidsetup {
 241   croak "suidsetup depriciated";
 242 }
 243
 244 =item getotaker
 245
 246 Returns the current Freeside user.
 247
 248 =cut
 249
 250 sub getotaker {
 251   $user;
 252 }
 253
 254 =item cgisetotaker
 255
 256 Sets and returns the CGI REMOTE_USER.  $cgi should be defined as a CGI.pm
 257 object (see L<CGI>) or an Apache object (see L<Apache>).  Support for CGI::Base
 258 and derived classes is depriciated.
 259
 260 =cut
 261
 262 sub cgisetotaker {
 263   if ( $cgi && $cgi->isa('CGI::Base') && defined $cgi->var('REMOTE_USER')) {
 264     carp "Use of CGI::Base is depriciated";
 265     $user = lc ( $cgi->var('REMOTE_USER') );
 266   } elsif ( $cgi && $cgi->isa('CGI') && defined $cgi->remote_user ) {
 267     $user = lc ( $cgi->remote_user );
 268   } elsif ( $cgi && $cgi->isa('Apache') ) {
 269     $user = lc ( $cgi->connection->user );
 270   } else {
 271     die "fatal: Can't get REMOTE_USER! for cgi $cgi - you need to setup ".
 272         "Apache user authentication as documented in httemplate/docs/install.html";
 273   }
 274   $user;
 275 }
 276
 277 =item checkeuid
 278
 279 Returns true if effective UID is that of the freeside user.
 280
 281 =cut
 282
 283 sub checkeuid {
 284   ( $> == $freeside_uid );
 285 }
 286
 287 =item checkruid
 288
 289 Returns true if the real UID is that of the freeside user.
 290
 291 =cut
 292
 293 sub checkruid {
 294   ( $< == $freeside_uid );
 295 }
 296
 297 =item getsecrets [ USER ]
 298
 299 Sets the user to USER, if supplied.
 300 Sets and returns the DBI datasource, username and password for this user from
 301 the `/usr/local/etc/freeside/mapsecrets' file.
 302
 303 =cut
 304
 305 sub getsecrets {
 306   my($setuser) = shift;
 307   $user = $setuser if $setuser;
 308
 309   if ( -e "$conf_dir/mapsecrets" ) {
 310     die "No user!" unless $user;
 311     my($line) = grep /^\s*($user|\*)\s/,
 312       map { /^(.*)$/; $1 } readline(new IO::File "$conf_dir/mapsecrets");
 313     confess "User $user not found in mapsecrets!" unless $line;
 314     $line =~ /^\s*($user|\*)\s+(.*)$/;
 315     $secrets = $2;
 316     die "Illegal mapsecrets line for user?!" unless $secrets;
 317   } else {
 318     # no mapsecrets file at all, so do the default thing
 319     $secrets = 'secrets';
 320   }
 321
 322   ($datasrc, $db_user, $db_pass) =
 323     map { /^(.*)$/; $1 } readline(new IO::File "$conf_dir/$secrets")
 324       or die "Can't get secrets: $conf_dir/$secrets: $!\n";
 325   undef $driver_name;
 326   ($datasrc, $db_user, $db_pass);
 327 }
 328
 329 =item use_confcompat
 330
 331 Returns true whenever we should use 1.7 configuration compatibility.
 332
 333 =cut
 334
 335 sub use_confcompat {
 336   $use_confcompat;
 337 }
 338
 339 =back
 340
 341 =head1 CALLBACKS
 342
 343 Warning: this interface is (still) likely to change in future releases.
 344
 345 New (experimental) callback interface:
 346
 347 A package can install a callback to be run in adminsuidsetup by passing
 348 a coderef to the FS::UID->install_callback class method.  If adminsuidsetup has
 349 run already, the callback will also be run immediately.
 350
 351     $coderef = sub { warn "Hi, I'm returning your call!" };
 352     FS::UID->install_callback($coderef);
 353
 354     install_callback FS::UID sub {
 355       warn "Hi, I'm returning your call!"
 356     };
 357
 358 Old (deprecated) callback interface:
 359
 360 A package can install a callback to be run in adminsuidsetup by putting a
 361 coderef into the hash %FS::UID::callback :
 362
 363     $coderef = sub { warn "Hi, I'm returning your call!" };
 364     $FS::UID::callback{'Package::Name'} = $coderef;
 365
 366 =head1 BUGS
 367
 368 Too many package-global variables.
 369
 370 Not OO.
 371
 372 No capabilities yet.  When mod_perl and Authen::DBI are implemented,
 373 cgisuidsetup will go away as well.
 374
 375 Goes through contortions to support non-OO syntax with multiple datasrc's.
 376
 377 Callbacks are (still) inelegant.
 378
 379 =head1 SEE ALSO
 380
 381 L<FS::Record>, L<CGI>, L<DBI>, config.html from the base documentation.
 382
 383 =cut
 384
 385 1;
 386