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