FS/FS/UID.pm

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