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