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!" 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 );
 290 }
 291
 292 =item checkruid
 293
 294 Returns true if the real UID is that of the freeside user.
 295
 296 =cut
 297
 298 sub checkruid {
 299   ( $< == $freeside_uid );
 300 }
 301
 302 =item getsecrets [ USER ]
 303
 304 Sets the user to USER, if supplied.
 305 Sets and returns the DBI datasource, username and password for this user from
 306 the `/usr/local/etc/freeside/mapsecrets' file.
 307
 308 =cut
 309
 310 sub getsecrets {
 311   my($setuser) = shift;
 312   $user = $setuser if $setuser;
 313
 314   if ( -e "$conf_dir/mapsecrets" ) {
 315     die "No user!" unless $user;
 316     my($line) = grep /^\s*($user|\*)\s/,
 317       map { /^(.*)$/; $1 } readline(new IO::File "$conf_dir/mapsecrets");
 318     confess "User $user not found in mapsecrets!" unless $line;
 319     $line =~ /^\s*($user|\*)\s+(.*)$/;
 320     $secrets = $2;
 321     die "Illegal mapsecrets line for user?!" unless $secrets;
 322   } else {
 323     # no mapsecrets file at all, so do the default thing
 324     $secrets = 'secrets';
 325   }
 326
 327   ($datasrc, $db_user, $db_pass) =
 328     map { /^(.*)$/; $1 } readline(new IO::File "$conf_dir/$secrets")
 329       or die "Can't get secrets: $conf_dir/$secrets: $!\n";
 330   undef $driver_name;
 331   ($datasrc, $db_user, $db_pass);
 332 }
 333
 334 =item use_confcompat
 335
 336 Returns true whenever we should use 1.7 configuration compatibility.
 337
 338 =cut
 339
 340 sub use_confcompat {
 341   $use_confcompat;
 342 }
 343
 344 =back
 345
 346 =head1 CALLBACKS
 347
 348 Warning: this interface is (still) likely to change in future releases.
 349
 350 New (experimental) callback interface:
 351
 352 A package can install a callback to be run in adminsuidsetup by passing
 353 a coderef to the FS::UID->install_callback class method.  If adminsuidsetup has
 354 run already, the callback will also be run immediately.
 355
 356     $coderef = sub { warn "Hi, I'm returning your call!" };
 357     FS::UID->install_callback($coderef);
 358
 359     install_callback FS::UID sub {
 360       warn "Hi, I'm returning your call!"
 361     };
 362
 363 Old (deprecated) callback interface:
 364
 365 A package can install a callback to be run in adminsuidsetup by putting a
 366 coderef into the hash %FS::UID::callback :
 367
 368     $coderef = sub { warn "Hi, I'm returning your call!" };
 369     $FS::UID::callback{'Package::Name'} = $coderef;
 370
 371 =head1 BUGS
 372
 373 Too many package-global variables.
 374
 375 Not OO.
 376
 377 No capabilities yet.  When mod_perl and Authen::DBI are implemented,
 378 cgisuidsetup will go away as well.
 379
 380 Goes through contortions to support non-OO syntax with multiple datasrc's.
 381
 382 Callbacks are (still) inelegant.
 383
 384 =head1 SEE ALSO
 385
 386 L<FS::Record>, L<CGI>, L<DBI>, config.html from the base documentation.
 387
 388 =cut
 389
 390 1;
 391