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