FS/FS/UID.pm

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