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 $callback_hack
   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
  22 $freeside_uid = scalar(getpwnam('freeside'));
  23
  24 $conf_dir = "%%%FREESIDE_CONF%%%/";
  25
  26 $AutoCommit = 1; #ours, not DBI
  27 $callback_hack = 0;
  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   unless($callback_hack) {
 109     foreach ( keys %callback ) {
 110       &{$callback{$_}};
 111       # breaks multi-database installs # delete $callback{$_}; #run once
 112     }
 113
 114     &{$_} foreach @callback;
 115   }
 116
 117   $dbh;
 118 }
 119
 120 sub myconnect {
 121   DBI->connect( getsecrets(@_), { 'AutoCommit'         => 0,
 122                                   'ChopBlanks'         => 1,
 123                                   'ShowErrorStatement' => 1,
 124                                 }
 125               )
 126     or die "DBI->connect error: $DBI::errstr\n";
 127 }
 128
 129 =item install_callback
 130
 131 A package can install a callback to be run in adminsuidsetup by passing
 132 a coderef to the FS::UID->install_callback class method.  If adminsuidsetup has
 133 run already, the callback will also be run immediately.
 134
 135     $coderef = sub { warn "Hi, I'm returning your call!" };
 136     FS::UID->install_callback($coderef);
 137
 138     install_callback FS::UID sub {
 139       warn "Hi, I'm returning your call!"
 140     };
 141
 142 =cut
 143
 144 sub install_callback {
 145   my $class = shift;
 146   my $callback = shift;
 147   push @callback, $callback;
 148   &{$callback} if $dbh;
 149 }
 150
 151 =item cgisuidsetup CGI_object
 152
 153 Takes a single argument, which is a CGI (see L<CGI>) or Apache (see L<Apache>)
 154 object (CGI::Base is depriciated).  Runs cgisetotaker and then adminsuidsetup.
 155
 156 =cut
 157
 158 sub cgisuidsetup {
 159   $cgi=shift;
 160   if ( $cgi->isa('CGI::Base') ) {
 161     carp "Use of CGI::Base is depriciated";
 162   } elsif ( $cgi->isa('Apache') ) {
 163
 164   } elsif ( ! $cgi->isa('CGI') ) {
 165     croak "fatal: unrecognized object $cgi";
 166   }
 167   cgisetotaker;
 168   adminsuidsetup($user);
 169 }
 170
 171 =item cgi
 172
 173 Returns the CGI (see L<CGI>) object.
 174
 175 =cut
 176
 177 sub cgi {
 178   carp "warning: \$FS::UID::cgi isa Apache" if $cgi->isa('Apache');
 179   $cgi;
 180 }
 181
 182 =item dbh
 183
 184 Returns the DBI database handle.
 185
 186 =cut
 187
 188 sub dbh {
 189   $dbh;
 190 }
 191
 192 =item datasrc
 193
 194 Returns the DBI data source.
 195
 196 =cut
 197
 198 sub datasrc {
 199   $datasrc;
 200 }
 201
 202 =item driver_name
 203
 204 Returns just the driver name portion of the DBI data source.
 205
 206 =cut
 207
 208 sub driver_name {
 209   return $driver_name if defined $driver_name;
 210   $driver_name = ( split(':', $datasrc) )[1];
 211 }
 212
 213 sub suidsetup {
 214   croak "suidsetup depriciated";
 215 }
 216
 217 =item getotaker
 218
 219 Returns the current Freeside user.
 220
 221 =cut
 222
 223 sub getotaker {
 224   $user;
 225 }
 226
 227 =item cgisetotaker
 228
 229 Sets and returns the CGI REMOTE_USER.  $cgi should be defined as a CGI.pm
 230 object (see L<CGI>) or an Apache object (see L<Apache>).  Support for CGI::Base
 231 and derived classes is depriciated.
 232
 233 =cut
 234
 235 sub cgisetotaker {
 236   if ( $cgi && $cgi->isa('CGI::Base') && defined $cgi->var('REMOTE_USER')) {
 237     carp "Use of CGI::Base is depriciated";
 238     $user = lc ( $cgi->var('REMOTE_USER') );
 239   } elsif ( $cgi && $cgi->isa('CGI') && defined $cgi->remote_user ) {
 240     $user = lc ( $cgi->remote_user );
 241   } elsif ( $cgi && $cgi->isa('Apache') ) {
 242     $user = lc ( $cgi->connection->user );
 243   } else {
 244     die "fatal: Can't get REMOTE_USER! for cgi $cgi - you need to setup ".
 245         "Apache user authentication as documented in httemplate/docs/install.html";
 246   }
 247   $user;
 248 }
 249
 250 =item checkeuid
 251
 252 Returns true if effective UID is that of the freeside user.
 253
 254 =cut
 255
 256 sub checkeuid {
 257   ( $> == $freeside_uid );
 258 }
 259
 260 =item checkruid
 261
 262 Returns true if the real UID is that of the freeside user.
 263
 264 =cut
 265
 266 sub checkruid {
 267   ( $< == $freeside_uid );
 268 }
 269
 270 =item getsecrets [ USER ]
 271
 272 Sets the user to USER, if supplied.
 273 Sets and returns the DBI datasource, username and password for this user from
 274 the `/usr/local/etc/freeside/mapsecrets' file.
 275
 276 =cut
 277
 278 sub getsecrets {
 279   my($setuser) = shift;
 280   $user = $setuser if $setuser;
 281
 282   if ( -e "$conf_dir/mapsecrets" ) {
 283     die "No user!" unless $user;
 284     my($line) = grep /^\s*($user|\*)\s/,
 285       map { /^(.*)$/; $1 } readline(new IO::File "$conf_dir/mapsecrets");
 286     confess "User $user not found in mapsecrets!" unless $line;
 287     $line =~ /^\s*($user|\*)\s+(.*)$/;
 288     $secrets = $2;
 289     die "Illegal mapsecrets line for user?!" unless $secrets;
 290   } else {
 291     # no mapsecrets file at all, so do the default thing
 292     $secrets = 'secrets';
 293   }
 294
 295   ($datasrc, $db_user, $db_pass) =
 296     map { /^(.*)$/; $1 } readline(new IO::File "$conf_dir/$secrets")
 297       or die "Can't get secrets: $secrets: $!\n";
 298   undef $driver_name;
 299   ($datasrc, $db_user, $db_pass);
 300 }
 301
 302 =back
 303
 304 =head1 CALLBACKS
 305
 306 Warning: this interface is (still) likely to change in future releases.
 307
 308 New (experimental) callback interface:
 309
 310 A package can install a callback to be run in adminsuidsetup by passing
 311 a coderef to the FS::UID->install_callback class method.  If adminsuidsetup has
 312 run already, the callback will also be run immediately.
 313
 314     $coderef = sub { warn "Hi, I'm returning your call!" };
 315     FS::UID->install_callback($coderef);
 316
 317     install_callback FS::UID sub {
 318       warn "Hi, I'm returning your call!"
 319     };
 320
 321 Old (deprecated) callback interface:
 322
 323 A package can install a callback to be run in adminsuidsetup by putting a
 324 coderef into the hash %FS::UID::callback :
 325
 326     $coderef = sub { warn "Hi, I'm returning your call!" };
 327     $FS::UID::callback{'Package::Name'} = $coderef;
 328
 329 =head1 BUGS
 330
 331 Too many package-global variables.
 332
 333 Not OO.
 334
 335 No capabilities yet.  When mod_perl and Authen::DBI are implemented,
 336 cgisuidsetup will go away as well.
 337
 338 Goes through contortions to support non-OO syntax with multiple datasrc's.
 339
 340 Callbacks are (still) inelegant.
 341
 342 =head1 SEE ALSO
 343
 344 L<FS::Record>, L<CGI>, L<DBI>, config.html from the base documentation.
 345
 346 =cut
 347
 348 1;
 349