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