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