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