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