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 $user $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 getotaker 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   $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 Returns the current Freeside user.
 280
 281 =cut
 282
 283 sub getotaker {
 284   $user;
 285 }
 286
 287 =item checkeuid
 288
 289 Returns true if effective UID is that of the freeside user.
 290
 291 =cut
 292
 293 sub checkeuid {
 294   #$> = $freeside_uid unless $>; #huh.  mpm-itk hack
 295   ( $> == $freeside_uid );
 296 }
 297
 298 =item checkruid
 299
 300 Returns true if the real UID is that of the freeside user.
 301
 302 =cut
 303
 304 sub checkruid {
 305   ( $< == $freeside_uid );
 306 }
 307
 308 =item getsecrets [ USER ]
 309
 310 Sets the user to USER, if supplied.
 311 Sets and returns the DBI datasource, username and password for this user from
 312 the `/usr/local/etc/freeside/mapsecrets' file.
 313
 314 =cut
 315
 316 sub getsecrets {
 317   my($setuser) = shift;
 318   $user = $setuser if $setuser;
 319
 320   if ( -e "$conf_dir/mapsecrets" ) {
 321     die "No user!" unless $user;
 322     my($line) = grep /^\s*($user|\*)\s/,
 323       map { /^(.*)$/; $1 } readline(new IO::File "$conf_dir/mapsecrets");
 324     confess "User $user not found in mapsecrets!" unless $line;
 325     $line =~ /^\s*($user|\*)\s+(.*)$/;
 326     $secrets = $2;
 327     die "Illegal mapsecrets line for user?!" unless $secrets;
 328   } else {
 329     # no mapsecrets file at all, so do the default thing
 330     $secrets = 'secrets';
 331   }
 332
 333   ($datasrc, $db_user, $db_pass, $schema) =
 334     map { /^(.*)$/; $1 } readline(new IO::File "$conf_dir/$secrets")
 335       or die "Can't get secrets: $conf_dir/$secrets: $!\n";
 336   undef $driver_name;
 337
 338   ($datasrc, $db_user, $db_pass);
 339 }
 340
 341 =item use_confcompat
 342
 343 Returns true whenever we should use 1.7 configuration compatibility.
 344
 345 =cut
 346
 347 sub use_confcompat {
 348   $use_confcompat;
 349 }
 350
 351 =back
 352
 353 =head1 CALLBACKS
 354
 355 Warning: this interface is (still) likely to change in future releases.
 356
 357 New (experimental) callback interface:
 358
 359 A package can install a callback to be run in adminsuidsetup by passing
 360 a coderef to the FS::UID->install_callback class method.  If adminsuidsetup has
 361 run already, the callback will also be run immediately.
 362
 363     $coderef = sub { warn "Hi, I'm returning your call!" };
 364     FS::UID->install_callback($coderef);
 365
 366     install_callback FS::UID sub {
 367       warn "Hi, I'm returning your call!"
 368     };
 369
 370 Old (deprecated) callback interface:
 371
 372 A package can install a callback to be run in adminsuidsetup by putting a
 373 coderef into the hash %FS::UID::callback :
 374
 375     $coderef = sub { warn "Hi, I'm returning your call!" };
 376     $FS::UID::callback{'Package::Name'} = $coderef;
 377
 378 =head1 BUGS
 379
 380 Too many package-global variables.
 381
 382 Not OO.
 383
 384 No capabilities yet. (What does this mean again?)
 385
 386 Goes through contortions to support non-OO syntax with multiple datasrc's.
 387
 388 Callbacks are (still) inelegant.
 389
 390 =head1 SEE ALSO
 391
 392 L<FS::Record>, L<CGI>, L<DBI>, config.html from the base documentation.
 393
 394 =cut
 395
 396 1;
 397