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