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