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