FS/FS/UID.pm

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