FS/FS/UID.pm

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