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 FS::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 = FS::DBI->connect(
 234     getsecrets( @_ ),
 235     {
 236       'AutoCommit'         => 0,
 237       'ChopBlanks'         => 1,
 238       'ShowErrorStatement' => 1,
 239       'pg_enable_utf8'     => 1,
 240       # 'mysql_enable_utf8'  => 1,
 241     }
 242   ) or die "FS::DBI->connect error: $FS::DBI::errstr\n";
 243
 244   if ( $schema ) {
 245     use DBIx::DBSchema::_util qw(_load_driver ); #quelle hack
 246     my $driver = _load_driver($handle);
 247     if ( $driver =~ /^Pg/ ) {
 248       no warnings 'redefine';
 249       eval "sub DBIx::DBSchema::DBD::${driver}::default_db_schema {'$schema'}";
 250       die $@ if $@;
 251     }
 252   }
 253
 254   $handle;
 255 }
 256
 257 =item install_callback
 258
 259 A package can install a callback to be run in adminsuidsetup by passing
 260 a coderef to the FS::UID->install_callback class method.  If adminsuidsetup has
 261 run already, the callback will also be run immediately.
 262
 263     $coderef = sub { warn "Hi, I'm returning your call!" };
 264     FS::UID->install_callback($coderef);
 265
 266     install_callback FS::UID sub {
 267       warn "Hi, I'm returning your call!"
 268     };
 269
 270 =cut
 271
 272 sub install_callback {
 273   my $class = shift;
 274   my $callback = shift;
 275   push @callback, $callback;
 276   &{$callback} if $dbh;
 277 }
 278
 279 =item cgisuidsetup CGI_object
 280
 281 Takes a single argument, which is a CGI (see L<CGI>) or Apache (see L<Apache>)
 282 object (CGI::Base is depriciated).  Runs cgisetotaker and then adminsuidsetup.
 283
 284 =cut
 285
 286 sub cgisuidsetup {
 287   $cgi=shift;
 288   if ( $cgi->isa('CGI::Base') ) {
 289     carp "Use of CGI::Base is depriciated";
 290   } elsif ( $cgi->isa('Apache') ) {
 291
 292   } elsif ( ! $cgi->isa('CGI') ) {
 293     croak "fatal: unrecognized object $cgi";
 294   }
 295   cgisetotaker;
 296   adminsuidsetup($user);
 297 }
 298
 299 =item cgi
 300
 301 Returns the CGI (see L<CGI>) object.
 302
 303 =cut
 304
 305 sub cgi {
 306   carp "warning: \$FS::UID::cgi isa Apache" if $cgi->isa('Apache');
 307   $cgi;
 308 }
 309
 310 =item dbh
 311
 312 Returns the DBI database handle.
 313
 314 =cut
 315
 316 sub dbh {
 317   $dbh;
 318 }
 319
 320 =item datasrc
 321
 322 Returns the DBI data source.
 323
 324 =cut
 325
 326 sub datasrc {
 327   $datasrc;
 328 }
 329
 330 =item driver_name
 331
 332 Returns just the driver name portion of the DBI data source.
 333
 334 =cut
 335
 336 sub driver_name {
 337   return $driver_name if defined $driver_name;
 338   $driver_name = ( split(':', $datasrc) )[1];
 339 }
 340
 341 sub suidsetup {
 342   croak "suidsetup depriciated";
 343 }
 344
 345 =item getotaker
 346
 347 Returns the current Freeside user.
 348
 349 =cut
 350
 351 sub getotaker {
 352   $user;
 353 }
 354
 355 =item cgisetotaker
 356
 357 Sets and returns the CGI REMOTE_USER.  $cgi should be defined as a CGI.pm
 358 object (see L<CGI>) or an Apache object (see L<Apache>).  Support for CGI::Base
 359 and derived classes is depriciated.
 360
 361 =cut
 362
 363 sub cgisetotaker {
 364   if ( $cgi && $cgi->isa('CGI::Base') && defined $cgi->var('REMOTE_USER')) {
 365     carp "Use of CGI::Base is depriciated";
 366     $user = lc ( $cgi->var('REMOTE_USER') );
 367   } elsif ( $cgi && $cgi->isa('CGI') && defined $cgi->remote_user ) {
 368     $user = lc ( $cgi->remote_user );
 369   } elsif ( $cgi && $cgi->isa('Apache') ) {
 370     $user = lc ( $cgi->connection->user );
 371   } else {
 372     die "fatal: Can't get REMOTE_USER! for cgi $cgi - you need to setup ".
 373         "Apache user authentication as documented in the installation instructions";
 374   }
 375   $user;
 376 }
 377
 378 =item checkeuid
 379
 380 Returns true if effective UID is that of the freeside user.
 381
 382 =cut
 383
 384 sub checkeuid {
 385   #$> = $freeside_uid unless $>; #huh.  mpm-itk hack
 386   ( $> == $freeside_uid );
 387 }
 388
 389 =item checkruid
 390
 391 Returns true if the real UID is that of the freeside user.
 392
 393 =cut
 394
 395 sub checkruid {
 396   ( $< == $freeside_uid );
 397 }
 398
 399 =item getsecrets [ USER ]
 400
 401 Sets the user to USER, if supplied.
 402 Sets and returns the DBI datasource, username and password for this user from
 403 the `/usr/local/etc/freeside/mapsecrets' file.
 404
 405 =cut
 406
 407 sub getsecrets {
 408   my($setuser) = shift;
 409   $user = $setuser if $setuser;
 410
 411   if ( -e "$conf_dir/mapsecrets" ) {
 412     die "No user!" unless $user;
 413     my($line) = grep /^\s*($user|\*)\s/,
 414       map { /^(.*)$/; $1 } readline(new IO::File "$conf_dir/mapsecrets");
 415     confess "User $user not found in mapsecrets!" unless $line;
 416     $line =~ /^\s*($user|\*)\s+(.*)$/;
 417     $secrets = $2;
 418     die "Illegal mapsecrets line for user?!" unless $secrets;
 419   } else {
 420     # no mapsecrets file at all, so do the default thing
 421     $secrets = 'secrets';
 422   }
 423
 424   ($datasrc, $db_user, $db_pass, $schema) =
 425     map { /^(.*)$/; $1 } readline(new IO::File "$conf_dir/$secrets")
 426       or die "Can't get secrets: $conf_dir/$secrets: $!\n";
 427   undef $driver_name;
 428
 429   ($datasrc, $db_user, $db_pass);
 430 }
 431
 432 =item use_confcompat
 433
 434 Returns true whenever we should use 1.7 configuration compatibility.
 435
 436 =cut
 437
 438 sub use_confcompat {
 439   $use_confcompat;
 440 }
 441
 442 =back
 443
 444 =head1 CALLBACKS
 445
 446 Warning: this interface is (still) likely to change in future releases.
 447
 448 New (experimental) callback interface:
 449
 450 A package can install a callback to be run in adminsuidsetup by passing
 451 a coderef to the FS::UID->install_callback class method.  If adminsuidsetup has
 452 run already, the callback will also be run immediately.
 453
 454     $coderef = sub { warn "Hi, I'm returning your call!" };
 455     FS::UID->install_callback($coderef);
 456
 457     install_callback FS::UID sub {
 458       warn "Hi, I'm returning your call!"
 459     };
 460
 461 Old (deprecated) callback interface:
 462
 463 A package can install a callback to be run in adminsuidsetup by putting a
 464 coderef into the hash %FS::UID::callback :
 465
 466     $coderef = sub { warn "Hi, I'm returning your call!" };
 467     $FS::UID::callback{'Package::Name'} = $coderef;
 468
 469 =head1 BUGS
 470
 471 Too many package-global variables.
 472
 473 Not OO.
 474
 475 No capabilities yet.  When mod_perl and Authen::DBI are implemented,
 476 cgisuidsetup will go away as well.
 477
 478 Goes through contortions to support non-OO syntax with multiple datasrc's.
 479
 480 Callbacks are (still) inelegant.
 481
 482 =head1 SEE ALSO
 483
 484 L<FS::Record>, L<CGI>, L<DBI>, config.html from the base documentation.
 485
 486 =cut
 487
 488 1;
 489