FS/FS/UID.pm

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