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 FS::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 = FS::DBI->connect(
 176     getsecrets(),
 177     {
 178       'AutoCommit'         => 0,
 179       'ChopBlanks'         => 1,
 180       'ShowErrorStatement' => 1,
 181       'pg_enable_utf8'     => 1,
 182       # 'mysql_enable_utf8'  => 1,
 183     }
 184   ) or die "FS::DBI->connect error: $FS::DBI::errstr\n";
 185
 186   $FS::Conf::conf_cache = undef;
 187
 188   if ( $schema ) {
 189     use DBIx::DBSchema::_util qw(_load_driver ); #quelle hack
 190     my $driver = _load_driver($handle);
 191     if ( $driver =~ /^Pg/ ) {
 192       no warnings 'redefine';
 193       eval "sub DBIx::DBSchema::DBD::${driver}::default_db_schema {'$schema'}";
 194       die $@ if $@;
 195     }
 196   }
 197
 198   $handle;
 199 }
 200
 201 =item install_callback
 202
 203 A package can install a callback to be run in adminsuidsetup by passing
 204 a coderef to the FS::UID->install_callback class method.  If adminsuidsetup has
 205 run already, the callback will also be run immediately.
 206
 207     $coderef = sub { warn "Hi, I'm returning your call!" };
 208     FS::UID->install_callback($coderef);
 209
 210     install_callback FS::UID sub {
 211       warn "Hi, I'm returning your call!"
 212     };
 213
 214 =cut
 215
 216 sub install_callback {
 217   my $class = shift;
 218   my $callback = shift;
 219   push @callback, $callback;
 220   &{$callback} if $dbh;
 221 }
 222
 223 =item cgi
 224
 225 (Deprecated) Returns the CGI (see L<CGI>) object.
 226
 227 =cut
 228
 229 sub cgi {
 230   carp "warning: \$FS::UID::cgi is undefined" unless defined($cgi);
 231   #carp "warning: \$FS::UID::cgi isa Apache" if $cgi && $cgi->isa('Apache');
 232   $cgi;
 233 }
 234
 235 =item setcgi CGI_OBJECT
 236
 237 (Deprecated) Sets the CGI (see L<CGI>) object.
 238
 239 =cut
 240
 241 sub setcgi {
 242   $cgi = shift;
 243 }
 244
 245 =item dbh
 246
 247 Returns the DBI database handle.
 248
 249 =cut
 250
 251 sub dbh {
 252   $dbh;
 253 }
 254
 255 =item datasrc
 256
 257 Returns the DBI data source.
 258
 259 =cut
 260
 261 sub datasrc {
 262   $datasrc;
 263 }
 264
 265 =item driver_name
 266
 267 Returns just the driver name portion of the DBI data source.
 268
 269 =cut
 270
 271 sub driver_name {
 272   return $driver_name if defined $driver_name;
 273   $driver_name = ( split(':', $datasrc) )[1];
 274 }
 275
 276 sub suidsetup {
 277   croak "suidsetup depriciated";
 278 }
 279
 280 =item getotaker
 281
 282 (Deprecated) Returns the current Freeside user's username.
 283
 284 =cut
 285
 286 sub getotaker {
 287   carp "FS::UID::getotaker deprecated";
 288   $FS::CurrentUser::CurrentUser->username;
 289 }
 290
 291 =item checkeuid
 292
 293 Returns true if effective UID is that of the freeside user.
 294
 295 =cut
 296
 297 sub checkeuid {
 298   #$> = $freeside_uid unless $>; #huh.  mpm-itk hack
 299   ( $> == $freeside_uid );
 300 }
 301
 302 =item checkruid
 303
 304 Returns true if the real UID is that of the freeside user.
 305
 306 =cut
 307
 308 sub checkruid {
 309   ( $< == $freeside_uid );
 310 }
 311
 312 =item getsecrets
 313
 314 Sets and returns the DBI datasource, username and password from
 315 the `/usr/local/etc/freeside/secrets' file.
 316
 317 =cut
 318
 319 sub getsecrets {
 320
 321   ($datasrc, $db_user, $db_pass, $schema) =
 322     map { /^(.*)$/; $1 } readline(new IO::File "$conf_dir/secrets")
 323       or die "Can't get secrets: $conf_dir/secrets: $!\n";
 324   undef $driver_name;
 325
 326   ($datasrc, $db_user, $db_pass);
 327 }
 328
 329 =back
 330
 331 =head1 CALLBACKS
 332
 333 Warning: this interface is (still) likely to change in future releases.
 334
 335 New (experimental) callback interface:
 336
 337 A package can install a callback to be run in adminsuidsetup by passing
 338 a coderef to the FS::UID->install_callback class method.  If adminsuidsetup has
 339 run already, the callback will also be run immediately.
 340
 341     $coderef = sub { warn "Hi, I'm returning your call!" };
 342     FS::UID->install_callback($coderef);
 343
 344     install_callback FS::UID sub {
 345       warn "Hi, I'm returning your call!"
 346     };
 347
 348 Old (deprecated) callback interface:
 349
 350 A package can install a callback to be run in adminsuidsetup by putting a
 351 coderef into the hash %FS::UID::callback :
 352
 353     $coderef = sub { warn "Hi, I'm returning your call!" };
 354     $FS::UID::callback{'Package::Name'} = $coderef;
 355
 356 =head1 BUGS
 357
 358 Too many package-global variables.
 359
 360 Not OO.
 361
 362 No capabilities yet. (What does this mean again?)
 363
 364 Goes through contortions to support non-OO syntax with multiple datasrc's.
 365
 366 Callbacks are (still) inelegant.
 367
 368 =head1 SEE ALSO
 369
 370 L<FS::Record>, L<CGI>, L<DBI>, config.html from the base documentation.
 371
 372 =cut
 373
 374 1;
 375