FS/FS/svc_acct.pm

   1 package FS::svc_acct;
   2
   3 use strict;
   4 use vars qw( @ISA $nossh_hack $conf $dir_prefix @shells $usernamemin
   5              $usernamemax $passwordmin $username_letter $username_letterfirst
   6              $shellmachine $useradd $usermod $userdel
   7              @saltset @pw_set);
   8 use Carp;
   9 use FS::Conf;
  10 use FS::Record qw( qsearch qsearchs fields );
  11 use FS::svc_Common;
  12 use Net::SSH qw(ssh);
  13 use FS::part_svc;
  14 use FS::svc_acct_pop;
  15 use FS::svc_acct_sm;
  16 use FS::cust_main_invoice;
  17 use FS::svc_domain;
  18
  19 @ISA = qw( FS::svc_Common );
  20
  21 #ask FS::UID to run this stuff for us later
  22 $FS::UID::callback{'FS::svc_acct'} = sub {
  23   $conf = new FS::Conf;
  24   $dir_prefix = $conf->config('home');
  25   @shells = $conf->config('shells');
  26   $shellmachine = $conf->config('shellmachine');
  27   $usernamemin = $conf->config('usernamemin') || 2;
  28   $usernamemax = $conf->config('usernamemax');
  29   $passwordmin = $conf->config('passwordmin') || 6;
  30   if ( $shellmachine ) {
  31     if ( $conf->exists('shellmachine-useradd') ) {
  32       $useradd = join("\n", $conf->config('shellmachine-useradd') )
  33                  || 'cp -pr /etc/skel $dir; chown -R $uid.$gid $dir';
  34     } else {
  35       $useradd = 'useradd -d $dir -m -s $shell -u $uid $username';
  36     }
  37     if ( $conf->exists('shellmachine-userdel') ) {
  38       $userdel = join("\n", $conf->config('shellmachine-userdel') )
  39                  || 'rm -rf $dir';
  40     } else {
  41       $userdel = 'userdel $username';
  42     }
  43     $usermod = join("\n", $conf->config('shellmachine-usermod') )
  44                || '[ -d $old_dir ] && mv $old_dir $new_dir || ( '.
  45                     'chmod u+t $old_dir; mkdir $new_dir; cd $old_dir; '.
  46                     'find . -depth -print | cpio -pdm $new_dir; '.
  47                     'chmod u-t $new_dir; chown -R $uid.$gid $new_dir; '.
  48                     'rm -rf $old_dir'.
  49                   ')';
  50   }
  51   $username_letter = $conf->exists('username-letter');
  52   $username_letterfirst = $conf->exists('username-letterfirst');
  53 };
  54
  55 @saltset = ( 'a'..'z' , 'A'..'Z' , '0'..'9' , '.' , '/' );
  56 @pw_set = ( 'a'..'z', 'A'..'Z', '0'..'9', '(', ')', '#', '!', '.', ',' );
  57
  58 #not needed in 5.004 #srand($$|time);
  59
  60 =head1 NAME
  61
  62 FS::svc_acct - Object methods for svc_acct records
  63
  64 =head1 SYNOPSIS
  65
  66   use FS::svc_acct;
  67
  68   $record = new FS::svc_acct \%hash;
  69   $record = new FS::svc_acct { 'column' => 'value' };
  70
  71   $error = $record->insert;
  72
  73   $error = $new_record->replace($old_record);
  74
  75   $error = $record->delete;
  76
  77   $error = $record->check;
  78
  79   $error = $record->suspend;
  80
  81   $error = $record->unsuspend;
  82
  83   $error = $record->cancel;
  84
  85   %hash = $record->radius;
  86
  87   %hash = $record->radius_reply;
  88
  89   %hash = $record->radius_check;
  90
  91 =head1 DESCRIPTION
  92
  93 An FS::svc_acct object represents an account.  FS::svc_acct inherits from
  94 FS::svc_Common.  The following fields are currently supported:
  95
  96 =over 4
  97
  98 =item svcnum - primary key (assigned automatcially for new accounts)
  99
 100 =item username
 101
 102 =item _password - generated if blank
 103
 104 =item popnum - Point of presence (see L<FS::svc_acct_pop>)
 105
 106 =item uid
 107
 108 =item gid
 109
 110 =item finger - GECOS
 111
 112 =item dir - set automatically if blank (and uid is not)
 113
 114 =item shell
 115
 116 =item quota - (unimplementd)
 117
 118 =item slipip - IP address
 119
 120 =item radius_I<Radius_Attribute> - I<Radius-Attribute>
 121
 122 =item domsvc - service number of svc_domain with which to associate
 123
 124 =back
 125
 126 =head1 METHODS
 127
 128 =over 4
 129
 130 =item new HASHREF
 131
 132 Creates a new account.  To add the account to the database, see L<"insert">.
 133
 134 =cut
 135
 136 sub table { 'svc_acct'; }
 137
 138 =item insert
 139
 140 Adds this account to the database.  If there is an error, returns the error,
 141 otherwise returns false.
 142
 143 The additional fields pkgnum and svcpart (see L<FS::cust_svc>) should be
 144 defined.  An FS::cust_svc record will be created and inserted.
 145
 146 If the configuration value (see L<FS::Conf>) shellmachine exists, and the
 147 username, uid, and dir fields are defined, the command(s) specified in
 148 the shellmachine-useradd configuration are exectued on shellmachine via ssh.
 149 This behaviour can be surpressed by setting $FS::svc_acct::nossh_hack true.
 150 If the shellmachine-useradd configuration file does not exist,
 151
 152   useradd -d $dir -m -s $shell -u $uid $username
 153
 154 is the default.  If the shellmachine-useradd configuration file exists but
 155 it empty,
 156
 157   cp -pr /etc/skel $dir; chown -R $uid.$gid $dir
 158
 159 is the default instead.  Otherwise the contents of the file are treated as
 160 a double-quoted perl string, with the following variables available:
 161 $username, $uid, $gid, $dir, and $shell.
 162
 163 =cut
 164
 165 sub insert {
 166   my $self = shift;
 167   my $error;
 168
 169   local $SIG{HUP} = 'IGNORE';
 170   local $SIG{INT} = 'IGNORE';
 171   local $SIG{QUIT} = 'IGNORE';
 172   local $SIG{TERM} = 'IGNORE';
 173   local $SIG{TSTP} = 'IGNORE';
 174   local $SIG{PIPE} = 'IGNORE';
 175
 176   $error = $self->check;
 177   return $error if $error;
 178
 179   return "Username ". $self->username. " in use"
 180     if qsearchs( 'svc_acct', { 'username' => $self->username,
 181                                'domsvc'   => $self->domsvc,
 182                              } );
 183
 184   my $part_svc = qsearchs( 'part_svc', { 'svcpart' => $self->svcpart } );
 185   return "Unknown svcpart" unless $part_svc;
 186   return "uid in use"
 187     if $part_svc->svc_acct__uid_flag ne 'F'
 188       && qsearchs( 'svc_acct', { 'uid' => $self->uid } )
 189       && $self->username !~ /^(hyla)?fax$/
 190     ;
 191
 192   $error = $self->SUPER::insert;
 193   return $error if $error;
 194
 195   my( $username, $uid, $gid, $dir, $shell ) = (
 196     $self->username,
 197     $self->uid,
 198     $self->gid,
 199     $self->dir,
 200     $self->shell,
 201   );
 202   if ( $username && $uid && $dir && $shellmachine && ! $nossh_hack ) {
 203     ssh("root\@$shellmachine", eval qq("$useradd") );
 204   }
 205
 206   ''; #no error
 207 }
 208
 209 =item delete
 210
 211 Deletes this account from the database.  If there is an error, returns the
 212 error, otherwise returns false.
 213
 214 The corresponding FS::cust_svc record will be deleted as well.
 215
 216 If the configuration value (see L<FS::Conf>) shellmachine exists, the
 217 command(s) specified in the shellmachine-userdel configuration file are
 218 executed on shellmachine via ssh.  This behavior can be surpressed by setting
 219 $FS::svc_acct::nossh_hack true.  If the shellmachine-userdel configuration
 220 file does not exist,
 221
 222   userdel $username
 223
 224 is the default.  If the shellmachine-userdel configuration file exists but
 225 is empty,
 226
 227   rm -rf $dir
 228
 229 is the default instead.  Otherwise the contents of the file are treated as a
 230 double-quoted perl string, with the following variables available:
 231 $username and $dir.
 232
 233 =cut
 234
 235 sub delete {
 236   my $self = shift;
 237
 238   return "Can't delete an account which has (svc_acct_sm) mail aliases!"
 239     if $self->uid && qsearch( 'svc_acct_sm', { 'domuid' => $self->uid } );
 240
 241   return "Can't delete an account which is a (svc_forward) source!"
 242     if qsearch( 'svc_forward', { 'srcsvc' => $self->svcnum } );
 243
 244   return "Can't delete an account which is a (svc_forward) destination!"
 245     if qsearch( 'svc_forward', { 'dstsvc' => $self->svcnum } );
 246
 247   return "Can't delete an account with (svc_www) web service!"
 248     if qsearch( 'svc_www', { 'usersvc' => $self->usersvc } );
 249
 250   # what about records in session ?
 251
 252   local $SIG{HUP} = 'IGNORE';
 253   local $SIG{INT} = 'IGNORE';
 254   local $SIG{QUIT} = 'IGNORE';
 255   local $SIG{TERM} = 'IGNORE';
 256   local $SIG{TSTP} = 'IGNORE';
 257   local $SIG{PIPE} = 'IGNORE';
 258
 259   my $oldAutoCommit = $FS::UID::AutoCommit;
 260   local $FS::UID::AutoCommit = 0;
 261   my $dbh = dbh;
 262
 263   foreach my $cust_main_invoice (
 264     qsearch( 'cust_main_invoice', { 'dest' => $self->svcnum } )
 265   ) {
 266     my %hash = $cust_main_invoice->hash;
 267     $hash{'dest'} = $self->email;
 268     my $new = new FS::cust_main_invoice \%hash;
 269     my $error = $new->replace($cust_main_invoice);
 270     if ( $error ) {
 271       $dbh->rollback if $oldAutoCommit;
 272       return $error;
 273     }
 274   }
 275
 276   foreach my $svc_domain (
 277     qsearch( 'svc_domain', { 'catchall' => $self->svcnum } )
 278   ) {
 279     my %hash = new FS::svc_domain->hash;
 280     $hash{'catchall'} = '';
 281     my $new = new FS::svc_domain \%hash;
 282     my $error = $new->replace($svc_domain);
 283     if ( $error ) {
 284       $dbh->rollback if $oldAutoCommit;
 285       return $error;
 286     }
 287   }
 288
 289   my $error = $self->SUPER::delete;
 290   if ( $error ) {
 291     $dbh->rollback if $oldAutoCommit;
 292     return $error;
 293   }
 294
 295   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 296
 297   my( $username, $dir ) = (
 298     $self->username,
 299     $self->dir,
 300   );
 301   if ( $username && $shellmachine && ! $nossh_hack ) {
 302     ssh("root\@$shellmachine", eval qq("$userdel") );
 303   }
 304
 305   '';
 306 }
 307
 308 =item replace OLD_RECORD
 309
 310 Replaces OLD_RECORD with this one in the database.  If there is an error,
 311 returns the error, otherwise returns false.
 312
 313 If the configuration value (see L<FS::Conf>) shellmachine exists, and the
 314 dir field has changed, the command(s) specified in the shellmachine-usermod
 315 configuraiton file are executed on shellmachine via ssh.  This behavior can
 316 be surpressed by setting $FS::svc-acct::nossh_hack true.  If the
 317 shellmachine-userdel configuration file does not exist or is empty, :
 318
 319   [ -d $old_dir ] && mv $old_dir $new_dir || (
 320     chmod u+t $old_dir;
 321     mkdir $new_dir;
 322     cd $old_dir;
 323     find . -depth -print | cpio -pdm $new_dir;
 324     chmod u-t $new_dir;
 325     chown -R $uid.$gid $new_dir;
 326     rm -rf $old_dir
 327   )
 328
 329 is executed on shellmachine via ssh.  This behaviour can be surpressed by
 330 setting $FS::svc_acct::nossh_hack true.
 331
 332 =cut
 333
 334 sub replace {
 335   my ( $new, $old ) = ( shift, shift );
 336   my $error;
 337
 338   return "Username in use"
 339     if $old->username ne $new->username &&
 340       qsearchs( 'svc_acct', { 'username' => $new->username } );
 341
 342   return "Can't change uid!" if $old->uid != $new->uid;
 343
 344   #change homdir when we change username
 345   $new->setfield('dir', '') if $old->username ne $new->username;
 346
 347   local $SIG{HUP} = 'IGNORE';
 348   local $SIG{INT} = 'IGNORE';
 349   local $SIG{QUIT} = 'IGNORE';
 350   local $SIG{TERM} = 'IGNORE';
 351   local $SIG{TSTP} = 'IGNORE';
 352   local $SIG{PIPE} = 'IGNORE';
 353
 354   $error = $new->SUPER::replace($old);
 355   return $error if $error;
 356
 357   my ( $old_dir, $new_dir, $uid, $gid ) = (
 358     $old->getfield('dir'),
 359     $new->getfield('dir'),
 360     $new->getfield('uid'),
 361     $new->getfield('gid'),
 362   );
 363   if ( $old_dir && $new_dir && $old_dir ne $new_dir && ! $nossh_hack ) {
 364     ssh("root\@$shellmachine", eval qq("$usermod") );
 365   }
 366
 367   ''; #no error
 368 }
 369
 370 =item suspend
 371
 372 Suspends this account by prefixing *SUSPENDED* to the password.  If there is an
 373 error, returns the error, otherwise returns false.
 374
 375 Called by the suspend method of FS::cust_pkg (see L<FS::cust_pkg>).
 376
 377 =cut
 378
 379 sub suspend {
 380   my $self = shift;
 381   my %hash = $self->hash;
 382   unless ( $hash{_password} =~ /^\*SUSPENDED\* / ) {
 383     $hash{_password} = '*SUSPENDED* '.$hash{_password};
 384     my $new = new FS::svc_acct ( \%hash );
 385     $new->replace($self);
 386   } else {
 387     ''; #no error (already suspended)
 388   }
 389 }
 390
 391 =item unsuspend
 392
 393 Unsuspends this account by removing *SUSPENDED* from the password.  If there is
 394 an error, returns the error, otherwise returns false.
 395
 396 Called by the unsuspend method of FS::cust_pkg (see L<FS::cust_pkg>).
 397
 398 =cut
 399
 400 sub unsuspend {
 401   my $self = shift;
 402   my %hash = $self->hash;
 403   if ( $hash{_password} =~ /^\*SUSPENDED\* (.*)$/ ) {
 404     $hash{_password} = $1;
 405     my $new = new FS::svc_acct ( \%hash );
 406     $new->replace($self);
 407   } else {
 408     ''; #no error (already unsuspended)
 409   }
 410 }
 411
 412 =item cancel
 413
 414 Just returns false (no error) for now.
 415
 416 Called by the cancel method of FS::cust_pkg (see L<FS::cust_pkg>).
 417
 418 =item check
 419
 420 Checks all fields to make sure this is a valid service.  If there is an error,
 421 returns the error, otherwise returns false.  Called by the insert and replace
 422 methods.
 423
 424 Sets any fixed values; see L<FS::part_svc>.
 425
 426 =cut
 427
 428 sub check {
 429   my $self = shift;
 430
 431   my($recref) = $self->hashref;
 432
 433   my $x = $self->setfixed;
 434   return $x unless ref($x);
 435   my $part_svc = $x;
 436
 437   my $error = $self->ut_numbern('svcnum')
 438               || $self->ut_number('domsvc')
 439   ;
 440   return $error if $error;
 441
 442   my $ulen = $usernamemax || $self->dbdef_table->column('username')->length;
 443   $recref->{username} =~ /^([a-z0-9_\-\.]{$usernamemin,$ulen})$/
 444     or return "Illegal username";
 445   $recref->{username} = $1;
 446   if ( $username_letterfirst ) {
 447     $recref->{username} =~ /^[a-z]/ or return "Illegal username";
 448   } elsif ( $username_letter ) {
 449     $recref->{username} =~ /[a-z]/ or return "Illegal username";
 450   }
 451
 452   $recref->{popnum} =~ /^(\d*)$/ or return "Illegal popnum: ".$recref->{popnum};
 453   $recref->{popnum} = $1;
 454   return "Unknown popnum" unless
 455     ! $recref->{popnum} ||
 456     qsearchs('svc_acct_pop',{'popnum'=> $recref->{popnum} } );
 457
 458   unless ( $part_svc->getfield('svc_acct__uid_flag') eq 'F' ) {
 459
 460     $recref->{uid} =~ /^(\d*)$/ or return "Illegal uid";
 461     $recref->{uid} = $1 eq '' ? $self->unique('uid') : $1;
 462
 463     $recref->{gid} =~ /^(\d*)$/ or return "Illegal gid";
 464     $recref->{gid} = $1 eq '' ? $recref->{uid} : $1;
 465     #not all systems use gid=uid
 466     #you can set a fixed gid in part_svc
 467
 468     return "Only root can have uid 0"
 469       if $recref->{uid} == 0 && $recref->{username} ne 'root';
 470
 471     $error = $self->ut_textn('finger');
 472     return $error if $error;
 473
 474     $recref->{dir} =~ /^([\/\w\-]*)$/
 475       or return "Illegal directory";
 476     $recref->{dir} = $1 ||
 477       $dir_prefix . '/' . $recref->{username}
 478       #$dir_prefix . '/' . substr($recref->{username},0,1). '/' . $recref->{username}
 479     ;
 480
 481     unless ( $recref->{username} eq 'sync' ) {
 482       if ( grep $_ eq $recref->{shell}, @shells ) {
 483         $recref->{shell} = (grep $_ eq $recref->{shell}, @shells)[0];
 484       } else {
 485         return "Illegal shell \`". $self->shell. "\'; ".
 486                $conf->dir. "/shells contains: @shells";
 487       }
 488     } else {
 489       $recref->{shell} = '/bin/sync';
 490     }
 491
 492     $recref->{quota} =~ /^(\d*)$/ or return "Illegal quota (unimplemented)";
 493     $recref->{quota} = $1;
 494
 495   } else {
 496     $recref->{gid} ne '' ?
 497       return "Can't have gid without uid" : ( $recref->{gid}='' );
 498     $recref->{finger} ne '' ?
 499       return "Can't have finger-name without uid" : ( $recref->{finger}='' );
 500     $recref->{dir} ne '' ?
 501       return "Can't have directory without uid" : ( $recref->{dir}='' );
 502     $recref->{shell} ne '' ?
 503       return "Can't have shell without uid" : ( $recref->{shell}='' );
 504     $recref->{quota} ne '' ?
 505       return "Can't have quota without uid" : ( $recref->{quota}='' );
 506   }
 507
 508   unless ( $part_svc->getfield('svc_acct__slipip_flag') eq 'F' ) {
 509     unless ( $recref->{slipip} eq '0e0' ) {
 510       $recref->{slipip} =~ /^(\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3})$/
 511         or return "Illegal slipip". $self->slipip;
 512       $recref->{slipip} = $1;
 513     } else {
 514       $recref->{slipip} = '0e0';
 515     }
 516
 517   }
 518
 519   #arbitrary RADIUS stuff; allow ut_textn for now
 520   foreach ( grep /^radius_/, fields('svc_acct') ) {
 521     $self->ut_textn($_);
 522   }
 523
 524   #generate a password if it is blank
 525   $recref->{_password} = join('',map($pw_set[ int(rand $#pw_set) ], (0..7) ) )
 526     unless ( $recref->{_password} );
 527
 528   #if ( $recref->{_password} =~ /^((\*SUSPENDED\* )?)([^\t\n]{4,16})$/ ) {
 529   if ( $recref->{_password} =~ /^((\*SUSPENDED\* )?)([^\t\n]{$passwordmin,8})$/ ) {
 530     $recref->{_password} = $1.$3;
 531     #uncomment this to encrypt password immediately upon entry, or run
 532     #bin/crypt_pw in cron to give new users a window during which their
 533     #password is available to techs, for faxing, etc.  (also be aware of
 534     #radius issues!)
 535     #$recref->{password} = $1.
 536     #  crypt($3,$saltset[int(rand(64))].$saltset[int(rand(64))]
 537     #;
 538   } elsif ( $recref->{_password} =~ /^((\*SUSPENDED\* )?)([\w\.\/\$]{13,34})$/ ) {
 539     $recref->{_password} = $1.$3;
 540   } elsif ( $recref->{_password} eq '*' ) {
 541     $recref->{_password} = '*';
 542   } elsif ( $recref->{_password} eq '!!' ) {
 543     $recref->{_password} = '!!';
 544   } else {
 545     return "Illegal password";
 546   }
 547
 548   ''; #no error
 549 }
 550
 551 =item radius
 552
 553 Depriciated, use radius_reply instead.
 554
 555 =cut
 556
 557 sub radius {
 558   carp "FS::svc_acct::radius depriciated, use radius_reply";
 559   $_[0]->radius_reply;
 560 }
 561
 562 =item radius_reply
 563
 564 Returns key/value pairs, suitable for assigning to a hash, for any RADIUS
 565 reply attributes of this record.
 566
 567 Note that this is now the preferred method for reading RADIUS attributes -
 568 accessing the columns directly is discouraged, as the column names are
 569 expected to change in the future.
 570
 571 =cut
 572
 573 sub radius_reply {
 574   my $self = shift;
 575   map {
 576     /^(radius_(.*))$/;
 577     my($column, $attrib) = ($1, $2);
 578     $attrib =~ s/_/\-/g;
 579     ( $attrib, $self->getfield($column) );
 580   } grep { /^radius_/ && $self->getfield($_) } fields( $self->table );
 581 }
 582
 583 =item radius_check
 584
 585 Returns key/value pairs, suitable for assigning to a hash, for any RADIUS
 586 check attributes of this record.
 587
 588 Accessing RADIUS attributes directly is not supported and will break in the
 589 future.
 590
 591 =cut
 592
 593 sub radius_check {
 594   my $self = shift;
 595   map {
 596     /^(rc_(.*))$/;
 597     my($column, $attrib) = ($1, $2);
 598     $attrib =~ s/_/\-/g;
 599     ( $attrib, $self->getfield($column) );
 600   } grep { /^rc_/ && $self->getfield($_) } fields( $self->table );
 601 }
 602
 603 =item domain
 604
 605 Returns the domain associated with this account.
 606
 607 -cut
 608
 609 sub domain {
 610   my $self = shift;
 611   my $svc_domain = qsearchs( 'svc_domain', { 'svcnum' => $self->domsvc } )
 612     or die "svc_acct.domsvc ". $self->domsvc." not found in svc_domain.svcnum";
 613   $svc_domain->domain;
 614 }
 615
 616 =item email
 617
 618 Returns an email address associated with the account.
 619
 620 =cut
 621
 622 sub email {
 623   my $self = shift;
 624   $self->username. '@'. $self->domain;
 625 }
 626
 627 =back
 628
 629 =head1 VERSION
 630
 631 $Id: svc_acct.pm,v 1.26 2001-08-20 11:04:38 ivan Exp $
 632
 633 =head1 BUGS
 634
 635 The bits which ssh should fork before doing so (or maybe queue jobs for a
 636 daemon).
 637
 638 The $recref stuff in sub check should be cleaned up.
 639
 640 The suspend, unsuspend and cancel methods update the database, but not the
 641 current object.  This is probably a bug as it's unexpected and
 642 counterintuitive.
 643
 644 =head1 SEE ALSO
 645
 646 L<FS::svc_Common>, L<FS::Record>, L<FS::Conf>, L<FS::cust_svc>,
 647 L<FS::part_svc>, L<FS::cust_pkg>, L<Net::SSH>, L<ssh>, L<FS::svc_acct_pop>,
 648 schema.html from the base documentation.
 649
 650 =cut
 651
 652 1;
 653