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