FS/FS/UID.pm

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