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 $sth = $dbh->prepare("SELECT COUNT(*) FROM conf") or die $dbh->errstr;
 118   $sth->execute or die $sth->errstr;
 119   my $confcount = $sth->fetchrow_arrayref->[0];
 120
 121   if ($confcount) {
 122     $use_confcompat = 0;
 123   }else{
 124     warn "NO CONFIGURATION RECORDS FOUND";
 125   }
 126
 127   unless ( $callback_hack ) {
 128     warn "$me calling callbacks\n" if $DEBUG;
 129     foreach ( keys %callback ) {
 130       &{$callback{$_}};
 131       # breaks multi-database installs # delete $callback{$_}; #run once
 132     }
 133
 134     &{$_} foreach @callback;
 135   } else {
 136     warn "$me skipping callbacks (callback_hack set)\n" if $DEBUG;
 137   }
 138
 139   warn "$me forksuidsetup loading user\n" if $DEBUG;
 140   FS::CurrentUser->load_user($user);
 141
 142   $dbh;
 143 }
 144
 145 sub myconnect {
 146   DBI->connect( getsecrets(@_), { 'AutoCommit'         => 0,
 147                                   'ChopBlanks'         => 1,
 148                                   'ShowErrorStatement' => 1,
 149                                 }
 150               )
 151     or die "DBI->connect error: $DBI::errstr\n";
 152 }
 153
 154 =item install_callback
 155
 156 A package can install a callback to be run in adminsuidsetup by passing
 157 a coderef to the FS::UID->install_callback class method.  If adminsuidsetup has
 158 run already, the callback will also be run immediately.
 159
 160     $coderef = sub { warn "Hi, I'm returning your call!" };
 161     FS::UID->install_callback($coderef);
 162
 163     install_callback FS::UID sub {
 164       warn "Hi, I'm returning your call!"
 165     };
 166
 167 =cut
 168
 169 sub install_callback {
 170   my $class = shift;
 171   my $callback = shift;
 172   push @callback, $callback;
 173   &{$callback} if $dbh;
 174 }
 175
 176 =item cgisuidsetup CGI_object
 177
 178 Takes a single argument, which is a CGI (see L<CGI>) or Apache (see L<Apache>)
 179 object (CGI::Base is depriciated).  Runs cgisetotaker and then adminsuidsetup.
 180
 181 =cut
 182
 183 sub cgisuidsetup {
 184   $cgi=shift;
 185   if ( $cgi->isa('CGI::Base') ) {
 186     carp "Use of CGI::Base is depriciated";
 187   } elsif ( $cgi->isa('Apache') ) {
 188
 189   } elsif ( ! $cgi->isa('CGI') ) {
 190     croak "fatal: unrecognized object $cgi";
 191   }
 192   cgisetotaker;
 193   adminsuidsetup($user);
 194 }
 195
 196 =item cgi
 197
 198 Returns the CGI (see L<CGI>) object.
 199
 200 =cut
 201
 202 sub cgi {
 203   carp "warning: \$FS::UID::cgi isa Apache" if $cgi->isa('Apache');
 204   $cgi;
 205 }
 206
 207 =item dbh
 208
 209 Returns the DBI database handle.
 210
 211 =cut
 212
 213 sub dbh {
 214   $dbh;
 215 }
 216
 217 =item datasrc
 218
 219 Returns the DBI data source.
 220
 221 =cut
 222
 223 sub datasrc {
 224   $datasrc;
 225 }
 226
 227 =item driver_name
 228
 229 Returns just the driver name portion of the DBI data source.
 230
 231 =cut
 232
 233 sub driver_name {
 234   return $driver_name if defined $driver_name;
 235   $driver_name = ( split(':', $datasrc) )[1];
 236 }
 237
 238 sub suidsetup {
 239   croak "suidsetup depriciated";
 240 }
 241
 242 =item getotaker
 243
 244 Returns the current Freeside user.
 245
 246 =cut
 247
 248 sub getotaker {
 249   $user;
 250 }
 251
 252 =item cgisetotaker
 253
 254 Sets and returns the CGI REMOTE_USER.  $cgi should be defined as a CGI.pm
 255 object (see L<CGI>) or an Apache object (see L<Apache>).  Support for CGI::Base
 256 and derived classes is depriciated.
 257
 258 =cut
 259
 260 sub cgisetotaker {
 261   if ( $cgi && $cgi->isa('CGI::Base') && defined $cgi->var('REMOTE_USER')) {
 262     carp "Use of CGI::Base is depriciated";
 263     $user = lc ( $cgi->var('REMOTE_USER') );
 264   } elsif ( $cgi && $cgi->isa('CGI') && defined $cgi->remote_user ) {
 265     $user = lc ( $cgi->remote_user );
 266   } elsif ( $cgi && $cgi->isa('Apache') ) {
 267     $user = lc ( $cgi->connection->user );
 268   } else {
 269     die "fatal: Can't get REMOTE_USER! for cgi $cgi - you need to setup ".
 270         "Apache user authentication as documented in httemplate/docs/install.html";
 271   }
 272   $user;
 273 }
 274
 275 =item checkeuid
 276
 277 Returns true if effective UID is that of the freeside user.
 278
 279 =cut
 280
 281 sub checkeuid {
 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 [ USER ]
 296
 297 Sets the user to USER, if supplied.
 298 Sets and returns the DBI datasource, username and password for this user from
 299 the `/usr/local/etc/freeside/mapsecrets' file.
 300
 301 =cut
 302
 303 sub getsecrets {
 304   my($setuser) = shift;
 305   $user = $setuser if $setuser;
 306
 307   if ( -e "$conf_dir/mapsecrets" ) {
 308     die "No user!" unless $user;
 309     my($line) = grep /^\s*($user|\*)\s/,
 310       map { /^(.*)$/; $1 } readline(new IO::File "$conf_dir/mapsecrets");
 311     confess "User $user not found in mapsecrets!" unless $line;
 312     $line =~ /^\s*($user|\*)\s+(.*)$/;
 313     $secrets = $2;
 314     die "Illegal mapsecrets line for user?!" unless $secrets;
 315   } else {
 316     # no mapsecrets file at all, so do the default thing
 317     $secrets = 'secrets';
 318   }
 319
 320   ($datasrc, $db_user, $db_pass) =
 321     map { /^(.*)$/; $1 } readline(new IO::File "$conf_dir/$secrets")
 322       or die "Can't get secrets: $conf_dir/$secrets: $!\n";
 323   undef $driver_name;
 324   ($datasrc, $db_user, $db_pass);
 325 }
 326
 327 =item use_confcompat
 328
 329 Returns true whenever we should use 1.7 configuration compatibility.
 330
 331 =cut
 332
 333 sub use_confcompat {
 334   $use_confcompat;
 335 }
 336
 337 =back
 338
 339 =head1 CALLBACKS
 340
 341 Warning: this interface is (still) likely to change in future releases.
 342
 343 New (experimental) callback interface:
 344
 345 A package can install a callback to be run in adminsuidsetup by passing
 346 a coderef to the FS::UID->install_callback class method.  If adminsuidsetup has
 347 run already, the callback will also be run immediately.
 348
 349     $coderef = sub { warn "Hi, I'm returning your call!" };
 350     FS::UID->install_callback($coderef);
 351
 352     install_callback FS::UID sub {
 353       warn "Hi, I'm returning your call!"
 354     };
 355
 356 Old (deprecated) callback interface:
 357
 358 A package can install a callback to be run in adminsuidsetup by putting a
 359 coderef into the hash %FS::UID::callback :
 360
 361     $coderef = sub { warn "Hi, I'm returning your call!" };
 362     $FS::UID::callback{'Package::Name'} = $coderef;
 363
 364 =head1 BUGS
 365
 366 Too many package-global variables.
 367
 368 Not OO.
 369
 370 No capabilities yet.  When mod_perl and Authen::DBI are implemented,
 371 cgisuidsetup will go away as well.
 372
 373 Goes through contortions to support non-OO syntax with multiple datasrc's.
 374
 375 Callbacks are (still) inelegant.
 376
 377 =head1 SEE ALSO
 378
 379 L<FS::Record>, L<CGI>, L<DBI>, config.html from the base documentation.
 380
 381 =cut
 382
 383 1;
 384