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