FS/FS/UID.pm

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