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