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