FS/FS/UID.pm

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